diff --git a/src/Core.hs b/src/Core.hs index b9ce564..86f3abe 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -17,6 +17,19 @@ import GHC.Generics (Generic) import Servant hiding ((:>), throwError) import qualified Servant as S +-- +-- 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 AppAPI = Root + :<|> UserList + :<|> UserGet + :<|> UserPost + -- -- Core data -- @@ -67,26 +80,15 @@ runLoggerIO = interpret $ \_ -> \case log :: (IOE :> es, Error ServerError :> es) => String -> Eff es () log msg = adapt $ putStrLn msg --- Utility adapt :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a +-- Lift IO into Eff and catch IOExceptions adapt m = liftIO m `catch` \(e::IOException) -> do + -- Log IOExceptions to stdout liftIO $ putStrLn $ "ERROR Exception: " ++ show e + -- Throw a custom Servant ServerError throwError $ ServerError { errHTTPCode = 500 , errReasonPhrase = "Internal Server Error" , errBody = "This incident will be investigated." , errHeaders = [] } - --- --- 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 diff --git a/src/Database.hs b/src/Database.hs index 04a083f..9d796e7 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -17,10 +17,10 @@ runDatabaseDebug = interpret $ \_ -> \case DatabaseWrite (statement, values) -> write statement values where read _ values = - writeLog "We just mocked a READ database operation" >>= \_ -> pure $ + writeLog "Mocked a READ database operation" >>= \_ -> pure $ Just (User values "Mock User") write _ values = - writeLog $ "We just mocked a WRITE database operation with a user named " + writeLog $ "Mocked a WRITE database operation with a user named " ++ values runDatabaseIO :: DatabaseEffects es => Eff (Database : es) a -> Eff es a diff --git a/src/Main.hs b/src/Main.hs index 4b2247c..58a6d5d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -19,13 +19,13 @@ import qualified Servant as S main :: IO () main = run port $ serve proxy app -app :: Server API +app :: Server AppAPI app = α $ rootHandler :<|> userListHandler :<|> userGetHandler :<|> userPostHandler -α :: ServerT API AppEff -> ServerT API Handler +α :: ServerT AppAPI AppEff -> ServerT AppAPI Handler α = hoistServer proxy $ Handler . ExceptT @@ -38,5 +38,5 @@ app = α $ rootHandler port :: Int port = 8080 -proxy :: Proxy API +proxy :: Proxy AppAPI proxy = Proxy