79 lines
2.6 KiB
Haskell
79 lines
2.6 KiB
Haskell
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE Rank2Types #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Lib where
|
|
|
|
import Control.Exception
|
|
import Control.Monad.Free.Church
|
|
import Database.PostgreSQL.Simple
|
|
import Data.Text
|
|
|
|
data SqlDBMethodF next where
|
|
SqlDBMethod :: FromRow r => (Connection -> Query -> IO [r]) -> ([r] -> next) -> SqlDBMethodF next
|
|
SqlThrowException :: Exception e => e -> (a -> next) -> SqlDBMethodF next
|
|
|
|
instance Functor SqlDBMethodF where
|
|
fmap f (SqlDBMethod runner next) = SqlDBMethod runner (f . next)
|
|
fmap f (SqlThrowException exceptionMsg next) = SqlThrowException exceptionMsg (f . next)
|
|
|
|
type SqlDb = F SqlDBMethodF
|
|
|
|
sqlDbMethod :: FromRow r => (Connection -> Query -> IO [r]) -> SqlDb [r]
|
|
sqlDbMethod action = liftF $ SqlDBMethod action id
|
|
|
|
sqlThrowException :: Exception e => e -> SqlDb a
|
|
sqlThrowException exception = liftF $ SqlThrowException exception id
|
|
|
|
interpretSqlDBMethod :: Connection -> Query -> SqlDBMethodF a -> IO a
|
|
interpretSqlDBMethod conn squery (SqlDBMethod runner next) = next <$> runner conn squery
|
|
interpretSqlDBMethod _ _ (SqlThrowException exception _) = throwIO exception
|
|
|
|
runDB :: Connection -> Query -> SqlDb a -> IO a
|
|
runDB conn squery = foldF $ interpretSqlDBMethod conn squery
|
|
|
|
data LoggerMethodF next where
|
|
LogMessage :: Text -> (() -> next) -> LoggerMethodF next
|
|
|
|
instance Functor LoggerMethodF where
|
|
fmap f (LogMessage msg next) = LogMessage msg (f . next)
|
|
|
|
type Logger = F LoggerMethodF
|
|
|
|
logMessage :: Text -> Logger ()
|
|
logMessage msg = liftF $ LogMessage msg id
|
|
|
|
interpretLoggerMethod :: LoggerMethodF a -> IO a
|
|
interpretLoggerMethod (LogMessage msg next) = next <$> print msg
|
|
|
|
runLogger :: Logger () -> IO ()
|
|
runLogger = foldF interpretLoggerMethod
|
|
|
|
data DSLMethod next where
|
|
LogMsg :: Logger () -> (() -> next) -> DSLMethod next
|
|
RunQuery :: FromRow r => Connection -> Query -> SqlDb [r] -> ([r] -> next) -> DSLMethod next
|
|
|
|
instance Functor DSLMethod where
|
|
fmap f (LogMsg msg next) = LogMsg msg (f . next)
|
|
fmap f (RunQuery conn squery act next) = RunQuery conn squery act (f . next)
|
|
|
|
type DSL = F DSLMethod
|
|
|
|
interpretDSLMethod :: DSLMethod a -> IO a
|
|
interpretDSLMethod (LogMsg logger next) =
|
|
fmap next $ runLogger logger
|
|
interpretDSLMethod (RunQuery conn squery sql next) =
|
|
fmap next $ runDB conn squery sql
|
|
|
|
runDSL :: DSL () -> IO ()
|
|
runDSL = foldF interpretDSLMethod
|
|
|
|
-- Smart constructors providing a convenient interface.
|
|
logMsg :: Text -> DSL ()
|
|
logMsg msg = liftF $ LogMsg (logMessage msg) id
|
|
|
|
runQuery :: (MonadFree DSLMethod m, FromRow r) => Connection -> Query -> m [r]
|
|
runQuery conn squery = liftF $ RunQuery conn squery (sqlDbMethod query_) id
|