{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module TmpProc.Example1.Server
(
runServer'
, runServer
, waiApp
) where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (throwE)
import Network.Wai (Application)
import Network.Wai.Handler.Warp (Port, run)
import Servant.API ((:<|>) (..))
import Servant.Server (Handler (..), Server, err401,
errBody, serve)
import TmpProc.Example1.Routes (ContactsAPI, contactsAPI)
import TmpProc.Example1.Schema (Contact, ContactID)
import qualified TmpProc.Example1.Cache as Cache
import qualified TmpProc.Example1.Database as DB
runServer' :: Port -> DB.Locator -> Cache.Locator -> IO ()
runServer' :: Port -> Locator -> Locator -> IO ()
runServer' Port
port Locator
dbLoc Locator
cacheLoc = Port -> Application -> IO ()
run Port
port (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ Locator -> Locator -> Application
waiApp Locator
dbLoc Locator
cacheLoc
waiApp :: DB.Locator -> Cache.Locator -> Application
waiApp :: Locator -> Locator -> Application
waiApp Locator
dbLoc Locator
cacheLoc = Proxy ContactsAPI -> Server ContactsAPI -> Application
forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy ContactsAPI
contactsAPI (Server ContactsAPI -> Application)
-> Server ContactsAPI -> Application
forall a b. (a -> b) -> a -> b
$ Locator -> Locator -> Server ContactsAPI
server Locator
dbLoc Locator
cacheLoc
runServer :: IO ()
runServer :: IO ()
runServer = Port -> Locator -> Locator -> IO ()
runServer' Port
8000 Locator
DB.defaultLoc Locator
Cache.defaultLoc
fetchContact :: DB.Locator -> Cache.Locator -> ContactID -> Handler Contact
fetchContact :: Locator -> Locator -> ContactID -> Handler Contact
fetchContact Locator
dbLoc Locator
cacheLoc ContactID
cid = do
(IO (Maybe Contact) -> Handler (Maybe Contact)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Contact) -> Handler (Maybe Contact))
-> IO (Maybe Contact) -> Handler (Maybe Contact)
forall a b. (a -> b) -> a -> b
$ Locator -> ContactID -> IO (Maybe Contact)
Cache.loadContact Locator
cacheLoc ContactID
cid) Handler (Maybe Contact)
-> (Maybe Contact -> Handler Contact) -> Handler Contact
forall a b. Handler a -> (a -> Handler b) -> Handler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Contact
contact -> Contact -> Handler Contact
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Contact
contact
Maybe Contact
Nothing -> (IO (Maybe Contact) -> Handler (Maybe Contact)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Contact) -> Handler (Maybe Contact))
-> IO (Maybe Contact) -> Handler (Maybe Contact)
forall a b. (a -> b) -> a -> b
$ Locator -> ContactID -> IO (Maybe Contact)
DB.fetch Locator
dbLoc ContactID
cid) Handler (Maybe Contact)
-> (Maybe Contact -> Handler Contact) -> Handler Contact
forall a b. Handler a -> (a -> Handler b) -> Handler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Contact
contact -> IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Locator -> ContactID -> Contact -> IO ()
Cache.saveContact Locator
cacheLoc ContactID
cid Contact
contact) Handler () -> Handler Contact -> Handler Contact
forall a b. Handler a -> Handler b -> Handler b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Contact -> Handler Contact
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Contact
contact
Maybe Contact
Nothing -> ExceptT ServerError IO Contact -> Handler Contact
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO Contact -> Handler Contact)
-> ExceptT ServerError IO Contact -> Handler Contact
forall a b. (a -> b) -> a -> b
$ (ServerError -> ExceptT ServerError IO Contact
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ServerError -> ExceptT ServerError IO Contact)
-> ServerError -> ExceptT ServerError IO Contact
forall a b. (a -> b) -> a -> b
$ ServerError
err401 { errBody = "No Contact with this ID" })
createContact :: DB.Locator -> Contact -> Handler ContactID
createContact :: Locator -> Contact -> Handler ContactID
createContact Locator
dbLoc Contact
contact = IO ContactID -> Handler ContactID
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ContactID -> Handler ContactID)
-> IO ContactID -> Handler ContactID
forall a b. (a -> b) -> a -> b
$ Locator -> Contact -> IO ContactID
DB.create Locator
dbLoc Contact
contact
server :: DB.Locator -> Cache.Locator -> Server ContactsAPI
server :: Locator -> Locator -> Server ContactsAPI
server Locator
dbLoc Locator
cacheLoc =
(Locator -> Locator -> ContactID -> Handler Contact
fetchContact Locator
dbLoc Locator
cacheLoc) (ContactID -> Handler Contact)
-> (Contact -> Handler ContactID)
-> (ContactID -> Handler Contact)
:<|> (Contact -> Handler ContactID)
forall a b. a -> b -> a :<|> b
:<|>
(Locator -> Contact -> Handler ContactID
createContact Locator
dbLoc)