{-# 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 a b. IO a -> (a -> IO b) -> IO b
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 App x -> Handler x
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 :: 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
(IO (Maybe Contact) -> m (Maybe Contact)
forall a. IO a -> m a
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Contact
contact -> Contact -> m Contact
forall a. a -> m a
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
(IO (Maybe Contact) -> m (Maybe Contact)
forall a. IO a -> m a
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Contact
contact -> IO () -> m ()
forall a. IO a -> m a
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 a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Contact -> m Contact
forall a. a -> m a
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 = "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
IO ContactID -> m ContactID
forall a. IO a -> m a
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 :: forall r (m :: * -> *).
(Has Connection r, Has Locator r, MonadReader r m, MonadIO m) =>
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
{ forall a. App a -> ReaderT AppEnv IO a
runApp :: ReaderT AppEnv IO a
} deriving ( Functor App
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
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
$cpure :: forall a. a -> App a
pure :: forall a. a -> App a
$c<*> :: forall a b. App (a -> b) -> App a -> App b
<*> :: forall a b. App (a -> b) -> App a -> App b
$cliftA2 :: forall a b c. (a -> b -> c) -> App a -> App b -> App c
liftA2 :: forall a b c. (a -> b -> c) -> App a -> App b -> App c
$c*> :: forall a b. App a -> App b -> App b
*> :: forall a b. App a -> App b -> App b
$c<* :: forall a b. App a -> App b -> App a
<* :: forall a b. App a -> App b -> App a
Applicative
, (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
$cfmap :: forall a b. (a -> b) -> App a -> App b
fmap :: forall a b. (a -> b) -> App a -> App b
$c<$ :: forall a b. a -> App b -> App a
<$ :: forall a b. a -> App b -> App a
Functor
, Applicative App
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
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
$c>>= :: forall a b. App a -> (a -> App b) -> App b
>>= :: forall a b. App a -> (a -> App b) -> App b
$c>> :: forall a b. App a -> App b -> App b
>> :: forall a b. App a -> App b -> App b
$creturn :: forall a. a -> App a
return :: forall a. a -> App a
Monad
, MonadThrow App
MonadThrow App =>
(forall e a.
(HasCallStack, Exception e) =>
App a -> (e -> App a) -> App a)
-> MonadCatch App
forall e a.
(HasCallStack, Exception e) =>
App a -> (e -> App a) -> App a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
(HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
App a -> (e -> App a) -> App a
catch :: forall e a.
(HasCallStack, Exception e) =>
App a -> (e -> App a) -> App a
MonadCatch
, MonadCatch App
MonadCatch App =>
(forall b.
HasCallStack =>
((forall a. App a -> App a) -> App b) -> App b)
-> (forall b.
HasCallStack =>
((forall a. App a -> App a) -> App b) -> App b)
-> (forall a b c.
HasCallStack =>
App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c))
-> MonadMask App
forall b.
HasCallStack =>
((forall a. App a -> App a) -> App b) -> App b
forall a b c.
HasCallStack =>
App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
HasCallStack =>
((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
HasCallStack =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. App a -> App a) -> App b) -> App b
mask :: forall b.
HasCallStack =>
((forall a. App a -> App a) -> App b) -> App b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. App a -> App a) -> App b) -> App b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. App a -> App a) -> App b) -> App b
$cgeneralBracket :: forall a b c.
HasCallStack =>
App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c)
generalBracket :: forall a b c.
HasCallStack =>
App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c)
MonadMask
, Monad App
Monad App =>
(forall e a. (HasCallStack, Exception e) => e -> App a)
-> MonadThrow App
forall e a. (HasCallStack, Exception e) => e -> App a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> App a
throwM :: forall e a. (HasCallStack, Exception e) => e -> App a
MonadThrow
, MonadReader AppEnv
, Monad App
Monad App => (forall a. IO a -> App a) -> MonadIO App
forall a. IO a -> App a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> App a
liftIO :: 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 (Locator -> Connection -> AppEnv)
-> IO Locator -> IO (Connection -> AppEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Locator -> IO Locator
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Locator
DB.defaultLoc) IO (Connection -> AppEnv) -> IO Connection -> IO AppEnv
forall a b. IO (a -> b) -> IO a -> IO b
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 = (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 :: forall field env (m :: * -> *).
(MonadReader env m, Has field env) =>
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 field env. Has field env => env -> field
obtain @field