Грубый узор на Хаскелле стойкий

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

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

2 3
haskell database persistent yesod

2 ответа:

Во-первых, осознайте, что именно вы повторяете. Вот он 

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
5

Я бы предпочел ситуацию, когда транзакции отделены от их выполнения.

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
0