{-# LANGUAGE UndecidableInstances #-} module Yesod.Servant ( HasRoute(..) , ServantApi(..), getServantApi , ServantApiDispatch(..) , servantApiLink , ServantHandlerFor(..) , ServantHandlerContextFor(..), getServantContext, getsServantContext, getYesodApproot, renderRouteAbsolute , MonadServantHandler(..), MonadHandler(..), MonadSite(..) , ServantDBFor, ServantPersist(..), defaultRunDB , 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 Data.Proxy import Network.Wai (Request, Middleware) import qualified Network.Wai as W import Language.Haskell.TH import Language.Haskell.Meta.Parse (parseType) import Yesod.Routes.TH.Types import Control.Monad.Fail (MonadFail(..)) import Data.Data (Data) import GHC.Exts (IsList(..), Constraint) import Servant.Swagger import Data.Swagger import Servant.Docs 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) 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 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 :: ([Text], [(Text, Text)]) -> Maybe (Route (ServantApi api)) 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 args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(HttpVersion :> endpoint)) f ps qs instance HasRoute sub => HasRoute (Vault :> sub) where parseServantRoute args = parseServantRoute @sub args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Vault :> endpoint)) f ps qs instance (HasRoute sub, KnownSymbol realm, Typeable a) => HasRoute (BasicAuth realm a :> sub) where parseServantRoute args = parseServantRoute @sub args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(BasicAuth realm a :> endpoint)) f ps qs instance (HasRoute sub, KnownSymbol s) => HasRoute (Description s :> sub) where parseServantRoute args = parseServantRoute @sub args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Description s :> endpoint)) f ps qs instance (HasRoute sub, KnownSymbol s) => HasRoute (Summary s :> sub) where parseServantRoute args = parseServantRoute @sub args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Summary s :> endpoint)) f ps qs instance (HasRoute sub, Typeable tag, Typeable k) => HasRoute (AuthProtect (tag :: k) :> sub) where parseServantRoute args = parseServantRoute @sub args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(AuthProtect tag :> endpoint)) f ps qs instance HasRoute sub => HasRoute (IsSecure :> sub) where parseServantRoute args = parseServantRoute @sub args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(IsSecure :> endpoint)) f ps qs instance HasRoute sub => HasRoute (RemoteHost :> sub) where parseServantRoute args = parseServantRoute @sub args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(RemoteHost :> endpoint)) f ps qs instance (HasRoute sub, Typeable mods, Typeable restr) => HasRoute (CaptureBearerRestriction' mods restr :> sub) where parseServantRoute args = parseServantRoute @sub args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(CaptureBearerRestriction' mods restr :> endpoint)) f ps qs instance (HasRoute sub, Typeable mods) => HasRoute (CaptureBearerToken' mods :> sub) where parseServantRoute args = parseServantRoute @sub args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(CaptureBearerToken' mods :> endpoint)) f ps qs instance (KnownSymbol sym, HasRoute sub, HasLink sub) => HasRoute (sym :> sub) where parseServantRoute (p : ps, qs) | p == escapedSymbol (Proxy @sym) = parseServantRoute @sub (ps, qs) <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(sym :> endpoint)) f (escapedSymbol (Proxy @sym) : ps') qs' parseServantRoute _ = Nothing instance (HasRoute a, HasRoute b) => HasRoute (a :<|> b) where parseServantRoute args = asum [ parseServantRoute @a args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs , parseServantRoute @b args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs ] instance (HasRoute sub, Typeable mods, Typeable ct, Typeable a) => HasRoute (ReqBody' mods ct a :> sub) where parseServantRoute args = parseServantRoute @sub args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(ReqBody' mods ct a :> endpoint)) f ps qs instance (HasRoute sub, Typeable mods, Typeable framing, Typeable ct, Typeable a) => HasRoute (StreamBody' mods framing ct a :> sub) where parseServantRoute args = parseServantRoute @sub args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(StreamBody' mods framing ct a :> endpoint)) f ps qs instance (HasRoute sub, KnownSymbol sym, Typeable mods, Typeable a) => HasRoute (Header' mods sym (a :: *) :> sub) where parseServantRoute args = parseServantRoute @sub args <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Header' mods sym a :> endpoint)) f ps qs instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable v, ToHttpApiDataInjective v, FromHttpApiData v) => HasRoute (Capture' mods sym (v :: *) :> sub) where parseServantRoute ((p : ps), qs) | Right v <- parseUrlPiece @v p = parseServantRoute @sub (ps, qs) <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(Capture' mods sym v :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs' 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 (ps, qs) <&> \case ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(CaptureCryptoID' mods ciphertext sym plaintext :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs' parseServantRoute _ = Nothing data ServantApi (api :: *) = ServantApi getServantApi :: forall master api. master -> ServantApi api getServantApi _ = ServantApi instance HasRoute api => RenderRoute (ServantApi api) where data Route (ServantApi api) = forall endpoint. ( IsElem endpoint api ~ (() :: Constraint) , HasRoute endpoint , Typeable endpoint ) => ServantApiRoute (Proxy endpoint) (forall a. MkLink endpoint a -> a) [Text] (HashMap Text [Text]) renderRoute (ServantApiRoute (_ :: Proxy endpoint) f _ _) = f $ safeLink' renderServantRoute (Proxy @api) (Proxy @endpoint) instance HasRoute api => Eq (Route (ServantApi api)) where (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) == (ServantApiRoute (_ :: Proxy endpoint') _ ps' qs') = case eqT @endpoint @endpoint' of Just Refl -> ps == ps' && qs == qs' Nothing -> False instance HasRoute api => Hashable (Route (ServantApi api)) where hashWithSalt salt (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) = salt `hashWithSalt` typeRep (Proxy @endpoint) `hashWithSalt` ps `hashWithSalt` qs instance HasRoute api => Read (Route (ServantApi api)) where readPrec = readP_to_Prec $ \d -> 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 api => Show (Route (ServantApi api)) 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 instance HasRoute api => ParseRoute (ServantApi api) where parseRoute = parseServantRoute newtype ServantErrorResponse = ServantErrorResponse { getServantErrorResponse :: W.Response } class (HasServer api context, HasRoute api) => ServantApiDispatch context m master api | master api -> context m where servantContext :: ServantApi api -> master -> Request -> Yesod.HandlerFor master (Context context) servantHoist :: ServantApi api -> master -> Request -> Context context -> (forall a. m a -> Handler a) servantMiddleware :: ServantApi api -> master -> Context context -> Middleware servantYesodMiddleware :: ServantApi api -> master -> Yesod.HandlerFor master Middleware servantServer :: ServantApi api -> master -> ServerT api m instance ServantApiDispatch context m master api => YesodSubDispatch (ServantApi api) master where yesodSubDispatch YesodSubRunnerEnv{..} req = ysreParentRunner handlerT ysreParentEnv (ysreToParentRoute <$> route) req where master :: master master = yreSite ysreParentEnv proxy :: ServantApi api 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 @api) (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 @api) ctx server') req $ unliftIO . sendResponse servantApiLink :: forall p1 p2 api endpoint. ( IsElem endpoint api ~ (() :: Constraint), HasRoute api, HasLink endpoint, Typeable endpoint ) => p1 api -> p2 endpoint -> MkLink endpoint (Route (ServantApi api)) servantApiLink _ _ = safeLink' (fromMaybe (error "Could not parse result of safeLink'") . guardEndpoint . parseServantRoute @api . renderServantRoute) (Proxy @api) (Proxy @endpoint) where guardEndpoint :: Maybe (Route (ServantApi api)) -> Maybe (Route (ServantApi api)) guardEndpoint x@(Just (ServantApiRoute (_ :: Proxy endpoint') _ _ _)) | Just Refl <- eqT @endpoint @endpoint' = x guardEndpoint _ = Nothing data ServantHandlerContextFor site = ServantHandlerContextFor { sctxSite :: site , sctxRequest :: Request } newtype ServantHandlerFor site a = ServantHandlerFor { unServantHandlerFor :: ServantHandlerContextFor site -> Handler a } deriving (Generic, Typeable) 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, MonadServantHandler site m) => m Text getYesodApproot = getsServantContext $ \ServantHandlerContextFor{..} -> Yesod.getApprootText Yesod.approot sctxSite sctxRequest renderRouteAbsolute :: (Yesod site, MonadServantHandler site 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 "") class MonadIO m => MonadServantHandler site m | m -> site where liftServantHandler :: forall a. ServantHandlerFor site a -> m a instance MonadServantHandler site (ServantHandlerFor site) where liftServantHandler = id instance (MonadTrans t, MonadIO (t (ServantHandlerFor 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 MonadSite site (ServantHandlerFor site) where getSite = liftServantHandler . ServantHandlerFor $ return . sctxSite 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))) => MonadSite site (t (ServantHandlerFor site)) where getSite = lift getSite getsSite = lift . getsSite 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 ) => 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) newtype PathPieceHttpApiData a = PathPieceHttpApiData { unPathPieceHttpApiData :: a } deriving (Eq, Ord, Read, Show, Generic, Typeable, 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 data BearerAuth data SessionAuth instance HasSwagger sub => HasSwagger (BearerAuth :> sub) where toSwagger _ = toSwagger (Proxy @sub) & securityDefinitions <>~ fromList [(defnKey, defn)] & allOperations . security <>~ [SecurityRequirement $ fromList [(defnKey, [])]] where defnKey :: Text defnKey = "bearer" defn = SecurityScheme { _securitySchemeType = SecuritySchemeApiKey ApiKeyParams { _apiKeyName = "Authorization" , _apiKeyIn = ApiKeyHeader } , _securitySchemeDescription = Just "JSON Web Token-based API key" } instance HasSwagger sub => HasSwagger (SessionAuth :> sub) where toSwagger _ = toSwagger (Proxy @sub) & allOperations . security <>~ [SecurityRequirement mempty] -- We do not expect API clients to be able/willing to conform with -- our CSRF mitigation, so we mark routes that require it as -- having unfullfillable security requirements instance HasLink sub => HasLink (BearerAuth :> sub) where type MkLink (BearerAuth :> sub) a = MkLink sub a toLink toA _ = toLink toA (Proxy @sub) instance HasLink sub => HasLink (SessionAuth :> sub) where type MkLink (SessionAuth :> sub) a = MkLink sub a toLink toA _ = toLink toA (Proxy @sub) instance HasDocs sub => HasDocs (BearerAuth :> sub) where docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action') where action' = action & authInfo %~ (|> authInfo') authInfo' = DocAuthentication "" "A JSON Web Token-based API key" instance HasDocs sub => HasDocs (SessionAuth :> sub) where docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action') where action' = action & authInfo %~ (|> authInfo') authInfo' = DocAuthentication "When a web session is used for authorization, CSRF-mitigation measures must be observed." "An active web session identifying the user as one with sufficient authorization" mkYesodApi :: Name -> [ResourceTree String] -> DecsQ mkYesodApi (nameBase -> masterN) ress = do let toPiecesApi :: [Piece String] -> ResourceTree String -> MaybeT Q [([Piece String], 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, 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 ]