{-# 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Port -> Application -> IO ()
run Port
port 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' = forall a. ExceptT ServerError IO a -> Handler a
Handler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
try forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AppEnv -> App a -> IO a
runApp' AppEnv
env
  in
    forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy ContactsAPI
contactsAPI forall a b. (a -> b) -> a -> b
$ 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 {a}. App a -> Handler a
hoist' 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 :: forall (m :: * -> *) r.
(MonadIO m, MonadReader r m, Has Locator r, Has Connection r) =>
ContactID -> m Contact
fetchContact ContactID
cid = do
  Connection
cache <- forall field env (m :: * -> *).
(MonadReader env m, Has field env) =>
m field
grab @Cache.Connection
  (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Connection -> ContactID -> IO (Maybe Contact)
Cache.loadContact Connection
cache 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 -> do
      Locator
db <- forall field env (m :: * -> *).
(MonadReader env m, Has field env) =>
m field
grab @DB.Locator
      (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
db 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 (Connection -> ContactID -> Contact -> IO ()
Cache.saveContact Connection
cache 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 e. Exception e => e -> a
throw 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 :: forall (m :: * -> *) r.
(MonadIO m, MonadReader r m, Has Locator r) =>
Contact -> m ContactID
createContact Contact
contact = do
  Locator
db <- forall field env (m :: * -> *).
(MonadReader env m, Has field env) =>
m field
grab @DB.Locator
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 :: forall r (m :: * -> *).
(Has Connection r, Has Locator r, MonadReader r m, MonadIO m) =>
ServerT ContactsAPI m
server = forall (m :: * -> *) r.
(MonadIO m, MonadReader r m, Has Locator r, Has Connection r) =>
ContactID -> m Contact
fetchContact forall a b. a -> b -> a :<|> b
:<|> 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
  { forall a. App a -> ReaderT AppEnv IO a
runApp :: ReaderT AppEnv IO a
  } deriving ( Functor App
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
<* :: forall a b. App a -> App b -> App a
$c<* :: forall a b. App a -> App b -> App a
*> :: forall a b. App a -> App b -> App b
$c*> :: forall a b. App a -> App b -> App b
liftA2 :: forall a b c. (a -> b -> c) -> App a -> App b -> App c
$cliftA2 :: forall a b c. (a -> b -> c) -> App a -> App b -> App c
<*> :: forall a b. App (a -> b) -> App a -> App b
$c<*> :: forall a b. App (a -> b) -> App a -> App b
pure :: forall a. a -> App a
$cpure :: forall a. a -> App a
Applicative
             , 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
<$ :: forall a b. a -> App b -> App a
$c<$ :: forall a b. a -> App b -> App a
fmap :: forall a b. (a -> b) -> App a -> App b
$cfmap :: forall a b. (a -> b) -> App a -> App b
Functor
             , Applicative App
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 :: forall a. a -> App a
$creturn :: forall a. a -> App a
>> :: forall a b. App a -> App b -> App b
$c>> :: forall a b. App a -> App b -> App b
>>= :: forall a b. App a -> (a -> App b) -> App b
$c>>= :: forall a b. App a -> (a -> App b) -> App b
Monad
             , MonadThrow App
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 :: forall e a. Exception e => App a -> (e -> App a) -> App a
$ccatch :: forall e a. Exception e => App a -> (e -> App a) -> App a
MonadCatch
             , MonadCatch App
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 :: forall a b c.
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 b. ((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 b. ((forall a. App a -> App a) -> App b) -> App b
$cmask :: forall b. ((forall a. App a -> App a) -> App b) -> App b
MonadMask
             , Monad App
forall e a. Exception e => e -> App a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> App a
$cthrowM :: forall e a. Exception e => e -> App a
MonadThrow
             , MonadReader AppEnv
             , Monad App
forall a. IO a -> App a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> App a
$cliftIO :: forall a. IO a -> App a
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Locator
DB.defaultLoc) 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' :: forall a. AppEnv -> App a -> IO a
runApp' AppEnv
env = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT AppEnv
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall field env (m :: * -> *).
(MonadReader env m, Has field env) =>
m field
grab = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ forall field env. Has field env => env -> field
obtain @field