堆棧內存溢出
  簡體   English   中英

Haskell Persistent上的CRUD模式

[英]CRUD pattern on Haskell Persistent

 原文  2016-01-06 02:01:05  4   2    database/ haskell/ yesod/ persistent

問題描述

這是我第二次嘗試學習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)

ps堆棧規則。

2 個解決方案

解決方案1
 5 已采納  2016-01-06 03:17:55

首先，要認識到你正在重復的是什么。 在這里 

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代碼變得更干凈和DRYer： 

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

解決方案2
 0  2018-10-03 17:06:39

我更喜歡交易與運行它們分開的情況。 

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

暫無
暫無

聲明:本站的技術帖子網頁，遵循CC BY-SA 4.0協議，如果您需要轉載，請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.

相關問題 CRUD：空記錄模式 Haskell 持久化 - 通過外鍵獲取價值 Haskell存儲具有持久性定義的組合ADT 有Hibernate和Repository Pattern的多個類似CRUD方法嗎？ Haskell / Persistent-Sqlite：“沒有（Control.Monad.Trans.Resource.MonadResource IO）的實例” Oracle對CRUD操作的權限 用PHP和Oracle進行CRUD&#39;ding CRUD和合並/持久 Flutter CRUD 離線 刪除所有行
相關標簽
 
粵ICP備18138465號  © 2020-2024 STACKOOM.COM