sanchayanmaity/free-monad-example
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Lib: Changes to the DSL

Browse source 
1. Fix the logger DSL and add top level helpers
2. Drop the servant server part in the DSL. As aptly explained by Arun,
"It won't accomplish a lot to DSL-ise the starting of that execution
flow -- it's not expressing any business logic, just setting up the
scaffolding within which our business logic will be executed".

Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
This commit is contained in:
Sanchayan Maity 2020-07-27 20:32:43 +05:30
parent 7547bcefad
commit 38d9cd6072
1 changed files with 10 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

39
src/Lib.hs
View file

@ -9,10 +9,7 @@ module Lib where
import Control.Exception import Control.Exception
import Control.Monad.Free.Church import Control.Monad.Free.Church
import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple
import Data.Proxy
import Data.Text import Data.Text
import Servant.API
import Servant.Server
data SqlDBMethodF next where data SqlDBMethodF next where
SqlDBMethod :: FromRow r => (Connection -> Query -> IO [r]) -> ([r] -> next) -> SqlDBMethodF next SqlDBMethod :: FromRow r => (Connection -> Query -> IO [r]) -> ([r] -> next) -> SqlDBMethodF next
@ -37,25 +34,6 @@ interpretSqlDBMethod _ _ (SqlThrowException exception _) = throwIO exception
runDB :: Connection -> Query -> SqlDb a -> IO a runDB :: Connection -> Query -> SqlDb a -> IO a
runDB conn squery = foldF $ interpretSqlDBMethod conn squery 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 data LoggerMethodF next where
LogMessage :: Text -> (() -> next) -> LoggerMethodF next LogMessage :: Text -> (() -> next) -> LoggerMethodF next
@ -65,22 +43,20 @@ instance Functor LoggerMethodF where
type Logger = F LoggerMethodF type Logger = F LoggerMethodF
logMessage :: Text -> Logger () logMessage :: Text -> Logger ()
logMessage logMsg = liftF $ LogMessage logMsg id logMessage msg = liftF $ LogMessage msg id
interpretLoggerMethod :: LoggerMethodF a -> IO a interpretLoggerMethod :: LoggerMethodF a -> IO a
interpretLoggerMethod (LogMessage msg next) = next <$> print msg interpretLoggerMethod (LogMessage msg next) = next <$> print msg
runLogger :: Logger a -> IO a runLogger :: Logger () -> IO ()
runLogger = foldF interpretLoggerMethod runLogger = foldF interpretLoggerMethod
data DSLMethod next where data DSLMethod next where
LogMsg :: Logger () -> (() -> next) -> DSLMethod next 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 RunQuery :: FromRow r => Connection -> Query -> SqlDb [r] -> ([r] -> next) -> DSLMethod next
instance Functor DSLMethod where instance Functor DSLMethod where
fmap f (LogMsg msg next) = LogMsg msg (f . next) 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) fmap f (RunQuery conn squery act next) = RunQuery conn squery act (f . next)
type DSL = F DSLMethod type DSL = F DSLMethod
@ -88,10 +64,15 @@ type DSL = F DSLMethod
interpretDSLMethod :: DSLMethod a -> IO a interpretDSLMethod :: DSLMethod a -> IO a
interpretDSLMethod (LogMsg logger next) = interpretDSLMethod (LogMsg logger next) =
fmap next $ runLogger logger fmap next $ runLogger logger
interpretDSLMethod (ServeHttp api server next) =
fmap next $ runServe api server
interpretDSLMethod (RunQuery conn squery sql next) = interpretDSLMethod (RunQuery conn squery sql next) =
fmap next $ runDB conn squery sql fmap next $ runDB conn squery sql
runDSL :: DSL a -> IO a runDSL :: DSL () -> IO ()
runDSL = foldF interpretDSLMethod 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