{-# 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 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
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
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
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
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
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 :: 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