{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.RawM.Server (
module Servant.RawM,
serveDirectoryWebApp,
serveDirectoryFileServer,
serveDirectoryWebAppLookup,
serveDirectoryEmbedded,
serveDirectoryWith
)
where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (runResourceT)
import Data.ByteString (ByteString)
import Data.Proxy (Proxy (Proxy))
import Network.Wai (Application, Request, Response,
ResponseReceived)
import Network.Wai.Application.Static (StaticSettings,
defaultFileServerSettings,
defaultWebAppSettings, embeddedSettings,
staticApp, webAppSettingsWithLookup)
import Servant (Context, Handler, HasServer (hoistServerWithContext, route),
ServerT, runHandler)
import Servant.Server.Internal (Delayed,
RouteResult (Fail, FailFatal, Route),
Router' (RawRouter),
responseServerError, runDelayed)
import System.FilePath (addTrailingPathSeparator)
import WaiAppStatic.Storage.Filesystem (ETagLookup)
import Servant.RawM
instance HasServer (RawM' serverType) context where
type ServerT (RawM' serverType) m = m Application
route
:: forall env.
Proxy (RawM' serverType)
-> Context context
-> Delayed env (Handler Application)
-> Router' env (Request -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived)
route Proxy _ rawApplication = RawRouter go
where
go
:: env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
go env request respond =
runResourceT $ do
routeRes <- runDelayed rawApplication env request
liftIO $
case routeRes of
(Fail e) -> respond $ Fail e
(FailFatal e) -> respond $ FailFatal e
(Route handlerApp) -> do
eitherApp <- runHandler handlerApp
case eitherApp of
Left err -> respond . Route $ responseServerError err
Right app -> app request (respond . Route)
hoistServerWithContext
:: Proxy (RawM' serverType)
-> Proxy context
-> (forall x. m x -> n x)
-> m Application
-> n Application
hoistServerWithContext Proxy Proxy f m = f m
serveDirectoryWebApp :: Applicative m => FilePath -> ServerT (RawM' serverType) m
serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . addTrailingPathSeparator
serveDirectoryFileServer :: Applicative m => FilePath -> ServerT (RawM' serverType) m
serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . addTrailingPathSeparator
serveDirectoryWebAppLookup :: Applicative m => ETagLookup -> FilePath -> ServerT (RawM' serverType) m
serveDirectoryWebAppLookup etag =
serveDirectoryWith . flip webAppSettingsWithLookup etag . addTrailingPathSeparator
serveDirectoryEmbedded :: Applicative m => [(FilePath, ByteString)] -> ServerT (RawM' serverType) m
serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files)
serveDirectoryWith :: Applicative m => StaticSettings -> ServerT (RawM' serverType) m
serveDirectoryWith = pure . staticApp