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

Implements a demo service.

-}
module TmpProc.Example2.Server
  ( -- * Server implementation
    AppEnv(..)
  , runServer'
  , runServer
  , waiApp
  ) where

import           Control.Exception          (try, throw)
import           Control.Monad.Catch        (MonadCatch, MonadMask, MonadThrow)
import           Control.Monad.IO.Class     (MonadIO, liftIO)
import           Control.Monad.Reader       (MonadReader, ReaderT, asks,
                                             runReaderT)
import           Control.Monad.Trans.Except (ExceptT (..))
import           Network.Wai                (Application)
import           Network.Wai.Handler.Warp   (Port, run)
import           Servant.API                ((:<|>) (..))
import           Servant.Server             (Handler (..), ServerT,
                                             err401, errBody, serve, hoistServer)

import           TmpProc.Example2.Routes    (ContactsAPI, contactsAPI)
import           TmpProc.Example2.Schema    (Contact, ContactID)

import qualified TmpProc.Example2.Cache     as Cache
import qualified TmpProc.Example2.Database  as DB


{-| Runs 'waiApp' on the given port. -}
runServer' :: IO AppEnv -> Port -> IO ()
runServer' :: IO AppEnv -> Port -> IO ()
runServer' IO AppEnv
mkEnv Port
port = IO AppEnv
mkEnv IO AppEnv -> (AppEnv -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Port -> Application -> IO ()
run Port
port (Application -> IO ())
-> (AppEnv -> Application) -> AppEnv -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppEnv -> Application
waiApp


{-| An 'Application' that runs the server using the given DB and Cache. -}
waiApp :: AppEnv -> Application
waiApp :: AppEnv -> Application
waiApp AppEnv
env =
  let
    hoist' :: App a -> Handler a
hoist' = ExceptT ServerError IO a -> Handler a
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO a -> Handler a)
-> (App a -> ExceptT ServerError IO a) -> App a -> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either ServerError a) -> ExceptT ServerError IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ServerError a) -> ExceptT ServerError IO a)
-> (App a -> IO (Either ServerError a))
-> App a
-> ExceptT ServerError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either ServerError a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO (Either ServerError a))
-> (App a -> IO a) -> App a -> IO (Either ServerError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppEnv -> App a -> IO a
forall a. AppEnv -> App a -> IO a
runApp' AppEnv
env
  in
    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
$ Proxy ContactsAPI
-> (forall x. App x -> Handler x)
-> ServerT ContactsAPI App
-> Server ContactsAPI
forall api (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer Proxy ContactsAPI
contactsAPI forall x. App x -> Handler x
hoist' ServerT ContactsAPI App
forall r (m :: * -> *).
(Has Connection r, Has Locator r, MonadReader r m, MonadIO m) =>
ServerT ContactsAPI m
server


{-| Runs 'waiApp' using defaults for local development. -}
runServer :: IO ()
runServer :: IO ()
runServer = IO AppEnv -> Port -> IO ()
runServer' IO AppEnv
defaultEnv Port
8000


fetchContact
  :: (MonadIO m, MonadReader r m, Has DB.Locator r, Has Cache.Connection r)
  => ContactID -> m Contact
fetchContact :: ContactID -> m Contact
fetchContact ContactID
cid = do
  Connection
cache <- forall field env (m :: * -> *).
(MonadReader env m, Has field env) =>
m field
forall env (m :: * -> *).
(MonadReader env m, Has Connection env) =>
m Connection
grab @Cache.Connection
  (IO (Maybe Contact) -> m (Maybe Contact)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Contact) -> m (Maybe Contact))
-> IO (Maybe Contact) -> m (Maybe Contact)
forall a b. (a -> b) -> a -> b
$ Connection -> ContactID -> IO (Maybe Contact)
Cache.loadContact Connection
cache ContactID
cid) m (Maybe Contact) -> (Maybe Contact -> m Contact) -> m Contact
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Contact
contact -> Contact -> m Contact
forall (f :: * -> *) a. Applicative f => a -> f a
pure Contact
contact
    Maybe Contact
Nothing -> do
      Locator
db <- forall field env (m :: * -> *).
(MonadReader env m, Has field env) =>
m field
forall env (m :: * -> *).
(MonadReader env m, Has Locator env) =>
m Locator
grab @DB.Locator
      (IO (Maybe Contact) -> m (Maybe Contact)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Contact) -> m (Maybe Contact))
