trjhtr

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 ConnectInfoconnectHost="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

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)

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)