CRUD App in Haskell with Servant/Opaleye

Question

I was trying to learn how to use libraries like Opaleye and Servant. I wrote this toy Create/Read/Update/Delete App.

{-# OPTIONS_GHC -Wall #-}

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TemplateHaskell #-}

module Main where

import Servant
import Data.Aeson
import Data.Aeson.Types
import Data.Aeson.Casing
import GHC.Generics
import Opaleye
import Database.PostgreSQL.Simple
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Control.Arrow
import Control.Monad.IO.Class (liftIO)
import Network.Wai.Handler.Warp
import qualified GHC.Int

type CrudAPI = "read" :> Get '[JSON] [User]
                :<|> "read" :> Capture "name" String :> Get '[JSON] [User]
                :<|> "create" :> ReqBody '[JSON] User :> Post '[JSON] [GHC.Int.Int64]
                :<|> "update" :> ReqBody '[JSON] User :> Post '[JSON] [GHC.Int.Int64]
                :<|> "delete" :> ReqBody '[PlainText] String :> Post '[JSON] [GHC.Int.Int64]

data UserPoly name city age = User
  { userName :: name
  , userCity :: city
  , userAge :: age
  } deriving (Eq, Show, Generic)

type User = UserPoly String String Int


$(makeAdaptorAndInstance "pUser" ''UserPoly)
$(makeLensesWith abbreviatedFields ''UserPoly)

userTable :: Table
            (UserPoly (Column PGText) (Column PGText) (Column PGInt4))
            (UserPoly (Column PGText) (Column PGText) (Column PGInt4))
userTable = Table "users" (pUser User { userName = required "name",
                                        userCity = required "city",
                                        userAge = required "age"})

instance FromJSON User
  where
  parseJSON = genericParseJSON $ aesonPrefix camelCase
instance ToJSON User
  where
  toJSON  = genericToJSON $ aesonPrefix camelCase
  toEncoding = genericToEncoding $ aesonPrefix camelCase

crudAPI :: Server CrudAPI
crudAPI = readAPI1 :<|> readAPI2 :<|> createAPI :<|> updateAPI :<|> deleteAPI
          where
            readAPI1 = liftIO $ dbConnection >>= selectAllRows
            readAPI2 = \ns -> liftIO $ dbConnection >>= \conn -> runQuery conn (nameQuery ns)
            createAPI = \u -> liftIO $ insertRow u
            updateAPI = \u -> liftIO $ updateRow u
            deleteAPI = \n -> liftIO $ deleteRow n

dbConnection :: IO Connection
dbConnection = connect ConnectInfo{connectHost="localhost"
                             ,connectPort=5432
                             ,connectDatabase="mydb"
                             ,connectPassword="b2b"
                             ,connectUser="b2b"
                             }

selectAllRows :: Connection -> IO [User]
selectAllRows conn = runQuery conn $ queryTable userTable


nameQuery :: String -> Opaleye.Query (UserPoly (Column PGText) (Column PGText) (Column PGInt4))
nameQuery ns = proc () -> do
                  row <- (queryTable userTable) -< ()
                  restrict -< (userName row .== pgString ns)
                  returnA -< row

insertRow :: User -> IO [GHC.Int.Int64]
insertRow u = do
              conn <- dbConnection
              success <- runInsert conn userTable (User (pgString (userName u)) (pgString (userCity u)) (pgInt4 (userAge u)))
              return [success]

updateRow :: User -> IO [GHC.Int.Int64]
updateRow u = do
                  conn <- dbConnection
                  success <- runUpdate conn userTable (const $ User (pgString (userName u)) (pgString (userCity u)) (pgInt4 (userAge u)))
                                                      (\ entry -> userName entry .== pgString (userName u))
                  return [success]

deleteRow :: String -> IO [GHC.Int.Int64]
deleteRow n = do
                conn <- dbConnection
                success <- runDelete conn userTable (\entry -> userName entry .== pgString n)
                return [success]


main :: IO ()
main = run 8081 (serve (Proxy :: Proxy CrudAPI) crudAPI)

Suggestions on coding styles and other things are welcome

Answer 1

I quickly looked at the code, and didn't see that we use the lazyness of the fields of Userpoly, so we could make them strict:

data UserPoly name city age = User
  { userName :: !name
  , userCity :: !city
  , userAge :: !age
  } deriving (Eq, Show, Generic)

Answer 2

Three of your definitions have a lot in common.

crudAPI :: Server CrudAPI
crudAPI = readAPI1 :<|> readAPI2 :<|> createAPI :<|> updateAPI :<|> deleteAPI where
  readAPI1 = liftIO $ dbConnection >>= selectAllRows
  readAPI2 = \ns -> liftIO $ dbConnection >>= \conn -> runQuery conn (nameQuery ns)
  createAPI = \u -> wrap insertRow $ \f -> f 
    (User (pgString (userName u)) (pgString (userCity u)) (pgInt4 (userAge u)))
  updateAPI = \u -> wrap runUpdate $ \f -> f
    (const $ User (pgString (userName u)) (pgString (userCity u)) (pgInt4 (userAge u)))
    (\entry -> userName entry .== pgString (userName u))
  deleteAPI = \n -> wrap runDelete $ \f -> f 
    (\entry -> userName entry .== pgString n)
  wrap f g = liftIO $ do
    conn <- dbConnection
    (:[]) <$> g (f conn userTable)