eckyputrady · April 2, 2023 12:07 · Oct 2, 2017 · Oct 2, 2017 · Oct 2, 2017
diff --git a/Pseudo.hs b/Pseudo.hs
@@ -6,10 +6,10 @@ type UserId = Text
 type User = Text
 
 class (Monad m) => UserRepo m where
-  getUserById :: UserId -> User
+  getUserById :: UserId -> m User
 
 class (Monad m) => SessionRepo m where
-  getUserIdBySession :: SessionId -> UserId
+  getUserIdBySession :: SessionId -> m UserId
 
 getUser :: (UserRepo m, SessionRepo m)
         => SessionId -> m User

diff --git a/Pseudo.hs b/Pseudo.hs
@@ -37,11 +37,11 @@ acquireConnection :: IO Connection
 acquireConnection = ...
 
 getUserById :: (Reader Connection m) 
-            => Domain.UserId -> Domain.User
+            => Domain.UserId -> m Domain.User
 getUserById = ...
 
 getUserIdBySession :: (Reader Connection m) 
-                   => Domain.Session -> Domain.UserId
+                   => Domain.Session -> m Domain.UserId
 getUserIdBySession = ...
 
 -----------------------------

diff --git a/Pseudo.hs b/Pseudo.hs
@@ -0,0 +1,68 @@
+-----------------------------
+-- Domain.hs
+
+type SessionId = Text
+type UserId = Text
+type User = Text
+
+class (Monad m) => UserRepo m where
+  getUserById :: UserId -> User
+
+class (Monad m) => SessionRepo m where
+  getUserIdBySession :: SessionId -> UserId
+
+getUser :: (UserRepo m, SessionRepo m)
+        => SessionId -> m User
+getUser sId = getUserIdBySession sId 
+          >>= getUserById
+
+-----------------------------
+-- Routes.hs
+
+import qualified Domain
+
+routes :: (Domain.UserRepo m, Domain.SessionRepo m) => m ()
+routes =
+  get "/user" $ do
+    sId <- parseSessionFromCookiesSomehow
+    user <- Domain.getUser sId
+    displayUserSomeHow user
+
+-----------------------------
+-- Redis.hs
+
+import qualified Domain
+
+acquireConnection :: IO Connection
+acquireConnection = ...
+
+getUserById :: (Reader Connection m) 
+            => Domain.UserId -> Domain.User
+getUserById = ...
+
+getUserIdBySession :: (Reader Connection m) 
+                   => Domain.Session -> Domain.UserId
+getUserIdBySession = ...
+
+-----------------------------
+-- Main.hs
+
+import qualified Domain
+import qualified Redis
+import qualified Routes
+
+newtype App a = App 
+  { unApp :: ReaderT Connection IO a
+  } deriving ( Applicative, Functor, Monad
+             , MonadReader Connection, MonadIO
+             )
+
+instance Domain.UserRepo App where
+  getUserById = Redis.getUserById
+
+instance Domain.SessionRepo App where
+  getUserIdBySession = Redis.getUserIdBySession
+
+main = do
+  conn <- Redis.acquireConnection
+  flip runReaderT conn . unApp $ Routes.routes