{-# 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 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 = forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy ContactsAPI
contactsAPI 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
(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Locator -> ContactID -> IO (Maybe Contact)
Cache.loadContact Locator
cacheLoc ContactID
cid) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Contact
contact -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Contact
contact
Maybe Contact
Nothing -> (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Locator -> ContactID -> IO (Maybe Contact)
DB.fetch Locator
dbLoc ContactID
cid) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Contact
contact -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Locator -> ContactID -> Contact -> IO ()
Cache.saveContact Locator
cacheLoc ContactID
cid Contact
contact) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Contact
contact
Maybe Contact
Nothing -> forall a. ExceptT ServerError IO a -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ ServerError
err401 { errBody :: ByteString
errBody = ByteString
"No Contact with this ID" })
createContact :: DB.Locator -> Contact -> Handler ContactID
createContact :: Locator -> Contact -> Handler ContactID
createContact Locator
dbLoc Contact
contact = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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) forall a b. a -> b -> a :<|> b
:<|>
(Locator -> Contact -> Handler ContactID
createContact Locator
dbLoc)