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)