Haskell Persistent 上的 CRUD 模式

Question

这是我第二次尝试学习 Haskell，我一直听到的一件事就是不要重复自己（实际上其他语言也是如此）。

无论如何...我正在尝试实现一个博客，并发现需要在数据库上实现 CRUD 操作，但是当我为评论、帖子和用户实现 CRUD 时，在我看来我只是在重复自己。

问题是我看不出如何不重复自己。

{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}

module Model where

import Control.Monad.IO.Class  (liftIO)
import Control.Monad.Logger    (runStderrLoggingT)
import Database.Persist
import Database.Persist.Postgresql
import Database.Persist.TH
import Data.Time
import Data.Int

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Users
    email String
    password String
    alias String
    image_url String
    show_email Bool
    UniqueEmail email
    date UTCTime default=CURRENT_TIMESTAMP
    deriving Show
Post
    atom Int
    material String
    processing String
    params String
    image_url String
    reference String
    owner UsersId
    material_url String
    date UTCTime default=CURRENT_TIMESTAMP
    deriving Show
Comment
    owner UsersId
    post PostId
    date UTCTime default=CURRENT_TIMESTAMP
    text String
    deriving Show
|]

connStr = "host=localhost dbname=communis-db user=communis password=facilderecordar789 port=5432"

--User CRUD
get_user :: Int64 -> IO(Maybe Users)
get_user i = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll
        get (toSqlKey i :: UsersId)

new_user :: Users -> IO ()
new_user(Users email pass alias image_url show_email _) = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll
        now <- liftIO getCurrentTime
        usrid <- insert $ Users email pass alias image_url show_email now
        usr <- get usrid
        liftIO $ print usr

update_user :: String -> Users -> IO()
update_user em u = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll
        usr <- getBy $ UniqueEmail em
        case usr of
          Just (Entity userId user) -> replace userId user

delete_user :: Int64 -> IO ()
delete_user i = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll
        delete (toSqlKey i :: UsersId)

--Post CRUD
get_post :: Int64 -> IO(Maybe Post)
get_post i = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll
        get (toSqlKey i :: PostId)

new_post :: Post -> IO ()
new_post (Post atom material processing params image_url reference owner material_url _) = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll
        now <- liftIO getCurrentTime
        postId <- insert $ Post atom material processing params image_url reference owner material_url now
        post <- get postId
        liftIO $ print post

update_post :: Int64 -> Post -> IO()
update_post id post = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll
        replace (toSqlKey id) post

delete_post :: Int64 -> IO ()
delete_post i = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll
        delete (toSqlKey i :: PostId)

-- Comments CRUD
get_comment :: Int64 -> IO(Maybe Comment)
get_comment i = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll
        get (toSqlKey i :: CommentId)

new_comment :: Comment -> IO ()
new_comment (Comment owner post _ text) = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll
        now <- liftIO getCurrentTime
        commentId <- insert $ Comment owner post now text
        comment <- get commentId
        liftIO $ print comment

update_comment :: Int64 -> Comment -> IO()
update_comment id comment = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll
        replace (toSqlKey id) comment

delete_comment :: Int64 -> IO ()
delete_comment i = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
        runMigration migrateAll
        delete (toSqlKey i :: CommentId)

附言堆栈规则。

Answer 1

首先，认清你在重复什么。这里是

runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
  flip runSqlPersistMPool pool $ do
    runMigration migrateAll
    <some-action>

解决方案只是将其抽象出来，创建一个让您指定 some-action 的函数：

inBackend :: ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a-> IO a
inBackend action = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
  flip runSqlPersistMPool pool $ do
    runMigration migrateAll
    action

然后你的 CRUD 代码变得更加干净和干燥：

--User CRUD
get_user :: Int64 -> IO (Maybe User)
get_user = inBackend . get . toUserId

new_user :: User -> IO ()
new_user (User email pass alias image_url show_email _) = inBackend $ do
  now <- liftIO getCurrentTime
  usrid <- insert $ User email pass alias image_url show_email now
  usr <- get usrid
  liftIO $ print usr

update_user :: String -> User -> IO()
update_user em user = inBackend $ do
  Just (Entity userId _) <- getBy $ UniqueEmail em
  replace userId user

delete_user :: Int64 -> IO ()
delete_user = inBackend . delete . toUserId

--Post CRUD
get_post :: Int64 -> IO(Maybe Post)
get_post = inBackend . get . toPostId

new_post :: Post -> IO ()
new_post (Post atom material processing params image_url reference owner material_url _) = inBackend $ do
  now <- liftIO getCurrentTime
  postId <- insert $ Post atom material processing params image_url reference owner material_url now
  post <- get postId
  liftIO $ print post

update_post :: Int64 -> Post -> IO()
update_post id post = inBackend $ replace (toPostId id) post

delete_post :: Int64 -> IO ()
delete_post = inBackend . delete . toPostId

-- Comments CRUD
get_comment :: Int64 -> IO(Maybe Comment)
get_comment = inBackend . get . toCommentId

new_comment :: Comment -> IO ()
new_comment (Comment owner post _ text) = inBackend $ do
  now <- liftIO getCurrentTime
  commentId <- insert $ Comment owner post now text
  comment <- get commentId
  liftIO $ print comment

update_comment :: Int64 -> Comment -> IO()
update_comment id comment = inBackend $ replace (toCommentId id) comment

delete_comment :: Int64 -> IO ()
delete_comment = inBackend . delete . toCommentId

为了完整性：

{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}

module Model where

import Control.Monad.IO.Class  (liftIO)
import Control.Monad.Logger    (runStderrLoggingT, NoLoggingT)
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.Trans.Resource (ResourceT)
import Database.Persist
import Database.Persist.Postgresql
import Database.Persist.TH
import Data.Time
import Data.Int

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
User
    email String
    password String
    alias String
    image_url String
    show_email Bool
    UniqueEmail email
    date UTCTime default=CURRENT_TIMESTAMP
    deriving Show
Post
    atom Int
    material String
    processing String
    params String
    image_url String
    reference String
    owner UserId
    material_url String
    date UTCTime default=CURRENT_TIMESTAMP
    deriving Show
Comment
    owner UserId
    post PostId
    date UTCTime default=CURRENT_TIMESTAMP
    text String
    deriving Show
|]

connStr = "host=localhost dbname=communis-db user=communis password=facilderecordar789 port=5432"

-- this is the repeated code that can be factored out
inBackend :: ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a-> IO a
inBackend action = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
  flip runSqlPersistMPool pool $ do
    runMigration migrateAll
    action

-- I prefer this to (toSqlKey :: ...), but YMMV
toUserId :: Int64 -> UserId
toUserId = toSqlKey

toPostId :: Int64 -> PostId
toPostId = toSqlKey

toCommentId :: Int64 -> CommentId
toCommentId = toSqlKey

--User CRUD
get_user :: Int64 -> IO (Maybe User)
get_user = inBackend . get . toUserId

new_user :: User -> IO ()
new_user (User email pass alias image_url show_email _) = inBackend $ do
  now <- liftIO getCurrentTime
  usrid <- insert $ User email pass alias image_url show_email now
  usr <- get usrid
  liftIO $ print usr

update_user :: String -> User -> IO()
update_user em user = inBackend $ do
  Just (Entity userId _) <- getBy $ UniqueEmail em
  replace userId user

delete_user :: Int64 -> IO ()
delete_user = inBackend . delete . toUserId

--Post CRUD
get_post :: Int64 -> IO(Maybe Post)
get_post = inBackend . get . toPostId

new_post :: Post -> IO ()
new_post (Post atom material processing params image_url reference owner material_url _) = inBackend $ do
  now <- liftIO getCurrentTime
  postId <- insert $ Post atom material processing params image_url reference owner material_url now
  post <- get postId
  liftIO $ print post

update_post :: Int64 -> Post -> IO()
update_post id post = inBackend $ replace (toPostId id) post

delete_post :: Int64 -> IO ()
delete_post = inBackend . delete . toPostId

-- Comments CRUD
get_comment :: Int64 -> IO(Maybe Comment)
get_comment = inBackend . get . toCommentId

new_comment :: Comment -> IO ()
new_comment (Comment owner post _ text) = inBackend $ do
  now <- liftIO getCurrentTime
  commentId <- insert $ Comment owner post now text
  comment <- get commentId
  liftIO $ print comment

update_comment :: Int64 -> Comment -> IO()
update_comment id comment = inBackend $ replace (toCommentId id) comment

delete_comment :: Int64 -> IO ()
delete_comment = inBackend . delete . toCommentId

Answer 2

我更喜欢事务与运行它们分开的情况。

import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Control.Monad.Logger (NoLoggingT, runNoLoggingT, runStderrLoggingT)
import           Control.Monad.Trans.Reader (ReaderT)
import           Control.Monad.Trans.Resource (ResourceT)
import           Data.Int (Int64)
import           Database.Persist (ToBackendKey)
import           Database.Persist.Postgresql (ConnectionString, Key, SqlBackend)
import qualified Database.Persist.Postgresql as Psql
import qualified Database.Persist.Sql as Sql
import           Database.PostgreSQL.Simple (SqlError)

type Mod m a = ReaderT SqlBackend m a

fromInt :: ToBackendKey SqlBackend record => Int64 -> Key record
fromInt = Sql.toSqlKey

toInt :: ToBackendKey SqlBackend record => Key record -> Int64
toInt = Sql.fromSqlKey

withPostgres :: ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a
withPostgres =
  runNoLoggingT . Psql.withPostgresqlPool conn 10 . Psql.liftSqlPersistMPool

conn = "host=localhost dbname=communis-db user=communis password=facilderecordar789 port=5432"

getUser :: MonadIO m => Int64 -> Mod m (Maybe User)
getUser = get . fromInt

newUser :: MonadIO m => User -> Mod m Int64
newUser (User email pass alias image_url show_email _) = do
  now <- liftIO getCurrentTime
  userId <- insert $ User email pass alias image_url show_email now
  return $ toInt userId

updateUser :: MonadIO m => String -> User -> Mod m ()
updateUser em user = inBackend $ do
  Just (Entity userId _) <- getBy $ UniqueEmail em
  replace userId user

deleteUser :: MonadIO m => Int64 -> Mod m ()
deleteUser = delete . fromInt


getPost :: MonadIO m => Int64 -> Mod m (Maybe Post)
getPost = get . fromInt

newPost :: MonadIO m => Post -> Mod m Int64
newPost (Post atom material processing params image_url reference owner material_url _) = do
  now <- liftIO getCurrentTime
  postId <- insert $ Post atom material processing params image_url reference owner material_url now
  toInt postId

updatePost :: MonadIO m => Int64 -> Post -> Mod m ()
updatePost id post = replace (fromInt id) post

deletePost :: Int64 -> IO ()
deletePost = delete . fromInt

-- and so on

这允许您决定何时运行迁移，或将这些操作中的任何一个合并到一个事务中，即

withPostgresDebug :: ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a
withPostgresDebug =
  runStderrLoggingT . Psql.withPostgresqlPool conn pools . Psql.liftSqlPersistMPool . (migrationAction >>)
  where migrationAction = runMigration migrateAll
-- then run you transaction
withPostgresDebug $ do
    Just user <- getUser 1
    let user' = user { userEmail = "makenoise@example.com" }
    newUserId <- insertUser user'
    liftIO $ print newUserId