Internal.hs

{-# LANGUAGE NoPolyKinds #-}

module Yam.Web.Internal(
    prepareMiddleware
  , errorMiddleware
  , API
  , API'
  , mkServe
  , mkServe'
  , AppM
  , App
  ) where

import           Yam.Web.Middleware

import           Control.Monad.Trans.Reader (ReaderT (..), runReaderT)
import           Data.Foldable              (foldr')
import           Data.Vault.Lazy
import           Network.Wai
import           Servant

type API api = HasServer api '[Vault]
type AppM = ReaderT Vault
type App  = AppM Handler

runAppM :: Vault -> AppM m a -> m a
runAppM = flip runReaderT

type API' api = (Proxy api, Server api)

mkServe' :: (API api, API api') => (API' api -> API' api') ->  Vault -> [Middleware] -> Proxy api -> ServerT api App -> Application
mkServe' f vault middlewares proxy server =
  let server' = hoistServerWithContext proxy (Proxy :: Proxy '[Vault]) (runAppM vault :: App a -> Handler a) server
      (p,s)   = f (proxy, server')
      app     = serveWithContext p (vault :. EmptyContext) s
      m       = prepareMiddleware (return . union vault)
  in foldr' ($) app $ m:servantErrorMiddleware:middlewares

mkServe :: API api => Vault -> [Middleware] -> Proxy api -> ServerT api App -> Application
mkServe = mkServe' id