diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 854adf135..d0a0bf301 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -923,7 +923,7 @@ CommCourseSubject: Kursmitteilung MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zum Kursverwalter InvitationAcceptDecline: Einladung annehmen/ablehnen InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in Uni2work ausgelöst hat. -InvitationUniWorXTip: Uni2work ist ein webbasiertes Lehrverwaltungssystem der LMU München. +InvitationUniWorXTip: Uni2work ist ein Lehrverwaltungssystem, welches an der Ludwig-Maximilians-Universität München entwickelt und eingesetzt wird. MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursteilnahme @@ -1293,6 +1293,8 @@ BreadcrumbAllocationUsers: Bewerber BreadcrumbAllocationPriorities: Zentrale Dringlichkeiten BreadcrumbAllocationCompute: Platzvergabe berechnen BreadcrumbAllocationAccept: Platzvergabe akzeptieren +BreadcrumbExternalApis: Externe APIs +BreadcrumbSwagger: API Dokumentation ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index b0b72dc39..64e10e5ca 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -923,7 +923,7 @@ CommCourseSubject: Course message MailSubjectLecturerInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitation to be a course administrator InvitationAcceptDecline: Accept/Decline invitation InvitationFromTip displayName: You are receiving this invitation because #{displayName} has caused it to be sent from within Uni2work. -InvitationUniWorXTip: Uni2work is a web based teaching management system at LMU Munich. +InvitationUniWorXTip: Uni2work is a teaching management system, developed and deployed at Ludwig-Maximilians-Universität München. MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitation to be a course participant @@ -1292,6 +1292,8 @@ BreadcrumbAllocationUsers: Applicants BreadcrumbAllocationPriorities: Central priorities BreadcrumbAllocationCompute: Compute allocation BreadcrumbAllocationAccept: Accept allocation +BreadcrumbExternalApis: External APIs +BreadcrumbSwagger: API documentation ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn} ExternalExamGrades coursen examn: Exam achievements: #{coursen}, #{examn} diff --git a/package.yaml b/package.yaml index 713a25260..bd8f9700e 100644 --- a/package.yaml +++ b/package.yaml @@ -142,6 +142,12 @@ dependencies: - extended-reals - rfc5051 - pandoc + - servant + - servant-server + - servant-swagger + - swagger2 + - haskell-src-meta + - network-uri other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index 125b6da56..af3f485dd 100644 --- a/routes +++ b/routes @@ -67,6 +67,8 @@ /help HelpR GET POST !free +/external-apis ExternalApisR ServantApiExternalApis getServantApiExternalApis + /user ProfileR GET POST !free /user/profile ProfileDataR GET !free /user/authpreds AuthPredsR GET POST !free @@ -227,4 +229,6 @@ !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists +/swagger.json SwaggerR GET !free + !/*WellKnownFileName WellKnownR GET !free diff --git a/src/Application.hs b/src/Application.hs index 918495cc6..07303e630 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -117,6 +117,9 @@ import Handler.Metrics import Handler.ExternalExam import Handler.Participants import Handler.StorageKey +import Handler.Swagger + +import ServantApi -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/Foundation.hs b/src/Foundation.hs index 66568e795..4d289a5a2 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1280,30 +1280,13 @@ authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem , [ AuthOwner, AuthRated ] -- Submission wide ] -defaultAuthDNF :: AuthDNF -defaultAuthDNF = PredDNF $ Set.fromList - [ impureNonNull . Set.singleton $ PLVariable AuthAdmin - , impureNonNull . Set.singleton $ PLVariable AuthToken - ] - routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF -- ^ DNF up to entailment: -- -- > (A_1 && A_2 && ...) OR' B OR' ... -- -- > A OR' B := ((A |- B) ==> A) && (A || B) -routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs - where - partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral)) - partition' prev t - | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t) - = if - | oany (authTags `Set.isSubsetOf`) prev - -> Right prev - | otherwise - -> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev - | otherwise - = Left $ InvalidAuthTag t +routeAuthTags = left InvalidAuthTag . parsePredDNF defaultAuthDNF . Set.toList . routeAttrs evalAuthTags :: forall m. MonadAP m => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult -- ^ `tell`s disabled predicates, identified as pivots @@ -2231,6 +2214,9 @@ instance YesodBreadcrumbs UniWorX where EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR + + breadcrumb (ExternalApisR _) = i18nCrumb MsgBreadcrumbExternalApis Nothing + breadcrumb SwaggerR = i18nCrumb MsgBreadcrumbSwagger Nothing -- breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index afe77ba0e..36bc627be 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -11,6 +11,8 @@ import Foundation.Type import Foundation.Routes.Definitions +import ServantApi + -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: -- http://www.yesodweb.com/book/routing-and-handlers @@ -43,6 +45,7 @@ deriving instance Generic (Route UniWorX) data RouteChildren type instance Children RouteChildren a = ChildrenRouteChildren a type family ChildrenRouteChildren a where + ChildrenRouteChildren (Route ServantApiExternalApis) = '[] ChildrenRouteChildren (Route EmbeddedStatic) = '[] ChildrenRouteChildren (Route Auth) = '[] ChildrenRouteChildren UUID = '[] diff --git a/src/Handler/Swagger.hs b/src/Handler/Swagger.hs new file mode 100644 index 000000000..d4e2bdfa1 --- /dev/null +++ b/src/Handler/Swagger.hs @@ -0,0 +1,67 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Swagger + ( getSwaggerR + ) where + +import Import hiding (host) +import ServantApi + +import Data.Swagger +import Servant.Swagger + +import qualified Data.Aeson.Encode.Pretty as Aeson +import qualified Data.Text.Lazy.Builder as Builder + +import Development.GitRev + +import Network.URI + +import Text.Read (readMaybe) + + + +instance ToContent Swagger where + toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder + +instance ToTypedContent Swagger where + toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent + +instance HasContentType Swagger where + getContentType _ = typeJson + + +getSwaggerR :: Handler Swagger +getSwaggerR = do + app <- getYesod + let docMR = renderMessage app . otoList $ selectLanguages appLanguages ["en"] + root <- getApprootText approot app <$> waiRequest + let applyApproot = do + URI{..} <- fmap rectify . parseURIReference $ unpack root + let mbScheme = do + str <- assertM (not . null) $ stripSuffix ":" uriScheme + case str of + "https" -> return Https + "http" -> return Http + _other -> mzero + applyAuthority = do + URIAuth{..} <- uriAuthority + let mbPort = readMaybe . fromMaybe "" $ stripPrefix ":" uriPort + return $ + host ?~ Host uriRegName mbPort + return $ \x -> x + & fromMaybe id applyAuthority + & schemes .~ fmap pure mbScheme + & basePath ?~ bool id (ensurePrefix "/") (is _Just mbScheme || is _Just uriAuthority) uriPath + + + tos <- toTextUrl $ LegalR :#: ("terms-of-use" :: Text) + c <- toTextUrl HelpR + + return $ toSwagger uniworxApi + & info.title .~ docMR MsgLogo + & info.description ?~ docMR MsgInvitationUniWorXTip + & info.termsOfService ?~ tos + & info.contact ?~ Contact Nothing (Just $ URL c) Nothing + & info.version .~ $gitDescribe + & fromMaybe id applyApproot diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index f43384eac..3be594c33 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -197,14 +197,14 @@ data TermFormTemplate = TermFormTemplate -- | TermFormTemplates form a pointwise-left biased Semigroup instance Semigroup TermFormTemplate where - left <> right = TermFormTemplate - { tftName = tftName left <|> tftName right - , tftStart = tftStart left <|> tftStart right - , tftEnd = tftEnd left <|> tftEnd right - , tftHolidays = tftHolidays left <|> tftHolidays right - , tftLectureStart = tftLectureStart left <|> tftLectureStart right - , tftLectureEnd = tftLectureEnd left <|> tftLectureEnd right - , tftActive = tftActive left <|> tftActive right + l <> r = TermFormTemplate + { tftName = tftName l <|> tftName r + , tftStart = tftStart l <|> tftStart r + , tftEnd = tftEnd l <|> tftEnd r + , tftHolidays = tftHolidays l <|> tftHolidays r + , tftLectureStart = tftLectureStart l <|> tftLectureStart r + , tftLectureEnd = tftLectureEnd l <|> tftLectureEnd r + , tftActive = tftActive l <|> tftActive r } instance Monoid TermFormTemplate where diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 723c699db..8e83cfb89 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -27,6 +27,8 @@ import Model.Types.TH.Wordlist as Import import Mail as Import +import ServantApi.Definition as Import + import Yesod.Auth as Import import Yesod.Core.Types as Import (loggerSet) import Yesod.Default.Config2 as Import @@ -165,7 +167,7 @@ import Control.Lens as Import import Control.Lens.Extras as Import (is) import Data.Set.Lens as Import -import Control.Arrow as Import (Kleisli(..)) +import Control.Arrow as Import (left, right, Kleisli(..)) import Data.Encoding as Import (DynEncoding, decodeLazyByteString, encodeLazyByteString) import Data.Encoding.UTF8 as Import (UTF8(UTF8)) diff --git a/src/Import/Servant.hs b/src/Import/Servant.hs new file mode 100644 index 000000000..f4131c854 --- /dev/null +++ b/src/Import/Servant.hs @@ -0,0 +1,18 @@ +module Import.Servant + ( module Import + ) where + +import Import.NoFoundation as Import hiding + ( Context + , Authorized, Unauthorized + , ServerError + , Header + , Strict + , Headers + , addHeader + ) + +import Foundation.Type as Import + +import Servant.API as Import +import Servant.Server as Import diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 71e35fbdf..87add310a 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -9,7 +9,19 @@ module Model.Types.Security ( module Model.Types.Security ) where -import Import.NoModel +import ClassyPrelude + +import Data.Aeson +import Data.Aeson.TH +import Utils.PathPiece +import Model.Types.TH.JSON +import Data.Universe +import Data.Universe.Instances.Reverse () +import Data.Default +import Web.PathPieces +import Data.Proxy + +import qualified Data.Set as Set import qualified Data.Text as Text @@ -17,9 +29,14 @@ import qualified Data.HashMap.Strict as HashMap import qualified Data.Aeson.Types as Aeson +import Data.Binary (Binary) import qualified Data.Binary as Binary +import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive.Instances () + +import Data.NonNull.Instances () import Model.Types.TH.PathPiece import Database.Persist.Sql @@ -138,6 +155,21 @@ newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (Semigroup, Monoid) +parsePredDNF :: forall a. (Ord a, PathPiece a) => PredDNF a -> [Text] -> Either Text (PredDNF a) +parsePredDNF start = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms start) + where + partition' :: Set (Set (PredLiteral a)) -> Text -> Either Text (Set (Set (PredLiteral a))) + partition' prev t + | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t) + = if + | oany (authTags `Set.isSubsetOf`) prev + -> Right prev + | otherwise + -> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev + | otherwise + = Left t + + $(return []) instance ToJSON a => ToJSON (PredDNF a) where @@ -153,6 +185,13 @@ type AuthLiteral = PredLiteral AuthTag type AuthDNF = PredDNF AuthTag +defaultAuthDNF :: AuthDNF +defaultAuthDNF = PredDNF $ Set.fromList + [ impureNonNull . Set.singleton $ PLVariable AuthAdmin + , impureNonNull . Set.singleton $ PLVariable AuthToken + ] + + data UserGroupName = UserGroupMetrics diff --git a/src/ServantApi.hs b/src/ServantApi.hs new file mode 100644 index 000000000..b0761b9c3 --- /dev/null +++ b/src/ServantApi.hs @@ -0,0 +1,15 @@ +module ServantApi + ( module ServantApi + ) where + +import Import.Servant +import Foundation.Routes.Definitions + + +import ServantApi.ExternalApis as ServantApi + + +mkYesodApi ''UniWorX uniworxRoutes + +uniworxApi :: Proxy UniWorXApi +uniworxApi = Proxy diff --git a/src/ServantApi/Definition.hs b/src/ServantApi/Definition.hs new file mode 100644 index 000000000..4faa7a7be --- /dev/null +++ b/src/ServantApi/Definition.hs @@ -0,0 +1,189 @@ +module ServantApi.Definition + ( ServantApi(..) + , servantApiLink + , mkYesodApi + , PathPieceHttpApiData(..) + , BearerAuth, SessionAuth + ) where + +import ClassyPrelude hiding (Handler, fromList) +import Control.Lens hiding (Context) + +import Utils +import Model.Types.Security + +import Yesod.Core ( RenderRoute(..), ParseRoute(..) + , YesodSubDispatch(..) + , WaiSubsiteWithAuth(..) + , PathPiece(..) + ) +import Yesod.Core.Types ( YesodRunnerEnv(..) + , YesodSubRunnerEnv(..) + , Route(WaiSubsiteWithAuthRoute) + ) + +import Servant.Links +import Servant.API +import Servant.Server + +import Data.Proxy + +import Network.Wai (Request) + +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(..)) + +import Servant.Swagger +import Data.Swagger + +import qualified Data.Set as Set + +import Network.URI +import Network.HTTP.Types.URI + + +data ServantApi api where + ServantApi :: forall (context :: [*]) (api :: *) (m :: * -> *). + HasServer api context + => { servantContext :: Request -> IO (Context context) + , servantHoist :: Request -> Context context -> (forall a. m a -> Handler a) + , servantServer :: ServerT api m + } + -> ServantApi api + +instance RenderRoute (ServantApi api) where + data Route (ServantApi api) = ServantApiRoute [Text] [(Text,Text)] + deriving (Show, Eq, Read, Ord) + renderRoute (ServantApiRoute ps qs) = (ps,qs) + +instance ParseRoute (ServantApi api) where + parseRoute (ps, qs) = Just $ ServantApiRoute ps qs + +instance YesodSubDispatch (ServantApi api) master where + yesodSubDispatch YesodSubRunnerEnv{..} = case ysreGetSub $ yreSite ysreParentEnv of + ServantApi{ servantContext = (servantContext :: Request -> IO (Context context)), .. } + -> let subEnv' :: YesodSubRunnerEnv WaiSubsiteWithAuth master + subEnv' = YesodSubRunnerEnv + { ysreGetSub = \_ -> WaiSubsiteWithAuth $ \req respond -> do + ctx <- servantContext req + let server' = hoistServerWithContext (Proxy @api) (Proxy @context) (servantHoist req ctx) servantServer + serveWithContext (Proxy @api) ctx server' req respond + , ysreToParentRoute = ysreToParentRoute . (\(WaiSubsiteWithAuthRoute ps qs) -> ServantApiRoute ps qs) + , .. + } + in yesodSubDispatch subEnv' + +servantApiLink :: forall p1 p2 api endpoint. + ( IsElem endpoint api, HasLink endpoint ) + => p1 api + -> p2 endpoint + -> MkLink endpoint (Route (ServantApi api)) +servantApiLink _ _ = safeLink' mkRoute (Proxy @api) (Proxy @endpoint) + where + mkRoute :: Link -> Route (ServantApi api) + mkRoute (linkURI -> uri@URI{..}) = ServantApiRoute + (map pack $ pathSegments uri) + (over (mapped . _2) (fromMaybe mempty) . parseQueryText . encodeUtf8 $ pack uriQuery) + + +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 @(SessionAuth :> 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) + & securityDefinitions <>~ fromList [(defnKey, defn)] + & allOperations . security <>~ [SecurityRequirement $ fromList [(defnKey, [])]] + where defnKey :: Text + defnKey = "session" + defn = SecurityScheme + { _securitySchemeType + = SecuritySchemeApiKey ApiKeyParams + { _apiKeyName = "Cookie" + , _apiKeyIn = ApiKeyHeader + } + , _securitySchemeDescription = Just + "JSON Web Token-based session identification as provided be the web interface" + } + +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) + + + +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 + ] diff --git a/src/ServantApi/ExternalApis.hs b/src/ServantApi/ExternalApis.hs new file mode 100644 index 000000000..f57dc85ff --- /dev/null +++ b/src/ServantApi/ExternalApis.hs @@ -0,0 +1,20 @@ +module ServantApi.ExternalApis + ( ExternalApis + , ServantApiExternalApis + , getServantApiExternalApis + ) where + +import Import.Servant + + +type ExternalApis = EmptyAPI + +type ServantApiExternalApis = ServantApi ExternalApis + + +getServantApiExternalApis :: UniWorX -> ServantApiExternalApis +getServantApiExternalApis _ = ServantApi + { servantContext = \_ -> return EmptyContext + , servantHoist = \_ _ -> id + , servantServer = emptyServer + }