-> IO (Maybe Contact) -> m (Maybe Contact)
forall a b. (a -> b) -> a -> b
$ Locator -> ContactID -> IO (Maybe Contact)
DB.fetch Locator
db ContactID
cid) m (Maybe Contact) -> (Maybe Contact -> m Contact) -> m Contact
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Contact
contact -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Connection -> ContactID -> Contact -> IO ()
Cache.saveContact Connection
cache ContactID
cid Contact
contact) m () -> m Contact -> m Contact
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Contact -> m Contact
forall (f :: * -> *) a. Applicative f => a -> f a
pure Contact
contact
        Maybe Contact
Nothing -> ServerError -> m Contact
forall a e. Exception e => e -> a
throw (ServerError -> m Contact) -> ServerError -> m Contact
forall a b. (a -> b) -> a -> b
$ ServerError
err401 { errBody :: ByteString
errBody = ByteString
"No Contact with this ID" }


createContact
  :: (MonadIO m, MonadReader r m, Has DB.Locator r)
  => Contact -> m ContactID
createContact :: Contact -> m ContactID
createContact Contact
contact = do
  Locator
db <- forall field env (m :: * -> *).
(MonadReader env m, Has field env) =>
m field
forall env (m :: * -> *).
(MonadReader env m, Has Locator env) =>
m Locator
grab @DB.Locator
  IO ContactID -> m ContactID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ContactID -> m ContactID) -> IO ContactID -> m ContactID
forall a b. (a -> b) -> a -> b
$ Locator -> Contact -> IO ContactID
DB.create Locator
db Contact
contact


server
  :: ( Has Cache.Connection r
     , Has DB.Locator r
     , MonadReader r m
     , MonadIO m
     )
  => ServerT ContactsAPI m
server :: ServerT ContactsAPI m
server = ContactID -> m Contact
forall (m :: * -> *) r.
(MonadIO m, MonadReader r m, Has Locator r, Has Connection r) =>
ContactID -> m Contact
fetchContact (ContactID -> m Contact)
-> (Contact -> m ContactID)
-> (ContactID -> m Contact) :<|> (Contact -> m ContactID)
forall a b. a -> b -> a :<|> b
:<|> Contact -> m ContactID
forall (m :: * -> *) r.
(MonadIO m, MonadReader r m, Has Locator r) =>
Contact -> m ContactID
createContact


-- | The application-level Monad, provides access to AppEnv via @Reader AppEnv@.
newtype App a = App
  { App a -> ReaderT AppEnv IO a
runApp :: ReaderT AppEnv IO a
  } deriving ( Functor App
a -> App a
Functor App
-> (forall a. a -> App a)
-> (forall a b. App (a -> b) -> App a -> App b)
-> (forall a b c. (a -> b -> c) -> App a -> App b -> App c)
-> (forall a b. App a -> App b -> App b)
-> (forall a b. App a -> App b -> App a)
-> Applicative App
App a -> App b -> App b
App a -> App b -> App a
App (a -> b) -> App a -> App b
(a -> b -> c) -> App a -> App b -> App c
forall a. a -> App a
forall a b. App a -> App b -> App a
forall a b. App a -> App b -> App b
forall a b. App (a -> b) -> App a -> App b
forall a b c. (a -> b -> c) -> App a -> App b -> App c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: App a -> App b -> App a
$c<* :: forall a b. App a -> App b -> App a
*> :: App a -> App b -> App b
$c*> :: forall a b. App a -> App b -> App b
liftA2 :: (a -> b -> c) -> App a -> App b -> App c
$cliftA2 :: forall a b c. (a -> b -> c) -> App a -> App b -> App c
<*> :: App (a -> b) -> App a -> App b
$c<*> :: forall a b. App (a -> b) -> App a -> App b
pure :: a -> App a
$cpure :: forall a. a -> App a
$cp1Applicative :: Functor App
Applicative
             , a -> App b -> App a
(a -> b) -> App a -> App b
(forall a b. (a -> b) -> App a -> App b)
-> (forall a b. a -> App b -> App a) -> Functor App
forall a b. a -> App b -> App a
forall a b. (a -> b) -> App a -> App b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> App b -> App a
$c<$ :: forall a b. a -> App b -> App a
fmap :: (a -> b) -> App a -> App b
$cfmap :: forall a b. (a -> b) -> App a -> App b
Functor
             , Applicative App
a -> App a
Applicative App
-> (forall a b. App a -> (a -> App b) -> App b)
-> (forall a b. App a -> App b -> App b)
-> (forall a. a -> App a)
-> Monad App
App a -> (a -> App b) -> App b
App a -> App b -> App b
forall a. a -> App a
forall a b. App a -> App b -> App b
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> App a
$creturn :: forall a. a -> App a
>> :: App a -> App b -> App b
$c>> :: forall a b. App a -> App b -> App b
>>= :: App a -> (a -> App b) -> App b
$c>>= :: forall a b. App a -> (a -> App b) -> App b
$cp1Monad :: Applicative App
Monad
             , MonadThrow App
MonadThrow App
-> (forall e a. Exception e => App a -> (e -> App a) -> App a)
-> MonadCatch App
App a -> (e -> App a) -> App a
forall e a. Exception e => App a -> (e -> App a) -> App a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: App a -> (e -> App a) -> App a
$ccatch :: forall e a. Exception e => App a -> (e -> App a) -> App a
$cp1MonadCatch :: MonadThrow App
MonadCatch
             , MonadCatch App
MonadCatch App
-> (forall b. ((forall a. App a -> App a) -> App b) -> App b)
-> (forall b. ((forall a. App a -> App a) -> App b) -> App b)
-> (forall a b c.
    App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c))
