Commit 3ad559d6 authored by MrMan's avatar MrMan

Added custom AppHandler monad for server

parent 275d2398
......@@ -2,19 +2,19 @@
module Main where
import Data.Functor.Identity
import Components.EntityStore.SQLite
import Config (AppConfig(..), EntityStoreConfig, Host, Port, ProcessEnvironment(..), makeAppConfig)
import Control.Monad (join)
import Data.Functor.Identity
import Data.Semigroup ((<>))
import Types
import Util (rightOrThrow)
import Lib
import Network.Wai.Handler.Warp (run)
import Options.Applicative
import Server (buildApp)
import System.Environment (getEnvironment)
import Text.Pretty.Simple (pPrint)
import Components.EntityStore.SQLite
import Server (app)
import Network.Wai.Handler.Warp (run)
import Types
import Util (rightOrThrow)
data Options = Options
{ cfgPath :: Maybe FilePath
......@@ -78,13 +78,16 @@ buildEntityStore cfg = putStrLn "[info] initializing EntityStore with config:"
-- | Start up the server and serve requests
server :: Complete AppConfig -> IO ()
server cfg = buildEntityStore entityStoreCfg
>>= \entityStore -> startApp
-- ^ Build the entity store
>>= pure . AppState cfg
-- ^ Build the app config with the entity store
>>= startApp
where
entityStoreCfg = runIdentity $ entityStoreConfig cfg
appPort = runIdentity $ port cfg
startApp = putStrLn ("Starting server at port [" <> show appPort <> "]...")
>> run appPort app
startApp state = putStrLn ("Starting server at port [" <> show appPort <> "]...")
>> run appPort (buildApp state)
main :: IO ()
main = parseOptions
......
......@@ -3,14 +3,15 @@
{-# LANGUAGE TypeOperators #-}
module Server
(app)
(buildApp)
where
import Data.Proxy
import Data.Semigroup ((<>))
import Servant.API
import Servant.Server (Server, Handler, Application, serve)
import Servant.Server (ServerT, Application, serve, hoistServer)
import qualified Data.Text as DT
import Types
type Name = DT.Text
type Greeting = DT.Text
......@@ -19,20 +20,22 @@ type HelloWorldAPI =
"hello" :> QueryParam "name" DT.Text :> Get '[JSON] Greeting
:<|> "goodbye" :> QueryParam "name" DT.Text :> Get '[JSON] Greeting
helloWorldServer :: Server HelloWorldAPI
helloWorldServer :: ServerT HelloWorldAPI AppHandler
helloWorldServer = handleHello
:<|> handleGoodbye
handleHello :: Maybe Name -> Handler Greeting
handleHello :: Maybe Name -> AppHandler Greeting
handleHello Nothing = return $ "hello world"
handleHello (Just name) = return $ "hello " <> name
handleGoodbye :: Maybe Name -> Handler Greeting
handleGoodbye :: Maybe Name -> AppHandler Greeting
handleGoodbye Nothing = return $ "goodbye world"
handleGoodbye (Just name) = return $ "goodbye " <> name
helloWorldAPI :: Proxy HelloWorldAPI
helloWorldAPI = Proxy
app :: Application
app = serve helloWorldAPI helloWorldServer
buildApp :: AppState -> Application
buildApp state = serve helloWorldAPI $ hoistServer helloWorldAPI naturalTransform helloWorldServer
where
naturalTransform = appToServantHandler state
......@@ -35,6 +35,7 @@ library:
- uuid
- sqlite-simple
- neat-interpolation
- transformers
executables:
haskell-restish-todo-exe:
......
......@@ -15,9 +15,10 @@
module Types where
import Control.Monad.Trans.Reader (ReaderT(..))
import Data.Bifunctor (second)
import Data.Kind(Type, Constraint)
import Config (CompleteTaskStoreConfig)
import Config (AppConfig, CompleteTaskStoreConfig)
import Control.Exception (throw, Exception)
import Data.Either (isRight)
import Data.Functor.Identity (Identity(..))
......@@ -28,6 +29,7 @@ import Data.Monoid ((<>))
import Data.UUID (UUID, toText, fromText)
import qualified Data.Text as DT
import Database.SQLite.Simple (SQLData, ToRow, FromRow)
import Servant (Handler)
-- Task state for abstracting over TaskState
data TaskState = Finished
......@@ -354,3 +356,16 @@ class SQLEntityStore store where
=> store
-> EntityID
-> IO (Either EntityStoreError (WithID ident (Complete entity)))
-- | Our application state
data AppState = forall estore. SQLEntityStore estore =>
AppState { appConfig :: Complete AppConfig
, entityStore :: estore
}
-- | Our custom application handler monad for use with servant
type AppHandler = ReaderT AppState Handler
-- | Natural transformation for custom servant monad
appToServantHandler :: AppState -> AppHandler a -> Handler a
appToServantHandler state appM = runReaderT appM state
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment