Commit 3ad559d6 authored by MrMan's avatar MrMan

Added custom AppHandler monad for server

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