Database Haskell持久化上的积垢模式

这是我第二次尝试学习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)

{-#语言EmptyDataDecls}
{-#语言灵活语境#-}
{-#语言GADTs}
{-#语言泛化newtypedering}
{-#语言MultiParamTypeClasses}
{-#语言重载字符串}
{-#语言准语言}
{-#语言模板haskell}
{-#语言类型族{-}
模块模型在哪里
导入控制.Monad.IO.Class（liftIO）
导入控制.Monad.Logger（runstderrlogging）
导入数据库。持久化
导入Database.Persist.Postgresql
导入Database.Persist.TH
导入数据。时间
导入数据.Int
共享[mkPersist sqlSettings，mkMigrate“migrateAll”][persist小写|
使用者
电子邮件字符串
密码字符串
别名字符串
图像url字符串
显示电子邮件地址
UniqueMail电子邮件
日期UTCTime默认值=当前时间戳
衍生节目
邮递
原子整数
材料串
处理字符串
参数字符串
图像url字符串
引用字符串
所有者用户SID
材料url字符串
日期UTCTime默认值=当前时间戳
衍生节目
评论
所有者用户SID
张贴
日期UTCTime默认值=当前时间戳
文本字符串
衍生节目
|]
connStr=“host=localhost dbname=communis db user=communis password=facilderecordar789 port=5432”
--用户积垢
获取用户：：Int64->IO（可能是用户）
使用PostgreSqlPool connStr 10$\pool->liftIO$do获取用户i=runStderrLoggingT$
翻转runSqlPersistMPool池$do
运行迁移
获取（toSqlKey i:：UsersId）
新建用户：：用户->IO（）
new_user（Users email pass alias image_url show_email）=runStderrLoggingT$with postgresqlpool connStr 10$\pool->liftIO$do
翻转runSqlPersistMPool池$do
运行迁移
现在我要做什么
翻转runSqlPersistMPool池$do
运行迁移
usr替换用户ID用户
删除用户：：Int64->IO（）
使用PostgreSqlPool connStr 10$\pool->liftIO$do删除用户i=runStderrLoggingT$
翻转runSqlPersistMPool池$do
运行迁移
删除（toSqlKey i:：UsersId）
--后积垢
get_post:：Int64->IO（可能是post）
get_post i=runStderrLoggingT$，使用Postgresqlpool connStr 10$\pool->liftIO$do
翻转runSqlPersistMPool池$do
运行迁移
get（toSqlKey i:：posted）
新帖子：：帖子->IO（）
new_post（post atom材质处理参数image_url参考所有者材质_url）=runStderrLoggingT$与Postgresqlpool connStr 10$\pool->liftIO$do
翻转runSqlPersistMPool池$do
运行迁移
现在我要做什么
翻转runSqlPersistMPool池$do
运行迁移
替换（toSqlKey id）post
删除帖子：：Int64->IO（）
使用PostgreSqlPool connStr 10$\pool->liftIO$do删除\u post i=runStderrLoggingT$
翻转runSqlPersistMPool池$do
运行迁移
删除（toSqlKey i:：PostId）
--评论积垢
获取注释：：Int64->IO（可能是注释）
get_comment i=runStderrLoggingT$，带有Postgresqlpool connStr 10$\pool->liftIO$do
翻转runSqlPersistMPool池$do
运行迁移
获取（toSqlKey i:：CommentId）
新注释：：注释->IO（）
new_comment（comment owner post text）=runStderrLoggingT$with postgresqlpool connStr 10$\pool->liftIO$do
翻转runSqlPersistMPool池$do
运行迁移
现在我要做什么
翻转runSqlPersistMPool池$do
运行迁移
替换（toSqlKey id）注释
删除注释：：Int64->IO（）
删除\u comment i=runStderrLoggingT$，使用PostgreSqlPool connStr 10$\pool->liftIO$do
翻转runSqlPersistMPool池$do
运行迁移
删除（toSqlKey i:：CommentId）

---

p、 首先，认识到你在重复什么。给你

runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
  flip runSqlPersistMPool pool $ do
    runMigration migrateAll
    <some-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

——用户积垢
获取用户：：Int64->IO（可能是用户）
get_user=inBackend。得到。乱七八糟的
新建用户：：用户->IO（）
新用户（用户电子邮件传递别名图像url显示电子邮件）=收件箱$do
现在IO（可能是Post）
get_post=inBackend。得到。拓扑虫
新帖子：：帖子->IO（）
new_post（post atom材料处理参数图像_url参考所有者材料_url）=inBackend$do
现在IO（）
删除\u post=inBackend。删除。拓扑虫
--评论积垢
获取注释：：Int64->IO（可能是注释）
get_comment=inBackend。得到。通俗
新注释：：注释->IO（）
新建注释（注释所有者帖子uu文本）=inBackend$do
现在IO（）
删除\u comment=inBackend。删除。通俗

完整性：

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

{-#语言EmptyDataDecls}
{-#语言灵活语境#-}
{-#语言GADTs}
{-#语言泛化newtypedering}
{-#语言MultiParamTypeClasses}
{-#语言重载字符串}
{-#语言准语言}
{-#语言模板haskell}
{-#语言类型族{-}
模块模型在哪里
导入控制.Monad.IO.Class（liftIO）
导入控制.Monad.Logger（runstderrloggint，nologging）
导入控制.Monad.Trans.Reader（ReaderT）
导入控制.Monad.Trans.Resource（ResourceT）
导入数据库。持久化
导入Database.Persist.Postgresql
导入Database.Persist.TH
导入数据。时间
导入数据.Int
共享[mkPersist sqlSetti]
{-# 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

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