597 lines
28 KiB
Haskell
597 lines
28 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-unused-foralls #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Yesod.Servant
|
|
( ServantApiUnproxy, ServantApiUnproxy', ServantApiDirect
|
|
, HasRoute(..)
|
|
, ServantApi(..), getServantApi
|
|
, ServantApiDispatch(..)
|
|
, servantApiLink
|
|
, ServantHandlerFor(..)
|
|
, HasServantHandlerContext(..), getServantContext, getsServantContext, getYesodApproot, renderRouteAbsolute, servantApiBaseUrl
|
|
, MonadServantHandler(..), MonadHandler(..), MonadSite(..), MonadRequest(..)
|
|
, ServantDBFor, ServantPersist(..), defaultRunDB
|
|
, ServantLog(..), ServantLogYesod(..)
|
|
, mkYesodApi
|
|
, PathPieceHttpApiData(..)
|
|
, BearerAuth, SessionAuth
|
|
, ServantErrorResponse, getServantErrorResponse
|
|
, module Yesod.Servant.HttpApiDataInjective
|
|
) where
|
|
|
|
import ClassyPrelude hiding (Handler, fromList, link)
|
|
import Control.Lens hiding (Context)
|
|
import Control.Lens.Extras
|
|
|
|
import Foundation.Servant.Types
|
|
|
|
import Utils hiding (HasRoute)
|
|
import Model.Types.Security
|
|
|
|
import Yesod.Core ( Yesod
|
|
, RenderRoute(..), ParseRoute(..)
|
|
, YesodSubDispatch(..)
|
|
, PathPiece(..)
|
|
)
|
|
import Yesod.Core.Types ( YesodRunnerEnv(..)
|
|
, YesodSubRunnerEnv(..)
|
|
)
|
|
import qualified Yesod.Core as Yesod
|
|
import qualified Yesod.Core.Types as Yesod
|
|
import qualified Yesod.Persist.Core as Yesod
|
|
|
|
import Servant.Links
|
|
import Servant.API
|
|
import Servant.Server hiding (route)
|
|
import Servant.Server.Instances ()
|
|
|
|
import Servant.Client.Core.BaseUrl
|
|
|
|
import Data.Proxy
|
|
|
|
import Network.Wai (Request, Middleware)
|
|
import qualified Network.Wai as W
|
|
|
|
import Language.Haskell.TH hiding (Type)
|
|
import qualified Language.Haskell.TH as TH (Type)
|
|
import Language.Haskell.Meta.Parse (parseType)
|
|
import Yesod.Routes.TH.Types
|
|
|
|
import Control.Monad.Fail (MonadFail(..))
|
|
|
|
import Data.Data (Data)
|
|
import Data.Kind (Type)
|
|
import GHC.Exts (Constraint)
|
|
|
|
import Data.Swagger
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Network.HTTP.Types.Status
|
|
import Network.HTTP.Types.URI
|
|
|
|
import Control.Monad.Trans.Class (MonadTrans)
|
|
import Control.Monad.Catch (MonadThrow(..), MonadCatch, MonadMask)
|
|
import Control.Monad.Base (MonadBase)
|
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
|
import Control.Monad.Error.Class (MonadError)
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
import Data.Text.Lens (packed)
|
|
|
|
import Data.Typeable (eqT, typeRep)
|
|
|
|
import Network.URI
|
|
import Network.URI.Lens
|
|
import GHC.TypeLits (KnownSymbol, symbolVal, KnownNat)
|
|
|
|
import Text.Read (Read(readPrec), readP_to_Prec, readPrec_to_P)
|
|
import Text.Show (showParen, showString)
|
|
import qualified Text.ParserCombinators.ReadP as R
|
|
import qualified Data.Char as Char
|
|
|
|
import Yesod.Servant.HttpApiDataInjective
|
|
|
|
import qualified Data.ByteString.Base64.URL as Base64 (encode)
|
|
import qualified Data.Binary.Builder as Builder
|
|
|
|
import Database.Persist
|
|
|
|
import Data.CryptoID.Class.ImplicitNamespace
|
|
|
|
import Control.Monad.Logger
|
|
|
|
|
|
renderServantRoute :: Link -> ([Text], [(Text, Text)])
|
|
renderServantRoute link
|
|
= ( linkSegments link <&> pack . unEscapeString
|
|
, linkQueryParams link <&> paramToPair
|
|
)
|
|
where paramToPair (FlagParam str ) = (pack $ unEscapeString str, Text.empty)
|
|
paramToPair (ArrayElemParam str val) = (pack $ unEscapeString str, val )
|
|
paramToPair (SingleParam str val) = (pack $ unEscapeString str, val )
|
|
|
|
|
|
escapedSymbol :: forall sym. KnownSymbol sym => Proxy sym -> Text
|
|
escapedSymbol _ = pack . escapeURIString isUnreserved . symbolVal $ Proxy @sym
|
|
|
|
class HasLink api => HasRoute api where
|
|
parseServantRoute :: forall proxy. ServantApiUnproxy' proxy ~ api => ([Text], [(Text, Text)]) -> Maybe (Route (ServantApi proxy))
|
|
|
|
instance HasRoute EmptyAPI where
|
|
parseServantRoute _ = Nothing
|
|
|
|
instance (Typeable m, Typeable k) => HasRoute (NoContentVerb (m :: k)) where
|
|
parseServantRoute ([], _) = Just $ ServantApiRoute (Proxy @(NoContentVerb m)) id mempty mempty
|
|
parseServantRoute _ = Nothing
|
|
|
|
instance (Typeable m, Typeable k, Typeable s, Typeable ct, Typeable a, IsSubList ct ct ~ (() :: Constraint)) => HasRoute (Verb (m :: k) s ct a) where
|
|
parseServantRoute ([], _) = Just $ ServantApiRoute (Proxy @(Verb m s ct a)) id mempty mempty
|
|
parseServantRoute _ = Nothing
|
|
|
|
instance (Typeable m, Typeable k, Typeable status, Typeable fr, Typeable ct, Typeable a) => HasRoute (Stream (m :: k) status fr ct a) where
|
|
parseServantRoute ([], _) = Just $ ServantApiRoute (Proxy @(Stream m status fr ct a)) id mempty mempty
|
|
parseServantRoute _ = Nothing
|
|
|
|
instance HasRoute sub => HasRoute (HttpVersion :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(HttpVersion :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance HasRoute sub => HasRoute (Vault :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Vault :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance (HasRoute sub, KnownSymbol realm, Typeable a) => HasRoute (BasicAuth realm a :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(BasicAuth realm a :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance (HasRoute sub, KnownSymbol s) => HasRoute (Description s :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Description s :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance (HasRoute sub, KnownSymbol s) => HasRoute (Summary s :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Summary s :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance (HasRoute sub, Typeable tag, Typeable k) => HasRoute (AuthProtect (tag :: k) :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(AuthProtect tag :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance HasRoute sub => HasRoute (IsSecure :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(IsSecure :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance HasRoute sub => HasRoute (RemoteHost :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(RemoteHost :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance (HasRoute sub, Typeable mods, Typeable restr) => HasRoute (CaptureBearerRestriction' mods restr :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(CaptureBearerRestriction' mods restr :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance (HasRoute sub, Typeable mods) => HasRoute (CaptureBearerToken' mods :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(CaptureBearerToken' mods :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance (KnownSymbol sym, HasRoute sub, HasLink sub) => HasRoute (sym :> sub) where
|
|
parseServantRoute (p : ps, qs)
|
|
| p == escapedSymbol (Proxy @sym)
|
|
= parseServantRoute @sub @(ServantApiDirect sub) (ps, qs) <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(sym :> endpoint)) f (escapedSymbol (Proxy @sym) : ps') qs'
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
parseServantRoute _ = Nothing
|
|
|
|
instance (HasRoute a, HasRoute b) => HasRoute (a :<|> b) where
|
|
parseServantRoute args = asum
|
|
[ parseServantRoute @a @(ServantApiDirect a) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
, parseServantRoute @b @(ServantApiDirect b) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
]
|
|
|
|
instance (HasRoute sub, Typeable mods, Typeable ct, Typeable a) => HasRoute (ReqBody' mods ct a :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(ReqBody' mods ct a :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance (HasRoute sub, Typeable mods, Typeable framing, Typeable ct, Typeable a) => HasRoute (StreamBody' mods framing ct a :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(StreamBody' mods framing ct a :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance (HasRoute sub, KnownSymbol sym, Typeable mods, Typeable a) => HasRoute (Header' mods sym (a :: Type) :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Header' mods sym a :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable v, ToHttpApiDataInjective v, FromHttpApiData v) => HasRoute (Capture' mods sym (v :: Type) :> sub) where
|
|
parseServantRoute (p : ps, qs)
|
|
| Right v <- parseUrlPiece @v p
|
|
= parseServantRoute @sub @(ServantApiDirect sub) (ps, qs) <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(Capture' mods sym v :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs'
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
parseServantRoute _ = Nothing
|
|
|
|
instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable plaintext, ToHttpApiDataInjective ciphertext, FromHttpApiData ciphertext, Typeable ciphertext) => HasRoute (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
|
|
parseServantRoute (p : ps, qs)
|
|
| Right v <- parseUrlPiece @(CryptoID ciphertext plaintext) p
|
|
= parseServantRoute @sub @(ServantApiDirect sub) (ps, qs) <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(CaptureCryptoID' mods ciphertext sym plaintext :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs'
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
parseServantRoute _ = Nothing
|
|
|
|
instance (HasRoute sub, KnownNat major, KnownNat minor, KnownNat patch) => HasRoute (ApiVersion major minor patch :> sub) where
|
|
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
|
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(ApiVersion major minor patch :> endpoint)) f ps qs
|
|
ServantApiBaseRoute -> ServantApiBaseRoute
|
|
|
|
|
|
data ServantApi (proxy :: k) = ServantApi
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
deriving anyclass (Hashable)
|
|
|
|
getServantApi :: forall master proxy. master -> ServantApi proxy
|
|
getServantApi _ = ServantApi
|
|
|
|
type family ServantApiUnproxy (proxy :: k) :: Type
|
|
|
|
type ServantApiUnproxy' :: forall k. forall (proxy :: k) -> Type
|
|
type family ServantApiUnproxy' proxy where
|
|
ServantApiUnproxy' @Type (ServantApiDirect api) = api
|
|
ServantApiUnproxy' @k' proxy = ServantApiUnproxy proxy
|
|
|
|
data ServantApiDirect (api :: Type)
|
|
type instance ServantApiUnproxy (ServantApiDirect api) = api
|
|
|
|
instance HasRoute (ServantApiUnproxy' proxy) => RenderRoute (ServantApi proxy) where
|
|
data Route (ServantApi proxy)
|
|
= forall endpoint.
|
|
( IsElem endpoint (ServantApiUnproxy' proxy) ~ (() :: Constraint)
|
|
, HasRoute endpoint
|
|
, Typeable endpoint
|
|
)
|
|
=> ServantApiRoute
|
|
(Proxy endpoint)
|
|
(forall a. MkLink endpoint a -> a)
|
|
[Text] (HashMap Text [Text])
|
|
| ServantApiBaseRoute
|
|
renderRoute (ServantApiRoute (_ :: Proxy endpoint) f _ _) = f $ safeLink' renderServantRoute (Proxy @(ServantApiUnproxy' proxy)) (Proxy @endpoint)
|
|
renderRoute ServantApiBaseRoute = mempty
|
|
|
|
instance HasRoute (ServantApiUnproxy' proxy) => Eq (Route (ServantApi proxy)) where
|
|
(ServantApiRoute (_ :: Proxy endpoint) _ ps qs) == (ServantApiRoute (_ :: Proxy endpoint') _ ps' qs')
|
|
= case eqT @endpoint @endpoint' of
|
|
Just Refl -> ps == ps' && qs == qs'
|
|
Nothing -> False
|
|
ServantApiBaseRoute == ServantApiBaseRoute = True
|
|
_ == _ = False
|
|
|
|
instance HasRoute (ServantApiUnproxy' proxy) => Ord (Route (ServantApi proxy)) where
|
|
compare (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) (ServantApiRoute (_ :: Proxy endpoint') _ ps' qs')
|
|
= case eqT @endpoint @endpoint' of
|
|
Just Refl -> compare ps ps' <> compare qs qs'
|
|
Nothing -> typeRep (Proxy @endpoint) `compare` typeRep (Proxy @endpoint')
|
|
compare ServantApiBaseRoute ServantApiBaseRoute = EQ
|
|
compare ServantApiBaseRoute _ = LT
|
|
compare _ ServantApiBaseRoute = GT
|
|
|
|
instance HasRoute (ServantApiUnproxy' proxy) => Hashable (Route (ServantApi proxy)) where
|
|
hashWithSalt salt (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) = salt `hashWithSalt` (0 :: Int) `hashWithSalt` typeRep (Proxy @endpoint) `hashWithSalt` ps `hashWithSalt` qs
|
|
hashWithSalt salt ServantApiBaseRoute = salt `hashWithSalt` (1 :: Int)
|
|
|
|
instance HasRoute (ServantApiUnproxy' proxy) => Read (Route (ServantApi proxy)) where
|
|
readPrec = readP_to_Prec $ \d -> asum
|
|
[ ServantApiBaseRoute <$ R.string "ServantApiBaseRoute"
|
|
, do
|
|
when (d > 10) . void $ R.char '('
|
|
R.skipSpaces
|
|
void $ R.string "ServantApiRoute "
|
|
R.skipSpaces
|
|
void $ R.string "_ "
|
|
R.skipSpaces
|
|
asum [ do
|
|
void $ R.char '('
|
|
R.skipMany . R.manyTill (R.satisfy $ const True) $ R.char ')'
|
|
void $ R.char ' '
|
|
, R.skipMany . R.manyTill (R.satisfy $ not . Char.isSpace) $ R.satisfy Char.isSpace
|
|
]
|
|
R.skipSpaces
|
|
ps <- readPrec_to_P readPrec 11
|
|
void $ R.char ' '
|
|
R.skipSpaces
|
|
qs <- readPrec_to_P readPrec 11 :: R.ReadP (HashMap Text [Text])
|
|
R.skipSpaces
|
|
when (d > 10) . void $ R.char ')'
|
|
maybe (fail "Could not parse servant route") return $ parseServantRoute (ps, ifoldMap (fmap . (,)) qs)
|
|
]
|
|
instance HasRoute (ServantApiUnproxy' proxy) => Show (Route (ServantApi proxy)) where
|
|
showsPrec d (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) = showParen (d > 10)
|
|
$ showString "ServantApiRoute "
|
|
. showsPrec 11 (typeRep $ Proxy @endpoint)
|
|
. showString " _ "
|
|
. showsPrec 11 ps
|
|
. showString " "
|
|
. showsPrec 11 qs
|
|
showsPrec _ ServantApiBaseRoute = showString "ServantApiBaseRoute"
|
|
|
|
instance HasRoute (ServantApiUnproxy' proxy) => ParseRoute (ServantApi proxy) where
|
|
parseRoute = parseServantRoute
|
|
|
|
newtype ServantErrorResponse
|
|
= ServantErrorResponse { getServantErrorResponse :: W.Response }
|
|
|
|
class (HasServer (ServantApiUnproxy' proxy) context, HasRoute (ServantApiUnproxy' proxy), HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters) => ServantApiDispatch context m master proxy | master proxy -> context m where
|
|
servantContext :: ServantApi proxy -> master -> Request -> Yesod.HandlerFor master (Context context)
|
|
servantHoist :: ServantApi proxy -> master -> Request -> Context context -> (forall a. m a -> Handler a)
|
|
servantMiddleware :: ServantApi proxy -> master -> Context context -> Middleware
|
|
servantYesodMiddleware :: ServantApi proxy -> master -> Yesod.HandlerFor master Middleware
|
|
servantServer :: ServantApi proxy -> master -> ServerT (ServantApiUnproxy' proxy) m
|
|
|
|
instance ServantApiDispatch context m master proxy => YesodSubDispatch (ServantApi proxy) master where
|
|
yesodSubDispatch YesodSubRunnerEnv{..} req
|
|
= ysreParentRunner handlerT ysreParentEnv (ysreToParentRoute <$> route) req
|
|
where
|
|
master :: master
|
|
master = yreSite ysreParentEnv
|
|
proxy :: ServantApi proxy
|
|
proxy = ysreGetSub master
|
|
|
|
route = parseRoute ( W.pathInfo req
|
|
, over (traverse . _2) (fromMaybe Text.empty) . queryToQueryText $ W.queryString req
|
|
)
|
|
|
|
handlerT :: Yesod.HandlerFor master Yesod.TypedContent
|
|
handlerT = do
|
|
yesodMiddleware <- servantYesodMiddleware proxy master
|
|
ctx <- servantContext proxy master req
|
|
|
|
let server' = hoistServerWithContext (Proxy @(ServantApiUnproxy' proxy)) (Proxy @context) (servantHoist proxy master req ctx) (servantServer proxy master)
|
|
toTypedContent = error "Servant handler did not shortcircuit"
|
|
sendResponse res = case yesodError of
|
|
Just err -> do
|
|
Yesod.cacheSet $ ServantErrorResponse res
|
|
throwM . Yesod.HCError =<< liftIO (err <$> resText)
|
|
Nothing -> do
|
|
when (is _Nothing route) $
|
|
$(Yesod.logErrorS) "Servant" "Could not parse route even though servant responded successfully"
|
|
|
|
Yesod.sendWaiResponse res
|
|
where
|
|
status = W.responseStatus res
|
|
resText = toText <$> getResBS
|
|
where
|
|
toText bs = case Text.decodeUtf8' bs of
|
|
Right t -> t
|
|
Left _ -> Text.decodeUtf8 $ Base64.encode bs
|
|
|
|
(_, _, resStream) = W.responseToStream res
|
|
getResBS = resStream $ \runStream -> do
|
|
resVar <- newTVarIO Builder.empty
|
|
runStream (\chunk -> atomically $ modifyTVar' resVar (<> chunk)) (return ())
|
|
toStrict . Builder.toLazyByteString <$> readTVarIO resVar
|
|
|
|
yesodError :: Maybe (Text -> Yesod.ErrorResponse)
|
|
yesodError
|
|
| status == notFound404
|
|
= Just $ const Yesod.NotFound
|
|
| status == internalServerError500
|
|
= Just Yesod.InternalError
|
|
| status == badRequest400
|
|
= Just $ Yesod.InvalidArgs . pure
|
|
| status == unauthorized401
|
|
= Just $ const Yesod.NotAuthenticated
|
|
| status == forbidden403
|
|
= Just Yesod.PermissionDenied
|
|
| status == methodNotAllowed405
|
|
= Just . const . Yesod.BadMethod $ W.requestMethod req
|
|
| otherwise = Nothing
|
|
|
|
fmap toTypedContent . withUnliftIO $ \UnliftIO{..} ->
|
|
(yesodMiddleware . servantMiddleware proxy master ctx $ serveWithContext (Proxy @(ServantApiUnproxy' proxy)) ctx server') req $ unliftIO . sendResponse
|
|
|
|
servantApiLink :: forall p1 p2 proxy endpoint.
|
|
( IsElem endpoint (ServantApiUnproxy' proxy) ~ (() :: Constraint), HasRoute (ServantApiUnproxy' proxy), HasLink endpoint, Typeable endpoint )
|
|
=> p1 proxy
|
|
-> p2 endpoint
|
|
-> MkLink endpoint (Route (ServantApi proxy))
|
|
servantApiLink _ _ = safeLink' (fromMaybe (error "Could not parse result of safeLink'") . guardEndpoint . parseServantRoute @(ServantApiUnproxy' proxy) . renderServantRoute) (Proxy @(ServantApiUnproxy' proxy)) (Proxy @endpoint)
|
|
where
|
|
guardEndpoint :: Maybe (Route (ServantApi proxy)) -> Maybe (Route (ServantApi proxy))
|
|
guardEndpoint x@(Just (ServantApiRoute (_ :: Proxy endpoint') _ _ _))
|
|
| Just Refl <- eqT @endpoint @endpoint' = x
|
|
guardEndpoint _ = Nothing
|
|
|
|
|
|
class HasServantHandlerContext site where
|
|
data ServantHandlerContextFor site :: Type
|
|
getSCtxSite :: ServantHandlerContextFor site -> site
|
|
getSCtxRequest :: ServantHandlerContextFor site -> Request
|
|
|
|
newtype ServantHandlerFor site a = ServantHandlerFor { unServantHandlerFor :: ServantHandlerContextFor site -> Handler a }
|
|
deriving (Generic)
|
|
deriving (Monad, Functor, Applicative, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadBase IO, MonadBaseControl IO, MonadError ServerError) via (ReaderT (ServantHandlerContextFor site) Handler)
|
|
|
|
instance MonadUnliftIO (ServantHandlerFor site) where
|
|
withRunInIO cont
|
|
= ServantHandlerFor $ \app -> withRunInIO $ \unliftHandler -> cont (unliftHandler . flip unServantHandlerFor app)
|
|
|
|
getServantContext :: (site ~ site', MonadServantHandler site m) => m (ServantHandlerContextFor site')
|
|
getServantContext = liftServantHandler $ ServantHandlerFor return
|
|
|
|
getsServantContext :: (site ~ site', MonadServantHandler site m) => (ServantHandlerContextFor site' -> a) -> m a
|
|
getsServantContext = liftServantHandler . ServantHandlerFor . (return .)
|
|
|
|
getYesodApproot :: (Yesod site, MonadSite site m, MonadRequest m) => m Text
|
|
getYesodApproot = Yesod.getApprootText Yesod.approot <$> getSite <*> getRequest
|
|
|
|
renderRouteAbsolute :: (Yesod site, MonadSite site m, MonadRequest m) => Route site -> m URI
|
|
renderRouteAbsolute (renderRoute -> (ps, qs)) = addRoute . unpack <$> getYesodApproot
|
|
where addRoute root = case parseURI root of
|
|
Just root' -> root' & uriPathLens . packed %~ addPath
|
|
& uriQueryLens . packed %~ addQuery
|
|
Nothing -> error "Could not parse approot as URI"
|
|
addPath p = p <> "/" <> Text.intercalate "/" ps
|
|
addQuery q | null qs = q
|
|
addQuery "" = "?" <> Text.intercalate "&" (map (\(q, v) -> q <> "=" <> v) qs)
|
|
addQuery "?" = addQuery ""
|
|
addQuery q = q <> "&" <> tailEx (addQuery "")
|
|
|
|
servantApiBaseUrl :: (Yesod site, MonadSite site m, MonadRequest m, MonadThrow m) => (Route (ServantApi proxy) -> Route site) -> m BaseUrl
|
|
servantApiBaseUrl = parseBaseUrl . ($ mempty). uriToString (const "") <=< renderRouteAbsolute . ($ ServantApiBaseRoute)
|
|
|
|
class (MonadIO m, HasServantHandlerContext site) => MonadServantHandler site m | m -> site where
|
|
liftServantHandler :: forall a. ServantHandlerFor site a -> m a
|
|
|
|
instance HasServantHandlerContext site => MonadServantHandler site (ServantHandlerFor site) where
|
|
liftServantHandler = id
|
|
|
|
instance (MonadTrans t, MonadIO (t (ServantHandlerFor site)), HasServantHandlerContext site) => MonadServantHandler site (t (ServantHandlerFor site)) where
|
|
liftServantHandler = lift
|
|
|
|
class MonadIO m => MonadHandler m where
|
|
liftHandler :: forall a. Handler a -> m a
|
|
|
|
instance MonadHandler (ServantHandlerFor site) where
|
|
liftHandler = ServantHandlerFor . const
|
|
|
|
instance (MonadTrans t, MonadIO (t (ServantHandlerFor site))) => MonadHandler (t (ServantHandlerFor site)) where
|
|
liftHandler = lift . ServantHandlerFor . const
|
|
|
|
class Monad m => MonadSite site m | m -> site where
|
|
getSite :: m site
|
|
|
|
getsSite :: (site -> a) -> m a
|
|
getsSite f = f <$> getSite
|
|
|
|
instance HasServantHandlerContext site => MonadSite site (ServantHandlerFor site) where
|
|
getSite = liftServantHandler . ServantHandlerFor $ return . getSCtxSite
|
|
|
|
instance MonadSite site (Reader site) where
|
|
getSite = ask
|
|
getsSite = asks
|
|
|
|
instance {-# OVERLAPPABLE #-} (Yesod.MonadHandler m, site ~ Yesod.HandlerSite m) => MonadSite site m where
|
|
getSite = Yesod.getYesod
|
|
getsSite = Yesod.getsYesod
|
|
|
|
instance {-# OVERLAPPING #-} (MonadTrans t, Monad (t (ServantHandlerFor site)), HasServantHandlerContext site) => MonadSite site (t (ServantHandlerFor site)) where
|
|
getSite = lift getSite
|
|
getsSite = lift . getsSite
|
|
|
|
class Monad m => MonadRequest m where
|
|
getRequest :: m Request
|
|
|
|
instance HasServantHandlerContext site => MonadRequest (ServantHandlerFor site) where
|
|
getRequest = liftServantHandler . ServantHandlerFor $ return . getSCtxRequest
|
|
|
|
instance {-# OVERLAPPABLE #-} (Yesod.MonadHandler m, Monad m) => MonadRequest m where
|
|
getRequest = Yesod.waiRequest
|
|
|
|
instance {-# OVERLAPPING #-} (MonadTrans t, Monad (t (ServantHandlerFor site)), HasServantHandlerContext site) => MonadRequest (t (ServantHandlerFor site)) where
|
|
getRequest = lift getRequest
|
|
|
|
|
|
type ServantDBFor site = ReaderT (Yesod.YesodPersistBackend site) (ServantHandlerFor site)
|
|
|
|
class Yesod.YesodPersist site => ServantPersist site where
|
|
runDB :: forall a. ServantDBFor site a -> ServantHandlerFor site a
|
|
|
|
defaultRunDB :: ( PersistConfig c
|
|
, ServantDBFor site a ~ PersistConfigBackend c (ServantHandlerFor site) a
|
|
, HasServantHandlerContext site
|
|
)
|
|
=> Getting c site c
|
|
-> Getting (PersistConfigPool c) site (PersistConfigPool c)
|
|
-> ServantDBFor site a -> ServantHandlerFor site a
|
|
defaultRunDB confL poolL f = do
|
|
app <- getSite
|
|
runPool (app ^. confL) f (app ^. poolL)
|
|
|
|
|
|
class ServantLog site where
|
|
servantLogLog :: (MonadIO m, ToLogStr msg) => site -> Loc -> LogSource -> LogLevel -> msg -> m ()
|
|
|
|
newtype ServantLogYesod site = ServantLogYesod { unServantLogYesod :: site }
|
|
|
|
instance Yesod site => ServantLog (ServantLogYesod site) where
|
|
servantLogLog (ServantLogYesod app) a b c (toLogStr -> d) = liftIO $ do
|
|
logger <- Yesod.makeLogger app
|
|
Yesod.messageLoggerSource app logger a b c d
|
|
|
|
instance (ServantLog site, HasServantHandlerContext site) => MonadLogger (ServantHandlerFor site) where
|
|
monadLoggerLog a b c d = do
|
|
app <- getSite
|
|
servantLogLog app a b c d
|
|
|
|
instance (ServantLog site, HasServantHandlerContext site) => MonadLoggerIO (ServantHandlerFor site) where
|
|
askLoggerIO = servantLogLog <$> getSite
|
|
|
|
|
|
newtype PathPieceHttpApiData a = PathPieceHttpApiData { unPathPieceHttpApiData :: a }
|
|
deriving (Eq, Ord, Read, Show, Generic, Data)
|
|
deriving newtype (PathPiece, ToParamSchema)
|
|
instance PathPiece a => FromHttpApiData (PathPieceHttpApiData a) where
|
|
parseUrlPiece = maybe (Left "Could not convert from HttpApiData via PathPiece") Right . fromPathPiece
|
|
instance PathPiece a => ToHttpApiData (PathPieceHttpApiData a) where
|
|
toUrlPiece = toPathPiece
|
|
|
|
|
|
mkYesodApi :: Name -> [ResourceTree String] -> DecsQ
|
|
mkYesodApi (nameBase -> masterN) ress = do
|
|
let toPiecesApi :: [Piece String]
|
|
-> ResourceTree String
|
|
-> MaybeT Q [([Piece String], TH.Type, [Text])]
|
|
toPiecesApi ps (ResourceLeaf Resource{..}) = do
|
|
Subsite{..} <- pure resourceDispatch
|
|
Just tn <- lift $ lookupTypeName subsiteType
|
|
TyConI (TySynD _ [] (ConT conN `AppT` apiT)) <- lift $ reify tn
|
|
guard $ conN == ''ServantApi
|
|
return $ pure (ps <> resourcePieces, ConT ''ServantApiUnproxy' `AppT` apiT, map pack resourceAttrs)
|
|
toPiecesApi ps (ResourceParent _ _ ps' cs)
|
|
= lift . fmap concat $ mapMaybeM (toPiecesApi (ps <> ps')) cs
|
|
apiRess <- concat <$> mapMaybeM (toPiecesApi []) ress
|
|
|
|
let apiType
|
|
| Just apiRess' <- fromNullable $ map apiEndpoint apiRess
|
|
= ofoldr1 (\e acc -> conT ''(:<|>) `appT` e `appT` acc) apiRess'
|
|
| otherwise
|
|
= conT ''EmptyAPI
|
|
|
|
apiEndpoint (pieces, apiT, attrs) = withAuth attrs $
|
|
foldr (\p acc -> conT ''(:>) `appT` apiPiece p `appT` acc) (return apiT) pieces
|
|
|
|
withAuth attrs typ = case authDNF of
|
|
Left t
|
|
-> fail $ "Invalid auth tag: " <> unpack t
|
|
Right PredDNF{..} | (impureNonNull . Set.singleton $ PLVariable AuthFree) `Set.member` dnfTerms
|
|
-> typ
|
|
Right PredDNF{..} | (impureNonNull . Set.singleton $ PLVariable AuthToken) `Set.member` dnfTerms
|
|
-> conT ''(:>) `appT` conT ''BearerAuth `appT` typ
|
|
Right _
|
|
-> conT ''(:>) `appT` conT ''SessionAuth `appT` typ
|
|
where authDNF = parsePredDNF defaultAuthDNF attrs
|
|
|
|
apiPiece (Static str) = litT $ strTyLit str
|
|
apiPiece (Dynamic str) = conT ''PathPieceHttpApiData `appT` either fail return (parseType str)
|
|
|
|
sequence
|
|
[ tySynD (mkName $ masterN <> "Api") [] apiType
|
|
]
|