init

src/Core.hs

@@ -0,0 +1,54 @@
+module Core where
+
+import Control.Exception                  (IOException)
+import Data.Aeson                         (FromJSON, ToJSON)
+import qualified Data.Text                as T
+import Database.PostgreSQL.Simple         (Query)
+import Database.PostgreSQL.Simple.FromRow (FromRow, field, fromRow)
+import Database.PostgreSQL.Simple.ToRow   (ToRow, toRow)
+import Database.PostgreSQL.Simple.ToField (ToField)
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Error.Static             (Error)
+import Effectful.FileSystem
+import GHC.Generics                       (Generic)
+import Servant hiding                     ((:>))
+import qualified Servant                  as S
+
+-- Core data
+data User = User { userId :: Int, userName :: String}
+  deriving (Show, Generic)
+
+instance FromRow User where
+    fromRow = User <$> field <*> field
+instance ToRow User where
+    toRow (User uid name) = toRow (uid, name)
+
+instance ToJSON User
+instance FromJSON User
+
+-- Effects
+type AppEff = Eff '[Database, FileSystem, Error ServerError, IOE]
+
+data Database :: Effect where
+  DatabaseRead  :: (Query, Int)    -> Database (Eff es) (Maybe User)
+  DatabaseWrite :: (Query, String) -> Database (Eff es) ()
+
+type instance DispatchOf Database = 'Dynamic
+
+databaseRead  :: (Database :> es, Error ServerError :> es) => (Query, Int) -> Eff es (Maybe User)
+databaseRead  = send . DatabaseRead
+
+databaseWrite :: (Database :> es, Error ServerError :> es) => (Query, String) -> Eff es ()
+databaseWrite = send . DatabaseWrite
+
+-- Routes
+type Root     = Get '[PlainText] T.Text
+type UserList = "user" S.:> Get '[JSON] [User]
+type UserGet  = "user" S.:> Capture "userId"     Int    S.:> Get  '[JSON] User
+type UserPost = "user" S.:> ReqBody '[PlainText] String S.:> PostCreated '[PlainText] NoContent
+
+type API = Root
+      :<|> UserList
+      :<|> UserGet
+      :<|> UserPost

src/Database.hs

@@ -0,0 +1,58 @@
+module Database where
+
+import Core
+
+import Control.Exception          (IOException)
+import Control.Monad.Catch        (catch)
+import Data.Aeson                 (ToJSON)
+import Data.ByteString.Lazy.UTF8  (fromString)
+import Data.Maybe                 (listToMaybe)
+import Database.PostgreSQL.Simple 
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Error.Static     (Error, HasCallStack, catchError, runErrorNoCallStack, throwError)
+import Servant hiding             ((:>), throwError)
+
+runDatabaseDebug :: (IOE :> es, Error ServerError :> es) => Eff (Database : es) a -> Eff es a
+runDatabaseDebug = interpret $ \_ -> \case
+  DatabaseRead  (statement, values)  -> adapt $ read  statement values
+  DatabaseWrite (statement, values)  -> adapt $ write statement values
+  where
+    read  _ values = 
+      putStrLn "We just mocked a READ database operation" >>= \_ -> pure $ 
+        Just (User values "Mock User")
+    write _ values = 
+      putStrLn $ "We just mocked a WRITE database operation with a user named " 
+        ++ values
+
+runDatabaseIO :: (IOE :> es, Error ServerError :> es) => Eff (Database : es) a -> Eff es a
+runDatabaseIO = interpret $ \_ -> \case
+  DatabaseRead  (statement, values) -> adapt $ read  statement values
+  DatabaseWrite (statement, values) -> adapt $ write statement values
+  where
+    read  :: Query -> Int -> IO (Maybe User)
+    read statement values  = do
+      conn <- openConn
+      user <- query conn statement (Only values)
+      pure  $ listToMaybe user
+    write :: Query -> String -> IO ()
+    write statement values = do
+      conn <- openConn
+      execute conn statement (Only values)
+      putStrLn $ "Wrote user to database using statement:\n" ++ show statement
+    openConn = connectPostgreSQL "host=localhost port=5432 dbname=demo connect_timeout=10"
+
+adapt :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a
+adapt m = liftIO m `catch` \(e::IOException) ->
+  throwError $ ServerError
+    { errHTTPCode     = 500
+    , errReasonPhrase = "Internal Database Error"
+    , errBody         = fromString $ show e
+    , errHeaders      = []
+    }
+
+queryUser :: Int -> (Query, Int)
+queryUser userId = ("SELECT id, name FROM users WHERE id = ?;", userId)
+
+writeUser :: String -> (Query, String)
+writeUser name   = ("INSERT INTO users (name) VALUES (?);", name)

src/Handlers.hs

@@ -0,0 +1,29 @@
+module Handlers where
+
+import Core
+import Database
+
+import qualified Data.ByteString.Char8    as C
+import Data.List
+import qualified Data.Text                as T
+import Effectful
+import Effectful.Error.Static             (Error, throwError)
+import Effectful.FileSystem
+import Effectful.FileSystem.IO.ByteString as EBS
+import Servant hiding                     ((:>), throwError)
+import qualified Servant                  as S
+
+rootHandler :: (Error ServerError :> es) => Eff es T.Text
+rootHandler = return "Hello, World!"
+
+userListHandler :: (Database :> es, Error ServerError :> es, FileSystem :> es) => Eff es [User]
+userListHandler = mapM userGetHandler [1, 2, 3]
+
+userGetHandler :: (Database :> es, Error ServerError :> es, FileSystem :> es) => Int -> Eff es User
+userGetHandler userId = databaseRead (queryUser userId) >>= \mUser -> 
+  case mUser of
+    Just a  -> pure a
+    Nothing -> pure (User 0 "No user found")
+
+userPostHandler :: (Database :> es, Error ServerError :> es, FileSystem :> es) => String -> Eff es NoContent
+userPostHandler name = databaseWrite (writeUser name) >>= \_ -> return NoContent

src/Main.hs

@@ -0,0 +1,33 @@
+module Main (main) where
+
+import Core
+import Database
+import Handlers
+
+import Control.Monad.Except     (ExceptT (ExceptT))
+import Data.List
+import Effectful
+import Effectful.Error.Static   (Error, runError, runErrorNoCallStack, throwError)
+import Effectful.FileSystem
+import Network.Wai.Handler.Warp (run)
+import Servant hiding           ((:>), throwError)
+import qualified Servant        as S
+
+main :: IO ()
+main = run port $ serve proxy app
+
+app :: Server API
+app = α $ rootHandler
+     :<|> userListHandler
+     :<|> userGetHandler
+     :<|> userPostHandler
+
+α :: ServerT API AppEff -> ServerT API Handler
+α = hoistServer proxy $ Handler . ExceptT .
+  runEff . runErrorNoCallStack . runFileSystem . runDatabaseIO
+
+port :: Int
+port = 8080
+
+proxy :: Proxy API
+proxy = Proxy