CRUD pattern на Haskell Persistent

Это второй раз, когда я пытаюсь изучить Haskell, и одна из вещей, которые я продолжаю слышать, - это не повторять себя (это на самом деле также верно для других языков).CRUD pattern на Haskell Persistent

В любом случае ... Я пытаюсь реализовать блог и обнаружил необходимость реализации операций 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)

p.s. Правила стека.

источник

2016-01-06 hefesto

Мои первые мысли о снижении 'runStderrLoggingT $ withPostgresqlPool connStr 10 $ \ бассейн -> liftIO $ сделать флип runSqlPersistMPool бассейн $ сделать runMigration migrateAll' к функции, и назвав его в каждом случае, но я не действительно хорошо это понимают и не выполняют такую функцию. – hefesto

Прежде всего, узнайте, что вы повторяете. Вот это

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

источник

2016-01-06 03:17:55 rampion

Спасибо большое :) – hefesto

Замечательно! Я потратил много времени, пытаясь разложить этот код, не преуспевая, прежде чем увидеть это! – cgold

ответ

Смежные вопросы