CRUD在Haskell中的仆人/操作系统应用程序

Question

我试着学习如何使用像Opaleye和仆人这样的图书馆。我写了这个玩具创建/读取/更新/删除应用程序。

{-# 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)

欢迎对编码风格和其他事项提出建议。

Answer 1

我很快地查看了代码，没有看到我们使用了Userpoly字段的懒散性，因此我们可以严格执行它们：

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

Answer 2

你们的三个定义有很多共同点。

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)