-> MonadMask App
App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c)
((forall a. App a -> App a) -> App b) -> App b
((forall a. App a -> App a) -> App b) -> App b
forall b. ((forall a. App a -> App a) -> App b) -> App b
forall a b c.
App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c)
$cgeneralBracket :: forall a b c.
App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c)
uninterruptibleMask :: ((forall a. App a -> App a) -> App b) -> App b
$cuninterruptibleMask :: forall b. ((forall a. App a -> App a) -> App b) -> App b
mask :: ((forall a. App a -> App a) -> App b) -> App b
$cmask :: forall b. ((forall a. App a -> App a) -> App b) -> App b
$cp1MonadMask :: MonadCatch App
MonadMask
             , Monad App
e -> App a
Monad App
-> (forall e a. Exception e => e -> App a) -> MonadThrow App
forall e a. Exception e => e -> App a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> App a
$cthrowM :: forall e a. Exception e => e -> App a
$cp1MonadThrow :: Monad App
MonadThrow
             , MonadReader AppEnv
             , Monad App
Monad App -> (forall a. IO a -> App a) -> MonadIO App
IO a -> App a
forall a. IO a -> App a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> App a
$cliftIO :: forall a. IO a -> App a
$cp1MonadIO :: Monad App
MonadIO
             )


instance Has DB.Locator     AppEnv  where obtain :: AppEnv -> Locator
obtain = AppEnv -> Locator
aeDbLocator
instance Has Cache.Connection  AppEnv  where obtain :: AppEnv -> Connection
obtain = AppEnv -> Connection
aeCacheLocator


defaultEnv :: IO AppEnv
defaultEnv :: IO AppEnv
defaultEnv = Locator -> Connection -> AppEnv
AppEnv (Locator -> Connection -> AppEnv)
-> IO Locator -> IO (Connection -> AppEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Locator -> IO Locator
forall (f :: * -> *) a. Applicative f => a -> f a
pure Locator
DB.defaultLoc) IO (Connection -> AppEnv) -> IO Connection -> IO AppEnv
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Connection
Cache.defaultConn


-- | Run a 'App' computation with the given environment.
runApp' :: AppEnv -> App a -> IO a
runApp' :: AppEnv -> App a -> IO a
runApp' AppEnv
env = (ReaderT AppEnv IO a -> AppEnv -> IO a)
-> AppEnv -> ReaderT AppEnv IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT AppEnv IO a -> AppEnv -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT AppEnv
env (ReaderT AppEnv IO a -> IO a)
-> (App a -> ReaderT AppEnv IO a) -> App a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App a -> ReaderT AppEnv IO a
forall a. App a -> ReaderT AppEnv IO a
runApp


{-| An application-level environment suitable for storing in a Reader. -}
data AppEnv = AppEnv
  { AppEnv -> Locator
aeDbLocator    :: !(DB.Locator)
  , AppEnv -> Connection
aeCacheLocator :: !(Cache.Connection)
  }


{- | General type class representing which @field@ is in @env@. -}
class Has field env where
  obtain :: env -> field


-- | A combinator that simplifies accessing 'Has' fields.
grab :: forall field env m . (MonadReader env m, Has field env) => m field
grab :: m field
grab = (env -> field) -> m field
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((env -> field) -> m field) -> (env -> field) -> m field
forall a b. (a -> b) -> a -> b
$ forall env. Has field env => env -> field
forall field env. Has field env => env -> field
obtain @field