{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module TmpProc.Example2.Server
(
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
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
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
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
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
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
data AppEnv = AppEnv
{ AppEnv -> Locator
aeDbLocator :: !(DB.Locator)
, AppEnv -> Connection
aeCacheLocator :: !(Cache.Connection)
}
class Has field env where
obtain :: env -> field
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