{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators     #-}
{-|
Copyright   : (c) 2020-2021 Tim Emiola
SPDX-License-Identifier: BSD3
Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>

Implements the demo service.

-}
module TmpProc.Example1.Server
  ( -- * Server implementation
    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


{-| Runs 'waiApp' on the given port. -}
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


{-| An 'Application' that runs the server using the given DB and Cache. -}
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


{-| Runs 'waiApp' using defaults for local development. -}
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)