98 lines
3.3 KiB
Haskell
98 lines
3.3 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.Proxy
|
|
import Data.Text
|
|
import Servant.API
|
|
import Servant.Server
|
|
|
|
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
|
|
|
|
type SampleAPI = Get '[JSON] Text
|
|
|
|
data ServeF next where
|
|
ServeMethod :: (forall api. HasServer api '[] => (Proxy api -> IO a)) -> (a -> next) -> ServeF next
|
|
|
|
instance Functor ServeF where
|
|
fmap f (ServeMethod runner next) = ServeMethod runner (f . next)
|
|
|
|
type Serve = F ServeF
|
|
|
|
serveMethod :: (forall api. HasServer api '[] => (Proxy api -> IO a)) -> Serve a
|
|
serveMethod action = liftF $ ServeMethod action id
|
|
|
|
interpretServeMethod :: HasServer api '[] => Proxy api -> ServeF a -> IO a
|
|
interpretServeMethod api (ServeMethod runner next) = next <$> runner api
|
|
|
|
runServe :: HasServer api '[] => Proxy api -> Serve a -> IO a
|
|
runServe api = foldF $ interpretServeMethod api
|
|
|
|
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 logMsg = liftF $ LogMessage logMsg id
|
|
|
|
interpretLoggerMethod :: LoggerMethodF a -> IO a
|
|
interpretLoggerMethod (LogMessage msg next) = next <$> print msg
|
|
|
|
runLogger :: Logger a -> IO a
|
|
runLogger = foldF interpretLoggerMethod
|
|
|
|
data DSLMethod next where
|
|
LogMsg :: Logger () -> (() -> next) -> DSLMethod next
|
|
ServeHttp :: HasServer api '[] => Proxy api -> Serve a -> (a -> 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 (ServeHttp api act next) = ServeHttp api act (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 (ServeHttp api server next) =
|
|
fmap next $ runServe api server
|
|
interpretDSLMethod (RunQuery conn squery sql next) =
|
|
fmap next $ runDB conn squery sql
|
|
|
|
runDSL :: DSL a -> IO a
|
|
runDSL = foldF interpretDSLMethod
|