Decouple Interface with Infrastucture

with ReaderT Design Pattern (Capability)

app/Main.hs

@@ -5,10 +5,13 @@ import Data.Proxy
 import API
 import Network.Wai.Handler.Warp (run)
 import Control.Concurrent.MVar (newMVar)
+import AppM (Config(MkConfig), userDatabase)
 import Data.Map.Strict as M
+import User
 
 main :: IO ()
 main = do
   putStrLn "Hello, Haskell!"
-  userRepo <- newMVar $ M.fromList [(1, User 1 "Johny Joestar"), (2, User 2 "Adam Levine")]
-  run 8080 (app userRepo)
\ No newline at end of file
+  userDatabase <- newMVar $ M.fromList [(1, User 1 "Johny Joestar"), (2, User 2 "Adam Levine")]
+  let config = MkConfig { userDatabase = userDatabase}
+  run 8080 (app config)
\ No newline at end of file

flyio.cabal

@@ -22,7 +22,10 @@ maintainer:         naufalauddin@gmail.com
 extra-source-files: CHANGELOG.md
 
 library
-    exposed-modules: API
+    exposed-modules:
+        API
+      , AppM
+      , User
 
     -- Modules included in this library but not exported.
     other-modules:

src/API.hs

@@ -10,13 +10,10 @@ import Data.Text
 import Servant.API
 import Servant.API.Generic
 import Servant
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
 import Control.Concurrent.MVar
-import Control.Monad.IO.Class
 import Data.Aeson (ToJSON (toEncoding), object, toJSON, (.=), pairs)
-import Control.Monad.Reader.Class
-import Control.Monad.Reader (ReaderT (runReaderT))
+import User (User)
+import AppM
 
 type API = NamedRoutes NamedAPI
 
@@ -29,40 +26,25 @@ data NamedAPI mode = NamedAPI
     deriving Generic
 
 data UserRoutes mode = UserRoutes
-    { getId :: mode :- "user" :> Capture "userId" Int :> Get '[JSON] User
+    { getById :: mode :- "user" :> Capture "userId" Int :> Get '[JSON] User
     , allUsers :: mode :- "users" :> Get '[JSON] [User]
     }
     deriving Generic
 
-data User = User
-    { id :: Int
-    , name :: Text
-    }
-
-instance ToJSON User where
-    toJSON (User id name) = object ["id" .= id, "name" .= name]
-    toEncoding (User id name) = pairs ("id" .= id <> "name" .= name)
-
-server :: ServerT API (ReaderT UserDatabase Handler)
+server :: ServerT API AppM
 server = NamedAPI
     { hello = pure "Hello, World!"
     , greet = pure . ("Hello, " <>)
     , add = \x y -> pure $ x + y
     , crudUser = UserRoutes
-        { getId = \id -> do
-            userMap <- ask
-            userRepo <- liftIO $ readMVar userMap
-            case M.lookup id userRepo of
+        { getById = \id -> do
+            maybeUser <- getUserById id
+            case maybeUser of
                 Just user -> pure user
                 Nothing -> throwError err404 { errBody = "User Not Found" }
-        , allUsers = do
-            userMap <- ask
-            userRepo <- liftIO $ readMVar userMap
-            pure $ M.elems userRepo
+        , allUsers = getAllUser
         }
     }
 
-type UserDatabase = MVar (Map Int User)
-
-app :: UserDatabase -> Application
-app userDatabase = serve (Proxy @API) (hoistServer (Proxy @API) (`runReaderT` userDatabase) server)
\ No newline at end of file
+app :: Config -> Application
+app config = serve (Proxy @API) (hoistServer (Proxy @API) (runApp config) server)
\ No newline at end of file

src/AppM.hs

+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module AppM where
+
+import Control.Monad.Reader.Class
+import Control.Monad.Reader (ReaderT (runReaderT))
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Except (MonadError)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import User
+import Servant (ServerError, Handler)
+import Control.Concurrent.MVar (MVar, readMVar)
+
+newtype AppM a = MkAppM { runAppM :: ReaderT Config Handler a }
+    deriving (Functor, Applicative, Monad, MonadReader Config, MonadIO, MonadError ServerError)
+
+data Config = MkConfig { userDatabase :: UserDatabase }
+
+runApp :: Config -> AppM a -> Handler a
+runApp config = (`runReaderT` config) . runAppM
+
+class HasUserDatabase m where
+    getUserById :: Int -> m (Maybe User)
+    getAllUser :: m [User]
+
+instance HasUserDatabase AppM where
+    getUserById id = do
+        userRepo <- asks userDatabase
+        userMap <- liftIO $ readMVar userRepo
+        pure $ M.lookup id userMap
+    getAllUser = do
+        userRepo <- asks userDatabase
+        userMap <- liftIO $ readMVar userRepo
+        pure $ M.elems userMap
+
+type UserDatabase = MVar (Map Int User)
\ No newline at end of file

src/User.hs

+{-# LANGUAGE OverloadedStrings #-}
+module User where
+import Data.Text
+import Data.Aeson
+
+data User = User
+    { id :: Int
+    , name :: Text
+    }
+
+instance ToJSON User where
+    toJSON (User id name) = object ["id" .= id, "name" .= name]
+    toEncoding (User id name) = pairs ("id" .= id <> "name" .= name)
\ No newline at end of file