From 38d9cd607205e2996e4b1c622bc2ad9128df2dfb Mon Sep 17 00:00:00 2001
From: Sanchayan Maity <maitysanchayan@gmail.com>
Date: Mon, 27 Jul 2020 20:32:43 +0530
Subject: [PATCH] Lib: Changes to the DSL

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>
---
 src/Lib.hs | 39 ++++++++++-----------------------------
 1 file changed, 10 insertions(+), 29 deletions(-)

diff --git a/src/Lib.hs b/src/Lib.hs
index 3e675ee..6dd6c31 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -9,10 +9,7 @@ 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
@@ -37,25 +34,6 @@ 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
 
@@ -65,22 +43,20 @@ instance Functor LoggerMethodF where
 type Logger = F LoggerMethodF
 
 logMessage :: Text -> Logger ()
-logMessage logMsg = liftF $ LogMessage logMsg id
+logMessage msg = liftF $ LogMessage msg id
 
 interpretLoggerMethod :: LoggerMethodF a -> IO a
 interpretLoggerMethod (LogMessage msg next) = next <$> print msg
 
-runLogger :: Logger a -> IO a
+runLogger :: Logger () -> IO ()
 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
@@ -88,10 +64,15 @@ 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 :: 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