CRUD pattern on Haskell Persistent

Question

This is the second time I am trying to learn Haskell, and one of the things that I keep hearing is not to repeat myself (that's actually also true for other languages).

Anyway... I am trying to implement a blog and found the need to implement CRUD operations on a database, but when I implemented CRUD for Comments, Posts and Users, it seemed to me that I was just repeating myself.

The problem is that I can't see how not to repeat myself.

{-# 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. Stack rules.

Answer 1

First, recognize what it is that you're repeating. Here it's

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

The solution is just to abstract that out, creating a function that lets you specify 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

Then your CRUD code becomes much cleaner and 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

For completeness:

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