From e3d504bd113f76854748929201c7e476c2911ee0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 17 Mar 2020 10:27:00 +0100 Subject: [PATCH 01/18] feat(apis): integrate servant --- messages/uniworx/de-de-formal.msg | 4 +- messages/uniworx/en-eu.msg | 4 +- package.yaml | 6 + routes | 4 + src/Application.hs | 3 + src/Foundation.hs | 22 +--- src/Foundation/Routes.hs | 3 + src/Handler/Swagger.hs | 67 +++++++++++ src/Handler/Term.hs | 16 +-- src/Import/NoModel.hs | 4 +- src/Import/Servant.hs | 18 +++ src/Model/Types/Security.hs | 41 ++++++- src/ServantApi.hs | 15 +++ src/ServantApi/Definition.hs | 189 ++++++++++++++++++++++++++++++ src/ServantApi/ExternalApis.hs | 20 ++++ 15 files changed, 386 insertions(+), 30 deletions(-) create mode 100644 src/Handler/Swagger.hs create mode 100644 src/Import/Servant.hs create mode 100644 src/ServantApi.hs create mode 100644 src/ServantApi/Definition.hs create mode 100644 src/ServantApi/ExternalApis.hs 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 + } From bf2ff2dc9c4a986e9088feca41c00123bf2c785a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 3 Apr 2020 14:40:48 +0200 Subject: [PATCH 02/18] feat(apis): further integrate servant --- config/settings.yml | 2 +- frontend/src/app.sass | 9 + messages/uniworx/de-de-formal.msg | 4 +- package.yaml | 3 + routes | 6 +- src/Application.hs | 3 +- src/CryptoID.hs | 1 + src/Data/CaseInsensitive/Instances.hs | 11 +- src/Foundation.hs | 157 +++++-- src/Foundation/Routes.hs | 25 +- src/Foundation/Servant.hs | 118 +++++ src/Handler/ApiDocs.hs | 29 ++ src/Handler/Swagger.hs | 55 ++- src/Handler/Utils/Form/MassInput.hs | 2 +- src/Handler/Utils/Table/Pagination.hs | 2 +- src/Handler/Utils/Tokens.hs | 22 +- src/Import/NoModel.hs | 9 +- src/Import/Servant.hs | 19 +- src/Import/Servant/NoFoundation.hs | 24 + src/Jose/Jwk/Instances.hs | 12 + src/Jose/Jwt/Instances.hs | 3 + src/Model/Tokens/Bearer.hs | 14 +- src/Model/Types.hs | 1 + src/Model/Types/Apis.hs | 24 + src/Model/Types/Security.hs | 11 +- src/Model/Types/Sheet.hs | 5 +- src/Model/Types/Submission.hs | 4 +- src/ServantApi.hs | 1 - src/ServantApi/Definition.hs | 189 -------- src/ServantApi/ExternalApis.hs | 19 +- src/ServantApi/ExternalApis/Type.hs | 20 + src/Utils.hs | 37 ++ src/Utils/Tokens.hs | 74 +-- src/Web/ServerSession/Frontend/Yesod/Jwt.hs | 3 +- src/Yesod/Core/Instances.hs | 2 - src/Yesod/Servant.hs | 475 ++++++++++++++++++++ src/Yesod/Servant/HttpApiDataInjective.hs | 82 ++++ stack.yaml | 5 + stack.yaml.lock | 28 ++ 39 files changed, 1146 insertions(+), 364 deletions(-) create mode 100644 src/Foundation/Servant.hs create mode 100644 src/Handler/ApiDocs.hs create mode 100644 src/Import/Servant/NoFoundation.hs create mode 100644 src/Jose/Jwk/Instances.hs create mode 100644 src/Model/Types/Apis.hs delete mode 100644 src/ServantApi/Definition.hs create mode 100644 src/ServantApi/ExternalApis/Type.hs create mode 100644 src/Yesod/Servant.hs create mode 100644 src/Yesod/Servant/HttpApiDataInjective.hs diff --git a/config/settings.yml b/config/settings.yml index 449757de4..15bfd8526 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -146,7 +146,7 @@ server-sessions: secure-cookies: "_env:SERVER_SESSION_COOKIES_SECURE:true" session-token-expiration: 28807 session-token-encoding: HS256 -session-samesite: strict +session-samesite: lax user-defaults: max-favourites: 12 diff --git a/frontend/src/app.sass b/frontend/src/app.sass index c1f05706c..81f4f803e 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -1262,3 +1262,12 @@ a.breadcrumbs__home &__label grid-area: label + +code + display: block + box-shadow: inset 0 0 4px 4px var(--color-grey-light) + white-space: pre-wrap + font-family: monospace + overflow-x: auto + tab-size: 2 + padding: 10px diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index d0a0bf301..3c3b045fd 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1224,6 +1224,7 @@ MenuAllocationUsers: Bewerber MenuAllocationPriorities: Zentrale Dringlichkeiten MenuAllocationCompute: Platzvergabe berechnen MenuAllocationAccept: Platzvergabe akzeptieren +MenuSwagger: OpenAPI 2.0 (Swagger) BreadcrumbSubmissionFile: Datei BreadcrumbSubmissionUserInvite: Einladung zur Abgabe @@ -1294,7 +1295,8 @@ BreadcrumbAllocationPriorities: Zentrale Dringlichkeiten BreadcrumbAllocationCompute: Platzvergabe berechnen BreadcrumbAllocationAccept: Platzvergabe akzeptieren BreadcrumbExternalApis: Externe APIs -BreadcrumbSwagger: API Dokumentation +BreadcrumbApiDocs: API Dokumentation +BreadcrumbSwagger: OpenAPI 2.0 (Swagger) ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} diff --git a/package.yaml b/package.yaml index bd8f9700e..dd3b531a1 100644 --- a/package.yaml +++ b/package.yaml @@ -145,9 +145,12 @@ dependencies: - servant - servant-server - servant-swagger + - servant-docs - swagger2 - haskell-src-meta - network-uri + - insert-ordered-containers + - vault other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index af3f485dd..be75be25f 100644 --- a/routes +++ b/routes @@ -67,7 +67,7 @@ /help HelpR GET POST !free -/external-apis ExternalApisR ServantApiExternalApis getServantApiExternalApis +/external-apis ExternalApisR ServantApiExternalApis getServantApi /user ProfileR GET POST !free /user/profile ProfileDataR GET !free @@ -229,6 +229,8 @@ !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -/swagger.json SwaggerR GET !free +/api ApiDocsR GET !free +/swagger SwaggerR GET !free +/swagger.json SwaggerJsonR GET !free !/*WellKnownFileName WellKnownR GET !free diff --git a/src/Application.hs b/src/Application.hs index 07303e630..77b2301e9 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -117,9 +117,10 @@ import Handler.Metrics import Handler.ExternalExam import Handler.Participants import Handler.StorageKey +import Handler.ApiDocs import Handler.Swagger -import ServantApi +import ServantApi () -- YesodSubDispatch instances -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 02ec64b11..78bebd386 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -73,6 +73,7 @@ decCryptoIDs [ ''SubmissionId , ''CourseNewsId , ''CourseEventId , ''TutorialId + , ''ExternalApiId ] -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission" diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index 6596fe47e..45e9652e8 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -6,7 +6,7 @@ module Data.CaseInsensitive.Instances ( ) where -import ClassyPrelude.Yesod hiding (lift) +import ClassyPrelude.Yesod hiding (lift, Proxy(..)) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -28,6 +28,10 @@ import Web.HttpApiData import qualified Data.Csv as Csv +import qualified Data.Swagger as Swagger + +import Data.Proxy + instance PersistField (CI Text) where toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText @@ -88,6 +92,8 @@ instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where instance ToHttpApiData s => ToHttpApiData (CI s) where toUrlPiece = toUrlPiece . CI.original toEncodedUrlPiece = toEncodedUrlPiece . CI.original + toHeader = toHeader . CI.original + toQueryParam = toQueryParam . CI.original instance (CI.FoldCase s, FromHttpApiData s) => FromHttpApiData (CI s) where parseUrlPiece = fmap CI.mk . parseUrlPiece @@ -101,3 +107,6 @@ instance Csv.ToField s => Csv.ToField (CI s) where instance (CI.FoldCase s, Csv.FromField s) => Csv.FromField (CI s) where parseField = fmap CI.mk . Csv.parseField + +instance Swagger.ToParamSchema s => Swagger.ToParamSchema (CI s) where + toParamSchema _ = Swagger.toParamSchema (Proxy @s) diff --git a/src/Foundation.hs b/src/Foundation.hs index 4d289a5a2..054c1ef50 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -22,7 +22,9 @@ import Auth.LDAP import Auth.PWHash import Auth.Dummy -import qualified Network.Wai as W (pathInfo) +import qualified Network.Wai as W +import qualified Network.HTTP.Types.Header as W +import qualified Network.Wai.Middleware.HttpAuth as W import Yesod.Core.Types (HandlerContents) import qualified Yesod.Core.Unsafe as Unsafe @@ -312,7 +314,7 @@ askBearerUnsafe :: forall m. -- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead askBearerUnsafe = $cachedHere $ do bearer <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askBearer - catch (decodeBearer bearer) $ \case + catch (liftHandler $ decodeBearer bearer) $ \case BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted other -> do @@ -1452,7 +1454,7 @@ instance Yesod UniWorX where Nothing -> getApprootText guessApproot app req Just root -> root - makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = sameSite $ case appSessionStore of + makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of SessionStorageMemcachedSql sqlStore -> mkBackend =<< stateSettings <$> ServerSession.createState sqlStore SessionStorageAcid acidStore @@ -1484,6 +1486,17 @@ instance Yesod UniWorX where = laxSameSiteSessions | otherwise = id + notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend) + notForBearer = fmap $ fmap notForBearer' + where notForBearer' :: SessionBackend -> SessionBackend + notForBearer' (SessionBackend load) + = let load' req + | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req + , any (is _Just) $ map W.extractBearerAuth aHdrs + = return (mempty, const $ return []) + | otherwise + = load req + in SessionBackend load' maximumContentLength app _ = app ^. _appMaximumContentLength @@ -1494,8 +1507,12 @@ instance Yesod UniWorX where -- b) Validates that incoming write requests include that token in either a header or POST parameter. -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. - yesodMiddleware = observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware + yesodMiddleware = observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . securityHeaderMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . csrfMiddleware . updateFavouritesMiddleware where + securityHeaderMiddleware :: Handler a -> Handler a + securityHeaderMiddleware handler = (*> handler) $ do + addHeader "X-Frame-Options" "sameorigin" + addHeader "X-Content-Type-Options" "nosniff" updateFavouritesMiddleware :: Handler a -> Handler a updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do route <- MaybeT getCurrentRoute @@ -1528,48 +1545,78 @@ instance Yesod UniWorX where addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode observeYesodCacheSizeMiddleware :: Handler a -> Handler a observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize + csrfMiddleware :: Handler a -> Handler a + csrfMiddleware handler = do + hasBearer <- is _Just <$> lookupBearerAuth + + if | hasBearer -> handler + | otherwise -> defaultCsrfMiddleware handler -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget` defaultMessageWidget _title _body = error "defaultMessageWidget: undefined" errorHandler err = do - mr <- getMessageRender - let - encrypted :: ToJSON a => a -> Widget -> Widget - encrypted plaintextJson plaintext = do - canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True - shouldEncrypt <- getsYesod $ view _appEncryptErrors - if - | shouldEncrypt - , not canDecrypt -> do - ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson + shouldEncrypt <- do + canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True + shouldEncrypt <- getsYesod $ view _appEncryptErrors + return $ shouldEncrypt && not canDecrypt - [whamlet| -

_{MsgErrorResponseEncrypted} - 

-                    #{ciphertext}
+      selectRep $ do
+        provideRep $ do
+          mr <- getMessageRender
+          let
+            encrypted :: ToJSON a => a -> Widget -> Widget
+            encrypted plaintextJson plaintext = do
+              if
+                | shouldEncrypt -> do
+                    ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
+
+                    [whamlet|
+                      
_{MsgErrorResponseEncrypted}
+                      
+                        #{ciphertext}
+                    |]
+                | otherwise -> plaintext
+
+            errPage = case err of
+              NotFound -> [whamlet|
_{MsgErrorResponseNotFound}|]
+              InternalError err' -> encrypted err' [whamlet|
#{err'}|]
+              InvalidArgs errs -> [whamlet|
+                  
    
+                    $forall err' <- errs
+                      
  • #{err'}
                 |]
-            | otherwise -> plaintext
-
-        errPage = case err of
-          NotFound -> [whamlet|
    _{MsgErrorResponseNotFound}|]
-          InternalError err' -> encrypted err' [whamlet|
    #{err'}|]
-          InvalidArgs errs -> [whamlet|
-              
      
-                $forall err' <- errs
-                  
    • #{err'}
-            |]
-          NotAuthenticated -> [whamlet|
      _{MsgErrorResponseNotAuthenticated}|]
-          PermissionDenied err' -> [whamlet|
      #{err'}|]
-          BadMethod method -> [whamlet|
      _{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
-      fmap toTypedContent . siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
-        toWidget
-          [cassius|
-            .errMsg
-              white-space: pre-wrap
-              font-family: monospace
-          |]
-        errPage
+              NotAuthenticated -> [whamlet|
      _{MsgErrorResponseNotAuthenticated}|]
+              PermissionDenied err' -> [whamlet|
      #{err'}|]
+              BadMethod method -> [whamlet|
      _{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
+          siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
+            toWidget
+              [cassius|
+                .errMsg
+                  white-space: pre-wrap
+                  font-family: monospace
+              |]
+            errPage
+        provideRep . fmap PrettyValue $ case err of
+          PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
+          InternalError err'
+            | shouldEncrypt -> do
+                ciphertext <- encodedSecretBox SecretBoxShort err'
+                return $ object [ "message" JSON..= ciphertext
+                                , "encrypted" JSON..= True
+                                ]
+            | otherwise -> return $ object [ "message" JSON..= err' ]
+          InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
+          _other -> return $ object []
+        provideRep $ case err of
+          PermissionDenied err' -> return err'
+          InternalError err'
+            | shouldEncrypt -> do
+                addHeader "Encrypted-Error-Message" "True"
+                encodedSecretBox SecretBoxPretty err'
+            | otherwise -> return err'
+          InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
+          _other -> return Text.empty
 
     defaultLayout = siteLayout' Nothing
 
@@ -1614,6 +1661,12 @@ instance Yesod UniWorX where
 
     makeLogger = readTVarIO . snd . appLogger
 
+    -- -- `normalizeRouteMiddleware` takes care of normalization
+    -- cleanPath _ = Right
+    -- joinPath _ ar pieces qs' = Text.encodeUtf8Builder ar <> encodePath pieces qs
+    --   where qs = map (Text.encodeUtf8 *** fmap Text.encodeUtf8 . assertM' (not . Text.null)) qs'
+                    
+
 
 -- langForm :: Form (Lang, Route UniWorX)
 -- langForm csrf = do
@@ -2216,7 +2269,10 @@ instance YesodBreadcrumbs UniWorX where
     EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR 
 
   breadcrumb (ExternalApisR _) = i18nCrumb MsgBreadcrumbExternalApis Nothing
-  breadcrumb SwaggerR = i18nCrumb MsgBreadcrumbSwagger Nothing
+
+  breadcrumb ApiDocsR = i18nCrumb MsgBreadcrumbApiDocs Nothing
+  breadcrumb SwaggerR = i18nCrumb MsgBreadcrumbSwagger $ Just ApiDocsR
+  breadcrumb SwaggerJsonR = breadcrumb SwaggerR
   
   -- breadcrumb  _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
 
@@ -3923,6 +3979,19 @@ pageActions ParticipantsListR = return
     , navChildren = []
     }
   ]
+pageActions ApiDocsR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuSwagger
+      , navRoute       = SwaggerR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
 pageActions _ = return []
 
 pageQuickActions :: ( MonadCatch m
@@ -4700,12 +4769,12 @@ instance YesodMail UniWorX where
     return mRes
 
 
-instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
+instance (MonadThrow m, MonadSite UniWorX m) => MonadCrypto m where
   type MonadCryptoKey m = CryptoIDKey
-  cryptoIDKey f = getsYesod appCryptoIDKey >>= f
+  cryptoIDKey f = getsSite appCryptoIDKey >>= f
 
-instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where
-  secretBoxKey = getsYesod appSecretBoxKey
+instance {-# OVERLAPPING #-} (Monad m, MonadSite UniWorX m) => MonadSecretBox m where
+  secretBoxKey = getsSite appSecretBoxKey
 
 -- Note: Some functionality previously present in the scaffolding has been
 -- moved to documentation in the Wiki. Following are some hopefully helpful
diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs
index 36bc627be..e5c56ef44 100644
--- a/src/Foundation/Routes.hs
+++ b/src/Foundation/Routes.hs
@@ -11,7 +11,9 @@ import Foundation.Type
 
 import Foundation.Routes.Definitions
 
-import ServantApi
+
+import ServantApi.ExternalApis.Type
+
 
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
@@ -42,6 +44,27 @@ deriving instance Generic CourseNewsR
 deriving instance Generic CourseEventR
 deriving instance Generic (Route UniWorX)
 
+
+instance Hashable CourseR
+instance Hashable SheetR
+instance Hashable SubmissionR
+instance Hashable MaterialR
+instance Hashable TutorialR
+instance Hashable ExamR
+instance Hashable EExamR
+instance Hashable CourseApplicationR
+instance Hashable AllocationR
+instance Hashable SchoolR
+instance Hashable ExamOfficeR
+instance Hashable CourseNewsR
+instance Hashable CourseEventR
+instance Hashable (Route UniWorX)
+instance Hashable (Route EmbeddedStatic) where
+  hashWithSalt s = hashWithSalt s . renderRoute
+instance Hashable (Route Auth) where
+  hashWithSalt s = hashWithSalt s . renderRoute
+  
+
 data RouteChildren
 type instance Children RouteChildren a = ChildrenRouteChildren a
 type family ChildrenRouteChildren a where
diff --git a/src/Foundation/Servant.hs b/src/Foundation/Servant.hs
new file mode 100644
index 000000000..5f90c95a8
--- /dev/null
+++ b/src/Foundation/Servant.hs
@@ -0,0 +1,118 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Foundation.Servant
+  ( ServantApiDispatchUniWorX(..)
+  , UniWorXContext
+  , ServantHandler
+  , BearerRestriction(..)
+  ) where
+
+import Import.Servant.NoFoundation
+import Foundation
+
+import Handler.Utils.Tokens
+
+import qualified Data.HashMap.Strict.InsOrd as HashMap
+
+import Network.Wai (Middleware, modifyResponse, mapResponseHeaders, vault)
+import qualified Network.Wai as W
+
+import qualified Data.Vault.Lazy as Vault
+
+import Servant.Server.Internal.DelayedIO (DelayedIO, delayedFailFatal, withRequest)
+import Servant.Server.Internal.Delayed (addAuthCheck)
+
+import System.IO.Unsafe (unsafePerformIO)
+
+import qualified Yesod.Servant as Servant
+
+import qualified Data.Text as Text
+
+
+waiBearerKey :: Vault.Key (Maybe (BearerToken UniWorX))
+waiBearerKey = unsafePerformIO Vault.newKey
+{-# NOINLINE waiBearerKey #-}
+
+waiRouteKey :: Vault.Key (Route UniWorX)
+waiRouteKey = unsafePerformIO Vault.newKey
+{-# NOINLINE waiRouteKey #-}
+
+
+data BearerRestriction (restr :: *) = BearerRestriction
+
+
+instance ( HasServer sub context
+         , ToJSON restr, FromJSON restr
+         )
+      => HasServer (BearerRestriction restr :> sub) context
+  where
+    type ServerT (BearerRestriction restr :> sub) m
+      = Maybe restr -> ServerT sub m
+
+    hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @sub) pc nt . s
+
+    route _ context subserver
+      = route (Proxy @sub) context (subserver `addAuthCheck` withRequest bearerCheck)
+      where
+        bearerCheck :: W.Request -> DelayedIO (Maybe restr)
+        bearerCheck req = do
+          let bearer = Vault.lookup waiBearerKey $ vault req
+              cRoute = Vault.lookup waiRouteKey  $ vault req
+
+              noRouteStored, noTokenStored, noTokenProvided :: ServerError
+              noTokenStored = err500 { errBody = "servantYesodMiddleware did not store bearer token in WAI vault." }
+              noTokenProvided = err400 { errBody = "The behaviour of this route depends on restrictions stored in the bearer token used for authorization. Therefor providing a bearer token is required." }
+              noRouteStored = err500 { errBody = "servantYesodMiddleware did not store current route in WAI vault." }
+
+          exceptT delayedFailFatal return $ do
+            bearer' <- maybeExceptT' noTokenProvided =<< maybeExceptT' noTokenStored bearer
+            cRoute' <- maybeExceptT' noRouteStored cRoute
+
+            return $ bearer' ^? _bearerRestrictionIx cRoute'
+
+
+type UniWorXContext = UniWorX ': '[]
+type ServantHandler = ServantHandlerFor UniWorX
+
+class (HasServer api UniWorXContext, Servant.HasRoute api) => ServantApiDispatchUniWorX api where
+  servantServer' :: ServantApi api -> ServerT api ServantHandler
+
+instance ServantApiDispatchUniWorX api => ServantApiDispatch UniWorXContext ServantHandler UniWorX api where
+  servantContext _ app _ = return $ app :. EmptyContext
+  servantHoist _ app _ _ = ($ app) . unServantHandlerFor
+  servantMiddleware _ _ _ = modifyResponse (mapResponseHeaders setDefaultHeaders) . fixTrailingSlash
+  servantYesodMiddleware _ _ = fmap appEndo $ foldMapM (fmap Endo) [storeBearerToken, storeCurrentRoute]
+  servantServer proxy _ = servantServer' proxy
+
+setDefaultHeaders :: ResponseHeaders -> ResponseHeaders
+setDefaultHeaders existing = HashMap.toList $ HashMap.fromList existing <> defaultHeaders
+  where defaultHeaders = HashMap.fromList
+          [ ("X-Frame-Options", "sameorigin")
+          , ("X-Content-Type-Options", "nosniff")
+          , ("Vary", "Accept")
+          , ("X-XSS-Protection", "1; mode=block")
+          ]
+
+fixTrailingSlash :: Middleware
+-- ^ `servant-server` contains a special case in their implementation
+--   of `runRouter`, that discards trailing slashes.
+--
+-- Because all slashes matter, this duplicates trailing slashes.
+fixTrailingSlash = (. fixTrailingSlash')
+  where fixTrailingSlash' req
+          | Just pathInfo' <- fromNullable $ W.pathInfo req
+          , Text.null $ last pathInfo'
+          = req { W.pathInfo = W.pathInfo req ++ [Text.empty] }
+          | otherwise
+          = req
+
+storeBearerToken, storeCurrentRoute :: HandlerFor UniWorX Middleware
+storeBearerToken = do
+  restr <- maybeBearerToken
+  return $ \app req -> app req{ vault = Vault.insert waiBearerKey restr $ vault req }
+storeCurrentRoute = do
+  cRoute <- getCurrentRoute
+
+  $logDebugS "storeCurrentRoute" $ tshow cRoute
+  
+  return $ \app req -> app req{ vault = maybe id (Vault.insert waiRouteKey) cRoute $ vault req }
diff --git a/src/Handler/ApiDocs.hs b/src/Handler/ApiDocs.hs
new file mode 100644
index 000000000..5b982af15
--- /dev/null
+++ b/src/Handler/ApiDocs.hs
@@ -0,0 +1,29 @@
+module Handler.ApiDocs
+  ( getApiDocsR
+  ) where
+
+import Import
+import ServantApi
+
+import qualified Servant.Docs as Servant
+
+import Handler.Utils.Pandoc
+
+
+getApiDocsR :: Handler TypedContent
+getApiDocsR = selectRep $ do
+  case htmlDocs of
+    Right html -> provideRep . siteLayoutMsg MsgBreadcrumbApiDocs $ do
+      setTitleI MsgBreadcrumbApiDocs
+
+      toWidget html
+    Left  _err -> return ()
+  provideRepType "text/markdown" $ return mdDocs
+  where
+    mdDocs = pack . Servant.markdown $ Servant.docsWith Servant.defaultDocOptions docIntros docExtra uniworxApi
+    htmlDocs = parseMarkdownWith markdownReaderOptions htmlWriterOptions mdDocs
+
+    docIntros = mempty
+    docExtra = mconcat
+      [
+      ]
diff --git a/src/Handler/Swagger.hs b/src/Handler/Swagger.hs
index d4e2bdfa1..9e4c7fdd1 100644
--- a/src/Handler/Swagger.hs
+++ b/src/Handler/Swagger.hs
@@ -1,18 +1,14 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 module Handler.Swagger
-  ( getSwaggerR
+  ( getSwaggerR, getSwaggerJsonR
   ) where
 
-import Import hiding (host)
+import Import hiding (host, Response)
 import ServantApi
 
 import Data.Swagger
+import Data.Swagger.Declare (Declare)
 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
@@ -20,19 +16,8 @@ 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
+genSwagger :: Handler Swagger
+genSwagger = do
   app <- getYesod
   let docMR = renderMessage app . otoList $ selectLanguages appLanguages ["en"]
   root <- getApprootText approot app <$> waiRequest
@@ -53,15 +38,39 @@ getSwaggerR = do
           & fromMaybe id applyAuthority
           & schemes .~ fmap pure mbScheme
           & basePath ?~ bool id (ensurePrefix "/") (is _Just mbScheme || is _Just uriAuthority) uriPath
+      errorResponses :: Map HttpStatusCode (Declare (Definitions Schema) Response)
+      errorResponses = mconcat
+        [ singletonMap 500 $ return mempty
+        , singletonMap 400 $ return mempty
+        , singletonMap 401 $ return mempty
+        , singletonMap 403 $ return mempty
+        , singletonMap 405 $ return mempty
+        ]
         
-
   tos <- toTextUrl $ LegalR :#: ("terms-of-use" :: Text)
   c <- toTextUrl HelpR
-  
+
+  let supportContact = mempty
+        & name .~ addressName supportAddress
+        & email ?~ addressEmail supportAddress
+        & url ?~ URL c
+        where
+          supportAddress = appMailSupport $ appSettings' app
+
   return $ toSwagger uniworxApi
     & info.title .~ docMR MsgLogo
     & info.description ?~ docMR MsgInvitationUniWorXTip
     & info.termsOfService ?~ tos
-    & info.contact ?~ Contact Nothing (Just $ URL c) Nothing
+    & info.contact ?~ supportContact
     & info.version .~ $gitDescribe
     & fromMaybe id applyApproot
+    & appEndo (ifoldMap ((Endo .) . setResponseWith const) errorResponses)
+
+
+getSwaggerR :: Handler TypedContent
+getSwaggerR = selectRep $ do
+  provideRep $ toPrettyJSON <$> genSwagger
+  provideRep $ toYAML       <$> genSwagger
+
+getSwaggerJsonR :: Handler Void
+getSwaggerJsonR = redirect SwaggerR
diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs
index e612b5fe7..e986bb9d1 100644
--- a/src/Handler/Utils/Form/MassInput.hs
+++ b/src/Handler/Utils/Form/MassInput.hs
@@ -287,7 +287,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
     shapeName :: MassInputFieldName (BoxCoord liveliness)
     shapeName = MassInputShape{..}
     shapeField :: Field handler (Map (BoxCoord liveliness) cellData)
-    shapeField = secretJsonField
+    shapeField = hoistField liftHandler secretJsonField
   sentShape <- runMaybeT $ do
     ts <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askParams
     fs <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askFiles
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 6943ffb61..7d4454b62 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -829,7 +829,7 @@ addPIHiddenField DBTable{ dbtIdent } pi form fragment
 
 addPreviousHiddenField :: (ToJSON k', MonadHandler m, HandlerSite m ~ UniWorX) => DBTable m' x -> [k'] -> (Html -> MForm m a) -> (Html -> MForm m a)
 addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
-  encrypted <- encodedSecretBox SecretBoxShort pKeys
+  encrypted <- liftHandler $ encodedSecretBox SecretBoxShort pKeys
   form $ fragment <> [shamlet|
     $newline never
     
diff --git a/src/Handler/Utils/Tokens.hs b/src/Handler/Utils/Tokens.hs
index 83266119f..bfdb26819 100644
--- a/src/Handler/Utils/Tokens.hs
+++ b/src/Handler/Utils/Tokens.hs
@@ -24,23 +24,23 @@ requireBearerToken = liftHandler $ do
   return bearer
 
 requireCurrentBearerRestrictions :: ( MonadHandler m
-                                   , HandlerSite m ~ UniWorX
-                                   , FromJSON a
-                                   , ToJSON a
-                                   )
-                                => m (Maybe a)
+                                    , HandlerSite m ~ UniWorX
+                                    , FromJSON a
+                                    , ToJSON a
+                                    )
+                                 => m (Maybe a)
 requireCurrentBearerRestrictions = runMaybeT $ do
   bearer <- requireBearerToken
   route <- MaybeT getCurrentRoute
   hoistMaybe $ bearer ^? _bearerRestrictionIx route
   
 maybeCurrentBearerRestrictions :: ( MonadHandler m
-                                 , HandlerSite m ~ UniWorX
-                                 , MonadCatch m
-                                 , FromJSON a
-                                 , ToJSON a
-                                 )
-                              => m (Maybe a)
+                                  , HandlerSite m ~ UniWorX
+                                  , MonadCatch m
+                                  , FromJSON a
+                                  , ToJSON a
+                                  )
+                               => m (Maybe a)
 maybeCurrentBearerRestrictions = runMaybeT $ do
   bearer <- MaybeT maybeBearerToken
   route <- MaybeT getCurrentRoute
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 8e83cfb89..189f19602 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -27,12 +27,13 @@ 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
 import Yesod.Core.Types.Instances as Import
+import Yesod.Servant          as Import
+  hiding ( MonadHandler(..), HasRoute(..)
+         )
 
 import Utils                  as Import
 import Utils.Frontend.I18n    as Import
@@ -102,7 +103,8 @@ import Control.Monad.Catch as Import hiding (Handler(..))
 import Control.Monad.Trans.Control as Import hiding (embed)
 import Control.Monad.Fail as Import
 
-import Jose.Jwt as Import (Jwt)
+import Jose.Jwk as Import (JwkSet, Jwk(..))
+import Jose.Jwt as Import (Jwt(..))
 
 import Data.Time.Calendar as Import
 import Data.Time.Clock as Import
@@ -139,6 +141,7 @@ import Database.Esqueleto.Instances as Import ()
 import Numeric.Natural.Instances as Import ()
 import Text.Blaze.Instances as Import ()
 import Jose.Jwt.Instances as Import ()
+import Jose.Jwk.Instances as Import ()
 import Web.PathPieces.Instances as Import ()
 import Data.Universe.Instances.Reverse.MonoTraversable ()
 import Data.Universe.Instances.Reverse.WithIndex ()
diff --git a/src/Import/Servant.hs b/src/Import/Servant.hs
index f4131c854..05160ee18 100644
--- a/src/Import/Servant.hs
+++ b/src/Import/Servant.hs
@@ -2,17 +2,8 @@ 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
+import Foundation as Import
+  hiding ( Handler
+         )
+import Foundation.Servant as Import
+import Import.Servant.NoFoundation as Import
diff --git a/src/Import/Servant/NoFoundation.hs b/src/Import/Servant/NoFoundation.hs
new file mode 100644
index 000000000..99842c491
--- /dev/null
+++ b/src/Import/Servant/NoFoundation.hs
@@ -0,0 +1,24 @@
+module Import.Servant.NoFoundation
+  ( module Import
+  ) where
+
+import Import.NoFoundation as Import hiding
+  ( Context
+  , Authorized, Unauthorized
+  , ServerError
+  , Header
+  , Strict
+  , Headers
+  , addHeader
+  )
+
+import Servant.API as Import
+import Servant.Server as Import
+import Servant.Docs as Import
+  ( ToCapture(..), DocCapture(..)
+  , ToSample(..), noSamples, singleSample, samples
+  , ToParam(..), DocQueryParam(..), ParamKind
+  )
+import Data.Swagger as Import
+  ( ToSchema(..)
+  )
diff --git a/src/Jose/Jwk/Instances.hs b/src/Jose/Jwk/Instances.hs
new file mode 100644
index 000000000..b5a314656
--- /dev/null
+++ b/src/Jose/Jwk/Instances.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Jose.Jwk.Instances
+  (
+  ) where
+
+import Model.Types.TH.JSON
+
+import Jose.Jwk
+
+
+derivePersistFieldJSON ''JwkSet
diff --git a/src/Jose/Jwt/Instances.hs b/src/Jose/Jwt/Instances.hs
index 0c0c093ef..ee86892a8 100644
--- a/src/Jose/Jwt/Instances.hs
+++ b/src/Jose/Jwt/Instances.hs
@@ -5,6 +5,7 @@ module Jose.Jwt.Instances
   ) where
 
 import ClassyPrelude.Yesod
+import Model.Types.TH.PathPiece
 
 import Jose.Jwt
 
@@ -20,6 +21,8 @@ instance PathPiece Jwt where
 
 instance Hashable Jwt
 
+derivePersistFieldPathPiece ''Jwt
+
 
 deriving instance Generic JwtError
 deriving instance Typeable JwtError
diff --git a/src/Model/Tokens/Bearer.hs b/src/Model/Tokens/Bearer.hs
index c1c4578fb..775d60166 100644
--- a/src/Model/Tokens/Bearer.hs
+++ b/src/Model/Tokens/Bearer.hs
@@ -10,6 +10,7 @@ module Model.Tokens.Bearer
 
 import ClassyPrelude.Yesod
 import Yesod.Core.Instances ()
+import Yesod.Servant (MonadSite(..))
   
 import Model
 import Model.Tokens.Lens
@@ -99,17 +100,16 @@ bearerRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route si
 bearerRestrict route (toJSON -> resVal) = over _bearerRestrictions $ HashMap.insert route resVal
 
 
-
-bearerToJSON :: forall m.
-               ( MonadHandler m
-               , HasCryptoUUID (AuthId (HandlerSite m)) m
-               , RenderRoute (HandlerSite m)
-               ) => BearerToken (HandlerSite m) -> m Value
+bearerToJSON :: forall site m.
+               ( MonadSite site m
+               , HasCryptoUUID (AuthId site) m
+               , RenderRoute site 
+               ) => BearerToken site -> m Value
 -- ^ Encode a `BearerToken` analogously to `toJSON`
 --
 -- Monadic context is needed because `AuthId`s are encrypted during encoding
 bearerToJSON BearerToken{..} = do
-  cID <- either (return . Left) (fmap Right . I.encrypt) bearerAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
+  cID <- either (return . Left) (fmap Right . I.encrypt) bearerAuthority :: m (Either Value (CryptoUUID (AuthId site)))
   let stdPayload = Jose.JwtClaims
         { jwtIss = Just $ toPathPiece bearerIssuedBy
         , jwtSub = Nothing
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 3797b0647..8f3a71ffd 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -15,3 +15,4 @@ import Model.Types.Misc as Types
 import Model.Types.School as Types
 import Model.Types.Allocation as Types
 import Model.Types.Languages as Types
+import Model.Types.Apis as Types
diff --git a/src/Model/Types/Apis.hs b/src/Model/Types/Apis.hs
new file mode 100644
index 000000000..a1fc65cc9
--- /dev/null
+++ b/src/Model/Types/Apis.hs
@@ -0,0 +1,24 @@
+module Model.Types.Apis
+  ( ExternalApiConfig(..)
+  , GradelistFormatIdent
+  ) where
+
+import Import.NoModel
+
+
+type GradelistFormatIdent = CI Text
+  
+data ExternalApiConfig
+  = EApiGradelistFormat
+    { eapiGradelistFormats :: NonNull (HashSet GradelistFormatIdent)
+    }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions
+  { tagSingleConstructors = True
+  , unwrapUnaryRecords = False
+  , sumEncoding = TaggedObject "type" "config"
+  , allNullaryToStringTag = False
+  , constructorTagModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 2
+  } ''ExternalApiConfig
+derivePersistFieldJSON ''ExternalApiConfig
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs
index 87add310a..568d0dd48 100644
--- a/src/Model/Types/Security.hs
+++ b/src/Model/Types/Security.hs
@@ -195,15 +195,18 @@ defaultAuthDNF = PredDNF $ Set.fromList
 
 data UserGroupName
   = UserGroupMetrics
+  | UserGroupExternalApis
   | UserGroupCustom { userGroupCustomName :: CI Text }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 instance PathPiece UserGroupName where
-  toPathPiece UserGroupMetrics = "metrics"
-  toPathPiece (UserGroupCustom t) = CI.original t
+  toPathPiece UserGroupMetrics      = "metrics"
+  toPathPiece UserGroupExternalApis = "external-apis"
+  toPathPiece (UserGroupCustom t)   = CI.original t
   fromPathPiece t = Just $ if
-    | "metrics" `ciEq` t -> UserGroupMetrics
-    | otherwise          -> UserGroupCustom $ CI.mk t
+    | "external-apis" `ciEq` t -> UserGroupExternalApis
+    | "metrics" `ciEq` t       -> UserGroupMetrics
+    | otherwise                -> UserGroupCustom $ CI.mk t
     where
       ciEq :: Text -> Text -> Bool
       ciEq = (==) `on` CI.mk
diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs
index 10ec7ceef..67af2f4b0 100644
--- a/src/Model/Types/Sheet.hs
+++ b/src/Model/Types/Sheet.hs
@@ -154,11 +154,8 @@ makeLenses_ ''SheetGroup
 
 data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
+  deriving anyclass (Universe, Finite, Hashable)
 derivePersistField "SheetFileType"
-
-instance Universe SheetFileType
-instance Finite SheetFileType
-
 finitePathPiece ''SheetFileType ["file", "hint", "solution", "marking"]
 
 sheetFile2markup :: SheetFileType -> Markup
diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs
index b8ace9549..3a2c4788d 100644
--- a/src/Model/Types/Submission.hs
+++ b/src/Model/Types/Submission.hs
@@ -33,9 +33,7 @@ import Data.Text.Metrics (damerauLevenshtein)
 
 data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
-
-instance Universe SubmissionFileType
-instance Finite SubmissionFileType
+  deriving anyclass (Universe, Finite, Hashable)
 
 nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1
 
diff --git a/src/ServantApi.hs b/src/ServantApi.hs
index b0761b9c3..e4a66c1bd 100644
--- a/src/ServantApi.hs
+++ b/src/ServantApi.hs
@@ -3,7 +3,6 @@ module ServantApi
   ) where
 
 import Import.Servant
-import Foundation.Routes.Definitions
 
 
 import ServantApi.ExternalApis as ServantApi
diff --git a/src/ServantApi/Definition.hs b/src/ServantApi/Definition.hs
deleted file mode 100644
index 4faa7a7be..000000000
--- a/src/ServantApi/Definition.hs
+++ /dev/null
@@ -1,189 +0,0 @@
-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
index f57dc85ff..6f9f07b8b 100644
--- a/src/ServantApi/ExternalApis.hs
+++ b/src/ServantApi/ExternalApis.hs
@@ -1,20 +1,15 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module ServantApi.ExternalApis
-  ( ExternalApis
-  , ServantApiExternalApis
-  , getServantApiExternalApis
+  ( module ServantApi.ExternalApis.Type
   ) where
 
 import Import.Servant
 
+import ServantApi.ExternalApis.Type
 
-type ExternalApis = EmptyAPI
-
-type ServantApiExternalApis = ServantApi ExternalApis
+import qualified Data.CaseInsensitive as CI
 
 
-getServantApiExternalApis :: UniWorX -> ServantApiExternalApis
-getServantApiExternalApis _ = ServantApi
-  { servantContext = \_ -> return EmptyContext
-  , servantHoist   = \_ _ -> id
-  , servantServer  = emptyServer
-  }
+instance ServantApiDispatchUniWorX ExternalApis where
+  servantServer' _ = return . ReplayedText . CI.original
diff --git a/src/ServantApi/ExternalApis/Type.hs b/src/ServantApi/ExternalApis/Type.hs
new file mode 100644
index 000000000..9995fb33d
--- /dev/null
+++ b/src/ServantApi/ExternalApis/Type.hs
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module ServantApi.ExternalApis.Type where
+
+import Import.Servant.NoFoundation
+
+
+type ExternalApis = "echo" :> Capture "citext" (CI Text) :> Get '[PlainText] ReplayedText
+
+type ServantApiExternalApis = ServantApi ExternalApis
+
+instance ToCapture (Capture "citext" (CI Text)) where
+  toCapture _ = DocCapture "citext" "a text to be replayed"
+
+
+newtype ReplayedText = ReplayedText Text
+  deriving newtype (MimeRender PlainText, MimeUnrender PlainText, ToSchema)
+
+instance ToSample ReplayedText where
+  toSamples _ = singleSample $ ReplayedText "Hello, World!"
diff --git a/src/Utils.hs b/src/Utils.hs
index f8879cf98..f04771074 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -61,6 +61,8 @@ import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
 import Text.Shakespeare.Text (st)
 
 import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Encode.Pretty as Aeson
+import qualified Data.Yaml as Yaml
 
 import Data.Universe
 
@@ -89,6 +91,9 @@ import Data.Constraint (Dict(..))
 import Control.Monad.Random.Class (MonadRandom)
 import qualified System.Random.Shuffle as Rand (shuffleM)
 
+import Data.Data (Data)
+import qualified Data.Text.Lazy.Builder as Builder
+
 {-# ANN module ("HLint: ignore Use asum" :: String) #-}
 
 
@@ -130,6 +135,35 @@ maybeAttribute _ _ Nothing  = []
 maybeAttribute a c (Just v) = [(a,c v)]
 
 
+newtype PrettyValue = PrettyValue { unPrettyValue :: Value }
+  deriving (Eq, Read, Show, Generic, Typeable, Data)
+  deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
+
+instance ToContent PrettyValue where
+  toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder
+instance ToTypedContent PrettyValue where
+  toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
+instance HasContentType PrettyValue where
+  getContentType _ = typeJson
+
+toPrettyJSON :: ToJSON a => a -> PrettyValue
+toPrettyJSON = PrettyValue . toJSON
+
+
+newtype YamlValue = YamlValue { unYamlValue :: Value }
+  deriving (Eq, Read, Show, Generic, Typeable, Data)
+  deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
+
+instance ToContent YamlValue where
+  toContent = toContent . Yaml.encode
+instance ToTypedContent YamlValue where
+  toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
+instance HasContentType YamlValue where
+  getContentType _ = "text/vnd.yaml"
+
+toYAML :: ToJSON a => a -> YamlValue
+toYAML = YamlValue . toJSON
+
 ---------------------
 -- Text and String --
 ---------------------
@@ -588,6 +622,9 @@ whenIsRight (Left  _) _ = return ()
 
 maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
 maybeExceptT err act = lift act >>= maybe (throwE err) return
+  
+maybeExceptT' :: Monad m => e -> Maybe b -> ExceptT e m b
+maybeExceptT' err = maybe (throwE err) return
 
 maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
 maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs
index e7853f525..5404e3c3c 100644
--- a/src/Utils/Tokens.hs
+++ b/src/Utils/Tokens.hs
@@ -14,7 +14,6 @@ import Model
 import Model.Tokens
 
 import Jose.Jwk (JwkSet(..))
-import Jose.Jwt (Jwt(..))
 import qualified Jose.Jwt as Jose
 
 import Data.Aeson.Types (Parser)
@@ -32,41 +31,42 @@ import CryptoID
 import Text.Blaze (Markup)
 
 
-bearerParseJSON' :: forall m.
-                  ( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
-                  , ParseRoute (HandlerSite m)
-                  , Hashable (Route (HandlerSite m))
-                  , MonadHandler m
+bearerParseJSON' :: forall site m.
+                  ( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
+                  , ParseRoute site 
+                  , Hashable (Route site)
+                  , MonadSite site m
                   , MonadCrypto m
                   , MonadCryptoKey m ~ CryptoIDKey
                   )
-               => m (Value -> Parser (BearerToken (HandlerSite m)))
+               => m (Value -> Parser (BearerToken site))
 -- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
 bearerParseJSON' = do
   cidKey <- cryptoIDKey return
   return $ flip runReaderT cidKey . bearerParseJSON
 
 
-bearerToken :: forall m.
-               ( MonadHandler m
-               , HasInstanceID (HandlerSite m) InstanceId
-               , HasClusterID (HandlerSite m) ClusterId
-               , HasAppSettings (HandlerSite m)
+bearerToken :: forall site m.
+               ( MonadSite site m
+               , MonadIO m
+               , HasInstanceID site InstanceId
+               , HasClusterID site ClusterId
+               , HasAppSettings site
                )
-            => Either Value (AuthId (HandlerSite m))
-            -> Maybe (HashSet (Route (HandlerSite m)))
+            => Either Value (AuthId site)
+            -> Maybe (HashSet (Route site))
             -> Maybe AuthDNF
             -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
             -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
-            -> m (BearerToken (HandlerSite m))
+            -> m (BearerToken site)
 -- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
 bearerToken bearerAuthority bearerRoutes bearerAddAuth mBearerExpiresAt bearerStartsAt = do
   bearerIdentifier <- liftIO getRandom
   bearerIssuedAt <- liftIO getCurrentTime
-  bearerIssuedBy <- getsYesod $ view instanceID
-  bearerIssuedFor <- getsYesod $ view clusterID
+  bearerIssuedBy <- getsSite $ view instanceID
+  bearerIssuedFor <- getsSite $ view clusterID
 
-  defaultExpiration <- getsYesod $ view _appBearerExpiration
+  defaultExpiration <- getsSite $ view _appBearerExpiration
   
   let bearerExpiresAt
         | Just t <- mBearerExpiresAt
@@ -80,19 +80,20 @@ bearerToken bearerAuthority bearerRoutes bearerAddAuth mBearerExpiresAt bearerSt
   return BearerToken{..}
 
 
-encodeBearer :: forall m.
-               ( MonadHandler m
-               , HasJSONWebKeySet (HandlerSite m) JwkSet
-               , HasAppSettings (HandlerSite m)
-               , HasCryptoUUID (AuthId (HandlerSite m)) m
-               , RenderRoute (HandlerSite m)
+encodeBearer :: forall site m.
+               ( MonadSite site m
+               , MonadIO m
+               , HasJSONWebKeySet site JwkSet
+               , HasAppSettings site
+               , HasCryptoUUID (AuthId site) m
+               , RenderRoute site
                )
-            => BearerToken (HandlerSite m) -> m Jwt
+            => BearerToken site -> m Jwt
 -- ^ Call `bearerToJSON` and encode the result as a `Jwt` according to `appJwtEncoding`
 encodeBearer token = do
   payload <- Jose.Claims . toStrict . JSON.encode <$> bearerToJSON token
-  JwkSet jwks <- getsYesod $ view jsonWebKeySet
-  jwtEncoding <- getsYesod $ view _appBearerEncoding
+  JwkSet jwks <- getsSite $ view jsonWebKeySet
+  jwtEncoding <- getsSite $ view _appBearerEncoding
   either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
 
 
@@ -105,21 +106,22 @@ data BearerTokenException
 
 instance Exception BearerTokenException
 
-decodeBearer :: forall m.
-               ( MonadHandler m
-               , HasJSONWebKeySet (HandlerSite m) JwkSet
-               , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
+decodeBearer :: forall site m.
+               ( MonadSite site m
+               , MonadIO m
+               , HasJSONWebKeySet site JwkSet
+               , HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
                , MonadCryptoKey m ~ CryptoIDKey
                , MonadCrypto m
-               , ParseRoute (HandlerSite m)
-               , Hashable (Route (HandlerSite m))
+               , ParseRoute site
+               , Hashable (Route site)
                )
-            => Jwt -> m (BearerToken (HandlerSite m))
+            => Jwt -> m (BearerToken site)
 -- ^ Decode a `Jwt` and call `bearerParseJSON`
 --
 -- Throws `bearerTokenException`s
 decodeBearer (Jwt bs) = do
-  JwkSet jwks <- getsYesod $ view jsonWebKeySet
+  JwkSet jwks <- getsSite $ view jsonWebKeySet
   content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
   content' <- case content of
     Jose.Unsecured _ -> throwM BearerTokenUnsecured
@@ -135,7 +137,7 @@ decodeBearer (Jwt bs) = do
   return bearer
 
 
-askBearer :: forall m. ( MonadHandler m )
+askBearer :: forall m. MonadHandler m
           => m (Maybe Jwt)
 -- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
 askBearer = runMaybeT $ asum
diff --git a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs
index 29c5e081b..22a90725f 100644
--- a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs
+++ b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs
@@ -18,8 +18,7 @@ import Model.Types.Common
 
 import Model.Tokens.Session
 
-import Jose.Jwk (JwkSet)
-import Jose.Jwt (Jwt(..), JwtEncoding(..))
+import Jose.Jwt (JwtEncoding(..))
 import qualified Jose.Jwt as Jose
 import qualified Jose.Jwk as Jose
 
diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs
index e145d6575..728612383 100644
--- a/src/Yesod/Core/Instances.hs
+++ b/src/Yesod/Core/Instances.hs
@@ -66,8 +66,6 @@ instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
   put = Binary.put . toPathPiece
   get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece
 
-instance RenderRoute site => Hashable (Route site) where
-  hashWithSalt s = hashWithSalt s . routeToPathPiece
 
 
 instance Monad FormResult where
diff --git a/src/Yesod/Servant.hs b/src/Yesod/Servant.hs
new file mode 100644
index 000000000..0e8ae5a74
--- /dev/null
+++ b/src/Yesod/Servant.hs
@@ -0,0 +1,475 @@
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Yesod.Servant
+  ( HasRoute(..)
+  , ServantApi(..), getServantApi
+  , ServantApiDispatch(..)
+  , servantApiLink
+  , ServantHandlerFor(..)
+  , MonadServantHandler(..), MonadHandler(..), MonadSite(..)
+  , 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 Utils hiding (HasRoute)
+import Model.Types.Security
+
+import Yesod.Core ( RenderRoute(..), ParseRoute(..)
+                  , YesodSubDispatch(..)
+                  , PathPiece(..)
+                  )
+import Yesod.Core.Types ( YesodRunnerEnv(..)
+                        , YesodSubRunnerEnv(..)
+                        )
+import qualified Yesod.Core as Yesod
+import qualified Yesod.Core.Types as Yesod
+
+import Servant.Links
+import Servant.API
+import Servant.Server hiding (route)
+
+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.Typeable (eqT, typeRep)
+
+import Network.URI
+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
+
+
+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 (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, Show v) => HasRoute (Capture' mods sym (v :: *) :> sub) where
+  parseServantRoute ((p : ps), qs)
+    | Right v <- traceShowId $ 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
+
+
+
+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
+
+  
+newtype ServantHandlerFor site a = ServantHandlerFor { unServantHandlerFor :: site -> Handler a }
+  deriving (Generic, Typeable)
+  deriving (Monad, Functor, Applicative, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadBase IO, MonadBaseControl IO, MonadError ServerError) via (ReaderT site Handler)
+
+class MonadIO m => MonadServantHandler site m 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
+
+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
+
+
+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
+    ]
diff --git a/src/Yesod/Servant/HttpApiDataInjective.hs b/src/Yesod/Servant/HttpApiDataInjective.hs
new file mode 100644
index 000000000..8294b9de4
--- /dev/null
+++ b/src/Yesod/Servant/HttpApiDataInjective.hs
@@ -0,0 +1,82 @@
+module Yesod.Servant.HttpApiDataInjective
+  ( ToHttpApiDataInjective(..)
+  ) where
+
+import ClassyPrelude hiding (Builder)
+import Web.HttpApiData
+import Network.HTTP.Types.URI (encodePathSegmentsRelative)
+
+import qualified Data.Text.Lazy as Lazy (Text)
+
+import Data.Binary.Builder (Builder)
+
+import Data.Void (Void)
+import Data.Int (Int8, Int16)
+import Data.Word (Word16)
+import Numeric.Natural (Natural)
+import Data.Fixed (HasResolution, Fixed)
+import Data.UUID (UUID)
+import Data.Time (ZonedTime, LocalTime, TimeOfDay, NominalDiffTime, DayOfWeek)
+import Data.CaseInsensitive (CI)
+import Data.CaseInsensitive.Instances ()
+import qualified Data.CaseInsensitive as CI
+import Data.Version (Version)
+import Data.Monoid (Any, All)
+
+
+class ToHttpApiData a => ToHttpApiDataInjective a where
+  toUrlPieceInjective :: a -> Text
+  toUrlPieceInjective = toUrlPiece
+
+  toEncodedUrlPieceInjective :: a -> Builder
+  toEncodedUrlPieceInjective = encodePathSegmentsRelative . pure . toUrlPiece
+
+  -- | Convert to HTTP header value.
+  toHeaderInjective :: a -> ByteString
+  toHeaderInjective = encodeUtf8 . toUrlPiece
+
+  -- | Convert to query param value.
+  toQueryParamInjective :: a -> Text
+  toQueryParamInjective = toQueryParam
+
+instance ToHttpApiDataInjective ()
+instance ToHttpApiDataInjective Bool
+instance ToHttpApiDataInjective Ordering
+instance ToHttpApiDataInjective Void
+instance ToHttpApiDataInjective Double
+instance ToHttpApiDataInjective Float
+instance ToHttpApiDataInjective Int
+instance ToHttpApiDataInjective Int8
+instance ToHttpApiDataInjective Int16
+instance ToHttpApiDataInjective Int32
+instance ToHttpApiDataInjective Int64
+instance ToHttpApiDataInjective Integer
+instance ToHttpApiDataInjective Natural
+instance ToHttpApiDataInjective Word
+instance ToHttpApiDataInjective Word8
+instance ToHttpApiDataInjective Word16
+instance ToHttpApiDataInjective Word32
+instance ToHttpApiDataInjective Word64
+instance HasResolution a => ToHttpApiDataInjective (Fixed a)
+instance ToHttpApiDataInjective Char
+instance ToHttpApiDataInjective Text
+instance ToHttpApiDataInjective Lazy.Text
+instance ToHttpApiDataInjective String
+instance ToHttpApiDataInjective str => ToHttpApiDataInjective (CI str) where
+  toUrlPieceInjective = toUrlPieceInjective . CI.foldedCase
+  toEncodedUrlPieceInjective = toEncodedUrlPieceInjective . CI.foldedCase
+  toHeaderInjective = toHeaderInjective . CI.foldedCase
+  toQueryParamInjective = toQueryParamInjective . CI.foldedCase
+instance ToHttpApiDataInjective Version
+instance ToHttpApiDataInjective All
+instance ToHttpApiDataInjective Any
+instance ToHttpApiDataInjective UTCTime
+instance ToHttpApiDataInjective ZonedTime
+instance ToHttpApiDataInjective LocalTime
+instance ToHttpApiDataInjective TimeOfDay
+instance ToHttpApiDataInjective NominalDiffTime
+instance ToHttpApiDataInjective Day
+instance ToHttpApiDataInjective DayOfWeek
+instance ToHttpApiDataInjective UUID
+instance ToHttpApiDataInjective a => ToHttpApiDataInjective (Maybe a)
+-- ^ Assumes @a@ never encodes to @"nothing"@
diff --git a/stack.yaml b/stack.yaml
index 07c492062..283d5ef92 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -102,5 +102,10 @@ extra-deps:
 
   - acid-state-0.16.0
 
+  - servant-0.17
+  - servant-server-0.17
+  - servant-client-0.17
+  - servant-swagger-1.1.8
+
 resolver: lts-15.0
 allow-newer: true
diff --git a/stack.yaml.lock b/stack.yaml.lock
index f8e0d7b61..f5b97ea23 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -274,6 +274,34 @@ packages:
       sha256: c6e4b7f00d2a500e6286beafe3a2da7ba898a9ea31f5744df57cdce8a8f5890f
   original:
     hackage: acid-state-0.16.0
+- completed:
+    hackage: servant-0.17@sha256:e78734cb6b75c5d1e52e8f5e16bc3f557154a580bbde4932a7e1a6a90da7eb04,5029
+    pantry-tree:
+      size: 2392
+      sha256: 36561a606c35393386aa48b7cc2407fa4013aba62a19d69f004ec9c2010209aa
+  original:
+    hackage: servant-0.17
+- completed:
+    hackage: servant-server-0.17@sha256:1a5adf564f0b703535eb733f249b282ef2ca7b587a303c357b549fb88e7a6dcd,5388
+    pantry-tree:
+      size: 2460
+      sha256: ea65ba54acb4362efedbfa7db616a51023579a6c83f18ab6d2ea6a84dea56021
+  original:
+    hackage: servant-server-0.17
+- completed:
+    hackage: servant-client-0.17@sha256:433be65dd541b9a387eaaced22715a028ea846d72d141419c40ddf6fd5e3409b,4573
+    pantry-tree:
+      size: 1299
+      sha256: 1f8f57c6ce96ed4f1316460aaab48f3765b2addbf1e2cd363c72bbc41fdcf907
+  original:
+    hackage: servant-client-0.17
+- completed:
+    hackage: servant-swagger-1.1.8@sha256:9b0282fce7e0895f7b6e47cfea461f59ba7a1cc98e20f5b4a66e7fa24897f361,4622
+    pantry-tree:
+      size: 1636
+      sha256: 2f1a79c09eb4fff96e6f948f15ed5d17d10eeb52de9299d57d853dbaebbda26e
+  original:
+    hackage: servant-swagger-1.1.8
 snapshots:
 - completed:
     size: 488576

From 4216785e90931ec54dc723166442a7acbe491851 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Mon, 6 Apr 2020 15:32:16 +0200
Subject: [PATCH 03/18] feat(external-apis): add ExternalApisList

---
 models/external-apis.model                   |   6 +
 package.yaml                                 |   4 +
 src/Control/Monad/Trans/Except/Instances.hs  |  19 ++++
 src/Data/CaseInsensitive/Instances.hs        |   3 +
 src/Data/CryptoID/Instances.hs               |  28 +++++
 src/Data/NonNull/Instances.hs                |   7 ++
 src/Data/Time/Calendar/Instances.hs          |   4 +
 src/Data/Time/Clock/Instances.hs             |  14 +++
 src/Data/Time/Clock/Instances/TH.hs          |  14 +++
 src/Database/Persist/Class/Instances.hs      |   5 +
 src/Foundation/Servant.hs                    |   7 +-
 src/Handler/Metrics.hs                       |   2 +-
 src/Handler/Swagger.hs                       |   2 +-
 src/Import/NoModel.hs                        |   8 ++
 src/Import/Servant/NoFoundation.hs           |  16 ++-
 src/Jose/Jwk/Instances.hs                    |  34 +++++-
 src/Model.hs                                 |   3 +
 src/Model/Types/Apis.hs                      |  30 +++--
 src/Model/Types/Security.hs                  |  10 ++
 src/Model/Types/TH/JSON.hs                   |  11 ++
 src/Servant/Client/Core/BaseUrl/Instances.hs |  49 ++++++++
 src/Servant/Server/Instances.hs              |  13 +++
 src/ServantApi/ExternalApis.hs               |  30 ++++-
 src/ServantApi/ExternalApis/Type.hs          | 113 +++++++++++++++++--
 src/Utils/Lens.hs                            |   2 +
 src/Yesod/Servant.hs                         |  25 ++++
 26 files changed, 431 insertions(+), 28 deletions(-)
 create mode 100644 models/external-apis.model
 create mode 100644 src/Control/Monad/Trans/Except/Instances.hs
 create mode 100644 src/Data/Time/Clock/Instances/TH.hs
 create mode 100644 src/Servant/Client/Core/BaseUrl/Instances.hs
 create mode 100644 src/Servant/Server/Instances.hs

diff --git a/models/external-apis.model b/models/external-apis.model
new file mode 100644
index 000000000..c19e50554
--- /dev/null
+++ b/models/external-apis.model
@@ -0,0 +1,6 @@
+ExternalApi
+  authority Jwt
+  keys JwkSet
+  baseUrl BaseUrl
+  config ExternalApiConfig
+  lastAlive UTCTime
\ No newline at end of file
diff --git a/package.yaml b/package.yaml
index dd3b531a1..88b2c5bb7 100644
--- a/package.yaml
+++ b/package.yaml
@@ -5,6 +5,7 @@ dependencies:
   - base
   - yesod
   - yesod-core
+  - yesod-persistent
   - yesod-auth
   - yesod-static
   - yesod-form
@@ -146,11 +147,14 @@ dependencies:
   - servant-server
   - servant-swagger
   - servant-docs
+  - servant-client
+  - servant-client-core
   - swagger2
   - haskell-src-meta
   - network-uri
   - insert-ordered-containers
   - vault
+  - tagged
 
 other-extensions:
   - GeneralizedNewtypeDeriving
diff --git a/src/Control/Monad/Trans/Except/Instances.hs b/src/Control/Monad/Trans/Except/Instances.hs
new file mode 100644
index 000000000..1bceee959
--- /dev/null
+++ b/src/Control/Monad/Trans/Except/Instances.hs
@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Control.Monad.Trans.Except.Instances
+  () where
+
+import ClassyPrelude
+
+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
+
+import Control.Arrow (left)
+
+
+newtype UnliftIOExceptTError e = UnliftIOExceptTError { getUnliftIOExceptTError :: e }
+  deriving (Read, Show, Generic, Typeable)
+  deriving newtype (Exception)
+  
+
+instance (Exception e, MonadUnliftIO m) => MonadUnliftIO (ExceptT e m) where
+  withRunInIO cont = ExceptT (withRunInIO $ \runInner -> fmap (left getUnliftIOExceptTError) . try $ cont (either (throwIO . UnliftIOExceptTError) return <=< runInner . runExceptT))
diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs
index 45e9652e8..dc8e615ed 100644
--- a/src/Data/CaseInsensitive/Instances.hs
+++ b/src/Data/CaseInsensitive/Instances.hs
@@ -110,3 +110,6 @@ instance (CI.FoldCase s, Csv.FromField s) => Csv.FromField (CI s) where
 
 instance Swagger.ToParamSchema s => Swagger.ToParamSchema (CI s) where
   toParamSchema _ = Swagger.toParamSchema (Proxy @s)
+
+instance Swagger.ToSchema s => Swagger.ToSchema (CI s) where
+  declareNamedSchema _ = Swagger.declareNamedSchema (Proxy @s)
diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs
index b48c0df70..6c42ae029 100644
--- a/src/Data/CryptoID/Instances.hs
+++ b/src/Data/CryptoID/Instances.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Data.CryptoID.Instances
@@ -5,6 +6,8 @@ module Data.CryptoID.Instances
   ) where
 
 import qualified Data.CryptoID as CID
+import qualified Data.CryptoID.Poly as CID
+import qualified Data.CryptoID.Class.ImplicitNamespace as I
 
 import Text.Blaze (ToMarkup(..))
 
@@ -18,6 +21,31 @@ import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..))
 
 import qualified Data.Csv as Csv
 
+import Data.Swagger (ToSchema)
+
+import Servant.Docs (ToSample(..))
+
+import Control.Monad.Catch.Pure
+
+import Data.Proxy
+import Data.Tagged
+
+import System.IO.Unsafe
+
+import Control.Lens ((??))
+
+
+deriving newtype instance ToSchema s => ToSchema (CID.CryptoID c s)
+
+sampleKey :: CID.CryptoIDKey
+sampleKey = unsafePerformIO CID.genKey
+{-# NOINLINE sampleKey #-}
+
+instance (ToSample p, ns ~ I.CryptoIDNamespace c p, CID.HasCryptoID ns c p (ReaderT CID.CryptoIDKey Catch)) => ToSample (Tagged p (CID.CryptoID ns c)) where
+  toSamples _ = mapMaybe (\(l, s) -> (l, ) <$> encrypt' s) $ toSamples (Proxy @p)
+    where
+      encrypt' :: p -> Maybe (Tagged p (CID.CryptoID ns c))
+      encrypt' p = either (const Nothing) (Just . Tagged) . runCatch . (runReaderT ?? sampleKey) $ I.encrypt p
 
 instance ToMarkup s => ToMarkup (CID.CryptoID c s) where
   toMarkup = toMarkup . CID.ciphertext
diff --git a/src/Data/NonNull/Instances.hs b/src/Data/NonNull/Instances.hs
index ad472219a..011b67358 100644
--- a/src/Data/NonNull/Instances.hs
+++ b/src/Data/NonNull/Instances.hs
@@ -13,6 +13,10 @@ import qualified Data.Binary as Binary
 
 import Control.Monad.Fail
 
+import Data.Swagger.Schema (ToSchema(..))
+
+import Data.Proxy
+  
 
 instance ToJSON a => ToJSON (NonNull a) where
   toJSON = toJSON . toNullable
@@ -20,6 +24,9 @@ instance ToJSON a => ToJSON (NonNull a) where
 instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where
   parseJSON = parseJSON >=> maybe (fail "Expected non-empty structure") return . fromNullable
 
+instance ToSchema a => ToSchema (NonNull a) where
+  declareNamedSchema _ = declareNamedSchema $ Proxy @a
+
 
 instance Hashable a => Hashable (NonNull a) where
   hashWithSalt s = hashWithSalt s . toNullable
diff --git a/src/Data/Time/Calendar/Instances.hs b/src/Data/Time/Calendar/Instances.hs
index 15c77e94b..782f8f2d4 100644
--- a/src/Data/Time/Calendar/Instances.hs
+++ b/src/Data/Time/Calendar/Instances.hs
@@ -11,8 +11,12 @@ import Data.Time.Calendar
 
 import Data.Universe
 
+import qualified Language.Haskell.TH.Syntax as TH
+
 
 deriving newtype instance Hashable Day
+deriving instance TH.Lift Day
+
 
 deriving instance Ord DayOfWeek
 instance Universe DayOfWeek where
diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs
index 2e410080e..ad3e2cbf3 100644
--- a/src/Data/Time/Clock/Instances.hs
+++ b/src/Data/Time/Clock/Instances.hs
@@ -10,6 +10,7 @@ import Database.Persist.Sql
 import Data.Proxy
 
 import Data.Time.Clock
+import Data.Time.Clock.Instances.TH ()
 import Data.Time.Calendar.Instances ()
 import Web.PathPieces
 
@@ -17,6 +18,11 @@ import qualified Data.Csv as Csv
 
 import Data.Time.Format.ISO8601
 
+import Servant.Docs (ToSample(..), samples)
+
+import qualified Language.Haskell.TH as TH
+import qualified Language.Haskell.TH.Syntax as TH
+
 
 instance Hashable DiffTime where
   hashWithSalt s = hashWithSalt s . toRational
@@ -41,3 +47,11 @@ instance Csv.ToField UTCTime where
 
 instance Csv.FromField UTCTime where
   parseField = iso8601ParseM <=< Csv.parseField
+
+
+instance ToSample UTCTime where
+  toSamples _ = samples $ do
+    diff <- [0,172801..]
+    sign <- [1, -1]
+    return $ (sign * diff) `addUTCTime` now
+    where now = $(TH.lift =<< TH.runIO getCurrentTime)
diff --git a/src/Data/Time/Clock/Instances/TH.hs b/src/Data/Time/Clock/Instances/TH.hs
new file mode 100644
index 000000000..17a9bc29c
--- /dev/null
+++ b/src/Data/Time/Clock/Instances/TH.hs
@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Time.Clock.Instances.TH
+  () where
+
+import ClassyPrelude
+
+import Data.Time.Calendar.Instances ()
+
+import qualified Language.Haskell.TH.Syntax as TH
+
+
+instance TH.Lift UTCTime where
+  lift UTCTime{..} = [e|UTCTime $(TH.lift utctDay) $ fromRational $(TH.lift $ toRational utctDayTime)|]
diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs
index 4a3a7208c..8704e5d5f 100644
--- a/src/Database/Persist/Class/Instances.hs
+++ b/src/Database/Persist/Class/Instances.hs
@@ -21,6 +21,8 @@ import Data.Aeson (ToJSONKey, FromJSONKey)
 
 import Control.Monad.Fail
 
+import Servant.Docs (ToSample(..), samples)
+
 
 instance PersistEntity record => Hashable (Key record) where
   hashWithSalt s = hashWithSalt s . toPersistValue
@@ -43,3 +45,6 @@ instance PersistEntity record => Eq (Unique record) where
 
 deriving newtype instance ToJSONKey (BackendKey SqlBackend)
 deriving newtype instance FromJSONKey (BackendKey SqlBackend)
+
+instance ToSample (BackendKey SqlBackend) where
+  toSamples _ = samples [0..]
diff --git a/src/Foundation/Servant.hs b/src/Foundation/Servant.hs
index 5f90c95a8..ad87b9034 100644
--- a/src/Foundation/Servant.hs
+++ b/src/Foundation/Servant.hs
@@ -3,7 +3,7 @@
 module Foundation.Servant
   ( ServantApiDispatchUniWorX(..)
   , UniWorXContext
-  , ServantHandler
+  , ServantHandler, ServantDB
   , BearerRestriction(..)
   ) where
 
@@ -73,6 +73,7 @@ instance ( HasServer sub context
 
 type UniWorXContext = UniWorX ': '[]
 type ServantHandler = ServantHandlerFor UniWorX
+type ServantDB      = ServantDBFor      UniWorX
 
 class (HasServer api UniWorXContext, Servant.HasRoute api) => ServantApiDispatchUniWorX api where
   servantServer' :: ServantApi api -> ServerT api ServantHandler
@@ -116,3 +117,7 @@ storeCurrentRoute = do
   $logDebugS "storeCurrentRoute" $ tshow cRoute
   
   return $ \app req -> app req{ vault = maybe id (Vault.insert waiRouteKey) cRoute $ vault req }
+
+
+instance ServantPersist UniWorX where
+  runDB = defaultRunDB _appDatabaseConf _appConnPool
diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs
index e49a57210..09a533306 100644
--- a/src/Handler/Metrics.hs
+++ b/src/Handler/Metrics.hs
@@ -2,7 +2,7 @@ module Handler.Metrics
   ( getMetricsR
   ) where
 
-import Import hiding (Info)
+import Import hiding (Info, samples, singleSample)
 
 import Prometheus
 import qualified Network.Wai.Middleware.Prometheus as Prometheus
diff --git a/src/Handler/Swagger.hs b/src/Handler/Swagger.hs
index 9e4c7fdd1..772696e65 100644
--- a/src/Handler/Swagger.hs
+++ b/src/Handler/Swagger.hs
@@ -2,7 +2,7 @@ module Handler.Swagger
   ( getSwaggerR, getSwaggerJsonR
   ) where
 
-import Import hiding (host, Response)
+import Import hiding (host, Response, Scheme(..))
 import ServantApi
 
 import Data.Swagger
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 189f19602..e2a97cdc1 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -33,7 +33,11 @@ import Yesod.Default.Config2  as Import
 import Yesod.Core.Types.Instances as Import
 import Yesod.Servant          as Import
   hiding ( MonadHandler(..), HasRoute(..)
+         , runDB, defaultRunDB
          )
+import Servant.Docs           as Import
+  ( ToSample(..), samples, noSamples, singleSample
+  )
 
 import Utils                  as Import
 import Utils.Frontend.I18n    as Import
@@ -158,6 +162,10 @@ import Data.Encoding.Instances as Import ()
 import Prometheus.Instances as Import ()
 import Yesod.Form.Fields.Instances as Import ()
 import Data.MonoTraversable.Instances as Import ()
+import Servant.Client.Core.BaseUrl.Instances as Import ()
+import Jose.Jwk.Instances as Import ()
+import Control.Monad.Trans.Except.Instances as Import ()
+import Servant.Server.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256)
 
diff --git a/src/Import/Servant/NoFoundation.hs b/src/Import/Servant/NoFoundation.hs
index 99842c491..c289f9e6c 100644
--- a/src/Import/Servant/NoFoundation.hs
+++ b/src/Import/Servant/NoFoundation.hs
@@ -10,15 +10,25 @@ import Import.NoFoundation as Import hiding
   , Strict
   , Headers
   , addHeader
+  , runDB, defaultRunDB
+  , MonadHandler(..), HasRoute(..), liftHandler
+  , encrypt, decrypt
   )
 
+import Yesod.Servant as Import
+
 import Servant.API as Import
 import Servant.Server as Import
 import Servant.Docs as Import
   ( ToCapture(..), DocCapture(..)
-  , ToSample(..), noSamples, singleSample, samples
   , ToParam(..), DocQueryParam(..), ParamKind
   )
-import Data.Swagger as Import
-  ( ToSchema(..)
+import Servant.Docs.Internal.Pretty as Import (PrettyJSON)
+import Data.Swagger as Import (SwaggerType(..), Referenced(..))
+import Data.Swagger.Schema as Import hiding (SchemaOptions(..))
+import Data.Swagger.Internal.Schema as Import (named)
+import Data.Swagger.Lens as Import hiding
+  ( host, port, get, delete, allOf
   )
+
+import Data.CryptoID.Class.ImplicitNamespace as Import (encrypt, decrypt)
diff --git a/src/Jose/Jwk/Instances.hs b/src/Jose/Jwk/Instances.hs
index b5a314656..45b0d435b 100644
--- a/src/Jose/Jwk/Instances.hs
+++ b/src/Jose/Jwk/Instances.hs
@@ -1,12 +1,42 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Jose.Jwk.Instances
-  (
-  ) where
+  () where
+
+import ClassyPrelude
 
 import Model.Types.TH.JSON
 
 import Jose.Jwk
+import Jose.Jwt
+
+import Data.Swagger.Schema (ToSchema(..))
+import Data.Swagger.Internal.Schema (named)
+
+import Servant.Docs (ToSample(..))
+
+import Crypto.Random
 
 
 derivePersistFieldJSON ''JwkSet
+
+instance ToSchema Jwk where
+  declareNamedSchema _ = pure $ named "Jwk" mempty
+
+instance ToSchema JwkSet
+
+
+sampleNotRandom :: MonadPseudoRandom ChaChaDRG a -> a
+sampleNotRandom = fst . withDRG (drgNewSeed $ seedFromInteger 0)
+
+instance ToSample JwkSet where
+  toSamples _ = [ ("Symmetric key", JwkSet [symmKey])
+                , ("Asymmetric keyset", JwkSet [rsaPub, rsaPriv])
+                , ("Symmetric & asymmetric keysets", JwkSet [symmKey, rsaPub, rsaPriv])
+                ]
+    where
+      symmKey = sampleNotRandom $
+        generateSymmetricKey 8 (KeyId "sample") Enc Nothing
+
+      (rsaPub, rsaPriv) = sampleNotRandom $
+        generateRsaKeyPair 128 (KeyId "sample RSA") Enc Nothing
diff --git a/src/Model.hs b/src/Model.hs
index d5a130d34..35f9e1525 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -39,6 +39,9 @@ deriving newtype instance FromJSONKey UserId
 deriving newtype instance ToJSONKey ExamOccurrenceId
 deriving newtype instance FromJSONKey ExamOccurrenceId
 
+deriving newtype instance ToSample UserId
+deriving newtype instance ToSample ExternalApiId
+
 -- ToMarkup and ToMessage instances for displaying selected database primary keys
 
 instance ToMarkup (Key School) where
diff --git a/src/Model/Types/Apis.hs b/src/Model/Types/Apis.hs
index a1fc65cc9..5867e9509 100644
--- a/src/Model/Types/Apis.hs
+++ b/src/Model/Types/Apis.hs
@@ -1,10 +1,18 @@
 module Model.Types.Apis
   ( ExternalApiConfig(..)
   , GradelistFormatIdent
+  , module Servant.Client.Core.BaseUrl
   ) where
 
 import Import.NoModel
 
+import Servant.Client.Core.BaseUrl (BaseUrl(..), Scheme(..))
+
+import Data.Aeson (genericToJSON, genericParseJSON)
+import Data.Swagger.Schema (ToSchema(..), fromAesonOptions, genericDeclareNamedSchema)
+
+import qualified Data.HashSet as HashSet
+
 
 type GradelistFormatIdent = CI Text
   
@@ -13,12 +21,18 @@ data ExternalApiConfig
     { eapiGradelistFormats :: NonNull (HashSet GradelistFormatIdent)
     }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
-deriveJSON defaultOptions
-  { tagSingleConstructors = True
-  , unwrapUnaryRecords = False
-  , sumEncoding = TaggedObject "type" "config"
-  , allNullaryToStringTag = False
-  , constructorTagModifier = camelToPathPiece' 2
-  , fieldLabelModifier = camelToPathPiece' 2
-  } ''ExternalApiConfig
+instance ToJSON ExternalApiConfig where
+  toJSON = genericToJSON externalApiConfigAesonOptions
+instance FromJSON ExternalApiConfig where
+  parseJSON = genericParseJSON externalApiConfigAesonOptions
+instance ToSchema ExternalApiConfig where
+  declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions externalApiConfigAesonOptions
+
 derivePersistFieldJSON ''ExternalApiConfig
+
+instance ToSample ExternalApiConfig where
+  toSamples _ = gradelistFormatters
+    where gradelistFormatters = samples
+            [ EApiGradelistFormat . impureNonNull $ HashSet.singleton "Format 1"
+            , EApiGradelistFormat . impureNonNull $ HashSet.fromList ["Format 1", "Format 2"]
+            ]
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs
index 568d0dd48..482cd42dd 100644
--- a/src/Model/Types/Security.hs
+++ b/src/Model/Types/Security.hs
@@ -41,6 +41,8 @@ import Data.NonNull.Instances ()
 import Model.Types.TH.PathPiece
 import Database.Persist.Sql
 
+import Servant.Docs (ToSample(..), samples)
+
 
 data AuthenticationMode = AuthLDAP
                         | AuthPWHash { authPWHash :: Text }
@@ -213,3 +215,11 @@ instance PathPiece UserGroupName where
 
 pathPieceJSON ''UserGroupName
 derivePersistFieldPathPiece' (sqlType (Proxy @(CI Text))) ''UserGroupName
+
+instance ToSample UserGroupName where
+  toSamples _ = builtins ++ samples custom
+    where builtins = ("Built in group", ) <$>
+            [ UserGroupMetrics
+            , UserGroupExternalApis
+            ]
+          custom = UserGroupCustom . CI.mk . ("Group " <>) . tshow <$> [1..]
diff --git a/src/Model/Types/TH/JSON.hs b/src/Model/Types/TH/JSON.hs
index 34a752350..c9896a260 100644
--- a/src/Model/Types/TH/JSON.hs
+++ b/src/Model/Types/TH/JSON.hs
@@ -1,6 +1,7 @@
 module Model.Types.TH.JSON
   ( derivePersistFieldJSON
   , predNFAesonOptions
+  , externalApiConfigAesonOptions
   ) where
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
@@ -65,3 +66,13 @@ predNFAesonOptions = defaultOptions
   , tagSingleConstructors = True
   }
   
+
+externalApiConfigAesonOptions :: Options
+externalApiConfigAesonOptions = defaultOptions
+  { tagSingleConstructors = True
+  , unwrapUnaryRecords = False
+  , sumEncoding = TaggedObject "type" "config"
+  , allNullaryToStringTag = False
+  , constructorTagModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 2
+  }
diff --git a/src/Servant/Client/Core/BaseUrl/Instances.hs b/src/Servant/Client/Core/BaseUrl/Instances.hs
new file mode 100644
index 000000000..5d180736f
--- /dev/null
+++ b/src/Servant/Client/Core/BaseUrl/Instances.hs
@@ -0,0 +1,49 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Servant.Client.Core.BaseUrl.Instances
+  () where
+
+import ClassyPrelude
+
+import Database.Persist
+import Database.Persist.Sql
+
+import Servant.Client.Core.BaseUrl
+
+import qualified Data.Text.Encoding as Text
+
+import Control.Arrow (left)
+
+import Data.Swagger hiding (Scheme(..))
+import Data.Swagger.Internal.Schema (named)
+
+import Control.Lens
+  
+import Servant.Docs (ToSample(..))
+
+
+parseBaseUrl' :: Text -> Either Text BaseUrl
+parseBaseUrl' = left tshow . parseBaseUrl . unpack
+  
+instance PersistField BaseUrl where
+  toPersistValue = PersistText . pack . showBaseUrl
+  fromPersistValue (PersistText t) = parseBaseUrl' t
+  fromPersistValue (PersistByteString bs) = parseBaseUrl' <=< left tshow $ Text.decodeUtf8' bs
+  fromPersistValue _ = Left "Unexpected type when converting to BaseUrl"
+
+instance PersistFieldSql BaseUrl where
+  sqlType _ = SqlString
+
+instance ToParamSchema BaseUrl where
+  toParamSchema _ = mempty
+    & type_ ?~ SwaggerString
+
+instance ToSchema BaseUrl where
+  declareNamedSchema = pure . named "BaseUrl" . paramSchemaToSchema
+    
+instance ToSample BaseUrl where
+  toSamples _
+    = [ ("Without path"    , BaseUrl Https "example.invalid" 443 "")
+      , ("With path"       , BaseUrl Https "example.invalid" 443 "/api")
+      , ("With custom port", BaseUrl Https "example.invalid" 8443 "")
+      ]
diff --git a/src/Servant/Server/Instances.hs b/src/Servant/Server/Instances.hs
new file mode 100644
index 000000000..f990bcf35
--- /dev/null
+++ b/src/Servant/Server/Instances.hs
@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Servant.Server.Instances
+  () where
+
+import ClassyPrelude hiding (Handler(..))
+import Servant.Server
+
+import Control.Monad.Trans.Except.Instances ()
+
+
+instance MonadUnliftIO Handler where
+  withRunInIO cont = Handler (withRunInIO $ \runInner -> cont (runInner . runHandler'))
diff --git a/src/ServantApi/ExternalApis.hs b/src/ServantApi/ExternalApis.hs
index 6f9f07b8b..19180952e 100644
--- a/src/ServantApi/ExternalApis.hs
+++ b/src/ServantApi/ExternalApis.hs
@@ -8,8 +8,32 @@ import Import.Servant
 
 import ServantApi.ExternalApis.Type
 
-import qualified Data.CaseInsensitive as CI
-
 
 instance ServantApiDispatchUniWorX ExternalApis where
-  servantServer' _ = return . ReplayedText . CI.original
+  servantServer' _ = externalApisList
+
+externalApisList :: ServantHandler ExternalApisList
+externalApisList = runDB $ fmap ExternalApisList . lift . toResponse =<< selectList [] [Desc ExternalApiLastAlive]
+  where
+    toResponse :: [Entity ExternalApi] -> ServantHandler (HashMap CryptoUUIDExternalApi ExternalApiInfo)
+    toResponse = foldMapM $ fmap (uncurry singletonMap) . toResponse'
+
+    toResponse' :: Entity ExternalApi -> ServantHandler (CryptoUUIDExternalApi, ExternalApiInfo)
+    toResponse' (Entity eApiId ExternalApi{..}) = (,) <$> encrypt eApiId <*> mkInfo
+      where
+        mkInfo = do
+          BearerToken{..} <- decodeBearer externalApiAuthority
+          eaiTokenAuthority <- either (return . Left) (fmap Right . encrypt) bearerAuthority
+          let eaiTokenIssued    = bearerIssuedAt
+              eaiTokenExpiresAt = bearerExpiresAt
+              eaiTokenStartsAt  = bearerStartsAt
+
+              eaiPublicKeys = externalApiKeys & _keys %~ filter isPublicJwk
+
+              eaiBaseUrl = externalApiBaseUrl
+
+              eaiLastAlive = externalApiLastAlive
+
+              eaiConfig = externalApiConfig
+
+          return ExternalApiInfo{..}
diff --git a/src/ServantApi/ExternalApis/Type.hs b/src/ServantApi/ExternalApis/Type.hs
index 9995fb33d..07cea95ed 100644
--- a/src/ServantApi/ExternalApis/Type.hs
+++ b/src/ServantApi/ExternalApis/Type.hs
@@ -2,19 +2,114 @@
 
 module ServantApi.ExternalApis.Type where
 
-import Import.Servant.NoFoundation
+import Import.Servant.NoFoundation hiding ((.=), keys)
+
+import Data.Aeson
+  
+import qualified Data.HashMap.Strict.InsOrd as HashMap.InsOrd
+
+import Jose.Jwk (JwkSet(..))
 
 
-type ExternalApis = "echo" :> Capture "citext" (CI Text) :> Get '[PlainText] ReplayedText
+type ExternalApis = Get '[PrettyJSON] ExternalApisList
 
 type ServantApiExternalApis = ServantApi ExternalApis
 
-instance ToCapture (Capture "citext" (CI Text)) where
-  toCapture _ = DocCapture "citext" "a text to be replayed"
+
+newtype ExternalApisList = ExternalApisList (HashMap CryptoUUIDExternalApi ExternalApiInfo)
+  deriving (Eq, Show, Generic, Typeable)
+  deriving newtype (ToJSON, FromJSON, ToSchema)
+
+instance ToSample ExternalApisList where
+  toSamples _ = samples $ map (\n -> ExternalApisList . fold $ take n singletons) [0,1,5]
+    where
+      singletons = zipWith (\(_, Tagged s) (_, s') -> singletonMap s s') (toSamples $ Proxy @(Tagged ExternalApiId CryptoUUIDExternalApi)) (toSamples $ Proxy @ExternalApiInfo)
+
+data ExternalApiInfo = ExternalApiInfo
+  { eaiTokenAuthority :: Either Value CryptoUUIDUser
+  , eaiTokenIssued :: UTCTime
+  , eaiTokenExpiresAt, eaiTokenStartsAt :: Maybe UTCTime
+  , eaiPublicKeys :: JwkSet
+  , eaiBaseUrl :: BaseUrl
+  , eaiLastAlive :: UTCTime
+  , eaiConfig :: ExternalApiConfig
+  } deriving (Eq, Show, Generic, Typeable)
+
+instance ToJSON ExternalApiInfo where
+  toJSON ExternalApiInfo{..} = object
+    [ "token_authority" .= either id toJSON eaiTokenAuthority
+    , "token_issued" .= eaiTokenIssued
+    , "token_expires_at" .= eaiTokenExpiresAt
+    , "token_starts_at" .= eaiTokenStartsAt
+    , "public_keys" .= keys eaiPublicKeys
+    , "base_url" .= eaiBaseUrl
+    , "last_alive" .= eaiLastAlive
+    , "config" .= eaiConfig
+    ]
+
+instance FromJSON ExternalApiInfo where
+  parseJSON = withObject "ExternalApiInfo" $ \o -> do
+    eaiTokenAuthority <- (Right <$> o .: "token_authority") <|> (Left <$> o .: "token_authority")
+    eaiTokenIssued <- o .: "token_issued"
+    eaiTokenExpiresAt <- o .: "token_expires_at"
+    eaiTokenStartsAt <- o .: "token_starts_at"
+    eaiPublicKeys <- JwkSet <$> o .: "public_keys"
+    eaiBaseUrl <- o .: "base_url"
+    eaiLastAlive <- o .: "last_alive"
+    eaiConfig <- o .: "config"
+    return ExternalApiInfo{..}
+
+instance ToSchema ExternalApiInfo where
+  declareNamedSchema _ = do
+    utcTimeSchema <- declareSchemaRef $ Proxy @UTCTime
+    jwkSetSchema <- declareSchemaRef $ Proxy @[Jwk]
+    baseUrlSchema <- declareSchemaRef $ Proxy @BaseUrl
+    externalApiConfigSchema <- declareSchemaRef $ Proxy @ExternalApiConfig
+    
+    pure . named "ExternalApiInfo" $ mempty
+      & type_ ?~ SwaggerObject
+      & properties .~ mconcat
+          [ HashMap.InsOrd.singleton "token_authority" $ Inline mempty
+          , HashMap.InsOrd.singleton "token_issued" utcTimeSchema
+          , HashMap.InsOrd.singleton "token_expires_at" utcTimeSchema
+          , HashMap.InsOrd.singleton "token_starts_at" utcTimeSchema
+          , HashMap.InsOrd.singleton "public_keys" jwkSetSchema
+          , HashMap.InsOrd.singleton "base_url" baseUrlSchema
+          , HashMap.InsOrd.singleton "last_alive" utcTimeSchema
+          , HashMap.InsOrd.singleton "config" externalApiConfigSchema
+          ]
+      & required .~ ["token_authority", "token_issued", "token_expires_at", "token_starts_at", "public_keys", "base_url", "last_alive", "config"]
+
+instance ToSample ExternalApiInfo where
+  toSamples _ = samples $ do
+    eaiTokenAuthority <- do
+      specificUser <- [False, True]
+      case specificUser of
+        True  -> Right <$> map (unTagged . snd) (toSamples $ Proxy @(Tagged UserId CryptoUUIDUser))
+        False -> Left <$> map (toJSON . snd) (toSamples $ Proxy @UserGroupName)
+
+    (_, eaiTokenIssued) <- toSamples Proxy
+    (_, eaiTokenExpiresAt) <- toSamples Proxy
+    (_, eaiTokenStartsAt) <- toSamples Proxy
+    (_, eaiLastAlive) <- toSamples Proxy
+
+    -- If times didn't match up this instance could not have registered
+    guard $ NTop (Just eaiTokenIssued) <= NTop eaiTokenExpiresAt
+    guard $ NTop (Just <$> eaiTokenExpiresAt) >= NTop (Just eaiTokenStartsAt)
+    guard $ eaiLastAlive >= eaiTokenIssued
+         && Just eaiLastAlive >= eaiTokenStartsAt
+         && NTop (Just eaiLastAlive) <= NTop eaiTokenExpiresAt
+    
+    (_, eaiBaseUrl) <- toSamples Proxy
+    (_, eaiConfig) <- toSamples Proxy
+
+    (_, eaiPublicKeys) <- toSamples Proxy
+      & traverse . _2 . _keys %~ filter isPublicJwk
+
+    return ExternalApiInfo{..}
 
 
-newtype ReplayedText = ReplayedText Text
-  deriving newtype (MimeRender PlainText, MimeUnrender PlainText, ToSchema)
-
-instance ToSample ReplayedText where
-  toSamples _ = singleSample $ ReplayedText "Hello, World!"
+isPublicJwk :: Jwk -> Bool
+isPublicJwk RsaPublicJwk{} = True
+isPublicJwk EcPublicJwk{}  = True
+isPublicJwk _              = False
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 8f02a65fb..df6313b67 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -229,6 +229,8 @@ makeLenses_ ''ExternalExam
 makeLenses_ ''ExternalExamOfficeSchool
 makeLenses_ ''ExternalExamStaff
 makeLenses_ ''ExternalExamResult
+
+makeLenses_ ''JwkSet
   
 
 -- makeClassy_ ''Load
diff --git a/src/Yesod/Servant.hs b/src/Yesod/Servant.hs
index 0e8ae5a74..3cccfdd79 100644
--- a/src/Yesod/Servant.hs
+++ b/src/Yesod/Servant.hs
@@ -8,6 +8,7 @@ module Yesod.Servant
   , servantApiLink
   , ServantHandlerFor(..)
   , MonadServantHandler(..), MonadHandler(..), MonadSite(..)
+  , ServantDBFor, ServantPersist(..), defaultRunDB
   , mkYesodApi
   , PathPieceHttpApiData(..)
   , BearerAuth, SessionAuth
@@ -31,10 +32,12 @@ import Yesod.Core.Types ( YesodRunnerEnv(..)
                         )
 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
 
@@ -84,6 +87,8 @@ import Yesod.Servant.HttpApiDataInjective
 import qualified Data.ByteString.Base64.URL as Base64 (encode)
 import qualified Data.Binary.Builder as Builder
 
+import Database.Persist
+
 
 renderServantRoute :: Link -> ([Text], [(Text, Text)])
 renderServantRoute link
@@ -333,6 +338,10 @@ newtype ServantHandlerFor site a = ServantHandlerFor { unServantHandlerFor :: si
   deriving (Generic, Typeable)
   deriving (Monad, Functor, Applicative, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadBase IO, MonadBaseControl IO, MonadError ServerError) via (ReaderT site Handler)
 
+instance MonadUnliftIO (ServantHandlerFor site) where
+  withRunInIO cont
+    = ServantHandlerFor $ \app -> withRunInIO $ \unliftHandler -> cont (unliftHandler . flip unServantHandlerFor app)
+
 class MonadIO m => MonadServantHandler site m where
   liftServantHandler :: forall a. ServantHandlerFor site a -> m a
 
@@ -372,6 +381,22 @@ instance {-# OVERLAPPING #-} (MonadTrans t, Monad (t (ServantHandlerFor site)))
   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)

From 559f9db7d58e26758209e61ef5ac8adc48b25221 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Tue, 7 Apr 2020 13:54:39 +0200
Subject: [PATCH 04/18] feat(external-apis): create new external api
 registrations

---
 src/Data/HashSet/Instances.hs       |  17 +++++
 src/Data/NonNull/Instances.hs       |   8 +++
 src/Foundation/Servant.hs           |  57 ++++++++++++----
 src/Foundation/Servant/Types.hs     |  43 ++++++++++++
 src/Import/NoModel.hs               |   2 +
 src/Import/Servant/NoFoundation.hs  |   6 ++
 src/Model/Types/Apis.hs             |  24 ++++++-
 src/Model/Types/TH/JSON.hs          |  17 +++++
 src/Network/URI/Instances.hs        |  37 ++++++++++
 src/ServantApi/ExternalApis.hs      |  45 +++++++++++++
 src/ServantApi/ExternalApis/Type.hs | 100 +++++++++++++++++++++-------
 src/Yesod/Core/Instances.hs         |   1 -
 src/Yesod/Servant.hs                |  50 ++++++++++++--
 13 files changed, 361 insertions(+), 46 deletions(-)
 create mode 100644 src/Data/HashSet/Instances.hs
 create mode 100644 src/Foundation/Servant/Types.hs
 create mode 100644 src/Network/URI/Instances.hs

diff --git a/src/Data/HashSet/Instances.hs b/src/Data/HashSet/Instances.hs
new file mode 100644
index 000000000..6c20a7af3
--- /dev/null
+++ b/src/Data/HashSet/Instances.hs
@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.HashSet.Instances
+  () where
+
+import ClassyPrelude
+
+import Servant.Docs
+
+import qualified Data.HashSet as HashSet
+
+import Control.Lens
+import Data.Proxy
+
+
+instance (ToSample a, Hashable a, Eq a) => ToSample (HashSet a) where
+  toSamples _ = over _2 HashSet.fromList <$> toSamples (Proxy @[a])
diff --git a/src/Data/NonNull/Instances.hs b/src/Data/NonNull/Instances.hs
index 011b67358..76618cc4f 100644
--- a/src/Data/NonNull/Instances.hs
+++ b/src/Data/NonNull/Instances.hs
@@ -16,6 +16,8 @@ import Control.Monad.Fail
 import Data.Swagger.Schema (ToSchema(..))
 
 import Data.Proxy
+
+import Servant.Docs
   
 
 instance ToJSON a => ToJSON (NonNull a) where
@@ -27,6 +29,12 @@ instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where
 instance ToSchema a => ToSchema (NonNull a) where
   declareNamedSchema _ = declareNamedSchema $ Proxy @a
 
+instance (ToSample a, MonoFoldable a) => ToSample (NonNull a) where
+  toSamples _ = do
+    (l, s) <- toSamples (Proxy @a)
+    s' <- maybe mzero pure $ fromNullable s
+    return (l, s')
+
 
 instance Hashable a => Hashable (NonNull a) where
   hashWithSalt s = hashWithSalt s . toNullable
diff --git a/src/Foundation/Servant.hs b/src/Foundation/Servant.hs
index ad87b9034..ae4666e04 100644
--- a/src/Foundation/Servant.hs
+++ b/src/Foundation/Servant.hs
@@ -1,14 +1,14 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Foundation.Servant
   ( ServantApiDispatchUniWorX(..)
   , UniWorXContext
   , ServantHandler, ServantDB
-  , BearerRestriction(..)
   ) where
 
 import Import.Servant.NoFoundation
-import Foundation
+-- import Foundation
 
 import Handler.Utils.Tokens
 
@@ -38,37 +38,68 @@ waiRouteKey = unsafePerformIO Vault.newKey
 {-# NOINLINE waiRouteKey #-}
 
 
-data BearerRestriction (restr :: *) = BearerRestriction
-
-
 instance ( HasServer sub context
          , ToJSON restr, FromJSON restr
+         , SBoolI (FoldRequired mods)
          )
-      => HasServer (BearerRestriction restr :> sub) context
+      => HasServer (CaptureBearerRestriction' mods restr :> sub) context
   where
-    type ServerT (BearerRestriction restr :> sub) m
-      = Maybe restr -> ServerT sub m
+    type ServerT (CaptureBearerRestriction' mods restr :> sub) m
+      = RequiredArgument mods restr -> ServerT sub m
 
     hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @sub) pc nt . s
 
     route _ context subserver
       = route (Proxy @sub) context (subserver `addAuthCheck` withRequest bearerCheck)
       where
-        bearerCheck :: W.Request -> DelayedIO (Maybe restr)
+        bearerCheck :: W.Request -> DelayedIO (RequiredArgument mods restr)
         bearerCheck req = do
           let bearer = Vault.lookup waiBearerKey $ vault req
               cRoute = Vault.lookup waiRouteKey  $ vault req
 
-              noRouteStored, noTokenStored, noTokenProvided :: ServerError
+              noRouteStored, noTokenStored, noTokenProvided, noRestrictionProvided :: ServerError
               noTokenStored = err500 { errBody = "servantYesodMiddleware did not store bearer token in WAI vault." }
               noTokenProvided = err400 { errBody = "The behaviour of this route depends on restrictions stored in the bearer token used for authorization. Therefor providing a bearer token is required." }
+              noRestrictionProvided = err400 { errBody = "The behaviour of this route depends on restrictions stored in the bearer token used for authorization. Therefor the provided bearer token must contain a restriction entry for this route." }
               noRouteStored = err500 { errBody = "servantYesodMiddleware did not store current route in WAI vault." }
 
           exceptT delayedFailFatal return $ do
-            bearer' <- maybeExceptT' noTokenProvided =<< maybeExceptT' noTokenStored bearer
+            bearer' <- maybeExceptT' noTokenStored bearer
             cRoute' <- maybeExceptT' noRouteStored cRoute
 
-            return $ bearer' ^? _bearerRestrictionIx cRoute'
+            let mbRet :: Maybe (Maybe restr)
+                mbRet = bearer' <&> preview (_bearerRestrictionIx cRoute')
+            case sbool @(FoldRequired mods) of
+              SFalse -> return $ join mbRet
+              STrue  -> maybe (throwE noTokenProvided) (maybe (throwE noRestrictionProvided) return) mbRet
+
+
+instance ( HasServer sub context
+         , SBoolI (FoldRequired mods)
+         )
+      => HasServer (CaptureBearerToken' mods :> sub) context
+  where
+    type ServerT (CaptureBearerToken' mods :> sub) m
+      = RequiredArgument mods (BearerToken UniWorX) -> ServerT sub m
+
+    hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @sub) pc nt . s
+
+    route _ context subserver
+      = route (Proxy @sub) context (subserver `addAuthCheck` withRequest bearerCheck)
+      where
+        bearerCheck :: W.Request -> DelayedIO (RequiredArgument mods (BearerToken UniWorX))
+        bearerCheck req = do
+          let bearer = Vault.lookup waiBearerKey $ vault req
+
+              noTokenStored, noTokenProvided :: ServerError
+              noTokenStored = err500 { errBody = "servantYesodMiddleware did not store bearer token in WAI vault." }
+              noTokenProvided = err400 { errBody = "The behaviour of this route depends on restrictions stored in the bearer token used for authorization. Therefor providing a bearer token is required." }
+
+          exceptT delayedFailFatal return $ do
+            bearer' <- maybeExceptT' noTokenStored bearer
+            case sbool @(FoldRequired mods) of
+              SFalse -> return bearer'
+              STrue  -> maybe (throwE noTokenProvided) return bearer'
 
 
 type UniWorXContext = UniWorX ': '[]
@@ -80,7 +111,7 @@ class (HasServer api UniWorXContext, Servant.HasRoute api) => ServantApiDispatch
 
 instance ServantApiDispatchUniWorX api => ServantApiDispatch UniWorXContext ServantHandler UniWorX api where
   servantContext _ app _ = return $ app :. EmptyContext
-  servantHoist _ app _ _ = ($ app) . unServantHandlerFor
+  servantHoist _ sctxSite sctxRequest _ = ($ ServantHandlerContextFor{..}) . unServantHandlerFor
   servantMiddleware _ _ _ = modifyResponse (mapResponseHeaders setDefaultHeaders) . fixTrailingSlash
   servantYesodMiddleware _ _ = fmap appEndo $ foldMapM (fmap Endo) [storeBearerToken, storeCurrentRoute]
   servantServer proxy _ = servantServer' proxy
diff --git a/src/Foundation/Servant/Types.hs b/src/Foundation/Servant/Types.hs
new file mode 100644
index 000000000..373b3ff6b
--- /dev/null
+++ b/src/Foundation/Servant/Types.hs
@@ -0,0 +1,43 @@
+module Foundation.Servant.Types
+  ( CaptureBearerRestriction, CaptureBearerRestriction'
+  , CaptureBearerToken, CaptureBearerToken'
+  ) where
+
+import ClassyPrelude
+import Data.Proxy
+
+import Servant.API
+import Servant.Swagger
+import Servant.Docs
+
+import Control.Lens
+
+
+type CaptureBearerRestriction = CaptureBearerRestriction' '[Required]
+data CaptureBearerRestriction' (mods :: [*]) (restr :: *)
+  
+type CaptureBearerToken = CaptureBearerToken' '[Required]
+data CaptureBearerToken' (mods :: [*])
+
+
+instance HasLink sub => HasLink (CaptureBearerRestriction' mods restr :> sub) where
+  type MkLink (CaptureBearerRestriction' mods restr :> sub) r = MkLink sub r
+  toLink toA _ = toLink toA $ Proxy @sub
+
+instance HasLink sub => HasLink (CaptureBearerToken' mods :> sub) where
+  type MkLink (CaptureBearerToken' mods :> sub) r = MkLink sub r
+  toLink toA _ = toLink toA $ Proxy @sub
+
+instance HasSwagger sub => HasSwagger (CaptureBearerRestriction' mods restr :> sub) where
+  toSwagger _ = toSwagger $ Proxy @sub
+
+instance HasSwagger sub => HasSwagger (CaptureBearerToken' mods :> sub) where
+  toSwagger _ = toSwagger $ Proxy @sub
+
+instance HasDocs sub => HasDocs (CaptureBearerRestriction' mods restr :> sub) where
+  docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action')
+    where action' = action & notes <>~ [DocNote "Bearer restrictions" ["The behaviour of this route dependes on the restrictions stored for it in the bearer token used for authorization"]]
+
+instance HasDocs sub => HasDocs (CaptureBearerToken' mods :> sub) where
+  docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action')
+    where action' = action & notes <>~ [DocNote "Bearer token" ["The behaviour of this route dependes on the exact bearer token used for authorization"]]
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index e2a97cdc1..2876eaf75 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -166,6 +166,8 @@ import Servant.Client.Core.BaseUrl.Instances as Import ()
 import Jose.Jwk.Instances as Import ()
 import Control.Monad.Trans.Except.Instances as Import ()
 import Servant.Server.Instances as Import ()
+import Network.URI.Instances as Import ()
+import Data.HashSet.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256)
 
diff --git a/src/Import/Servant/NoFoundation.hs b/src/Import/Servant/NoFoundation.hs
index c289f9e6c..4f88df9dd 100644
--- a/src/Import/Servant/NoFoundation.hs
+++ b/src/Import/Servant/NoFoundation.hs
@@ -16,8 +16,12 @@ import Import.NoFoundation as Import hiding
   )
 
 import Yesod.Servant as Import
+import Foundation.Servant.Types as Import
+
+import Foundation.Type as Import
 
 import Servant.API as Import
+import Servant.API.Modifiers as Import
 import Servant.Server as Import
 import Servant.Docs as Import
   ( ToCapture(..), DocCapture(..)
@@ -32,3 +36,5 @@ import Data.Swagger.Lens as Import hiding
   )
 
 import Data.CryptoID.Class.ImplicitNamespace as Import (encrypt, decrypt)
+
+import Control.Monad.Error.Class as Import (MonadError(..))
diff --git a/src/Model/Types/Apis.hs b/src/Model/Types/Apis.hs
index 5867e9509..f60fc7e9e 100644
--- a/src/Model/Types/Apis.hs
+++ b/src/Model/Types/Apis.hs
@@ -1,6 +1,8 @@
 module Model.Types.Apis
-  ( ExternalApiConfig(..)
+  ( ExternalApiKind(..)
+  , ExternalApiConfig(..)
   , GradelistFormatIdent
+  , classifyExternalApiConfig
   , module Servant.Client.Core.BaseUrl
   ) where
 
@@ -9,11 +11,26 @@ import Import.NoModel
 import Servant.Client.Core.BaseUrl (BaseUrl(..), Scheme(..))
 
 import Data.Aeson (genericToJSON, genericParseJSON)
-import Data.Swagger.Schema (ToSchema(..), fromAesonOptions, genericDeclareNamedSchema)
+import Data.Swagger (SwaggerType(..), ToParamSchema(..), enum_, type_, paramSchemaToSchema, ToSchema(..), fromAesonOptions, genericDeclareNamedSchema)
+import Data.Swagger.Internal.Schema (named)
 
 import qualified Data.HashSet as HashSet
 
 
+data ExternalApiKind = EApiKindGradelistFormat
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite, Hashable)
+nullaryPathPiece ''ExternalApiKind $ camelToPathPiece' 3
+pathPieceJSON ''ExternalApiKind
+instance ToParamSchema ExternalApiKind where
+  toParamSchema _ = mempty
+    & type_ ?~ SwaggerString
+    & enum_ ?~ map toJSON (universeF @ExternalApiKind)
+instance ToSchema ExternalApiKind where
+  declareNamedSchema = pure . named "ExternalApiKind" . paramSchemaToSchema
+instance ToSample ExternalApiKind where
+  toSamples _ = samples universeF
+
 type GradelistFormatIdent = CI Text
   
 data ExternalApiConfig
@@ -36,3 +53,6 @@ instance ToSample ExternalApiConfig where
             [ EApiGradelistFormat . impureNonNull $ HashSet.singleton "Format 1"
             , EApiGradelistFormat . impureNonNull $ HashSet.fromList ["Format 1", "Format 2"]
             ]
+
+classifyExternalApiConfig :: ExternalApiConfig -> ExternalApiKind
+classifyExternalApiConfig EApiGradelistFormat{} = EApiKindGradelistFormat
diff --git a/src/Model/Types/TH/JSON.hs b/src/Model/Types/TH/JSON.hs
index c9896a260..0ff6fb5a6 100644
--- a/src/Model/Types/TH/JSON.hs
+++ b/src/Model/Types/TH/JSON.hs
@@ -2,6 +2,7 @@ module Model.Types.TH.JSON
   ( derivePersistFieldJSON
   , predNFAesonOptions
   , externalApiConfigAesonOptions
+  , externalApiCreationRequestAesonOptions, externalApiCreationResponseAesonOptions, externalApiCreationRestrictionsAesonOptions 
   ) where
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
@@ -76,3 +77,19 @@ externalApiConfigAesonOptions = defaultOptions
   , constructorTagModifier = camelToPathPiece' 2
   , fieldLabelModifier = camelToPathPiece' 2
   }
+
+
+externalApiCreationRequestAesonOptions, externalApiCreationResponseAesonOptions, externalApiCreationRestrictionsAesonOptions :: Options
+externalApiCreationRequestAesonOptions = defaultOptions
+  { tagSingleConstructors = False
+  , fieldLabelModifier = camelToPathPiece' 1
+  }
+externalApiCreationResponseAesonOptions = defaultOptions
+  { tagSingleConstructors = False
+  , fieldLabelModifier = camelToPathPiece' 1
+  }
+externalApiCreationRestrictionsAesonOptions = defaultOptions
+  { tagSingleConstructors = False
+  , unwrapUnaryRecords = False
+  , fieldLabelModifier = camelToPathPiece' 1
+  }
diff --git a/src/Network/URI/Instances.hs b/src/Network/URI/Instances.hs
new file mode 100644
index 000000000..100047c1a
--- /dev/null
+++ b/src/Network/URI/Instances.hs
@@ -0,0 +1,37 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Network.URI.Instances
+  () where
+
+import ClassyPrelude
+
+import Network.URI
+import Network.URI.Static
+import Web.HttpApiData
+
+import Data.Swagger
+import Data.Swagger.Internal.Schema
+
+import Data.Proxy
+
+import Servant.Docs
+
+
+instance ToHttpApiData URI where
+  toQueryParam = pack . ($ mempty) . uriToString id
+
+instance FromHttpApiData URI where
+  parseQueryParam = maybe (Left "Could not parse URIReference") Right . parseURIReference . unpack
+
+instance ToParamSchema URI where
+  toParamSchema _ = toParamSchema $ Proxy @String
+
+instance ToSchema URI where
+  declareNamedSchema = pure . named "URI" . paramSchemaToSchema
+
+instance ToSample URI where
+  toSamples _ = samples
+    [ [uri|https://example.invalid/path/to/resource?key1=val1&key1=val2&key2=val3#fragment|]
+    , [relativeReference|unAnchored/path/to/resource|]
+    , [relativeReference|/anchored/path/to/resource|]
+    ]
diff --git a/src/ServantApi/ExternalApis.hs b/src/ServantApi/ExternalApis.hs
index 19180952e..19571fecb 100644
--- a/src/ServantApi/ExternalApis.hs
+++ b/src/ServantApi/ExternalApis.hs
@@ -11,6 +11,7 @@ import ServantApi.ExternalApis.Type
 
 instance ServantApiDispatchUniWorX ExternalApis where
   servantServer' _ = externalApisList
+                :<|> externalApiCreate
 
 externalApisList :: ServantHandler ExternalApisList
 externalApisList = runDB $ fmap ExternalApisList . lift . toResponse =<< selectList [] [Desc ExternalApiLastAlive]
@@ -37,3 +38,47 @@ externalApisList = runDB $ fmap ExternalApisList . lift . toResponse =<< selectL
               eaiConfig = externalApiConfig
 
           return ExternalApiInfo{..}
+
+externalApiCreate :: Maybe ExternalApiCreationRestrictions
+                  -> BearerToken UniWorX
+                  -> ExternalApiCreationRequest
+                  -> ServantHandler (Headers '[Header "Location" URI] ExternalApiCreationResponse)
+externalApiCreate mRestr bearer@BearerToken{..} ExternalApiCreationRequest{..} = do
+  now <- liftIO getCurrentTime
+  
+  unless (maybe True matchesRequest mRestr) $
+    throwError err403{ errBody = "Bearer restrictions do not permit request" }
+
+  externalApiAuthority <- encodeBearer bearer
+
+  apiId <- runDB $ insert ExternalApi
+    { externalApiAuthority
+    , externalApiKeys = eacrPublicKeys & _keys %~ filter (not . isPrivateJwk)
+    , externalApiBaseUrl = eacrBaseUrl
+    , externalApiConfig = eacrConfig
+    , externalApiLastAlive = now
+    }
+  eacrId <- encrypt apiId
+
+  location <- renderRouteAbsolute . ExternalApisR $ servantApiLink (Proxy @ExternalApis) (Proxy @ExternalApisListR) -- TODO
+
+  eaiTokenAuthority <- either (return . Left) (fmap Right . encrypt) bearerAuthority
+
+  return $ addHeader location ExternalApiCreationResponse
+    { eacrId
+    , eacrInfo = ExternalApiInfo
+      { eaiTokenAuthority
+      , eaiTokenIssued    = bearerIssuedAt
+      , eaiTokenExpiresAt = bearerExpiresAt
+      , eaiTokenStartsAt  = bearerStartsAt
+      , eaiPublicKeys     = eacrPublicKeys & _keys %~ filter (not . isPrivateJwk)
+      , eaiBaseUrl        = eacrBaseUrl
+      , eaiLastAlive      = now
+      , eaiConfig         = eacrConfig
+      }
+    }
+
+  where
+    matchesRequest ExternalApiCreationRestrictions{..} = and
+      [ classifyExternalApiConfig eacrConfig `elem` eacrApiKinds
+      ]
diff --git a/src/ServantApi/ExternalApis/Type.hs b/src/ServantApi/ExternalApis/Type.hs
index 07cea95ed..74c773c82 100644
--- a/src/ServantApi/ExternalApis/Type.hs
+++ b/src/ServantApi/ExternalApis/Type.hs
@@ -11,20 +11,67 @@ import qualified Data.HashMap.Strict.InsOrd as HashMap.InsOrd
 import Jose.Jwk (JwkSet(..))
 
 
-type ExternalApis = Get '[PrettyJSON] ExternalApisList
+type ExternalApisListR = Get '[PrettyJSON] ExternalApisList
+type ExternalApisCreateR = CaptureBearerRestriction' '[Optional] ExternalApiCreationRestrictions :> CaptureBearerToken :> ReqBody '[JSON] ExternalApiCreationRequest :> PostCreated '[PrettyJSON] (Headers '[Header "Location" URI] ExternalApiCreationResponse)
+
+type ExternalApis = ExternalApisListR
+               :<|> ExternalApisCreateR
 
 type ServantApiExternalApis = ServantApi ExternalApis
 
 
+data ExternalApiCreationRequest = ExternalApiCreationRequest
+  { eacrPublicKeys :: JwkSet
+  , eacrBaseUrl :: BaseUrl
+  , eacrConfig :: ExternalApiConfig
+  } deriving (Eq, Show, Generic, Typeable)
+
+instance ToJSON ExternalApiCreationRequest where
+  toJSON = genericToJSON externalApiCreationRequestAesonOptions
+instance FromJSON ExternalApiCreationRequest where
+  parseJSON = genericParseJSON externalApiCreationRequestAesonOptions
+instance ToSchema ExternalApiCreationRequest where
+  declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions externalApiCreationRequestAesonOptions
+instance ToSample ExternalApiCreationRequest
+
+data ExternalApiCreationResponse = ExternalApiCreationResponse
+  { eacrId :: CryptoUUIDExternalApi
+  , eacrInfo :: ExternalApiInfo
+  } deriving (Eq, Show, Generic, Typeable)
+
+instance ToJSON ExternalApiCreationResponse where
+  toJSON = genericToJSON externalApiCreationResponseAesonOptions
+instance FromJSON ExternalApiCreationResponse where
+  parseJSON = genericParseJSON externalApiCreationResponseAesonOptions
+instance ToSchema ExternalApiCreationResponse where
+  declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions externalApiCreationResponseAesonOptions
+instance ToSample ExternalApiCreationResponse where
+  toSamples _ = samples $ ExternalApiCreationResponse
+    <$> fmap (unTagged . snd) (toSamples $ Proxy @(Tagged ExternalApiId CryptoUUIDExternalApi))
+    <*> fmap snd (toSamples $ Proxy @ExternalApiInfo)
+
+data ExternalApiCreationRestrictions = ExternalApiCreationRestrictions
+  { eacrApiKinds :: NonNull (HashSet ExternalApiKind)
+  } deriving (Eq, Show, Generic, Typeable)
+instance ToJSON ExternalApiCreationRestrictions where
+  toJSON = genericToJSON externalApiCreationRestrictionsAesonOptions
+instance FromJSON ExternalApiCreationRestrictions where
+  parseJSON = genericParseJSON externalApiCreationRestrictionsAesonOptions
+instance ToSchema ExternalApiCreationRestrictions where
+  declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions externalApiCreationRestrictionsAesonOptions
+instance ToSample ExternalApiCreationRestrictions
+
+
 newtype ExternalApisList = ExternalApisList (HashMap CryptoUUIDExternalApi ExternalApiInfo)
   deriving (Eq, Show, Generic, Typeable)
   deriving newtype (ToJSON, FromJSON, ToSchema)
 
 instance ToSample ExternalApisList where
-  toSamples _ = samples $ map (\n -> ExternalApisList . fold $ take n singletons) [0,1,5]
+  toSamples _ = samples $ map (\n -> ExternalApisList . fold $ take n singletons) [0..]
     where
       singletons = zipWith (\(_, Tagged s) (_, s') -> singletonMap s s') (toSamples $ Proxy @(Tagged ExternalApiId CryptoUUIDExternalApi)) (toSamples $ Proxy @ExternalApiInfo)
 
+
 data ExternalApiInfo = ExternalApiInfo
   { eaiTokenAuthority :: Either Value CryptoUUIDUser
   , eaiTokenIssued :: UTCTime
@@ -37,25 +84,25 @@ data ExternalApiInfo = ExternalApiInfo
 
 instance ToJSON ExternalApiInfo where
   toJSON ExternalApiInfo{..} = object
-    [ "token_authority" .= either id toJSON eaiTokenAuthority
-    , "token_issued" .= eaiTokenIssued
-    , "token_expires_at" .= eaiTokenExpiresAt
-    , "token_starts_at" .= eaiTokenStartsAt
-    , "public_keys" .= keys eaiPublicKeys
-    , "base_url" .= eaiBaseUrl
-    , "last_alive" .= eaiLastAlive
+    [ "token-authority" .= either id toJSON eaiTokenAuthority
+    , "token-issued" .= eaiTokenIssued
+    , "token-expires-at" .= eaiTokenExpiresAt
+    , "token-starts-at" .= eaiTokenStartsAt
+    , "public-keys" .= keys eaiPublicKeys
+    , "base-url" .= eaiBaseUrl
+    , "last-alive" .= eaiLastAlive
     , "config" .= eaiConfig
     ]
 
 instance FromJSON ExternalApiInfo where
   parseJSON = withObject "ExternalApiInfo" $ \o -> do
-    eaiTokenAuthority <- (Right <$> o .: "token_authority") <|> (Left <$> o .: "token_authority")
-    eaiTokenIssued <- o .: "token_issued"
-    eaiTokenExpiresAt <- o .: "token_expires_at"
-    eaiTokenStartsAt <- o .: "token_starts_at"
-    eaiPublicKeys <- JwkSet <$> o .: "public_keys"
-    eaiBaseUrl <- o .: "base_url"
-    eaiLastAlive <- o .: "last_alive"
+    eaiTokenAuthority <- (Right <$> o .: "token-authority") <|> (Left <$> o .: "token-authority")
+    eaiTokenIssued <- o .: "token-issued"
+    eaiTokenExpiresAt <- o .: "token-expires-at"
+    eaiTokenStartsAt <- o .: "token-starts-at"
+    eaiPublicKeys <- JwkSet <$> o .: "public-keys"
+    eaiBaseUrl <- o .: "base-url"
+    eaiLastAlive <- o .: "last-alive"
     eaiConfig <- o .: "config"
     return ExternalApiInfo{..}
 
@@ -69,16 +116,16 @@ instance ToSchema ExternalApiInfo where
     pure . named "ExternalApiInfo" $ mempty
       & type_ ?~ SwaggerObject
       & properties .~ mconcat
-          [ HashMap.InsOrd.singleton "token_authority" $ Inline mempty
-          , HashMap.InsOrd.singleton "token_issued" utcTimeSchema
-          , HashMap.InsOrd.singleton "token_expires_at" utcTimeSchema
-          , HashMap.InsOrd.singleton "token_starts_at" utcTimeSchema
-          , HashMap.InsOrd.singleton "public_keys" jwkSetSchema
-          , HashMap.InsOrd.singleton "base_url" baseUrlSchema
-          , HashMap.InsOrd.singleton "last_alive" utcTimeSchema
+          [ HashMap.InsOrd.singleton "token-authority" $ Inline mempty
+          , HashMap.InsOrd.singleton "token-issued" utcTimeSchema
+          , HashMap.InsOrd.singleton "token-expires-at" utcTimeSchema
+          , HashMap.InsOrd.singleton "token-starts-at" utcTimeSchema
+          , HashMap.InsOrd.singleton "public-keys" jwkSetSchema
+          , HashMap.InsOrd.singleton "base-url" baseUrlSchema
+          , HashMap.InsOrd.singleton "last-alive" utcTimeSchema
           , HashMap.InsOrd.singleton "config" externalApiConfigSchema
           ]
-      & required .~ ["token_authority", "token_issued", "token_expires_at", "token_starts_at", "public_keys", "base_url", "last_alive", "config"]
+      & required .~ ["token-authority", "token-issued", "token-expires-at", "token-starts-at", "public-keys", "base-url", "last-alive", "config"]
 
 instance ToSample ExternalApiInfo where
   toSamples _ = samples $ do
@@ -109,7 +156,10 @@ instance ToSample ExternalApiInfo where
     return ExternalApiInfo{..}
 
 
-isPublicJwk :: Jwk -> Bool
+isPublicJwk, isPrivateJwk :: Jwk -> Bool
 isPublicJwk RsaPublicJwk{} = True
 isPublicJwk EcPublicJwk{}  = True
 isPublicJwk _              = False
+isPrivateJwk RsaPrivateJwk{} = True
+isPrivateJwk EcPrivateJwk{}  = True
+isPrivateJwk _               = False
diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs
index 728612383..9e6314126 100644
--- a/src/Yesod/Core/Instances.hs
+++ b/src/Yesod/Core/Instances.hs
@@ -67,7 +67,6 @@ instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
   get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece
 
 
-
 instance Monad FormResult where
   (FormSuccess a)    >>= f = f a
   FormMissing        >>= _ = FormMissing
diff --git a/src/Yesod/Servant.hs b/src/Yesod/Servant.hs
index 3cccfdd79..18fe08ec0 100644
--- a/src/Yesod/Servant.hs
+++ b/src/Yesod/Servant.hs
@@ -7,6 +7,7 @@ module Yesod.Servant
   , ServantApiDispatch(..)
   , servantApiLink
   , ServantHandlerFor(..)
+  , ServantHandlerContextFor(..), getServantContext, getsServantContext, getYesodApproot, renderRouteAbsolute
   , MonadServantHandler(..), MonadHandler(..), MonadSite(..)
   , ServantDBFor, ServantPersist(..), defaultRunDB
   , mkYesodApi
@@ -20,10 +21,13 @@ 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 ( RenderRoute(..), ParseRoute(..)
+import Yesod.Core ( Yesod
+                  , RenderRoute(..), ParseRoute(..)
                   , YesodSubDispatch(..)
                   , PathPiece(..)
                   )
@@ -71,10 +75,12 @@ 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)
@@ -153,6 +159,14 @@ 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)
@@ -334,15 +348,41 @@ servantApiLink _ _ = safeLink' (fromMaybe (error "Could not parse result of safe
     guardEndpoint _ = Nothing
 
   
-newtype ServantHandlerFor site a = ServantHandlerFor { unServantHandlerFor :: site -> Handler a }
+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 site Handler)
+  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)
 
-class MonadIO m => MonadServantHandler site m where
+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
@@ -367,7 +407,7 @@ class Monad m => MonadSite site m | m -> site where
   getsSite f = f <$> getSite
 
 instance MonadSite site (ServantHandlerFor site) where
-  getSite = liftServantHandler $ ServantHandlerFor return
+  getSite = liftServantHandler . ServantHandlerFor $ return . sctxSite
 
 instance MonadSite site (Reader site) where
   getSite = ask

From 5a964f347c9306989f753a69cd56a92404aed699 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Tue, 7 Apr 2020 15:39:35 +0200
Subject: [PATCH 05/18] feat(nix): add postman for api debugging

---
 shell.nix | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/shell.nix b/shell.nix
index b3d1273a7..574586dd9 100644
--- a/shell.nix
+++ b/shell.nix
@@ -19,7 +19,7 @@ let
   '';
 
   override = oldAttrs: {
-    nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-13_x postgresql openldap google-chrome exiftool ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder ]);
+    nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-13_x postgresql openldap google-chrome exiftool postman ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder ]);
     shellHook = ''
       export PROMPT_INFO="${oldAttrs.name}"
 

From 90679e00952ee4d6df584b52ceba99c0216e222e Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Wed, 8 Apr 2020 16:07:11 +0200
Subject: [PATCH 06/18] feat(external-apis): idents, info, pong, delete, and
 expiry

---
 config/settings.yml                       |  4 ++
 models/external-apis.model                |  4 +-
 src/Data/CryptoID/Instances.hs            |  3 +-
 src/Data/UUID/Instances.hs                | 10 +++
 src/Foundation/Routes.hs                  |  2 +-
 src/Foundation/Servant.hs                 | 34 ++++++++-
 src/Foundation/Servant/Types.hs           | 30 ++++++++
 src/Handler/ApiDocs.hs                    |  4 +-
 src/Import/Servant/NoFoundation.hs        |  3 +
 src/Jobs.hs                               |  1 +
 src/Jobs/Crontab.hs                       | 13 ++++
 src/Jobs/Handler/ExternalApis.hs          | 15 ++++
 src/Jobs/Types.hs                         |  2 +
 src/Model/Types/TH/JSON.hs                |  9 ++-
 src/ServantApi/ExternalApis.hs            | 87 ++++++++++++++---------
 src/ServantApi/ExternalApis/Type.hs       | 49 +++++++++++--
 src/Settings.hs                           |  8 +++
 src/Yesod/Servant.hs                      | 14 +++-
 src/Yesod/Servant/HttpApiDataInjective.hs |  8 ++-
 stack.yaml                                |  2 +-
 stack.yaml.lock                           |  7 ++
 21 files changed, 257 insertions(+), 52 deletions(-)
 create mode 100644 src/Jobs/Handler/ExternalApis.hs

diff --git a/config/settings.yml b/config/settings.yml
index 15bfd8526..a54d04dab 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -148,6 +148,10 @@ session-token-expiration: 28807
 session-token-encoding: HS256
 session-samesite: lax
 
+external-apis-ping-interval: 300
+external-apis-pong-timeout: 600
+external-apis-expiry: 1200
+
 user-defaults:
   max-favourites:      12
   max-favourite-terms: 2
diff --git a/models/external-apis.model b/models/external-apis.model
index c19e50554..dcb732e7e 100644
--- a/models/external-apis.model
+++ b/models/external-apis.model
@@ -1,6 +1,8 @@
 ExternalApi
+  ident UUID Maybe
   authority Jwt
   keys JwkSet
   baseUrl BaseUrl
   config ExternalApiConfig
-  lastAlive UTCTime
\ No newline at end of file
+  lastAlive UTCTime
+  UniqueExternalApiIdent ident !force
\ No newline at end of file
diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs
index 6c42ae029..56b4819bd 100644
--- a/src/Data/CryptoID/Instances.hs
+++ b/src/Data/CryptoID/Instances.hs
@@ -21,7 +21,7 @@ import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..))
 
 import qualified Data.Csv as Csv
 
-import Data.Swagger (ToSchema)
+import Data.Swagger (ToSchema, ToParamSchema)
 
 import Servant.Docs (ToSample(..))
 
@@ -35,6 +35,7 @@ import System.IO.Unsafe
 import Control.Lens ((??))
 
 
+deriving newtype instance ToParamSchema s => ToParamSchema (CID.CryptoID c s)
 deriving newtype instance ToSchema s => ToSchema (CID.CryptoID c s)
 
 sampleKey :: CID.CryptoIDKey
diff --git a/src/Data/UUID/Instances.hs b/src/Data/UUID/Instances.hs
index 38b20d104..b5e88c163 100644
--- a/src/Data/UUID/Instances.hs
+++ b/src/Data/UUID/Instances.hs
@@ -10,6 +10,9 @@ import qualified Data.UUID as UUID
 import Database.Persist.Sql
 
 import Text.Blaze (ToMarkup(..))
+
+import Servant.Docs (ToSample(..), samples)
+import Crypto.Random
   
 
 instance PathPiece UUID where
@@ -36,3 +39,10 @@ instance ToMarkup UUID where
 
 instance ToWidget site UUID where
   toWidget = toWidget . toMarkup
+
+sampleNotRandom :: MonadPseudoRandom ChaChaDRG a -> a
+sampleNotRandom = fst . withDRG (drgNewSeed $ seedFromInteger 0)
+
+instance ToSample UUID where
+  toSamples _ = samples $ sampleNotRandom getRandoms
+    where getRandoms = fmap (maybe id (:) . UUID.fromByteString . fromStrict) (getRandomBytes 16) <*> getRandoms
diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs
index e5c56ef44..dcefda76d 100644
--- a/src/Foundation/Routes.hs
+++ b/src/Foundation/Routes.hs
@@ -68,7 +68,7 @@ instance Hashable (Route Auth) where
 data RouteChildren
 type instance Children RouteChildren a = ChildrenRouteChildren a
 type family ChildrenRouteChildren a where
-  ChildrenRouteChildren (Route ServantApiExternalApis) = '[]
+  ChildrenRouteChildren (Route (ServantApi _)) = '[]
   ChildrenRouteChildren (Route EmbeddedStatic) = '[]
   ChildrenRouteChildren (Route Auth) = '[]
   ChildrenRouteChildren UUID = '[]
diff --git a/src/Foundation/Servant.hs b/src/Foundation/Servant.hs
index ae4666e04..add5cbbaf 100644
--- a/src/Foundation/Servant.hs
+++ b/src/Foundation/Servant.hs
@@ -8,7 +8,7 @@ module Foundation.Servant
   ) where
 
 import Import.Servant.NoFoundation
--- import Foundation
+import Foundation ()
 
 import Handler.Utils.Tokens
 
@@ -19,8 +19,7 @@ import qualified Network.Wai as W
 
 import qualified Data.Vault.Lazy as Vault
 
-import Servant.Server.Internal.DelayedIO (DelayedIO, delayedFailFatal, withRequest)
-import Servant.Server.Internal.Delayed (addAuthCheck)
+import Servant.Server.Internal.DelayedIO (DelayedIO, delayedFail, delayedFailFatal, withRequest)
 
 import System.IO.Unsafe (unsafePerformIO)
 
@@ -28,6 +27,11 @@ import qualified Yesod.Servant as Servant
 
 import qualified Data.Text as Text
 
+import Control.Monad.Catch.Pure
+
+import Servant.Server.Internal.Delayed
+import Servant.Server.Internal.Router
+
 
 waiBearerKey :: Vault.Key (Maybe (BearerToken UniWorX))
 waiBearerKey = unsafePerformIO Vault.newKey
@@ -102,6 +106,30 @@ instance ( HasServer sub context
               STrue  -> maybe (throwE noTokenProvided) return bearer'
 
 
+instance ( HasServer sub context
+         , HasCryptoID ciphertext plaintext (ReaderT CryptoIDKey Catch)
+         , SBoolI (FoldLenient mods)
+         , FromHttpApiData ciphertext
+         , HasContextEntry context UniWorX
+         ) => HasServer (CaptureCryptoID' mods ciphertext sym plaintext :> sub) context where
+  type ServerT (CaptureCryptoID' mods ciphertext sym plaintext :> sub) m
+    = If (FoldLenient mods) (Either String plaintext) plaintext -> ServerT sub m
+
+  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @sub) pc nt . s
+
+  route _ context subserver = CaptureRouter .
+    route (Proxy @sub) context . addCapture subserver $ \txt -> case ( sbool :: SBool (FoldLenient mods)
+                                                                     , decrypt' <$> parseUrlPiece txt
+                                                                     ) of
+      (SFalse, Left   e         ) -> delayedFail err400{ errBody = fromStrict $ encodeUtf8 e }
+      (SFalse, Right (Left  _  )) -> delayedFail err400{ errBody = "Could not decrypt CryptoID" }
+      (SFalse, Right (Right pID)) -> return pID
+      (STrue,  join -> piece)     -> return $ left unpack piece
+    where
+      decrypt' :: CryptoID ciphertext plaintext -> Either Text plaintext
+      decrypt' inp = left tshow . runCatch . runReaderT (decrypt inp) . appCryptoIDKey $ getContextEntry context
+
+
 type UniWorXContext = UniWorX ': '[]
 type ServantHandler = ServantHandlerFor UniWorX
 type ServantDB      = ServantDBFor      UniWorX
diff --git a/src/Foundation/Servant/Types.hs b/src/Foundation/Servant/Types.hs
index 373b3ff6b..d4d785c43 100644
--- a/src/Foundation/Servant/Types.hs
+++ b/src/Foundation/Servant/Types.hs
@@ -1,17 +1,30 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 module Foundation.Servant.Types
   ( CaptureBearerRestriction, CaptureBearerRestriction'
   , CaptureBearerToken, CaptureBearerToken'
+  , CaptureCryptoID', CaptureCryptoID, CaptureCryptoUUID, CaptureCryptoFileName
   ) where
 
 import ClassyPrelude
 import Data.Proxy
 
 import Servant.API
+import Servant.API.Description
 import Servant.Swagger
 import Servant.Docs
 
 import Control.Lens
 
+import Data.UUID (UUID)
+import Data.CaseInsensitive (CI)
+import Data.CryptoID.Class.ImplicitNamespace
+import Data.CryptoID.Instances ()
+
+import GHC.TypeLits (Symbol, KnownSymbol)
+
+import Data.Swagger (ToParamSchema)
+
 
 type CaptureBearerRestriction = CaptureBearerRestriction' '[Required]
 data CaptureBearerRestriction' (mods :: [*]) (restr :: *)
@@ -19,6 +32,11 @@ data CaptureBearerRestriction' (mods :: [*]) (restr :: *)
 type CaptureBearerToken = CaptureBearerToken' '[Required]
 data CaptureBearerToken' (mods :: [*])
 
+data CaptureCryptoID' (mods :: [*]) (ciphertext :: *) (sym :: Symbol) (plaintext :: *)
+type CaptureCryptoID = CaptureCryptoID' '[]
+type CaptureCryptoUUID = CaptureCryptoID UUID
+type CaptureCryptoFileName = CaptureCryptoID (CI FilePath)
+
 
 instance HasLink sub => HasLink (CaptureBearerRestriction' mods restr :> sub) where
   type MkLink (CaptureBearerRestriction' mods restr :> sub) r = MkLink sub r
@@ -28,12 +46,19 @@ instance HasLink sub => HasLink (CaptureBearerToken' mods :> sub) where
   type MkLink (CaptureBearerToken' mods :> sub) r = MkLink sub r
   toLink toA _ = toLink toA $ Proxy @sub
 
+instance (HasLink sub, ToHttpApiData ciphertext) => HasLink (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
+  type MkLink (CaptureCryptoID' mods ciphertext sym plaintext :> sub) r = MkLink (Capture' mods sym (CryptoID ciphertext plaintext) :> sub) r
+  toLink toA _ = toLink toA $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub)
+
 instance HasSwagger sub => HasSwagger (CaptureBearerRestriction' mods restr :> sub) where
   toSwagger _ = toSwagger $ Proxy @sub
 
 instance HasSwagger sub => HasSwagger (CaptureBearerToken' mods :> sub) where
   toSwagger _ = toSwagger $ Proxy @sub
 
+instance (HasSwagger sub, ToParamSchema ciphertext, KnownSymbol sym, KnownSymbol (FoldDescription mods)) => HasSwagger (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
+  toSwagger _ = toSwagger $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub)
+
 instance HasDocs sub => HasDocs (CaptureBearerRestriction' mods restr :> sub) where
   docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action')
     where action' = action & notes <>~ [DocNote "Bearer restrictions" ["The behaviour of this route dependes on the restrictions stored for it in the bearer token used for authorization"]]
@@ -41,3 +66,8 @@ instance HasDocs sub => HasDocs (CaptureBearerRestriction' mods restr :> sub) wh
 instance HasDocs sub => HasDocs (CaptureBearerToken' mods :> sub) where
   docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action')
     where action' = action & notes <>~ [DocNote "Bearer token" ["The behaviour of this route dependes on the exact bearer token used for authorization"]]
+
+instance (ToCapture (Capture sym ciphertext), KnownSymbol sym, HasDocs sub) => HasDocs (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
+  docsFor _ = docsFor $ Proxy @(Capture' mods sym ciphertext :> sub)
+
+type instance IsElem' (CaptureCryptoID' mods ciphertext sym plaintext :> sub) api = IsElem (Capture' mods sym (CryptoID ciphertext plaintext) :> sub) api
diff --git a/src/Handler/ApiDocs.hs b/src/Handler/ApiDocs.hs
index 5b982af15..51d9594a2 100644
--- a/src/Handler/ApiDocs.hs
+++ b/src/Handler/ApiDocs.hs
@@ -7,6 +7,8 @@ import ServantApi
 
 import qualified Servant.Docs as Servant
 
+import Servant.Docs.Internal.Pretty
+
 import Handler.Utils.Pandoc
 
 
@@ -20,7 +22,7 @@ getApiDocsR = selectRep $ do
     Left  _err -> return ()
   provideRepType "text/markdown" $ return mdDocs
   where
-    mdDocs = pack . Servant.markdown $ Servant.docsWith Servant.defaultDocOptions docIntros docExtra uniworxApi
+    mdDocs = pack . Servant.markdown $ Servant.docsWith Servant.defaultDocOptions docIntros docExtra (Proxy @(Pretty UniWorXApi))
     htmlDocs = parseMarkdownWith markdownReaderOptions htmlWriterOptions mdDocs
 
     docIntros = mempty
diff --git a/src/Import/Servant/NoFoundation.hs b/src/Import/Servant/NoFoundation.hs
index 4f88df9dd..3de40297d 100644
--- a/src/Import/Servant/NoFoundation.hs
+++ b/src/Import/Servant/NoFoundation.hs
@@ -35,6 +35,9 @@ import Data.Swagger.Lens as Import hiding
   ( host, port, get, delete, allOf
   )
 
+import Servant.API.Generic as Import
+import Servant.Server.Generic as Import
+
 import Data.CryptoID.Class.ImplicitNamespace as Import (encrypt, decrypt)
 
 import Control.Monad.Error.Class as Import (MonadError(..))
diff --git a/src/Jobs.hs b/src/Jobs.hs
index 0daaaadcb..a0d6f294f 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -60,6 +60,7 @@ import Jobs.Handler.SynchroniseLdap
 import Jobs.Handler.PruneInvitations
 import Jobs.Handler.ChangeUserDisplayEmail
 import Jobs.Handler.PruneFiles
+import Jobs.Handler.ExternalApis
 
 import Jobs.HealthReport
 
diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs
index c087a1b3a..799d3b299 100644
--- a/src/Jobs/Crontab.hs
+++ b/src/Jobs/Crontab.hs
@@ -393,3 +393,16 @@ determineCrontab = execWriterT $ do
             }
 
   runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ allocationJobs
+
+
+  let externalApiJobs (Entity jExternalApi ExternalApi{..}) =
+        tell $ HashMap.singleton
+          (JobCtlQueue JobExternalApiExpire{..})
+          Cron
+            { cronInitial   = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appExternalApisExpiry externalApiLastAlive
+            , cronRepeat    = CronRepeatOnChange
+            , cronRateLimit = appExternalApisExpiry
+            , cronNotAfter  = Right CronNotScheduled
+            }
+
+  runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ externalApiJobs
diff --git a/src/Jobs/Handler/ExternalApis.hs b/src/Jobs/Handler/ExternalApis.hs
new file mode 100644
index 000000000..98866b77e
--- /dev/null
+++ b/src/Jobs/Handler/ExternalApis.hs
@@ -0,0 +1,15 @@
+module Jobs.Handler.ExternalApis
+  ( dispatchJobExternalApiExpire
+  ) where
+
+import Import
+
+
+dispatchJobExternalApiExpire :: ExternalApiId -> Handler ()
+dispatchJobExternalApiExpire apiId = do
+  now <- liftIO getCurrentTime
+  expiry <- getsYesod $ view _appExternalApisExpiry
+  void . runDB . runMaybeT $ do
+    ExternalApi{..} <- MaybeT $ get apiId
+    guard $ externalApiLastAlive <= addUTCTime (- expiry) now
+    lift $ delete apiId
diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs
index 5d1eb8be5..2799c5628 100644
--- a/src/Jobs/Types.hs
+++ b/src/Jobs/Types.hs
@@ -77,6 +77,8 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
                                      }
          | JobPruneSessionFiles
          | JobPruneUnreferencedFiles
+         | JobExternalApiExpire { jExternalApi :: ExternalApiId
+                                }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetActive { nSheet :: SheetId }
diff --git a/src/Model/Types/TH/JSON.hs b/src/Model/Types/TH/JSON.hs
index 0ff6fb5a6..ab6e53ad0 100644
--- a/src/Model/Types/TH/JSON.hs
+++ b/src/Model/Types/TH/JSON.hs
@@ -2,7 +2,7 @@ module Model.Types.TH.JSON
   ( derivePersistFieldJSON
   , predNFAesonOptions
   , externalApiConfigAesonOptions
-  , externalApiCreationRequestAesonOptions, externalApiCreationResponseAesonOptions, externalApiCreationRestrictionsAesonOptions 
+  , externalApiCreationRequestAesonOptions, externalApiCreationResponseAesonOptions, externalApiCreationRestrictionsAesonOptions, externalApiPongResponseAesonOptions
   ) where
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
@@ -79,7 +79,7 @@ externalApiConfigAesonOptions = defaultOptions
   }
 
 
-externalApiCreationRequestAesonOptions, externalApiCreationResponseAesonOptions, externalApiCreationRestrictionsAesonOptions :: Options
+externalApiCreationRequestAesonOptions, externalApiCreationResponseAesonOptions, externalApiCreationRestrictionsAesonOptions, externalApiPongResponseAesonOptions :: Options
 externalApiCreationRequestAesonOptions = defaultOptions
   { tagSingleConstructors = False
   , fieldLabelModifier = camelToPathPiece' 1
@@ -93,3 +93,8 @@ externalApiCreationRestrictionsAesonOptions = defaultOptions
   , unwrapUnaryRecords = False
   , fieldLabelModifier = camelToPathPiece' 1
   }
+externalApiPongResponseAesonOptions = defaultOptions
+  { tagSingleConstructors = False
+  , unwrapUnaryRecords = False
+  , fieldLabelModifier = camelToPathPiece' 1
+  }
diff --git a/src/ServantApi/ExternalApis.hs b/src/ServantApi/ExternalApis.hs
index 19571fecb..5867ef535 100644
--- a/src/ServantApi/ExternalApis.hs
+++ b/src/ServantApi/ExternalApis.hs
@@ -12,6 +12,9 @@ import ServantApi.ExternalApis.Type
 instance ServantApiDispatchUniWorX ExternalApis where
   servantServer' _ = externalApisList
                 :<|> externalApiCreate
+                :<|> externalApiInfo
+                :<|> externalApiPong
+                :<|> externalApiDelete
 
 externalApisList :: ServantHandler ExternalApisList
 externalApisList = runDB $ fmap ExternalApisList . lift . toResponse =<< selectList [] [Desc ExternalApiLastAlive]
@@ -20,24 +23,7 @@ externalApisList = runDB $ fmap ExternalApisList . lift . toResponse =<< selectL
     toResponse = foldMapM $ fmap (uncurry singletonMap) . toResponse'
 
     toResponse' :: Entity ExternalApi -> ServantHandler (CryptoUUIDExternalApi, ExternalApiInfo)
-    toResponse' (Entity eApiId ExternalApi{..}) = (,) <$> encrypt eApiId <*> mkInfo
-      where
-        mkInfo = do
-          BearerToken{..} <- decodeBearer externalApiAuthority
-          eaiTokenAuthority <- either (return . Left) (fmap Right . encrypt) bearerAuthority
-          let eaiTokenIssued    = bearerIssuedAt
-              eaiTokenExpiresAt = bearerExpiresAt
-              eaiTokenStartsAt  = bearerStartsAt
-
-              eaiPublicKeys = externalApiKeys & _keys %~ filter isPublicJwk
-
-              eaiBaseUrl = externalApiBaseUrl
-
-              eaiLastAlive = externalApiLastAlive
-
-              eaiConfig = externalApiConfig
-
-          return ExternalApiInfo{..}
+    toResponse' (Entity eApiId eApi) = (,) <$> encrypt eApiId <*> dbToInfo eApi
 
 externalApiCreate :: Maybe ExternalApiCreationRestrictions
                   -> BearerToken UniWorX
@@ -49,36 +35,71 @@ externalApiCreate mRestr bearer@BearerToken{..} ExternalApiCreationRequest{..} =
   unless (maybe True matchesRequest mRestr) $
     throwError err403{ errBody = "Bearer restrictions do not permit request" }
 
-  externalApiAuthority <- encodeBearer bearer
+  jwt <- encodeBearer bearer
 
-  apiId <- runDB $ insert ExternalApi
-    { externalApiAuthority
+  Entity apiId api <- runDB $ upsert ExternalApi
+    { externalApiIdent = mRestr >>= eacrIdent
+    , externalApiAuthority = jwt
     , externalApiKeys = eacrPublicKeys & _keys %~ filter (not . isPrivateJwk)
     , externalApiBaseUrl = eacrBaseUrl
     , externalApiConfig = eacrConfig
     , externalApiLastAlive = now
     }
+    [ ExternalApiAuthority =. jwt
+    , ExternalApiKeys =. (eacrPublicKeys & _keys %~ filter (not . isPrivateJwk))
+    , ExternalApiBaseUrl =. eacrBaseUrl
+    , ExternalApiConfig =. eacrConfig
+    , ExternalApiLastAlive =. now
+    ]
   eacrId <- encrypt apiId
 
-  location <- renderRouteAbsolute . ExternalApisR $ servantApiLink (Proxy @ExternalApis) (Proxy @ExternalApisListR) -- TODO
+  location <- renderRouteAbsolute . ExternalApisR $ servantApiLink (Proxy @ExternalApis) (Proxy @ExternalApisInfoR) eacrId
 
-  eaiTokenAuthority <- either (return . Left) (fmap Right . encrypt) bearerAuthority
+  eacrInfo <- set _eaiPublicKeys (eacrPublicKeys & _keys %~ filter (not . isPrivateJwk)) <$> dbToInfo api
 
   return $ addHeader location ExternalApiCreationResponse
     { eacrId
-    , eacrInfo = ExternalApiInfo
-      { eaiTokenAuthority
-      , eaiTokenIssued    = bearerIssuedAt
-      , eaiTokenExpiresAt = bearerExpiresAt
-      , eaiTokenStartsAt  = bearerStartsAt
-      , eaiPublicKeys     = eacrPublicKeys & _keys %~ filter (not . isPrivateJwk)
-      , eaiBaseUrl        = eacrBaseUrl
-      , eaiLastAlive      = now
-      , eaiConfig         = eacrConfig
-      }
+    , eacrInfo
     }
 
   where
     matchesRequest ExternalApiCreationRestrictions{..} = and
       [ classifyExternalApiConfig eacrConfig `elem` eacrApiKinds
       ]
+
+externalApiInfo :: ExternalApiId -> ServantHandler ExternalApiInfo
+externalApiInfo apiId =
+  dbToInfo <=< runDB $ get apiId >>= maybe (throwError err404) return
+
+externalApiPong :: ExternalApiId -> ServantHandler ExternalApiPongResponse
+externalApiPong apiId = do
+  now <- liftIO getCurrentTime
+  ExternalApi{..} <- runDB $ do
+    unlessM (existsKey apiId) $ throwError err404
+    updateGet apiId [ ExternalApiLastAlive =. now ]
+
+  return $ ExternalApiPongResponse externalApiLastAlive
+
+externalApiDelete :: ExternalApiId -> ServantHandler NoContent
+externalApiDelete apiId = NoContent <$ runDB (delete apiId)
+
+
+dbToInfo :: ExternalApi -> ServantHandler ExternalApiInfo
+dbToInfo ExternalApi{..} = do
+  BearerToken{..} <- decodeBearer externalApiAuthority
+  eaiTokenAuthority <- either (return . Left) (fmap Right . encrypt) bearerAuthority
+  let eaiTokenIssued    = bearerIssuedAt
+      eaiTokenExpiresAt = bearerExpiresAt
+      eaiTokenStartsAt  = bearerStartsAt
+
+      eaiPublicKeys = externalApiKeys & _keys %~ filter isPublicJwk
+
+      eaiBaseUrl = externalApiBaseUrl
+
+      eaiLastAlive = externalApiLastAlive
+
+      eaiConfig = externalApiConfig
+
+      eaiIdent = externalApiIdent
+
+  return ExternalApiInfo{..}
diff --git a/src/ServantApi/ExternalApis/Type.hs b/src/ServantApi/ExternalApis/Type.hs
index 74c773c82..0d4599cbe 100644
--- a/src/ServantApi/ExternalApis/Type.hs
+++ b/src/ServantApi/ExternalApis/Type.hs
@@ -12,14 +12,31 @@ import Jose.Jwk (JwkSet(..))
 
 
 type ExternalApisListR = Get '[PrettyJSON] ExternalApisList
-type ExternalApisCreateR = CaptureBearerRestriction' '[Optional] ExternalApiCreationRestrictions :> CaptureBearerToken :> ReqBody '[JSON] ExternalApiCreationRequest :> PostCreated '[PrettyJSON] (Headers '[Header "Location" URI] ExternalApiCreationResponse)
+type ExternalApisCreateR = CaptureBearerRestriction' '[Optional] ExternalApiCreationRestrictions
+                        :> CaptureBearerToken
+                        :> ReqBody '[JSON] ExternalApiCreationRequest
+                        :> PostCreated '[PrettyJSON] (Headers '[Header "Location" URI] ExternalApiCreationResponse)
+type ExternalApisPongR = CaptureCryptoUUID "external-api" ExternalApiId
+                      :> "pong"
+                      :> Post '[PrettyJSON] ExternalApiPongResponse
+type ExternalApisInfoR = CaptureCryptoUUID "external-api" ExternalApiId
+                      :> Get '[PrettyJSON] ExternalApiInfo
+type ExternalApisDeleteR = CaptureCryptoUUID "external-api" ExternalApiId
+                        :> DeleteNoContent
 
 type ExternalApis = ExternalApisListR
                :<|> ExternalApisCreateR
+               :<|> ExternalApisInfoR
+               :<|> ExternalApisPongR
+               :<|> ExternalApisDeleteR
 
 type ServantApiExternalApis = ServantApi ExternalApis
 
 
+instance ToCapture (Capture "external-api" UUID) where
+  toCapture _ = DocCapture "external-api" "Internal id of the registered external api"
+
+
 data ExternalApiCreationRequest = ExternalApiCreationRequest
   { eacrPublicKeys :: JwkSet
   , eacrBaseUrl :: BaseUrl
@@ -51,7 +68,8 @@ instance ToSample ExternalApiCreationResponse where
     <*> fmap snd (toSamples $ Proxy @ExternalApiInfo)
 
 data ExternalApiCreationRestrictions = ExternalApiCreationRestrictions
-  { eacrApiKinds :: NonNull (HashSet ExternalApiKind)
+  { eacrIdent :: Maybe UUID
+  , eacrApiKinds :: NonNull (HashSet ExternalApiKind)
   } deriving (Eq, Show, Generic, Typeable)
 instance ToJSON ExternalApiCreationRestrictions where
   toJSON = genericToJSON externalApiCreationRestrictionsAesonOptions
@@ -62,6 +80,18 @@ instance ToSchema ExternalApiCreationRestrictions where
 instance ToSample ExternalApiCreationRestrictions
 
 
+data ExternalApiPongResponse = ExternalApiPongResponse
+  { eaprLastAlive :: UTCTime
+  } deriving (Eq, Show, Generic, Typeable)
+instance ToJSON ExternalApiPongResponse where
+  toJSON = genericToJSON externalApiPongResponseAesonOptions
+instance FromJSON ExternalApiPongResponse where
+  parseJSON = genericParseJSON externalApiPongResponseAesonOptions
+instance ToSchema ExternalApiPongResponse where
+  declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions externalApiPongResponseAesonOptions
+instance ToSample ExternalApiPongResponse
+
+
 newtype ExternalApisList = ExternalApisList (HashMap CryptoUUIDExternalApi ExternalApiInfo)
   deriving (Eq, Show, Generic, Typeable)
   deriving newtype (ToJSON, FromJSON, ToSchema)
@@ -73,7 +103,8 @@ instance ToSample ExternalApisList where
 
 
 data ExternalApiInfo = ExternalApiInfo
-  { eaiTokenAuthority :: Either Value CryptoUUIDUser
+  { eaiIdent :: Maybe UUID
+  , eaiTokenAuthority :: Either Value CryptoUUIDUser
   , eaiTokenIssued :: UTCTime
   , eaiTokenExpiresAt, eaiTokenStartsAt :: Maybe UTCTime
   , eaiPublicKeys :: JwkSet
@@ -83,7 +114,7 @@ data ExternalApiInfo = ExternalApiInfo
   } deriving (Eq, Show, Generic, Typeable)
 
 instance ToJSON ExternalApiInfo where
-  toJSON ExternalApiInfo{..} = object
+  toJSON ExternalApiInfo{..} = object $ maybe id ((:) . ("ident" .=)) eaiIdent
     [ "token-authority" .= either id toJSON eaiTokenAuthority
     , "token-issued" .= eaiTokenIssued
     , "token-expires-at" .= eaiTokenExpiresAt
@@ -96,6 +127,7 @@ instance ToJSON ExternalApiInfo where
 
 instance FromJSON ExternalApiInfo where
   parseJSON = withObject "ExternalApiInfo" $ \o -> do
+    eaiIdent <- o .:? "token-authority"
     eaiTokenAuthority <- (Right <$> o .: "token-authority") <|> (Left <$> o .: "token-authority")
     eaiTokenIssued <- o .: "token-issued"
     eaiTokenExpiresAt <- o .: "token-expires-at"
@@ -112,11 +144,13 @@ instance ToSchema ExternalApiInfo where
     jwkSetSchema <- declareSchemaRef $ Proxy @[Jwk]
     baseUrlSchema <- declareSchemaRef $ Proxy @BaseUrl
     externalApiConfigSchema <- declareSchemaRef $ Proxy @ExternalApiConfig
+    uuidSchema <- declareSchemaRef $ Proxy @UUID
     
     pure . named "ExternalApiInfo" $ mempty
       & type_ ?~ SwaggerObject
       & properties .~ mconcat
-          [ HashMap.InsOrd.singleton "token-authority" $ Inline mempty
+          [ HashMap.InsOrd.singleton "ident" uuidSchema
+          , HashMap.InsOrd.singleton "token-authority" $ Inline mempty
           , HashMap.InsOrd.singleton "token-issued" utcTimeSchema
           , HashMap.InsOrd.singleton "token-expires-at" utcTimeSchema
           , HashMap.InsOrd.singleton "token-starts-at" utcTimeSchema
@@ -129,6 +163,8 @@ instance ToSchema ExternalApiInfo where
 
 instance ToSample ExternalApiInfo where
   toSamples _ = samples $ do
+    (_, eaiIdent) <- toSamples Proxy
+    
     eaiTokenAuthority <- do
       specificUser <- [False, True]
       case specificUser of
@@ -163,3 +199,6 @@ isPublicJwk _              = False
 isPrivateJwk RsaPrivateJwk{} = True
 isPrivateJwk EcPrivateJwk{}  = True
 isPrivateJwk _               = False
+
+
+makeLenses_ ''ExternalApiInfo
diff --git a/src/Settings.hs b/src/Settings.hs
index 88c7c8e8d..86702fc39 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -155,6 +155,10 @@ data AppSettings = AppSettings
     , appUserDefaults           :: UserDefaultConf
     , appAuthPWHash             :: PWHashConf
 
+    , appExternalApisPingInterval
+    , appExternalApisPongTimeout
+    , appExternalApisExpiry :: NominalDiffTime
+
     , appInitialInstanceID      :: Maybe (Either FilePath UUID)
     , appRibbon                 :: Maybe Text
     } deriving Show
@@ -501,6 +505,10 @@ instance FromJSON AppSettings where
         appSessionTokenEncoding   <- o .: "session-token-encoding"
         appSessionSameSite        <- o .:? "session-samesite"
 
+        appExternalApisPingInterval <- o .: "external-apis-ping-interval"
+        appExternalApisPongTimeout <- o .: "external-apis-pong-timeout"
+        appExternalApisExpiry <- o .: "external-apis-expiry"
+
         return AppSettings{..}
 
 makeClassy_ ''AppSettings
diff --git a/src/Yesod/Servant.hs b/src/Yesod/Servant.hs
index 18fe08ec0..51de5fe35 100644
--- a/src/Yesod/Servant.hs
+++ b/src/Yesod/Servant.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-deprecations #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Yesod.Servant
@@ -95,6 +94,8 @@ import qualified Data.Binary.Builder as Builder
 
 import Database.Persist
 
+import Data.CryptoID.Class.ImplicitNamespace
+
 
 renderServantRoute :: Link -> ([Text], [(Text, Text)])
 renderServantRoute link
@@ -194,13 +195,20 @@ instance (HasRoute sub, KnownSymbol sym, Typeable mods, Typeable a) => HasRoute
   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, Show v) => HasRoute (Capture' mods sym (v :: *) :> sub) where
+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 <- traceShowId $ parseUrlPiece @v p
+    | 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
diff --git a/src/Yesod/Servant/HttpApiDataInjective.hs b/src/Yesod/Servant/HttpApiDataInjective.hs
index 8294b9de4..cfa9e3eaf 100644
--- a/src/Yesod/Servant/HttpApiDataInjective.hs
+++ b/src/Yesod/Servant/HttpApiDataInjective.hs
@@ -23,6 +23,8 @@ import qualified Data.CaseInsensitive as CI
 import Data.Version (Version)
 import Data.Monoid (Any, All)
 
+import Data.CryptoID (CryptoID(..))
+
 
 class ToHttpApiData a => ToHttpApiDataInjective a where
   toUrlPieceInjective :: a -> Text
@@ -79,4 +81,8 @@ instance ToHttpApiDataInjective Day
 instance ToHttpApiDataInjective DayOfWeek
 instance ToHttpApiDataInjective UUID
 instance ToHttpApiDataInjective a => ToHttpApiDataInjective (Maybe a)
--- ^ Assumes @a@ never encodes to @"nothing"@
+instance ToHttpApiDataInjective a => ToHttpApiDataInjective (CryptoID ns a) where
+  toUrlPieceInjective = toUrlPieceInjective . ciphertext
+  toEncodedUrlPieceInjective = toEncodedUrlPieceInjective . ciphertext
+  toHeaderInjective = toHeaderInjective . ciphertext
+  toQueryParamInjective = toQueryParamInjective . ciphertext
diff --git a/stack.yaml b/stack.yaml
index 283d5ef92..c7bf5ad32 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -29,7 +29,6 @@ extra-deps:
       - serversession
       - serversession-backend-acid-state
     
-
   - colonnade-1.2.0.2
   - hsass-0.8.0
   - hlibsass-0.1.8.1
@@ -106,6 +105,7 @@ extra-deps:
   - servant-server-0.17
   - servant-client-0.17
   - servant-swagger-1.1.8
+  - servant-docs-0.11.5
 
 resolver: lts-15.0
 allow-newer: true
diff --git a/stack.yaml.lock b/stack.yaml.lock
index f5b97ea23..fac28bd68 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -302,6 +302,13 @@ packages:
       sha256: 2f1a79c09eb4fff96e6f948f15ed5d17d10eeb52de9299d57d853dbaebbda26e
   original:
     hackage: servant-swagger-1.1.8
+- completed:
+    hackage: servant-docs-0.11.5@sha256:2c78eaa6f6bf7d2832de6fb4843ec526669e68c7d002c201353c08547ed781f0,3284
+    pantry-tree:
+      size: 702
+      sha256: 23ea4145b94acf5878744a4d9af40873c4753ca54811f90dc0eb5a1752759f7c
+  original:
+    hackage: servant-docs-0.11.5
 snapshots:
 - completed:
     size: 488576

From e8bbaa0463afb11998d1a21a9e4ff068ba2b7ea3 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Wed, 8 Apr 2020 17:04:57 +0200
Subject: [PATCH 07/18] feat(apis): support servant-generic

---
 src/Foundation/Servant.hs           |   6 +-
 src/ServantApi/ExternalApis.hs      |  12 +--
 src/ServantApi/ExternalApis/Type.hs |  14 ++--
 src/Yesod/Servant.hs                | 119 +++++++++++++++-------------
 4 files changed, 82 insertions(+), 69 deletions(-)

diff --git a/src/Foundation/Servant.hs b/src/Foundation/Servant.hs
index add5cbbaf..0540de681 100644
--- a/src/Foundation/Servant.hs
+++ b/src/Foundation/Servant.hs
@@ -134,10 +134,10 @@ type UniWorXContext = UniWorX ': '[]
 type ServantHandler = ServantHandlerFor UniWorX
 type ServantDB      = ServantDBFor      UniWorX
 
-class (HasServer api UniWorXContext, Servant.HasRoute api) => ServantApiDispatchUniWorX api where
-  servantServer' :: ServantApi api -> ServerT api ServantHandler
+class (HasServer (ServantApiUnproxy proxy) UniWorXContext, Servant.HasRoute (ServantApiUnproxy proxy)) => ServantApiDispatchUniWorX proxy where
+  servantServer' :: ServantApi proxy -> ServerT (ServantApiUnproxy proxy) ServantHandler
 
-instance ServantApiDispatchUniWorX api => ServantApiDispatch UniWorXContext ServantHandler UniWorX api where
+instance ServantApiDispatchUniWorX proxy => ServantApiDispatch UniWorXContext ServantHandler UniWorX proxy where
   servantContext _ app _ = return $ app :. EmptyContext
   servantHoist _ sctxSite sctxRequest _ = ($ ServantHandlerContextFor{..}) . unServantHandlerFor
   servantMiddleware _ _ _ = modifyResponse (mapResponseHeaders setDefaultHeaders) . fixTrailingSlash
diff --git a/src/ServantApi/ExternalApis.hs b/src/ServantApi/ExternalApis.hs
index 5867ef535..e3370d28f 100644
--- a/src/ServantApi/ExternalApis.hs
+++ b/src/ServantApi/ExternalApis.hs
@@ -10,11 +10,13 @@ import ServantApi.ExternalApis.Type
 
 
 instance ServantApiDispatchUniWorX ExternalApis where
-  servantServer' _ = externalApisList
-                :<|> externalApiCreate
-                :<|> externalApiInfo
-                :<|> externalApiPong
-                :<|> externalApiDelete
+  servantServer' _ = genericServerT ExternalApis
+    { externalApisListR   = externalApisList
+    , externalApisCreateR = externalApiCreate
+    , externalApisInfoR   = externalApiInfo
+    , externalApisPongR   = externalApiPong
+    , externalApisDeleteR = externalApiDelete
+    }
 
 externalApisList :: ServantHandler ExternalApisList
 externalApisList = runDB $ fmap ExternalApisList . lift . toResponse =<< selectList [] [Desc ExternalApiLastAlive]
diff --git a/src/ServantApi/ExternalApis/Type.hs b/src/ServantApi/ExternalApis/Type.hs
index 0d4599cbe..ec55257c7 100644
--- a/src/ServantApi/ExternalApis/Type.hs
+++ b/src/ServantApi/ExternalApis/Type.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module ServantApi.ExternalApis.Type where
@@ -24,13 +25,16 @@ type ExternalApisInfoR = CaptureCryptoUUID "external-api" ExternalApiId
 type ExternalApisDeleteR = CaptureCryptoUUID "external-api" ExternalApiId
                         :> DeleteNoContent
 
-type ExternalApis = ExternalApisListR
-               :<|> ExternalApisCreateR
-               :<|> ExternalApisInfoR
-               :<|> ExternalApisPongR
-               :<|> ExternalApisDeleteR
+data ExternalApis mode = ExternalApis
+  { externalApisListR   :: mode :- ExternalApisListR
+  , externalApisCreateR :: mode :- ExternalApisCreateR
+  , externalApisInfoR   :: mode :- ExternalApisInfoR
+  , externalApisPongR   :: mode :- ExternalApisPongR
+  , externalApisDeleteR :: mode :- ExternalApisDeleteR
+  } deriving (Generic)
 
 type ServantApiExternalApis = ServantApi ExternalApis
+type instance ServantApiUnproxy ExternalApis = ToServantApi ExternalApis
 
 
 instance ToCapture (Capture "external-api" UUID) where
diff --git a/src/Yesod/Servant.hs b/src/Yesod/Servant.hs
index 51de5fe35..ccb24f22b 100644
--- a/src/Yesod/Servant.hs
+++ b/src/Yesod/Servant.hs
@@ -1,7 +1,8 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 module Yesod.Servant
-  ( HasRoute(..)
+  ( ServantApiUnproxy, ServantApiDirect
+  , HasRoute(..)
   , ServantApi(..), getServantApi
   , ServantApiDispatch(..)
   , servantApiLink
@@ -111,7 +112,7 @@ 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))
+  parseServantRoute :: forall proxy. ServantApiUnproxy proxy ~ api => ([Text], [(Text, Text)]) -> Maybe (Route (ServantApi proxy))
 
 instance HasRoute EmptyAPI where
   parseServantRoute _ = Nothing
@@ -129,115 +130,121 @@ instance (Typeable m, Typeable k, Typeable status, Typeable fr, Typeable ct, Typ
   parseServantRoute  _      = Nothing
 
 instance HasRoute sub => HasRoute (HttpVersion :> sub) where
-  parseServantRoute args = parseServantRoute @sub args <&> \case
+  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect 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
+  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect 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
+  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect 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
+  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect 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
+  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect 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
+  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect 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
+  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect 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
+  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect 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
+  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect 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
+  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect 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
+    = parseServantRoute @sub @(ServantApiDirect 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
+    [ parseServantRoute @a @(ServantApiDirect a) args <&> \case
         ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs
-    , parseServantRoute @b args <&> \case
+    , parseServantRoute @b @(ServantApiDirect 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
+  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect 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
+  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
 
 instance (HasRoute sub, KnownSymbol sym, Typeable mods, Typeable a) => HasRoute (Header' mods sym (a :: *) :> sub) where
-  parseServantRoute args = parseServantRoute @sub args <&> \case
+  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect 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
+    = 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'
   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
+    = 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'
   parseServantRoute _ = Nothing
 
 
 
-data ServantApi (api :: *) = ServantApi
+data ServantApi (proxy :: k) = ServantApi
 
-getServantApi :: forall master api. master -> ServantApi api
+getServantApi :: forall master proxy. master -> ServantApi proxy
 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
+type family ServantApiUnproxy (proxy :: k) :: *
+
+data ServantApiDirect (api :: *)
+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])
+  renderRoute (ServantApiRoute (_ :: Proxy endpoint) f _ _) = f $ safeLink' renderServantRoute (Proxy @(ServantApiUnproxy proxy)) (Proxy @endpoint)
+
+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
 
-instance HasRoute api => Hashable (Route (ServantApi api)) where
+instance HasRoute (ServantApiUnproxy proxy) => Hashable (Route (ServantApi proxy)) 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
+instance HasRoute (ServantApiUnproxy proxy) => Read (Route (ServantApi proxy)) where
   readPrec = readP_to_Prec $ \d -> do
     when (d > 10) . void $ R.char '('
     R.skipSpaces
@@ -259,7 +266,7 @@ instance HasRoute api => Read (Route (ServantApi api)) where
     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
+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)
@@ -268,26 +275,26 @@ instance HasRoute api => Show (Route (ServantApi api)) where
     . showString " "
     . showsPrec 11 qs
 
-instance HasRoute api => ParseRoute (ServantApi api) where
+instance HasRoute (ServantApiUnproxy proxy) => ParseRoute (ServantApi proxy) 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
+class (HasServer (ServantApiUnproxy proxy) context, HasRoute (ServantApiUnproxy proxy)) => 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 api => YesodSubDispatch (ServantApi api) master where
+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 api
+      proxy :: ServantApi proxy
       proxy = ysreGetSub master
       
       route = parseRoute ( W.pathInfo req
@@ -299,7 +306,7 @@ instance ServantApiDispatch context m master api => YesodSubDispatch (ServantApi
         yesodMiddleware <- servantYesodMiddleware proxy master
         ctx <- servantContext proxy master req
 
-        let server' = hoistServerWithContext (Proxy @api) (Proxy @context) (servantHoist proxy master req ctx) (servantServer proxy master)
+        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
@@ -341,16 +348,16 @@ instance ServantApiDispatch context m master api => YesodSubDispatch (ServantApi
                   | otherwise = Nothing
   
         fmap toTypedContent . withUnliftIO $ \UnliftIO{..} ->
-          (yesodMiddleware . servantMiddleware proxy master ctx $ serveWithContext (Proxy @api) ctx server') req $ unliftIO . sendResponse
+          (yesodMiddleware . servantMiddleware proxy master ctx $ serveWithContext (Proxy @(ServantApiUnproxy proxy)) ctx server') req $ unliftIO . sendResponse
 
-servantApiLink :: forall p1 p2 api endpoint.
-                  ( IsElem endpoint api ~ (() :: Constraint), HasRoute api, HasLink endpoint, Typeable endpoint )
-               => p1 api
+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 api))
-servantApiLink _ _ = safeLink' (fromMaybe (error "Could not parse result of safeLink'") . guardEndpoint . parseServantRoute @api . renderServantRoute) (Proxy @api) (Proxy @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 api)) -> Maybe (Route (ServantApi api))
+    guardEndpoint :: Maybe (Route (ServantApi proxy)) -> Maybe (Route (ServantApi proxy))
     guardEndpoint x@(Just (ServantApiRoute (_ :: Proxy endpoint') _ _ _))
       | Just Refl <- eqT @endpoint @endpoint' = x
     guardEndpoint _ = Nothing
@@ -515,7 +522,7 @@ mkYesodApi (nameBase -> masterN) ress = do
         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)
+        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

From b277bd8424bdb8aef6c0c2e22acd70854f6ba18b Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Fri, 22 Jan 2021 11:27:03 +0100
Subject: [PATCH 08/18] feat: link api docs

---
 messages/uniworx/de-de-formal.msg |  1 +
 messages/uniworx/en-eu.msg        |  3 +++
 src/Foundation/Navigation.hs      | 21 +++++++++++++++++++++
 3 files changed, 25 insertions(+)

diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg
index 4878e3014..a07b7ed9c 100644
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@@ -1428,6 +1428,7 @@ MenuAllocationUsers: Bewerber
 MenuAllocationPriorities: Zentrale Dringlichkeiten
 MenuAllocationCompute: Platzvergabe berechnen
 MenuAllocationAccept: Platzvergabe akzeptieren
+MenuApiDocs: API-Dokumentation (Englisch)
 MenuSwagger: OpenAPI 2.0 (Swagger)
 MenuAllocationAddUser: Bewerber hinzufügen
 MenuFaq: FAQ
diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg
index bb00e62bc..61df840d0 100644
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@@ -1428,6 +1428,8 @@ MenuAllocationUsers: Applicants
 MenuAllocationPriorities: Central priorities
 MenuAllocationCompute: Compute allocation
 MenuAllocationAccept: Accept allocation
+MenuApiDocs: API documentation
+MenuSwagger: OpenAPI 2.0 (Swagger)
 MenuAllocationAddUser: Add applicant
 MenuFaq: FAQ
 MenuSheetPersonalisedFiles: Download personalised sheet files
@@ -1522,6 +1524,7 @@ BreadcrumbAllocationPriorities: Central priorities
 BreadcrumbAllocationCompute: Compute allocation
 BreadcrumbAllocationAccept: Accept allocation
 BreadcrumbExternalApis: External APIs
+BreadcrumbApiDocs: API documentation
 BreadcrumbSwagger: API documentation
 BreadcrumbAllocationAddUser: Add applicant
 BreadcrumbMessageHide: Hide
diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
index be33ae209..83587b671 100644
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@@ -666,6 +666,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
       , navQuick'      = mempty
       , navForceActive = False
       }
+  , return $ NavFooter NavLink
+      { navLabel       = MsgMenuApiDocs
+      , navRoute       = ApiDocsR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
   , return NavHeader
       { navHeaderRole = NavHeaderPrimary
       , navIcon       = IconMenuNews
@@ -2564,6 +2572,19 @@ pageActions TopWorkflowInstanceListR = return
     , navChildren = []
     }
   ]
+pageActions ApiDocsR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuSwagger
+      , navRoute       = SwaggerR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
 pageActions _ = return []
 
 submissionList :: ( MonadIO m

From 76e0bcf693afeb15edae0b8170c3a813b10ae062 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Mon, 15 Feb 2021 23:18:35 +0100
Subject: [PATCH 09/18] feat(apis): version negotiation

---
 package.yaml                        |   1 +
 src/Data/SemVer/Instances.hs        |  31 +++++
 src/Foundation/Servant.hs           |   4 +-
 src/Foundation/Servant/Types.hs     | 196 +++++++++++++++++++++++++++-
 src/Import/NoModel.hs               |   1 +
 src/ServantApi/ExternalApis/Type.hs |   2 +-
 src/Yesod/Servant.hs                |  47 ++++---
 stack.yaml                          |   1 +
 stack.yaml.lock                     |   7 +
 test/Foundation/ServantSpec.hs      |   3 +
 test/FoundationSpec.hs              |   6 +-
 test/Model/TypesSpec.hs             |  40 ++++++
 12 files changed, 311 insertions(+), 28 deletions(-)
 create mode 100644 src/Data/SemVer/Instances.hs

diff --git a/package.yaml b/package.yaml
index d8a6ce0b4..fe68fd2ff 100644
--- a/package.yaml
+++ b/package.yaml
@@ -174,6 +174,7 @@ dependencies:
   - network-uri
   - psqueues
   - nonce
+  - semver
 other-extensions:
   - GeneralizedNewtypeDeriving
   - IncoherentInstances
diff --git a/src/Data/SemVer/Instances.hs b/src/Data/SemVer/Instances.hs
new file mode 100644
index 000000000..51d60dfb2
--- /dev/null
+++ b/src/Data/SemVer/Instances.hs
@@ -0,0 +1,31 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.SemVer.Instances
+  () where
+
+import ClassyPrelude
+import qualified Data.SemVer as SemVer
+import qualified Data.SemVer.Constraint as SemVer (Constraint(..))
+import qualified Data.SemVer.Constraint as SemVer.Constraint
+
+import Web.HttpApiData
+
+
+instance ToHttpApiData SemVer.Version where
+  toUrlPiece = SemVer.toText
+  
+instance ToHttpApiData SemVer.Constraint where
+  toUrlPiece SemVer.CAny = "*"
+  toUrlPiece (SemVer.CLt v) = "<" <> toUrlPiece v
+  toUrlPiece (SemVer.CLtEq v) = "<=" <> toUrlPiece v
+  toUrlPiece (SemVer.CGt v) = ">" <> toUrlPiece v
+  toUrlPiece (SemVer.CGtEq v) = ">=" <> toUrlPiece v
+  toUrlPiece (SemVer.CEq v) = toUrlPiece v
+  toUrlPiece (SemVer.CAnd a b) = toUrlPiece a <> " " <> toUrlPiece b
+  toUrlPiece (SemVer.COr a b) = toUrlPiece a <> " || " <> toUrlPiece b
+
+instance FromHttpApiData SemVer.Version where
+  parseUrlPiece = first pack . SemVer.fromText
+
+instance FromHttpApiData SemVer.Constraint where
+  parseUrlPiece = first pack . SemVer.Constraint.fromText
diff --git a/src/Foundation/Servant.hs b/src/Foundation/Servant.hs
index dd4b77b0d..c76d6511d 100644
--- a/src/Foundation/Servant.hs
+++ b/src/Foundation/Servant.hs
@@ -133,8 +133,8 @@ type UniWorXContext = UniWorX ': '[]
 type ServantHandler = ServantHandlerFor UniWorX
 type ServantDB      = ServantDBFor      UniWorX
 
-class (HasServer (ServantApiUnproxy proxy) UniWorXContext, Servant.HasRoute (ServantApiUnproxy proxy)) => ServantApiDispatchUniWorX proxy where
-  servantServer' :: ServantApi proxy -> ServerT (ServantApiUnproxy proxy) ServantHandler
+class (HasServer (ServantApiUnproxy' proxy) UniWorXContext, Servant.HasRoute (ServantApiUnproxy' proxy)) => ServantApiDispatchUniWorX proxy where
+  servantServer' :: ServantApi proxy -> ServerT (ServantApiUnproxy' proxy) ServantHandler
 
 instance ServantApiDispatchUniWorX proxy => ServantApiDispatch UniWorXContext ServantHandler UniWorX proxy where
   servantContext _ app _ = return $ app :. EmptyContext
diff --git a/src/Foundation/Servant/Types.hs b/src/Foundation/Servant/Types.hs
index de751eb82..3e4c8b4d1 100644
--- a/src/Foundation/Servant/Types.hs
+++ b/src/Foundation/Servant/Types.hs
@@ -4,6 +4,7 @@ module Foundation.Servant.Types
   ( CaptureBearerRestriction, CaptureBearerRestriction'
   , CaptureBearerToken, CaptureBearerToken'
   , CaptureCryptoID', CaptureCryptoID, CaptureCryptoUUID, CaptureCryptoFileName
+  , ApiVersion, apiVersionToSemVer, matchesApiVersion
   ) where
 
 import ClassyPrelude
@@ -13,20 +14,34 @@ import Servant.API
 import Servant.API.Description
 import Servant.Swagger
 import Servant.Docs
+import Servant.Server
+import Servant.Server.Internal.Router
+import Servant.Server.Internal.RouteResult
+import Servant.Server.Internal.Delayed
+import Servant.Server.Internal.ErrorFormatter
+-- import Servant.Server.Internal.DelayedIO
 
-import Control.Lens
+import Network.Wai (mapResponseHeaders, requestHeaders)
+
+import Control.Lens hiding (Context)
 
 import Data.UUID (UUID)
 import Data.CaseInsensitive (CI)
 import Data.CryptoID.Class.ImplicitNamespace
 import Data.CryptoID.Instances ()
 
-import GHC.TypeLits (Symbol, KnownSymbol)
+import GHC.TypeLits
 
 import Data.Swagger (ToParamSchema)
 
 import Data.Kind (Type)
 
+import qualified Data.SemVer as SemVer
+import qualified Data.SemVer.Constraint as SemVer (Constraint)
+import qualified Data.SemVer.Constraint as SemVer.Constraint
+
+import Data.SemVer.Instances ()
+
 
 type CaptureBearerRestriction = CaptureBearerRestriction' '[Required]
 data CaptureBearerRestriction' (mods :: [Type]) (restr :: Type)
@@ -39,6 +54,26 @@ type CaptureCryptoID = CaptureCryptoID' '[]
 type CaptureCryptoUUID = CaptureCryptoID UUID
 type CaptureCryptoFileName = CaptureCryptoID (CI FilePath)
 
+data ApiVersion (major :: Nat) (minor :: Nat) (patch :: Nat)
+
+apiVersionToSemVer :: forall major minor patch p.
+                      ( KnownNat major, KnownNat minor, KnownNat patch )
+                   => p (ApiVersion major minor patch)
+                   -> SemVer.Version
+apiVersionToSemVer _ = SemVer.version
+  (fromIntegral . natVal $ Proxy @major)
+  (fromIntegral . natVal $ Proxy @minor)
+  (fromIntegral . natVal $ Proxy @patch)
+  []
+  []
+
+matchesApiVersion :: forall major minor patch p.
+                     ( KnownNat major, KnownNat minor, KnownNat patch )
+                  => p (ApiVersion major minor patch)
+                  -> SemVer.Constraint
+                  -> Bool
+matchesApiVersion _ = SemVer.Constraint.satisfies . apiVersionToSemVer $ Proxy @(ApiVersion major minor patch)
+
 
 instance HasLink sub => HasLink (CaptureBearerRestriction' mods restr :> sub) where
   type MkLink (CaptureBearerRestriction' mods restr :> sub) r = MkLink sub r
@@ -52,6 +87,10 @@ instance (HasLink sub, ToHttpApiData ciphertext) => HasLink (CaptureCryptoID' mo
   type MkLink (CaptureCryptoID' mods ciphertext sym plaintext :> sub) r = MkLink (Capture' mods sym (CryptoID ciphertext plaintext) :> sub) r
   toLink toA _ = toLink toA $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub)
 
+instance HasLink sub => HasLink (ApiVersion major minor patch :> sub) where
+  type MkLink (ApiVersion major minor patch :> sub) r = MkLink sub r
+  toLink toA _ = toLink toA $ Proxy @sub
+
 instance HasSwagger sub => HasSwagger (CaptureBearerRestriction' mods restr :> sub) where
   toSwagger _ = toSwagger $ Proxy @sub
 
@@ -61,6 +100,9 @@ instance HasSwagger sub => HasSwagger (CaptureBearerToken' mods :> sub) where
 instance (HasSwagger sub, ToParamSchema ciphertext, KnownSymbol sym, KnownSymbol (FoldDescription mods)) => HasSwagger (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
   toSwagger _ = toSwagger $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub)
 
+instance HasSwagger sub => HasSwagger (ApiVersion major minor patch :> sub) where
+  toSwagger _ = toSwagger $ Proxy @sub
+
 instance HasDocs sub => HasDocs (CaptureBearerRestriction' mods restr :> sub) where
   docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action')
     where action' = action & notes <>~ [DocNote "Bearer restrictions" ["The behaviour of this route dependes on the restrictions stored for it in the bearer token used for authorization"]]
@@ -72,4 +114,152 @@ instance HasDocs sub => HasDocs (CaptureBearerToken' mods :> sub) where
 instance (ToCapture (Capture sym ciphertext), KnownSymbol sym, HasDocs sub) => HasDocs (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
   docsFor _ = docsFor $ Proxy @(Capture' mods sym ciphertext :> sub)
 
-type instance IsElem' (CaptureCryptoID' mods ciphertext sym plaintext :> sub) api = IsElem (Capture' mods sym (CryptoID ciphertext plaintext) :> sub) api
+
+type family ApiVersionSub major minor patch sup sub where
+  ApiVersionSub major minor patch (ApiVersion major' minor' patch') sub = ApiVersion major' minor' patch' :> sub
+  ApiVersionSub major minor patch sup sub = sup :> (ApiVersion major minor patch :> sub)
+
+instance HasServer (ApiVersionSub major minor patch sup sub) context => HasServer (ApiVersion major minor patch :> ((sup :: Type) :> sub)) context where
+  type ServerT (ApiVersion major minor patch :> (sup :> sub)) m = ServerT (ApiVersionSub major minor patch sup sub) m
+  hoistServerWithContext _ = hoistServerWithContext $ Proxy @(ApiVersionSub major minor patch sup sub)
+  route _ = route $ Proxy @(ApiVersionSub major minor patch sup sub)
+  
+instance HasServer (sup :> (ApiVersion major minor patch :> sub)) context => HasServer (ApiVersion major minor patch :> ((sup :: Symbol) :> sub)) context where
+  type ServerT (ApiVersion major minor patch :> (sup :> sub)) m = ServerT (sup :> (ApiVersion major minor patch :> sub)) m
+  hoistServerWithContext _ = hoistServerWithContext $ Proxy @(sup :> (ApiVersion major minor patch :> sub))
+  route _ = route $ Proxy @(sup :> (ApiVersion major minor patch :> sub))
+
+instance ( HasServer (ApiVersion major minor patch :> a) context
+         , HasServer (ApiVersion major minor patch :> b) context
+         , SBoolI (IsLT (CmpVersion (FinalApiVersion (ApiVersion major minor patch :> a)) (FinalApiVersion (ApiVersion major minor patch :> b))))
+         ) => HasServer (ApiVersion major minor patch :> (a :<|> b)) context where
+  type ServerT (ApiVersion major minor patch :> (a :<|> b)) m = ServerT (ApiVersion major minor patch :> a) m :<|> ServerT (ApiVersion major minor patch :> b) m
+  hoistServerWithContext _ = hoistServerWithContext $ Proxy @((ApiVersion major minor patch :> a) :<|> (ApiVersion major minor patch :> b))
+  route Proxy context server = choice'
+    (route (Proxy @(ApiVersion major minor patch :> a)) context $ (\(a :<|> _) -> a) <$> server)
+    (route (Proxy @(ApiVersion major minor patch :> b)) context $ (\(_ :<|> b) -> b) <$> server)
+    where
+      choice' :: forall env' a'. Router' env' a' -> Router' env' a' -> Router' env' a'
+      choice' = case (sbool :: SBool (IsLT (CmpVersion (FinalApiVersion (ApiVersion major minor patch :> a)) (FinalApiVersion (ApiVersion major minor patch :> b))))) of
+        STrue  -> flip choice
+        SFalse -> choice
+         
+  
+routeWithApiVersion :: forall api context env major minor patch.
+                       ( HasServer api context
+                       , KnownNat major, KnownNat minor, KnownNat patch
+                       , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
+                       )
+                    => Proxy (ApiVersion major minor patch)
+                    -> Proxy api -> Context context -> Delayed env (Server api) -> Router env
+routeWithApiVersion _ _ context subserver = RawRouter $ \env req ((. addVersion) -> cont) -> case maybe (pure SemVer.Constraint.CAny) parseHeader . lookup versionRequestHeaderName $ requestHeaders req of
+  Left parseErr -> cont $ FailFatal err400 { errBody = encodeUtf8 . fromStrict $ "Could not parse version constraint: " <> parseErr }
+  Right vHdr -> if
+    | version `SemVer.Constraint.satisfies` vHdr -> runRouterEnv notFound (route (Proxy @api) context subserver) env req cont
+    | otherwise -> cont $ Fail err400 { errBody = encodeUtf8 "Requested version could not be satisfied" }
+  where addVersion (Fail sError) = Fail sError { errHeaders = addVersionHeader $ errHeaders sError}
+        addVersion (FailFatal sError) = FailFatal sError { errHeaders = addVersionHeader $ errHeaders sError }
+        addVersion (Route resp) = Route $ mapResponseHeaders addVersionHeader resp
+
+        addVersionHeader hdrs
+          | has (folded . _1 . only versionHeaderName) hdrs = hdrs
+          | otherwise = hdrs <> pure (versionHeaderName, versionHeader)
+
+        version = apiVersionToSemVer $ Proxy @(ApiVersion major minor patch)
+
+        versionHeaderName = "API-Version"
+        versionRequestHeaderName = "Accept-API-Version"
+        versionHeader = encodeUtf8 $ SemVer.toText version
+
+        notFound = notFoundErrorFormatter . getContextEntry $ mkContextWithErrorFormatter context
+  
+instance ( HasServer (Verb method statusCode contentTypes a) context
+         , KnownNat major, KnownNat minor, KnownNat patch
+         , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
+         ) => HasServer (ApiVersion major minor patch :> Verb method statusCode contentTypes a) context where
+  type ServerT (ApiVersion major minor patch :> Verb method statusCode contentTypes a) m = ServerT (Verb method statusCode contentTypes a) m
+
+  hoistServerWithContext _ = hoistServerWithContext $ Proxy @(Verb method statusCode contentTypes a)
+
+  route _ = routeWithApiVersion (Proxy @(ApiVersion major minor patch)) (Proxy @(Verb method statusCode contentTypes a))
+
+instance ( HasServer (NoContentVerb method) context
+         , KnownNat major, KnownNat minor, KnownNat patch
+         , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
+         ) => HasServer (ApiVersion major minor patch :> NoContentVerb method) context where
+  type ServerT (ApiVersion major minor patch :> NoContentVerb method) m = ServerT (NoContentVerb method) m
+
+  hoistServerWithContext _ = hoistServerWithContext $ Proxy @(NoContentVerb method)
+
+  route _ = routeWithApiVersion (Proxy @(ApiVersion major minor patch)) (Proxy @(NoContentVerb method))
+
+
+instance ( HasDocs (ApiVersionSub major minor patch sup sub)
+         ) => HasDocs (ApiVersion major minor patch :> ((sup :: Type) :> sub)) where
+  docsFor _ = docsFor $ Proxy @(ApiVersionSub major minor patch sup sub)
+
+instance ( HasDocs (sup :> (ApiVersion major minor patch :> sub))
+         ) => HasDocs (ApiVersion major minor patch :> ((sup :: Symbol) :> sub)) where
+  docsFor _ = docsFor $ Proxy @(sup :> (ApiVersion major minor patch :> sub))
+
+instance ( HasDocs (ApiVersion major minor patch :> a)
+         , HasDocs (ApiVersion major minor patch :> b)
+         ) => HasDocs (ApiVersion major minor patch :> (a :<|> b)) where
+  docsFor _ = docsFor $ Proxy @(ApiVersion major minor patch :> a :<|> ApiVersion major minor patch :> b)
+
+  
+apiVersionDocNote :: forall major minor patch.
+                     ( KnownNat major, KnownNat minor, KnownNat patch )
+                  => Proxy (ApiVersion major minor patch)
+                  -> DocNote
+apiVersionDocNote p = DocNote "Versioning" ["This route is provided in version " <> SemVer.toString (apiVersionToSemVer p)]
+  
+instance ( HasDocs (Verb method statusCode contentTypes a)
+         , KnownNat major, KnownNat minor, KnownNat patch
+         ) => HasDocs (ApiVersion major minor patch :> Verb method statusCode contentTypes a) where
+  docsFor _ (endpoint, action) = docsFor (Proxy @(Verb method statusCode contentTypes a)) (endpoint, action')
+    where action' = action & notes <>~ [apiVersionDocNote $ Proxy @(ApiVersion major minor patch)]
+
+instance ( HasDocs (NoContentVerb method)
+         , KnownNat major, KnownNat minor, KnownNat patch
+         ) => HasDocs (ApiVersion major minor patch :> NoContentVerb method) where
+  docsFor _ (endpoint, action) = docsFor (Proxy @(NoContentVerb method)) (endpoint, action')
+    where action' = action & notes <>~ [apiVersionDocNote $ Proxy @(ApiVersion major minor patch)]
+
+  
+type family FinalApiVersion api where
+  FinalApiVersion (ApiVersion major minor patch :> sub) = AlternativeMaybe (FinalApiVersion sub) ('Just (ApiVersion major minor patch))
+  FinalApiVersion (sup :> sub) = FinalApiVersion sub
+  FinalApiVersion (a :<|> b) = MaxMaybe (CmpVersion (FinalApiVersion a) (FinalApiVersion b)) (FinalApiVersion a) (FinalApiVersion b)
+  FinalApiVersion (Verb method statusCode contentTypes a) = 'Nothing
+  FinalApiVersion (NoContentVerb method) = 'Nothing
+
+type family MaxMaybe ord a b where
+  MaxMaybe _ a 'Nothing = a
+  MaxMaybe _ 'Nothing b = b
+  MaxMaybe 'LT _ b = b
+  MaxMaybe _   a _ = a
+
+type family MappendOrdering a b where
+  MappendOrdering 'EQ b = b
+  MappendOrdering a _ = a
+
+type family AlternativeMaybe a b where
+  AlternativeMaybe ('Just a) _ = 'Just a
+  AlternativeMaybe _ ('Just b) = 'Just b
+  AlternativeMaybe _ _ = 'Nothing
+
+type family CmpVersion x y where
+  CmpVersion 'Nothing 'Nothing = 'EQ
+  CmpVersion 'Nothing _ = 'GT
+  CmpVersion _ 'Nothing = 'LT
+  CmpVersion ('Just (ApiVersion major minor patch)) ('Just (ApiVersion major' minor' patch')) = MappendOrdering (CmpNat major major') (MappendOrdering (CmpNat minor minor') (CmpNat patch patch'))
+
+type family IsLT x where
+  IsLT 'LT = 'True
+  IsLT _ = 'False
+ 
+
+type instance IsElem' sa (CaptureCryptoID' mods ciphertext sym plaintext :> sb) = IsElem sa (Capture' mods sym (CryptoID ciphertext plaintext) :> sb)
+
+type instance IsElem' sa (ApiVersion major minor patch :> sb) = IsElem sa sb
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 552adaab6..dd52b4d26 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -200,6 +200,7 @@ import Text.Shakespeare.Text.Instances as Import ()
 import Ldap.Client.Instances as Import ()
 import Data.MultiSet.Instances as Import ()
 import Control.Arrow.Instances as Import ()
+import Data.SemVer.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
 import Crypto.Random as Import (ChaChaDRG, Seed)
diff --git a/src/ServantApi/ExternalApis/Type.hs b/src/ServantApi/ExternalApis/Type.hs
index 12b7f64e1..181f2bca2 100644
--- a/src/ServantApi/ExternalApis/Type.hs
+++ b/src/ServantApi/ExternalApis/Type.hs
@@ -37,7 +37,7 @@ data ExternalApis mode = ExternalApis
   } deriving (Generic)
 
 type ServantApiExternalApis = ServantApi ExternalApis
-type instance ServantApiUnproxy ExternalApis = ToServantApi ExternalApis
+type instance ServantApiUnproxy ExternalApis = ApiVersion 1 0 0 :> ToServantApi ExternalApis
 
 
 instance ToCapture (Capture "external-api" UUID) where
diff --git a/src/Yesod/Servant.hs b/src/Yesod/Servant.hs
index cc2413f13..611727e6c 100644
--- a/src/Yesod/Servant.hs
+++ b/src/Yesod/Servant.hs
@@ -1,7 +1,8 @@
+{-# OPTIONS_GHC -fno-warn-unused-foralls #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Yesod.Servant
-  ( ServantApiUnproxy, ServantApiDirect
+  ( ServantApiUnproxy, ServantApiUnproxy', ServantApiDirect
   , HasRoute(..)
   , ServantApi(..), getServantApi
   , ServantApiDispatch(..)
@@ -83,7 +84,7 @@ import Data.Typeable (eqT, typeRep)
 
 import Network.URI
 import Network.URI.Lens
-import GHC.TypeLits (KnownSymbol, symbolVal)
+import GHC.TypeLits (KnownSymbol, symbolVal, KnownNat)
 
 import Text.Read (Read(readPrec), readP_to_Prec, readPrec_to_P)
 import Text.Show (showParen, showString)
@@ -114,7 +115,7 @@ 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))
+  parseServantRoute :: forall proxy. ServantApiUnproxy' proxy ~ api => ([Text], [(Text, Text)]) -> Maybe (Route (ServantApi proxy))
 
 instance HasRoute EmptyAPI where
   parseServantRoute _ = Nothing
@@ -212,6 +213,9 @@ instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable plaintext, ToHt
         ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(CaptureCryptoID' mods ciphertext sym plaintext :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs'
   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
 
 
 data ServantApi (proxy :: k) = ServantApi
@@ -223,13 +227,18 @@ 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
+instance HasRoute (ServantApiUnproxy' proxy) => RenderRoute (ServantApi proxy) where
   data Route (ServantApi proxy)
     = forall endpoint.
-      ( IsElem endpoint (ServantApiUnproxy proxy) ~ (() :: Constraint)
+      ( IsElem endpoint (ServantApiUnproxy' proxy) ~ (() :: Constraint)
       , HasRoute endpoint
       , Typeable endpoint
       )
@@ -237,24 +246,24 @@ instance HasRoute (ServantApiUnproxy proxy) => RenderRoute (ServantApi proxy) wh
       (Proxy endpoint)
       (forall a. MkLink endpoint a -> a)
       [Text] (HashMap Text [Text])
-  renderRoute (ServantApiRoute (_ :: Proxy endpoint) f _ _) = f $ safeLink' renderServantRoute (Proxy @(ServantApiUnproxy proxy)) (Proxy @endpoint)
+  renderRoute (ServantApiRoute (_ :: Proxy endpoint) f _ _) = f $ safeLink' renderServantRoute (Proxy @(ServantApiUnproxy' proxy)) (Proxy @endpoint)
 
-instance HasRoute (ServantApiUnproxy proxy) => Eq (Route (ServantApi proxy)) where
+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
 
-instance HasRoute (ServantApiUnproxy proxy) => Ord (Route (ServantApi proxy)) where
+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')
 
-instance HasRoute (ServantApiUnproxy proxy) => Hashable (Route (ServantApi proxy)) where
+instance HasRoute (ServantApiUnproxy' proxy) => Hashable (Route (ServantApi proxy)) where
   hashWithSalt salt (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) = salt `hashWithSalt` typeRep (Proxy @endpoint) `hashWithSalt` ps `hashWithSalt` qs
 
-instance HasRoute (ServantApiUnproxy proxy) => Read (Route (ServantApi proxy)) where
+instance HasRoute (ServantApiUnproxy' proxy) => Read (Route (ServantApi proxy)) where
   readPrec = readP_to_Prec $ \d -> do
     when (d > 10) . void $ R.char '('
     R.skipSpaces
@@ -276,7 +285,7 @@ instance HasRoute (ServantApiUnproxy proxy) => Read (Route (ServantApi proxy)) w
     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
+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)
@@ -285,18 +294,18 @@ instance HasRoute (ServantApiUnproxy proxy) => Show (Route (ServantApi proxy)) w
     . showString " "
     . showsPrec 11 qs
 
-instance HasRoute (ServantApiUnproxy proxy) => ParseRoute (ServantApi proxy) where
+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
+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
+  servantServer          :: ServantApi proxy -> master -> ServerT (ServantApiUnproxy' proxy) m
 
 instance ServantApiDispatch context m master proxy => YesodSubDispatch (ServantApi proxy) master where
   yesodSubDispatch YesodSubRunnerEnv{..} req
@@ -316,7 +325,7 @@ instance ServantApiDispatch context m master proxy => YesodSubDispatch (ServantA
         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)
+        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
@@ -358,14 +367,14 @@ instance ServantApiDispatch context m master proxy => YesodSubDispatch (ServantA
                   | otherwise = Nothing
   
         fmap toTypedContent . withUnliftIO $ \UnliftIO{..} ->
-          (yesodMiddleware . servantMiddleware proxy master ctx $ serveWithContext (Proxy @(ServantApiUnproxy proxy)) ctx server') req $ unliftIO . sendResponse
+          (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 )
+                  ( 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)
+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') _ _ _))
@@ -532,7 +541,7 @@ mkYesodApi (nameBase -> masterN) ress = do
         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)
+        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
diff --git a/stack.yaml b/stack.yaml
index 91987818a..4cd889f17 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -80,6 +80,7 @@ extra-deps:
   - hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
   - network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506
   - servant-quickcheck-0.0.10.0@sha256:1d5849d703c2487752f8fc7391cca7c998ee24f54ca0bb72d238bf99b64ac667,3755
+  - servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
 
 resolver: nightly-2021-01-11
 compiler: ghc-8.10.3
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 085e9fd4f..04e9c994d 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -359,6 +359,13 @@ packages:
       sha256: 37dab60111c71d011fc4964e9a8b4b05ac544bc0ba8155e895518680066c2adb
   original:
     hackage: servant-quickcheck-0.0.10.0@sha256:1d5849d703c2487752f8fc7391cca7c998ee24f54ca0bb72d238bf99b64ac667,3755
+- completed:
+    hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
+    pantry-tree:
+      size: 325
+      sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3
+  original:
+    hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
 snapshots:
 - completed:
     size: 562265
diff --git a/test/Foundation/ServantSpec.hs b/test/Foundation/ServantSpec.hs
index 94256fd60..57ae11006 100644
--- a/test/Foundation/ServantSpec.hs
+++ b/test/Foundation/ServantSpec.hs
@@ -29,5 +29,8 @@ instance HasGenRequest sub => HasGenRequest (CaptureBearerToken' mods :> sub) wh
 instance HasGenRequest sub => HasGenRequest (CaptureBearerRestriction' mods restr :> sub) where
   genRequest _ = genRequest $ Proxy @sub
 
+instance HasGenRequest sub => HasGenRequest (ApiVersion major minor patch :> sub) where
+  genRequest _ = genRequest $ Proxy @sub
+
 spec :: Spec
 spec = return ()
diff --git a/test/FoundationSpec.hs b/test/FoundationSpec.hs
index 5f9c78300..5166550d8 100644
--- a/test/FoundationSpec.hs
+++ b/test/FoundationSpec.hs
@@ -12,7 +12,7 @@ import Servant.QuickCheck.Internal.HasGenRequest (HasGenRequest(..))
 import qualified Network.HTTP.Client as HTTP
 import qualified Network.HTTP.Types.URI as URI
 
-import Yesod.Servant (HasRoute(..), ServantApi, ServantApiUnproxy)
+import Yesod.Servant (HasRoute(..), ServantApi, ServantApiUnproxy')
 
 import Foundation.ServantSpec ()
 import ServantApi.ExternalApis.TypeSpec ()
@@ -36,9 +36,9 @@ instance Arbitrary (Route EmbeddedStatic) where
     params <- replicateM paramNum $ (,) <$> printableText' <*> printableText
     return $ embeddedResourceR path params
 
-instance (HasRoute (ServantApiUnproxy api), HasGenRequest (ServantApiUnproxy api)) => Arbitrary (Route (ServantApi api)) where
+instance (HasRoute (ServantApiUnproxy' api), HasGenRequest (ServantApiUnproxy' api)) => Arbitrary (Route (ServantApi api)) where
   arbitrary = do
-    genReq <- view _2 . genRequest $ Proxy @(ServantApiUnproxy api)
+    genReq <- view _2 . genRequest $ Proxy @(ServantApiUnproxy' api)
     let req = genReq $ BaseUrl Http "" 0 ""
         p = filter (not . null) . URI.decodePathSegments $ HTTP.path req
         qs = over (traverse . _2) (fromMaybe mempty) . URI.parseQueryText $ HTTP.queryString req
diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs
index 032378e11..8f92ee3e9 100644
--- a/test/Model/TypesSpec.hs
+++ b/test/Model/TypesSpec.hs
@@ -7,6 +7,8 @@ module Model.TypesSpec
 import TestImport
 import Settings
 
+import Utils (guardOn)
+
 import Data.Aeson (Value)
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
@@ -46,6 +48,10 @@ import qualified Data.Text.Lazy as LT
 
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 
+import qualified Data.SemVer as SemVer
+import qualified Data.SemVer.Constraint as SemVer (Constraint)
+import qualified Data.SemVer.Constraint as SemVer.Constraint
+
 
 
 instance Arbitrary Season where
@@ -330,6 +336,36 @@ instance Arbitrary ExternalApiConfig where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
+instance Arbitrary SemVer.Version where
+  arbitrary = SemVer.version
+    <$> fmap getNonNegative arbitrary
+    <*> fmap getNonNegative arbitrary
+    <*> fmap getNonNegative arbitrary
+    <*> arbitrary
+    <*> arbitrary
+
+instance Arbitrary SemVer.Identifier where
+  arbitrary = -- oneof
+    -- [ SemVer.numeric . getNonNegative <$> arbitrary -- Numeric does not roundtrip
+    {- , -} fmap (\s -> fromMaybe (error $ "Generated invalid SemVer.Identifier: " <> s) . SemVer.textual $ pack s) . listOf1 . elements $ ['A'..'Z'] <> ['a'..'z'] {- <> ['0'..'9'] -} <> ['-']
+    -- ]
+
+deriving instance Generic SemVer.Constraint
+
+instance Arbitrary SemVer.Constraint where
+  -- Syntax has no brackets; so be very careful about nesting
+  arbitrary = sized $ \n -> oneof $ catMaybes
+    [ pure unitary
+    , guardOn (n > 1) conj
+    , guardOn (n > 1) disj
+    ]
+    where unitary = oneof
+            [ pure SemVer.Constraint.CAny
+            , elements [SemVer.Constraint.CLt, SemVer.Constraint.CLtEq, SemVer.Constraint.CGt, SemVer.Constraint.CGtEq, SemVer.Constraint.CEq] <*> arbitrary
+            ]
+          conj = SemVer.Constraint.CAnd <$> unitary <*> sized (\n -> oneof $ catMaybes [pure unitary, guardOn (n > 1) $ scale (`div` 2) conj])
+          disj = SemVer.Constraint.COr <$> unitary <*> scale (`div` 2) arbitrary
+
 
 
 spec :: Spec
@@ -435,6 +471,10 @@ spec = do
       [ eqLaws, ordLaws, finiteLaws, showReadLaws, pathPieceLaws, boundedEnumLaws ]
     lawsCheckHspec (Proxy @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey))
       [ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ]
+    lawsCheckHspec (Proxy @SemVer.Version)
+      [ eqLaws, ordLaws, showLaws, hashableLaws, httpApiDataLaws ]
+    lawsCheckHspec (Proxy @SemVer.Constraint)
+      [ eqLaws, showLaws, httpApiDataLaws ]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $

From 4e5989bb8178323aa6b8ea550c8e82cf3dd687c7 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Thu, 19 Aug 2021 12:52:52 +0200
Subject: [PATCH 10/18] style(apidocs): fix code blocks

---
 frontend/src/app.sass  | 16 ++++++++--------
 src/Handler/ApiDocs.hs |  6 +++++-
 2 files changed, 13 insertions(+), 9 deletions(-)

diff --git a/frontend/src/app.sass b/frontend/src/app.sass
index acc5e6aa1..c085be12a 100644
--- a/frontend/src/app.sass
+++ b/frontend/src/app.sass
@@ -1444,14 +1444,14 @@ a.breadcrumbs__home
   &__label
     grid-area: label
 
-code
-  display: block
-  box-shadow: inset 0 0 4px 4px var(--color-grey-light)
-  white-space: pre-wrap
-  font-family: monospace
-  overflow-x: auto
-  tab-size: 2
-  padding: 10px
+.apidocs
+  pre
+    display: block
+    box-shadow: inset 0 0 4px 4px var(--color-grey-light)
+    white-space: pre-wrap
+    overflow-x: auto
+    tab-size: 2
+    padding: 10px
 
 .news__system-messages
   overflow-y: auto
diff --git a/src/Handler/ApiDocs.hs b/src/Handler/ApiDocs.hs
index 51d9594a2..6775333dc 100644
--- a/src/Handler/ApiDocs.hs
+++ b/src/Handler/ApiDocs.hs
@@ -18,7 +18,11 @@ getApiDocsR = selectRep $ do
     Right html -> provideRep . siteLayoutMsg MsgBreadcrumbApiDocs $ do
       setTitleI MsgBreadcrumbApiDocs
 
-      toWidget html
+      [whamlet|
+        $newline never
+        
      
+          ^{html}
+      |]
     Left  _err -> return ()
   provideRepType "text/markdown" $ return mdDocs
   where

From 47df8a312f72c7d019a536e7f2155ab7bd52febf Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Wed, 26 Jan 2022 22:09:03 +0100
Subject: [PATCH 11/18] feat(servant): dry-run support

---
 package.yaml                                  |   1 +
 src/Foundation/Authorization.hs               |   6 +-
 src/Foundation/Servant.hs                     | 110 ++++++-----
 src/Foundation/Servant/Types.hs               | 164 +++++++++++++++-
 src/Import/NoModel.hs                         |   3 +-
 src/Import/Servant/NoFoundation.hs            |   1 +
 src/Servant/Docs/Internal/Pretty/Instances.hs |  14 ++
 src/ServantApi/ExternalApis/Type.hs           |  29 +--
 src/Utils.hs                                  |   7 +-
 src/Yesod/Servant.hs                          | 182 +++++++++---------
 test/Model/TypesSpec.hs                       |   6 +-
 .../Client/Core/BaseUrl/TestInstances.hs      |  11 +-
 test/ServantApi/ExternalApis/TypeSpec.hs      |   5 +-
 test/ServantApi/ExternalApisSpec.hs           |  48 +++++
 test/ServantApiSpec.hs                        |  36 ++++
 test/TestImport.hs                            | 132 +++++++++++++
 16 files changed, 585 insertions(+), 170 deletions(-)
 create mode 100644 src/Servant/Docs/Internal/Pretty/Instances.hs
 create mode 100644 test/ServantApi/ExternalApisSpec.hs
 create mode 100644 test/ServantApiSpec.hs

diff --git a/package.yaml b/package.yaml
index d1f284c52..033a740eb 100644
--- a/package.yaml
+++ b/package.yaml
@@ -346,6 +346,7 @@ tests:
       - quickcheck-io
       - network-arbitrary
       - lens-properties
+      - http-media
     ghc-options:
       - -fno-warn-orphans
       - -threaded -rtsopts "-with-rtsopts=-N -T"
diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs
index 4626a4c53..bbed1a1d9 100644
--- a/src/Foundation/Authorization.hs
+++ b/src/Foundation/Authorization.hs
@@ -9,6 +9,7 @@ module Foundation.Authorization
   , wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
   , AuthContext(..), getAuthContext
   , isDryRun, isDryRunDB
+  , IsDryRun(..)
   , maybeBearerToken, requireBearerToken
   , requireCurrentBearerRestrictions, maybeCurrentBearerRestrictions
   , BearerAuthSite, MonadAP
@@ -276,7 +277,9 @@ getAuthContext = liftHandler $ do
   return authCtx
 
 newtype IsDryRun = MkIsDryRun { unIsDryRun :: Bool }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving stock (Read, Show, Generic, Typeable)
+  deriving newtype (Eq, Ord)
+  deriving (Semigroup, Monoid) via Any
 
 isDryRun :: ( HasCallStack
             , BearerAuthSite UniWorX
@@ -296,6 +299,7 @@ isDryRunDB :: forall m backend m'.
 isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM
   [ hasGlobalPostParam PostDryRun
   , hasGlobalGetParam GetDryRun
+  , hasCustomHeader HeaderDryRun
   , and2M bearerDryRun bearerRequired
   ]
   where
diff --git a/src/Foundation/Servant.hs b/src/Foundation/Servant.hs
index e522d9094..380703d79 100644
--- a/src/Foundation/Servant.hs
+++ b/src/Foundation/Servant.hs
@@ -9,19 +9,15 @@ module Foundation.Servant
 
 import Import.Servant.NoFoundation
 import Foundation.DB (runSqlPoolRetry')
-import Foundation.Authorization (maybeBearerToken)
+import Foundation.Authorization (maybeBearerToken, IsDryRun(..), isDryRun)
 import Foundation.Instances ()
 
 import qualified Data.HashMap.Strict.InsOrd as HashMap
 
-import Network.Wai (Middleware, modifyResponse, mapResponseHeaders, vault)
+import Network.Wai (Middleware, modifyResponse, mapResponseHeaders)
 import qualified Network.Wai as W
 
-import qualified Data.Vault.Lazy as Vault
-
-import Servant.Server.Internal.DelayedIO (DelayedIO, delayedFail, delayedFailFatal, withRequest)
-
-import System.IO.Unsafe (unsafePerformIO)
+import Servant.Server.Internal.DelayedIO (DelayedIO, delayedFail, delayedFailFatal)
 
 import qualified Yesod.Servant as Servant
 
@@ -32,21 +28,16 @@ import Control.Monad.Catch.Pure
 import Servant.Server.Internal.Delayed
 import Servant.Server.Internal.Router
 
--- import Database.Persist.Sql (transactionUndo)
+import Database.Persist.Sql (transactionUndo)
 
-
-waiBearerKey :: Vault.Key (Maybe (BearerToken UniWorX))
-waiBearerKey = unsafePerformIO Vault.newKey
-{-# NOINLINE waiBearerKey #-}
-
-waiRouteKey :: Vault.Key (Route UniWorX)
-waiRouteKey = unsafePerformIO Vault.newKey
-{-# NOINLINE waiRouteKey #-}
+import qualified Data.CaseInsensitive as CI
 
 
 instance ( HasServer sub context
          , ToJSON restr, FromJSON restr
          , SBoolI (FoldRequired mods)
+         , HasContextEntry context (Maybe (BearerToken UniWorX))
+         , HasContextEntry context (Maybe (Route UniWorX))
          )
       => HasServer (CaptureBearerRestriction' mods restr :> sub) context
   where
@@ -56,25 +47,25 @@ instance ( HasServer sub context
     hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @sub) pc nt . s
 
     route _ context subserver
-      = route (Proxy @sub) context (subserver `addAuthCheck` withRequest bearerCheck)
+      = route (Proxy @sub) context (subserver `addAuthCheck` bearerCheck)
       where
-        bearerCheck :: W.Request -> DelayedIO (RequiredArgument mods restr)
-        bearerCheck req = do
-          let bearer = Vault.lookup waiBearerKey $ vault req
-              cRoute = Vault.lookup waiRouteKey  $ vault req
+        bearerCheck :: DelayedIO (RequiredArgument mods restr)
+        bearerCheck = do
+          let bearer :: Maybe (BearerToken UniWorX)
+              bearer = getContextEntry context
+              cRoute :: Maybe (Route UniWorX)
+              cRoute = getContextEntry context
 
-              noRouteStored, noTokenStored, noTokenProvided, noRestrictionProvided :: ServerError
-              noTokenStored = err500 { errBody = "servantYesodMiddleware did not store bearer token in WAI vault." }
+              noRouteStored, noTokenProvided, noRestrictionProvided :: ServerError
               noTokenProvided = err400 { errBody = "The behaviour of this route depends on restrictions stored in the bearer token used for authorization. Therefor providing a bearer token is required." }
               noRestrictionProvided = err400 { errBody = "The behaviour of this route depends on restrictions stored in the bearer token used for authorization. Therefor the provided bearer token must contain a restriction entry for this route." }
               noRouteStored = err500 { errBody = "servantYesodMiddleware did not store current route in WAI vault." }
 
           exceptT delayedFailFatal return $ do
-            bearer' <- maybeExceptT' noTokenStored bearer
             cRoute' <- maybeExceptT' noRouteStored cRoute
 
             let mbRet :: Maybe (Maybe restr)
-                mbRet = bearer' <&> preview (_bearerRestrictionIx cRoute')
+                mbRet = bearer <&> preview (_bearerRestrictionIx cRoute')
             case sbool @(FoldRequired mods) of
               SFalse -> return $ join mbRet
               STrue  -> maybe (throwE noTokenProvided) (maybe (throwE noRestrictionProvided) return) mbRet
@@ -82,6 +73,7 @@ instance ( HasServer sub context
 
 instance ( HasServer sub context
          , SBoolI (FoldRequired mods)
+         , HasContextEntry context (Maybe (BearerToken UniWorX))
          )
       => HasServer (CaptureBearerToken' mods :> sub) context
   where
@@ -91,21 +83,20 @@ instance ( HasServer sub context
     hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @sub) pc nt . s
 
     route _ context subserver
-      = route (Proxy @sub) context (subserver `addAuthCheck` withRequest bearerCheck)
+      = route (Proxy @sub) context (subserver `addAuthCheck` bearerCheck)
       where
-        bearerCheck :: W.Request -> DelayedIO (RequiredArgument mods (BearerToken UniWorX))
-        bearerCheck req = do
-          let bearer = Vault.lookup waiBearerKey $ vault req
+        bearerCheck :: DelayedIO (RequiredArgument mods (BearerToken UniWorX))
+        bearerCheck = do
+          let bearer :: Maybe (BearerToken UniWorX)
+              bearer = getContextEntry context
 
-              noTokenStored, noTokenProvided :: ServerError
-              noTokenStored = err500 { errBody = "servantYesodMiddleware did not store bearer token in WAI vault." }
+              noTokenProvided :: ServerError
               noTokenProvided = err400 { errBody = "The behaviour of this route depends on restrictions stored in the bearer token used for authorization. Therefor providing a bearer token is required." }
 
           exceptT delayedFailFatal return $ do
-            bearer' <- maybeExceptT' noTokenStored bearer
             case sbool @(FoldRequired mods) of
-              SFalse -> return bearer'
-              STrue  -> maybe (throwE noTokenProvided) return bearer'
+              SFalse -> return bearer
+              STrue  -> maybe (throwE noTokenProvided) return bearer
 
 
 instance ( HasServer sub context
@@ -132,23 +123,40 @@ instance ( HasServer sub context
       decrypt' inp = left tshow . runCatch . runReaderT (decrypt inp) . appCryptoIDKey $ getContextEntry context
 
 
-type UniWorXContext = UniWorX ': '[]
+type UniWorXContext = Maybe (Route UniWorX) ': Maybe (BearerToken UniWorX) ': IsDryRun ': UniWorX ': '[]
 type ServantHandler = ServantHandlerFor UniWorX
 type ServantDB      = ServantDBFor      UniWorX
 
 deriving via (ServantLogYesod UniWorX) instance ServantLog UniWorX
 
+instance HasServantHandlerContext UniWorX where
+  data ServantHandlerContextFor UniWorX = ServantHandlerContextForUniWorX
+    { usctxSite     :: UniWorX
+    , usctxRequest  :: W.Request
+    , usctxIsDryRun :: IsDryRun
+    }
+  getSCtxSite = usctxSite
+  getSCtxRequest = usctxRequest
+
 class (HasServer (ServantApiUnproxy' proxy) UniWorXContext, Servant.HasRoute (ServantApiUnproxy' proxy)) => ServantApiDispatchUniWorX proxy where
   servantServer' :: ServantApi proxy -> ServerT (ServantApiUnproxy' proxy) ServantHandler
 
 instance ServantApiDispatchUniWorX proxy => ServantApiDispatch UniWorXContext ServantHandler UniWorX proxy where
-  servantContext _ app _ = return $ app :. EmptyContext
-  servantHoist _ sctxSite sctxRequest _ = ($ ServantHandlerContextFor{..}) . unServantHandlerFor
-  servantMiddleware _ _ _ = modifyResponse (mapResponseHeaders setDefaultHeaders) . fixTrailingSlash
-  servantYesodMiddleware _ _ = appEndo <$> foldMapM (fmap Endo) [storeBearerToken, storeCurrentRoute]
+  servantContext _ app _ = do
+    isDryRun' <- MkIsDryRun <$> isDryRun
+    restr <- maybeBearerToken
+    cRoute <- getCurrentRoute
+    return $ cRoute :. restr :. isDryRun' :. app :. EmptyContext
+  servantHoist _ usctxSite usctxRequest ctx = ($ ServantHandlerContextForUniWorX{ usctxIsDryRun = getContextEntry ctx, .. }) . unServantHandlerFor
+  servantMiddleware _ _ ctx = appEndo . foldMap Endo $
+       guardOn (unIsDryRun $ getContextEntry ctx) (modifyResponse $ mapResponseHeaders setDryRunHeader)
+    ++ [ modifyResponse (mapResponseHeaders setDefaultHeaders)
+       , fixTrailingSlash
+       ]
+  servantYesodMiddleware _ _ = return id
   servantServer proxy _ = servantServer' proxy
 
-setDefaultHeaders :: ResponseHeaders -> ResponseHeaders
+setDefaultHeaders, setDryRunHeader :: ResponseHeaders -> ResponseHeaders
 setDefaultHeaders existing = HashMap.toList $ HashMap.fromList existing <> defaultHeaders
   where defaultHeaders = HashMap.fromList
           [ ("X-Frame-Options", "sameorigin")
@@ -156,6 +164,7 @@ setDefaultHeaders existing = HashMap.toList $ HashMap.fromList existing <> defau
           , ("Vary", "Accept")
           , ("X-XSS-Protection", "1; mode=block")
           ]
+setDryRunHeader existing = HashMap.toList $ HashMap.fromList existing <> HashMap.singleton (CI.mk . encodeUtf8 $ toPathPiece HeaderDryRun) (encodeUtf8 $ toPathPiece True)
 
 fixTrailingSlash :: Middleware
 -- ^ `servant-server` contains a special case in their implementation
@@ -170,17 +179,6 @@ fixTrailingSlash = (. fixTrailingSlash')
           | otherwise
           = req
 
-storeBearerToken, storeCurrentRoute :: HandlerFor UniWorX Middleware
-storeBearerToken = do
-  restr <- maybeBearerToken
-  return $ \app req -> app req{ vault = Vault.insert waiBearerKey restr $ vault req }
-storeCurrentRoute = do
-  cRoute <- getCurrentRoute
-
-  $logDebugS "storeCurrentRoute" $ tshow cRoute
-  
-  return $ \app req -> app req{ vault = maybe id (Vault.insert waiRouteKey) cRoute $ vault req }
-
 
 instance ServantPersist UniWorX where
   runDB :: HasCallStack => ServantDBFor UniWorX a -> ServantHandlerFor UniWorX a
@@ -189,9 +187,9 @@ instance ServantPersist UniWorX where
 runDB' :: CallStack -> ServantDBFor UniWorX a -> ServantHandlerFor UniWorX a
 runDB' lbl action = do
   $logDebugS "ServantPersist" "runDB"
-  -- let action' = do
-  --       dryRun <- isDryRunDB
-  --       if | dryRun    -> action <* transactionUndo
-  --          | otherwise -> action
+  MkIsDryRun dryRun <- getsServantContext usctxIsDryRun
+  let action'
+        | dryRun    = action <* transactionUndo
+        | otherwise = action
 
-  flip (runSqlPoolRetry' action) lbl . appConnPool =<< getSite
+  flip (runSqlPoolRetry' action') lbl . appConnPool =<< getSite
diff --git a/src/Foundation/Servant/Types.hs b/src/Foundation/Servant/Types.hs
index 3e4c8b4d1..f10462d14 100644
--- a/src/Foundation/Servant/Types.hs
+++ b/src/Foundation/Servant/Types.hs
@@ -5,12 +5,14 @@ module Foundation.Servant.Types
   , CaptureBearerToken, CaptureBearerToken'
   , CaptureCryptoID', CaptureCryptoID, CaptureCryptoUUID, CaptureCryptoFileName
   , ApiVersion, apiVersionToSemVer, matchesApiVersion
+  , BearerAuth, SessionAuth
   ) where
 
-import ClassyPrelude
+import ClassyPrelude hiding (fromList)
 import Data.Proxy
 
 import Servant.API
+import Servant.API.Modifiers (FoldRequired)
 import Servant.API.Description
 import Servant.Swagger
 import Servant.Docs
@@ -21,6 +23,13 @@ import Servant.Server.Internal.Delayed
 import Servant.Server.Internal.ErrorFormatter
 -- import Servant.Server.Internal.DelayedIO
 
+import Servant.Client.Core.RunClient (RunClient)
+import Servant.Client.Core.HasClient
+import qualified Servant.Client.Core.Request as Servant (Request)
+import qualified Servant.Client.Core.Request as Request
+
+import Jose.Jwt (Jwt(..))
+
 import Network.Wai (mapResponseHeaders, requestHeaders)
 
 import Control.Lens hiding (Context)
@@ -31,8 +40,9 @@ import Data.CryptoID.Class.ImplicitNamespace
 import Data.CryptoID.Instances ()
 
 import GHC.TypeLits
+import GHC.Exts (IsList(..))
 
-import Data.Swagger (ToParamSchema)
+import Data.Swagger hiding (version)
 
 import Data.Kind (Type)
 
@@ -114,6 +124,11 @@ instance HasDocs sub => HasDocs (CaptureBearerToken' mods :> sub) where
 instance (ToCapture (Capture sym ciphertext), KnownSymbol sym, HasDocs sub) => HasDocs (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
   docsFor _ = docsFor $ Proxy @(Capture' mods sym ciphertext :> sub)
 
+instance (RunClient m, HasClient m (Capture' mods sym (CryptoID ciphertext plaintext) :> sub)) => HasClient m (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
+  type Client m (CaptureCryptoID' mods ciphertext sym plaintext :> sub) = Client m (Capture' mods sym (CryptoID ciphertext plaintext) :> sub)
+  clientWithRoute pm _ = clientWithRoute pm $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub)
+  hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub)
+
 
 type family ApiVersionSub major minor patch sup sub where
   ApiVersionSub major minor patch (ApiVersion major' minor' patch') sub = ApiVersion major' minor' patch' :> sub
@@ -143,8 +158,30 @@ instance ( HasServer (ApiVersion major minor patch :> a) context
       choice' = case (sbool :: SBool (IsLT (CmpVersion (FinalApiVersion (ApiVersion major minor patch :> a)) (FinalApiVersion (ApiVersion major minor patch :> b))))) of
         STrue  -> flip choice
         SFalse -> choice
+
+instance (RunClient m, HasClient m (ApiVersionSub major minor patch sup sub)) => HasClient m (ApiVersion major minor patch :> ((sup :: Type) :> sub)) where
+  type Client m (ApiVersion major minor patch :> (sup :> sub)) = Client m (ApiVersionSub major minor patch sup sub)
+  clientWithRoute pm _ = clientWithRoute pm $ Proxy @(ApiVersionSub major minor patch sup sub)
+  hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(ApiVersionSub major minor patch sup sub)
+
+instance (RunClient m, HasClient m (sup :> (ApiVersion major minor patch :> sub))) => HasClient m (ApiVersion major minor patch :> ((sup :: Symbol) :> sub)) where
+  type Client m (ApiVersion major minor patch :> (sup :> sub)) = Client m (sup :> (ApiVersion major minor patch :> sub))
+  clientWithRoute pm _ = clientWithRoute pm $ Proxy @(sup :> (ApiVersion major minor patch :> sub))
+  hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(sup :> (ApiVersion major minor patch :> sub))
+
+instance ( HasClient m (ApiVersion major minor patch :> a)
+         , HasClient m (ApiVersion major minor patch :> b)
+         ) => HasClient m (ApiVersion major minor patch :> (a :<|> b)) where
+  type Client m (ApiVersion major minor patch :> (a :<|> b)) = Client m (ApiVersion major minor patch :> a) :<|> Client m (ApiVersion major minor patch :> b)
+  clientWithRoute pm _ req = clientWithRoute pm (Proxy @(ApiVersion major minor patch :> a)) req
+                        :<|> clientWithRoute pm (Proxy @(ApiVersion major minor patch :> b)) req
+  hoistClientMonad pm _ f (ca :<|> cb) = hoistClientMonad pm (Proxy @(ApiVersion major minor patch :> a)) f ca
+                                    :<|> hoistClientMonad pm (Proxy @(ApiVersion major minor patch :> b)) f cb
          
   
+versionRequestHeaderName :: CI ByteString
+versionRequestHeaderName = "Accept-API-Version"
+  
 routeWithApiVersion :: forall api context env major minor patch.
                        ( HasServer api context
                        , KnownNat major, KnownNat minor, KnownNat patch
@@ -168,7 +205,6 @@ routeWithApiVersion _ _ context subserver = RawRouter $ \env req ((. addVersion)
         version = apiVersionToSemVer $ Proxy @(ApiVersion major minor patch)
 
         versionHeaderName = "API-Version"
-        versionRequestHeaderName = "Accept-API-Version"
         versionHeader = encodeUtf8 $ SemVer.toText version
 
         notFound = notFoundErrorFormatter . getContextEntry $ mkContextWithErrorFormatter context
@@ -194,6 +230,26 @@ instance ( HasServer (NoContentVerb method) context
   route _ = routeWithApiVersion (Proxy @(ApiVersion major minor patch)) (Proxy @(NoContentVerb method))
 
 
+semVerCompatibleTo :: SemVer.Version -> SemVer.Constraint
+semVerCompatibleTo v = SemVer.Constraint.CAnd (SemVer.Constraint.CGtEq v) (SemVer.Constraint.CLt $ SemVer.incrementMajor v)
+  
+instance ( HasClient m (Verb method statusCode contentTypes a)
+         , KnownNat major, KnownNat minor, KnownNat patch
+         ) => HasClient m (ApiVersion major minor patch :> Verb method statusCode contentTypes a) where
+  type Client m (ApiVersion major minor patch :> Verb method statusCode contentTypes a) = Client m (Verb method statusCode contentTypes a)
+  clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method statusCode contentTypes a)) . Request.addHeader versionRequestHeaderName (semVerCompatibleTo version)
+    where version = apiVersionToSemVer $ Proxy @(ApiVersion major minor patch)
+  hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(Verb method statusCode contentTypes a)
+
+instance ( HasClient m (NoContentVerb method)
+         , KnownNat major, KnownNat minor, KnownNat patch
+         ) => HasClient m (ApiVersion major minor patch :> NoContentVerb method) where
+  type Client m (ApiVersion major minor patch :> NoContentVerb method) = Client m (NoContentVerb method)
+  clientWithRoute pm _ = clientWithRoute pm (Proxy @(NoContentVerb method)) . Request.addHeader versionRequestHeaderName (semVerCompatibleTo version)
+    where version = apiVersionToSemVer $ Proxy @(ApiVersion major minor patch)
+  hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(NoContentVerb method)
+
+
 instance ( HasDocs (ApiVersionSub major minor patch sup sub)
          ) => HasDocs (ApiVersion major minor patch :> ((sup :: Type) :> sub)) where
   docsFor _ = docsFor $ Proxy @(ApiVersionSub major minor patch sup sub)
@@ -263,3 +319,105 @@ type family IsLT x where
 type instance IsElem' sa (CaptureCryptoID' mods ciphertext sym plaintext :> sb) = IsElem sa (Capture' mods sym (CryptoID ciphertext plaintext) :> sb)
 
 type instance IsElem' sa (ApiVersion major minor patch :> sb) = IsElem sa sb
+
+
+type family StripBearer api where
+  StripBearer (CaptureBearerRestriction' mods restr :> sub) = sub
+  StripBearer (CaptureBearerToken' mods :> sub) = sub
+  StripBearer (BearerAuth :> sub) = sub
+  StripBearer (sup :> sub) = sup :> StripBearer sub
+  StripBearer (a :<|> b) = StripBearer a :<|> StripBearer b
+  StripBearer (Verb method statusCode contentTypes a) = Verb method statusCode contentTypes a
+  StripBearer (NoContentVerb method) = NoContentVerb method
+
+type family BearerRequired api where
+  BearerRequired (CaptureBearerRestriction' mods restr :> sub) = OrBool (FoldRequired mods) (BearerRequired sub)
+  BearerRequired (CaptureBearerToken' mods :> sub) = OrBool (FoldRequired mods) (BearerRequired sub)
+  BearerRequired (BearerAuth :> sub) = 'True
+  BearerRequired (sup :> sub) = BearerRequired sub
+  BearerRequired (a :<|> b) = OrBool (BearerRequired a) (BearerRequired b)
+  BearerRequired (Verb method statusCode contentTypes a) = 'False
+  BearerRequired (NoContentVerb method) = 'False
+
+type family OrBool a b where
+  OrBool 'False 'False = 'False 
+  OrBool a b = 'True
+
+maybeWithJwt :: forall (a :: Bool). SBoolI a => Proxy a -> If a Jwt (Maybe Jwt) -> Servant.Request -> Servant.Request
+maybeWithJwt _ mparam = case (sbool :: SBool a, mparam) of
+    (STrue, jwt) -> add jwt
+    (SFalse, mJwt) -> maybe id add mJwt
+  where add (Jwt jwt) = Request.addHeader "Authorization" . decodeUtf8 $ "Bearer " <> jwt
+
+instance ( HasClient m (StripBearer sub)
+         , RunClient m
+         , SBoolI (BearerRequired (CaptureBearerRestriction' mods restr :> sub))
+         ) => HasClient m (CaptureBearerRestriction' mods restr :> sub) where
+  type Client m (CaptureBearerRestriction' mods restr :> sub) = If (BearerRequired (CaptureBearerRestriction' mods restr :> sub)) Jwt (Maybe Jwt) -> Client m (StripBearer sub)
+  clientWithRoute pm _ req mparam = clientWithRoute pm (Proxy @(StripBearer sub)) $ maybeWithJwt (Proxy @(BearerRequired (CaptureBearerRestriction' mods restr :> sub))) mparam req
+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy @(StripBearer sub)) f . cl
+
+instance ( HasClient m (StripBearer sub)
+         , RunClient m
+         , SBoolI (BearerRequired (CaptureBearerToken' mods :> sub))
+         ) => HasClient m (CaptureBearerToken' mods :> sub) where
+  type Client m (CaptureBearerToken' mods :> sub) = If (BearerRequired (CaptureBearerToken' mods :> sub)) Jwt (Maybe Jwt) -> Client m (StripBearer sub)
+  clientWithRoute pm _ req mparam = clientWithRoute pm (Proxy @(StripBearer sub)) $ maybeWithJwt (Proxy @(BearerRequired (CaptureBearerToken' mods :> sub))) mparam req
+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy @(StripBearer sub)) f . cl
+
+instance ( HasClient m (StripBearer sub)
+         , RunClient m
+         , SBoolI (BearerRequired (BearerAuth :> sub))
+         ) => HasClient m (BearerAuth :> sub) where
+  type Client m (BearerAuth :> sub) = If (BearerRequired (BearerAuth :> sub)) Jwt (Maybe Jwt) -> Client m (StripBearer sub)
+  clientWithRoute pm _ req mparam = clientWithRoute pm (Proxy @(StripBearer sub)) $ maybeWithJwt (Proxy @(BearerRequired (BearerAuth :> sub))) mparam req
+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy @(StripBearer sub)) f . cl
+
+
+data BearerAuth
+data SessionAuth
+
+instance HasSwagger sub => HasSwagger (BearerAuth :> sub) where
+  toSwagger _ = toSwagger (Proxy @sub)
+    & securityDefinitions <>~ 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"
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index fc51f0302..06a8e4af7 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -40,7 +40,7 @@ import Yesod.Core.Types       as Import (loggerSet)
 import Yesod.Default.Config2  as Import
 import Yesod.Core.Types.Instances as Import
 import Yesod.Servant          as Import
-  hiding ( MonadHandler(..), HasRoute(..)
+  hiding ( MonadHandler(..), HasRoute(..), MonadRequest(..)
          , runDB, defaultRunDB
          )
 import Servant.Docs           as Import
@@ -210,6 +210,7 @@ import Data.MonoTraversable.Instances as Import ()
 import Servant.Client.Core.BaseUrl.Instances as Import ()
 import Control.Monad.Trans.Except.Instances as Import ()
 import Servant.Server.Instances as Import ()
+import Servant.Docs.Internal.Pretty.Instances as Import ()
 import Network.URI.Instances as Import ()
 import Data.HashSet.Instances as Import ()
 import Web.Cookie.Instances as Import ()
diff --git a/src/Import/Servant/NoFoundation.hs b/src/Import/Servant/NoFoundation.hs
index 7e8c66b84..c9b4e06c6 100644
--- a/src/Import/Servant/NoFoundation.hs
+++ b/src/Import/Servant/NoFoundation.hs
@@ -14,6 +14,7 @@ import Import.NoFoundation as Import hiding
   , MonadHandler(..), HasRoute(..), liftHandler
   , encrypt, decrypt
   , Unique, Fragment(..), respond
+  , getRequest
   )
 
 import Yesod.Servant as Import
diff --git a/src/Servant/Docs/Internal/Pretty/Instances.hs b/src/Servant/Docs/Internal/Pretty/Instances.hs
new file mode 100644
index 000000000..24b761d96
--- /dev/null
+++ b/src/Servant/Docs/Internal/Pretty/Instances.hs
@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Servant.Docs.Internal.Pretty.Instances () where
+
+import ClassyPrelude
+
+import Servant.Docs.Internal.Pretty
+import Servant.API.ContentTypes
+
+import Data.Proxy
+
+
+instance MimeUnrender JSON a => MimeUnrender PrettyJSON a where
+  mimeUnrender _ = mimeUnrender $ Proxy @JSON
diff --git a/src/ServantApi/ExternalApis/Type.hs b/src/ServantApi/ExternalApis/Type.hs
index 181f2bca2..4a1b6be51 100644
--- a/src/ServantApi/ExternalApis/Type.hs
+++ b/src/ServantApi/ExternalApis/Type.hs
@@ -15,17 +15,22 @@ import Jose.Jwk (JwkSet(..))
 {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
 
 
-type ExternalApisListR = Get '[PrettyJSON] ExternalApisList
-type ExternalApisCreateR = CaptureBearerRestriction' '[Optional] ExternalApiCreationRestrictions
+type ExternalApisListR = ApiVersion 1 0 0
+                      :> Get '[PrettyJSON] ExternalApisList
+type ExternalApisCreateR = ApiVersion 1 0 0
+                        :> CaptureBearerRestriction' '[Optional] ExternalApiCreationRestrictions
                         :> CaptureBearerToken
                         :> ReqBody '[JSON] ExternalApiCreationRequest
                         :> PostCreated '[PrettyJSON] (Headers '[Header "Location" URI] ExternalApiCreationResponse)
-type ExternalApisPongR = CaptureCryptoUUID "external-api" ExternalApiId
+type ExternalApisPongR = ApiVersion 1 0 0
+                      :> CaptureCryptoUUID "external-api" ExternalApiId
                       :> "pong"
                       :> Post '[PrettyJSON] ExternalApiPongResponse
-type ExternalApisInfoR = CaptureCryptoUUID "external-api" ExternalApiId
+type ExternalApisInfoR = ApiVersion 1 0 0
+                      :> CaptureCryptoUUID "external-api" ExternalApiId
                       :> Get '[PrettyJSON] ExternalApiInfo
-type ExternalApisDeleteR = CaptureCryptoUUID "external-api" ExternalApiId
+type ExternalApisDeleteR = ApiVersion 1 0 0
+                        :> CaptureCryptoUUID "external-api" ExternalApiId
                         :> DeleteNoContent
 
 data ExternalApis mode = ExternalApis
@@ -37,7 +42,7 @@ data ExternalApis mode = ExternalApis
   } deriving (Generic)
 
 type ServantApiExternalApis = ServantApi ExternalApis
-type instance ServantApiUnproxy ExternalApis = ApiVersion 1 0 0 :> ToServantApi ExternalApis
+type instance ServantApiUnproxy ExternalApis = ToServantApi ExternalApis
 
 
 instance ToCapture (Capture "external-api" UUID) where
@@ -122,7 +127,9 @@ data ExternalApiInfo = ExternalApiInfo
 
 instance ToJSON ExternalApiInfo where
   toJSON ExternalApiInfo{..} = object $ maybe id ((:) . ("ident" .=)) eaiIdent
-    [ "token-authority" .= foldMap (HashSet.singleton . either id toJSON) eaiTokenAuthority
+    [ "token-authority" .= case HashSet.toList eaiTokenAuthority of
+        [x] -> either id toJSON x
+        _   -> toJSON $ foldMap (HashSet.singleton . either id toJSON) eaiTokenAuthority
     , "token-issued" .= eaiTokenIssued
     , "token-expires-at" .= eaiTokenExpiresAt
     , "token-starts-at" .= eaiTokenStartsAt
@@ -134,11 +141,11 @@ instance ToJSON ExternalApiInfo where
 
 instance FromJSON ExternalApiInfo where
   parseJSON = withObject "ExternalApiInfo" $ \o -> do
-    eaiIdent <- o .:? "token-authority"
+    eaiIdent <- o .:? "ident"
     eaiTokenAuthority <- asum
-      [ HashSet.singleton . Right <$> o .: "authority"
-      , (o .: "authority" :: _ (HashSet Value)) >>= foldMapM (\v' -> fmap HashSet.singleton $ (Right <$> parseJSON v') <|> return (Left v'))
-      , HashSet.singleton . Left  <$> o .: "authority"
+      [ HashSet.singleton . Right <$> o .: "token-authority"
+      , (o .: "token-authority" :: _ (HashSet Value)) >>= foldMapM (\v' -> fmap HashSet.singleton $ (Right <$> parseJSON v') <|> return (Left v'))
+      , HashSet.singleton . Left  <$> o .: "token-authority"
       ]
     eaiTokenIssued <- o .: "token-issued"
     eaiTokenExpiresAt <- o .: "token-expires-at"
diff --git a/src/Utils.hs b/src/Utils.hs
index 862ae9cc9..4b8f8de89 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -113,7 +113,9 @@ import Data.Binary (Binary)
 import qualified Data.Binary as Binary
 
 import Network.Wai (requestMethod)
-import Network.HTTP.Types.Header
+import Network.HTTP.Types.Header as Wai
+
+import Web.HttpApiData
 
 import Data.Time.Clock
 
@@ -1143,6 +1145,9 @@ addCustomHeader, replaceOrAddCustomHeader :: (MonadHandler m, PathPiece payload)
 addCustomHeader ident payload = addHeader (toPathPiece ident) (toPathPiece payload)
 replaceOrAddCustomHeader ident payload = replaceOrAddHeader (toPathPiece ident) (toPathPiece payload)
 
+waiCustomHeader :: ToHttpApiData payload => CustomHeader -> payload -> Wai.Header
+waiCustomHeader ident payload = (CI.mk . encodeUtf8 $ toPathPiece ident, toHeader payload)
+
 ------------------
 -- HTTP Headers --
 ------------------
diff --git a/src/Yesod/Servant.hs b/src/Yesod/Servant.hs
index 2f2e567d4..3abe2732d 100644
--- a/src/Yesod/Servant.hs
+++ b/src/Yesod/Servant.hs
@@ -8,8 +8,8 @@ module Yesod.Servant
   , ServantApiDispatch(..)
   , servantApiLink
   , ServantHandlerFor(..)
-  , ServantHandlerContextFor(..), getServantContext, getsServantContext, getYesodApproot, renderRouteAbsolute
-  , MonadServantHandler(..), MonadHandler(..), MonadSite(..)
+  , HasServantHandlerContext(..), getServantContext, getsServantContext, getYesodApproot, renderRouteAbsolute, servantApiBaseUrl
+  , MonadServantHandler(..), MonadHandler(..), MonadSite(..), MonadRequest(..)
   , ServantDBFor, ServantPersist(..), defaultRunDB
   , ServantLog(..), ServantLogYesod(..)
   , mkYesodApi
@@ -45,6 +45,8 @@ 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)
@@ -59,13 +61,10 @@ import Control.Monad.Fail (MonadFail(..))
 
 import Data.Data (Data)
 import Data.Kind (Type)
-import GHC.Exts (IsList(..), Constraint)
+import GHC.Exts (Constraint)
   
-import Servant.Swagger
 import Data.Swagger
 
-import Servant.Docs
-
 import qualified Data.Set as Set
 
 import Network.HTTP.Types.Status
@@ -138,75 +137,92 @@ instance (Typeable m, Typeable k, Typeable status, Typeable fr, Typeable ct, Typ
 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
@@ -214,11 +230,13 @@ instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable plaintext, ToHt
     | 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
@@ -249,45 +267,56 @@ instance HasRoute (ServantApiUnproxy' proxy) => RenderRoute (ServantApi proxy) w
       (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` typeRep (Proxy @endpoint) `hashWithSalt` ps `hashWithSalt` qs
+  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 -> 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)
+  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 "
@@ -296,6 +325,7 @@ instance HasRoute (ServantApiUnproxy' proxy) => Show (Route (ServantApi proxy))
     . showsPrec 11 ps
     . showString " "
     . showsPrec 11 qs
+  showsPrec _ ServantApiBaseRoute = showString "ServantApiBaseRoute"
 
 instance HasRoute (ServantApiUnproxy' proxy) => ParseRoute (ServantApi proxy) where
   parseRoute = parseServantRoute
@@ -385,10 +415,10 @@ servantApiLink _ _ = safeLink' (fromMaybe (error "Could not parse result of safe
     guardEndpoint _ = Nothing
 
   
-data ServantHandlerContextFor site = ServantHandlerContextFor
-  { sctxSite :: site
-  , sctxRequest :: Request
-  }
+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, Typeable)
@@ -404,10 +434,10 @@ 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
+getYesodApproot :: (Yesod site, MonadSite site m, MonadRequest m) => m Text
+getYesodApproot = Yesod.getApprootText Yesod.approot <$> getSite <*> getRequest
 
-renderRouteAbsolute :: (Yesod site, MonadServantHandler site m) => Route site -> m URI
+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
@@ -419,13 +449,16 @@ renderRouteAbsolute (renderRoute -> (ps, qs)) = addRoute . unpack <$> getYesodAp
         addQuery "?" = addQuery ""
         addQuery q = q <> "&" <> tailEx (addQuery "")
 
-class MonadIO m => MonadServantHandler site m | m -> site where
+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 MonadServantHandler site (ServantHandlerFor site) where
+instance HasServantHandlerContext site => MonadServantHandler site (ServantHandlerFor site) where
   liftServantHandler = id
 
-instance (MonadTrans t, MonadIO (t (ServantHandlerFor site))) => MonadServantHandler site (t (ServantHandlerFor site)) where
+instance (MonadTrans t, MonadIO (t (ServantHandlerFor site)), HasServantHandlerContext site) => MonadServantHandler site (t (ServantHandlerFor site)) where
   liftServantHandler = lift
 
 class MonadIO m => MonadHandler m where
@@ -443,8 +476,8 @@ class Monad m => MonadSite site m | m -> site where
   getsSite :: (site -> a) -> m a
   getsSite f = f <$> getSite
 
-instance MonadSite site (ServantHandlerFor site) where
-  getSite = liftServantHandler . ServantHandlerFor $ return . sctxSite
+instance HasServantHandlerContext site => MonadSite site (ServantHandlerFor site) where
+  getSite = liftServantHandler . ServantHandlerFor $ return . getSCtxSite
 
 instance MonadSite site (Reader site) where
   getSite = ask
@@ -454,10 +487,22 @@ instance {-# OVERLAPPABLE #-} (Yesod.MonadHandler m, site ~ Yesod.HandlerSite m)
   getSite = Yesod.getYesod
   getsSite = Yesod.getsYesod
 
-instance {-# OVERLAPPING #-} (MonadTrans t, Monad (t (ServantHandlerFor site))) => MonadSite site (t (ServantHandlerFor site)) where
+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)
 
@@ -466,6 +511,7 @@ class Yesod.YesodPersist site => ServantPersist site where
 
 defaultRunDB :: ( PersistConfig c
                 , ServantDBFor site a ~ PersistConfigBackend c (ServantHandlerFor site) a
+                , HasServantHandlerContext site
                 )
              => Getting c site c
              -> Getting (PersistConfigPool c) site (PersistConfigPool c)
@@ -485,12 +531,12 @@ instance Yesod site => ServantLog (ServantLogYesod site) where
     logger <- Yesod.makeLogger app
     Yesod.messageLoggerSource app logger a b c d
 
-instance ServantLog site => MonadLogger (ServantHandlerFor site) where
+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 => MonadLoggerIO (ServantHandlerFor site) where
+instance (ServantLog site, HasServantHandlerContext site) => MonadLoggerIO (ServantHandlerFor site) where
   askLoggerIO = servantLogLog <$> getSite
 
 
@@ -501,56 +547,6 @@ 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 <>~ 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
diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs
index 8d2758458..04344823f 100644
--- a/test/Model/TypesSpec.hs
+++ b/test/Model/TypesSpec.hs
@@ -51,6 +51,8 @@ import qualified Data.SemVer as SemVer
 import qualified Data.SemVer.Constraint as SemVer (Constraint)
 import qualified Data.SemVer.Constraint as SemVer.Constraint
 
+import qualified Data.HashSet as HashSet
+
 
 
 instance Arbitrary Season where
@@ -343,7 +345,9 @@ instance Arbitrary RoomReference' where
   arbitrary = genericArbitrary
 
 instance Arbitrary ExternalApiConfig where
-  arbitrary = genericArbitrary
+  arbitrary = oneof
+    [ EApiGradelistFormat <$> ((fmap HashSet.fromList . scale (`div` 10) $ listOf1 (resize 3 arbitrary)) `suchThatMap` fromNullable)
+    ]
   shrink = genericShrink
 
 instance Arbitrary SemVer.Version where
diff --git a/test/Servant/Client/Core/BaseUrl/TestInstances.hs b/test/Servant/Client/Core/BaseUrl/TestInstances.hs
index 07b8a4eb3..86dbe9453 100644
--- a/test/Servant/Client/Core/BaseUrl/TestInstances.hs
+++ b/test/Servant/Client/Core/BaseUrl/TestInstances.hs
@@ -7,7 +7,14 @@ import Network.URI
 import Network.URI.Arbitrary ()
 import Servant.Client.Core.BaseUrl
 
+import Control.Lens.Extras
+
 
 instance Arbitrary BaseUrl where
-  arbitrary = toBaseUrl <$> arbitrary
-    where toBaseUrl = either (error . displayException) id . parseBaseUrl . ($ mempty) . uriToString id
+  arbitrary = (`suchThatMap` toBaseUrl) $ do
+      uri <- scale (min 10) arbitrary `suchThat` (is _Just . uriAuthority)
+      uriScheme <- oneof $ map (return . (<> ":")) [ "http", "https" ]
+      let uriAuthority'' = uriAuthority uri <&> \uriAuthority' -> uriAuthority'{ uriUserInfo = "" }
+      return (uri, uriScheme, uriAuthority'')
+    where
+      toBaseUrl (uri, uriScheme, uriAuthority'') = either (const Nothing) Just . parseBaseUrl . ($ mempty) $ uriToString (const mempty) uri{ uriScheme, uriAuthority = uriAuthority'', uriQuery = "", uriFragment = "" }
diff --git a/test/ServantApi/ExternalApis/TypeSpec.hs b/test/ServantApi/ExternalApis/TypeSpec.hs
index 466ba5b7e..312aa6cad 100644
--- a/test/ServantApi/ExternalApis/TypeSpec.hs
+++ b/test/ServantApi/ExternalApis/TypeSpec.hs
@@ -8,7 +8,10 @@ import ServantApi.ExternalApis.Type
 
 
 instance Arbitrary ExternalApiCreationRequest where
-  arbitrary = genericArbitrary
+  arbitrary = ExternalApiCreationRequest
+    <$> scale (`div` 2) arbitrary
+    <*> scale (`div` 2) arbitrary
+    <*> scale (`div` 2) arbitrary
   shrink = genericShrink
 
 
diff --git a/test/ServantApi/ExternalApisSpec.hs b/test/ServantApi/ExternalApisSpec.hs
new file mode 100644
index 000000000..2fba5b343
--- /dev/null
+++ b/test/ServantApi/ExternalApisSpec.hs
@@ -0,0 +1,48 @@
+{-# OPTIONS_GHC -Wno-error=unused-local-binds #-}
+
+module ServantApi.ExternalApisSpec where
+
+import TestImport
+import ServantApi.ExternalApis.Type
+import ServantApi.ExternalApis.TypeSpec ()
+
+import Servant.Client.Core (RequestF(..))
+import Servant.Client.Generic
+
+import Utils.Tokens
+import Data.Time.Clock (nominalDay)
+
+import qualified Data.HashSet as HashSet
+import qualified Data.HashMap.Strict as HashMap
+
+import qualified Data.Sequence as Seq
+
+import Control.Monad.Reader.Class (MonadReader(local))
+import Utils (CustomHeader(..), waiCustomHeader)
+
+
+spec :: Spec
+spec = withApp . describe "ExternalApis" $ do
+    it "Supports dryRun" $ do
+      adminId <- runDB $ do
+        Entity adminId _ <- insertEntity $ fakeUser id
+        ifi <- insert $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional Nothing True SchoolAuthorshipStatementModeRequired Nothing False
+        insert_ $ UserFunction adminId ifi SchoolAdmin
+        return adminId
+
+      accessToken <- runHandler $ encodeBearer =<< bearerToken (HashSet.singleton $ Right adminId) Nothing HashMap.empty Nothing Nothing Nothing
+
+      let
+        insertExternalApi = void $ externalApisCreateR accessToken =<< liftIO (generate $ resize 10 arbitrary)
+          where ExternalApis{..} = genericClient
+        withDryRun :: ServantExampleEnv -> ServantExampleEnv
+        withDryRun seEnv = seEnv
+          { yseMakeClientRequest = \burl req -> yseMakeClientRequest seEnv burl req{ requestHeaders = requestHeaders req Seq.:|> waiCustomHeader HeaderDryRun True }
+          }
+        externalApiCount = runDB $ count @_ @_ @ExternalApi []
+      
+      runServantExample ExternalApisR insertExternalApi
+      liftIO . (`shouldBe` 1) =<< externalApiCount
+
+      runServantExample ExternalApisR $ local withDryRun insertExternalApi
+      liftIO . (`shouldBe` 1) =<< externalApiCount
diff --git a/test/ServantApiSpec.hs b/test/ServantApiSpec.hs
new file mode 100644
index 000000000..001e9a7e7
--- /dev/null
+++ b/test/ServantApiSpec.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+module ServantApiSpec where
+
+import TestImport
+import ServantApi
+
+import Servant.API
+import Servant.API.TypeLevel (MapSub, AppendList)
+import Foundation.Servant.Types (ApiVersion)
+
+import GHC.TypeLits
+import Data.Kind (Constraint)
+
+
+type family Unversioned api where
+  Unversioned (ApiVersion _ _ _ :> _) = '[]
+  Unversioned (sup :> sub) = MapSub sup (Unversioned sub)
+  Unversioned (a :<|> b) = AppendList (Unversioned a) (Unversioned b)
+  Unversioned (Verb method statusCode contentTypes a) = '[Verb method statusCode contentTypes a]
+  Unversioned (NoContentVerb method) = '[NoContentVerb method]
+
+type family UnversionedError xs :: ErrorMessage where
+  UnversionedError (x ': '[]) = 'Text "Unversioned API endpoint: " ':$$: ('Text "  " ':<>: 'ShowType x)
+  UnversionedError (x ': xs) = UnversionedError (x ': '[]) ':$$: UnversionedError xs
+  
+type family IsEmpty xs :: Constraint where
+  IsEmpty '[] = ()
+  IsEmpty xs = TypeError ('Text "All API endpoints must be versioned." ':$$: UnversionedError xs)
+
+spec :: Spec
+spec = describe "Servant endpoints" $ it "are all versioned" versioned
+  where
+    versioned :: IsEmpty (Unversioned UniWorXApi) => Bool
+    versioned = True
diff --git a/test/TestImport.hs b/test/TestImport.hs
index be362d41d..ed01b32da 100644
--- a/test/TestImport.hs
+++ b/test/TestImport.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
+
 module TestImport
     ( module TestImport
     , module X
@@ -44,6 +46,34 @@ import Jobs (handleJobs)
 import Numeric.Natural as X
 import Network.URI.Arbitrary as X ()
 
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Test as Wai
+import qualified Network.Wai.Test.Internal as Wai (ClientState)
+import Network.HTTP.Types (Status(..), hContentType, hAccept)
+import Network.HTTP.Types.Header (hHost)
+import qualified Network.HTTP.Types as Wai
+
+import Control.Monad.Trans.Except (ExceptT)
+import qualified Servant.Client.Core as Servant
+import Servant.Client.Core.ClientError
+import Servant.Client.Core.RunClient
+import Control.Monad.Except (MonadError(..))
+import Control.Monad.State.Class (MonadState(..))
+import qualified Control.Monad.State.Class as State
+import qualified Servant.Types.SourceT as S
+import Servant.API (SourceIO)
+
+import Utils (throwExceptT)
+
+import Yesod.Servant (ServantApi, servantApiBaseUrl)
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as Lazy (ByteString)
+import qualified Data.ByteString.Lazy as LBS hiding (ByteString)
+import qualified Data.Binary.Builder as B
+import Network.HTTP.Media (renderHeader)
+import Control.Monad.Fail
+
 import Control.Lens as X hiding ((<.), elements)
 
 import Network.IP.Addr as X (IP)
@@ -133,3 +163,105 @@ lawsCheckHspec p = parallel . describe (show $ typeRep p) . mapM_ (checkHspec .
   where
     checkHspec (Laws className properties) = describe className $
       forM_ properties $ \(name, prop) -> it name $ property prop
+
+
+newtype ServantExample a = ServantExample
+  { unServantExample :: ReaderT ServantExampleEnv (ExceptT ClientError Wai.Session) a
+  } deriving stock (Generic, Typeable)
+    deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader ServantExampleEnv, MonadError ClientError, MonadThrow, MonadCatch, MonadState Wai.ClientState)
+
+data ServantExampleEnv = ServantExampleEnv
+  { yseBaseUrl :: BaseUrl
+  , yseMakeClientRequest :: BaseUrl -> Servant.Request -> IO Wai.Request
+  } deriving (Generic, Typeable)
+
+runServantExample :: (Route (ServantApi proxy) -> Route UniWorX) -> ServantExample a -> YesodExample UniWorX a
+runServantExample apiR (ServantExample act) = do
+  yseBaseUrl <- runHandler $ servantApiBaseUrl apiR
+  let yseMakeClientRequest burl Servant.Request{..} = do
+        ((body, bodyLength), contentTypeHdr) <- case requestBody of
+            Nothing           -> return ((return BS.empty, Wai.KnownLength 0), Nothing)
+            Just (body', typ) -> let (mkBody, bLength) = convertBody body'
+                                  in (, Just (hContentType, renderHeader typ)) . (, bLength) <$> mkBody
+
+        return $ Wai.defaultRequest
+          { Wai.requestMethod = requestMethod
+          , Wai.requestHeaders = maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
+          , Wai.requestHeaderHost =
+              let BaseUrl{..} = yseBaseUrl
+               in Just . encodeUtf8 . pack $ baseUrlHost <> bool (":" <> show baseUrlPort) mempty (baseUrlPort == 80)
+          , Wai.requestBody = body, Wai.requestBodyLength = bodyLength
+          , Wai.isSecure = isSecure
+          }
+          & flip Wai.setPath (encodeUtf8 (pack $ baseUrlPath burl) <> toStrict (B.toLazyByteString requestPath) <> Wai.renderQuery True (toList requestQueryString))
+        where
+          headers = filter (\(h, _) -> h `notElem` [hAccept, hContentType, hHost]) $ toList requestHeaders
+
+          acceptHdr
+              | null hs   = Nothing
+              | otherwise = Just (hAccept, renderHeader hs)
+            where
+              hs = toList requestAccept
+
+          convertBody :: Servant.RequestBody -> (IO (IO ByteString), Wai.RequestBodyLength)
+          convertBody bd = case bd of
+              Servant.RequestBodyLBS body'       -> ( givesPopper . S.source . map fromStrict $ LBS.toChunks body'
+                                                    , Wai.KnownLength . fromIntegral $ LBS.length body'
+                                                    )
+              Servant.RequestBodyBS body'        -> ( return $ return body'
+                                                    , Wai.KnownLength . fromIntegral $ BS.length body'
+                                                    )
+              Servant.RequestBodySource sourceIO -> ( givesPopper sourceIO
+                                                    , Wai.ChunkedBody
+                                                    )
+            where
+              givesPopper :: SourceIO Lazy.ByteString -> IO (IO ByteString)
+              givesPopper sourceIO = S.unSourceT sourceIO $ \step0 -> do
+                  ref <- newMVar step0
+                  return $ modifyMVar ref nextBs
+
+              nextBs S.Stop          = return (S.Stop, BS.empty)
+              nextBs (S.Error err)   = fail err
+              nextBs (S.Skip s)      = nextBs s
+              nextBs (S.Effect ms)   = ms >>= nextBs
+              nextBs (S.Yield lbs s) = case LBS.toChunks lbs of
+                  []     -> nextBs s
+                  (x:xs) | BS.null x -> nextBs step'
+                         | otherwise -> return (step', x)
+                      where
+                        step' = S.Yield (LBS.fromChunks xs) s
+
+          isSecure = case baseUrlScheme burl of
+              Servant.Http -> False
+              Servant.Https -> True
+  YesodExampleData waiApp _ _ _ <- State.get
+  liftIO . flip Wai.runSession waiApp . throwExceptT $ runReaderT act ServantExampleEnv{..}
+
+instance RunClient ServantExample where
+  runRequestAcceptStatus acceptStatus req = do
+    ServantExampleEnv{..} <- ask
+    waiRequest <- liftIO $ yseMakeClientRequest yseBaseUrl req
+    waiResponse@Wai.SResponse{..} <- ServantExample . lift . lift $ Wai.request waiRequest
+    let Status{..} = simpleStatus
+        statusOk = case acceptStatus of
+          Nothing -> 200 <= statusCode && statusCode < 300
+          Just good -> simpleStatus `elem` good
+        response = (waiResponseToResponse waiResponse) { Servant.responseHttpVersion = Wai.httpVersion waiRequest }
+    unless statusOk $
+      throwError $ mkFailureResponse yseBaseUrl req response
+    return response
+    where
+      mkFailureResponse :: BaseUrl -> Servant.Request -> Servant.ResponseF Lazy.ByteString -> ClientError
+      mkFailureResponse burl request' =
+          FailureResponse (bimap (const ()) f request')
+        where
+          f b = (burl, LBS.toStrict $ B.toLazyByteString b)
+
+      waiResponseToResponse :: Wai.SResponse -> Servant.Response
+      waiResponseToResponse Wai.SResponse{..} = Servant.Response
+          { responseStatusCode  = simpleStatus
+          , responseBody        = simpleBody
+          , responseHeaders     = fromList simpleHeaders
+          , responseHttpVersion = error "WAI Response does not carry http version information"
+          }
+  throwClientError = throwError

From 6e46e4e9ef34130582a3511ff01b42f4428dd1a1 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sat, 4 Jun 2022 00:57:04 +0200
Subject: [PATCH 12/18] fix(workflows): add missing Hashable instance for
 WorkflowWorkflowListType

---
 src/Model/Types/Workflow.hs | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs
index 98d7dccd5..f7d96375e 100644
--- a/src/Model/Types/Workflow.hs
+++ b/src/Model/Types/Workflow.hs
@@ -684,6 +684,8 @@ data WorkflowWorkflowListType = WorkflowWorkflowListActive | WorkflowWorkflowLis
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 
+instance Hashable WorkflowWorkflowListType
+
 
 ----- Lenses needed here -----
   

From 5542be678055b0439f18b29ba0432dac50847b09 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sat, 4 Jun 2022 01:14:06 +0200
Subject: [PATCH 13/18] chore: npm update

---
 package-lock.json | 406 +++++++++++++++++++++++++++++-----------------
 package.json      |  22 +--
 2 files changed, 268 insertions(+), 160 deletions(-)

diff --git a/package-lock.json b/package-lock.json
index 52bd56b93..f71b5ed91 100644
--- a/package-lock.json
+++ b/package-lock.json
@@ -1341,9 +1341,9 @@
       "dev": true
     },
     "@commitlint/cli": {
-      "version": "17.0.1",
-      "resolved": "https://registry.npmjs.org/@commitlint/cli/-/cli-17.0.1.tgz",
-      "integrity": "sha512-5xT1G5pnynR0tk/ms8Ji7yr9lZCeQs4GLVVtyK/gw20w+enoLTVuRKKY9zg88hy9FoCycc/W8iip2xv3c8payg==",
+      "version": "17.0.2",
+      "resolved": "https://registry.npmjs.org/@commitlint/cli/-/cli-17.0.2.tgz",
+      "integrity": "sha512-Axe89Js0YzGGd4gxo3JLlF7yIdjOVpG1LbOorGc6PfYF+drBh14PvarSDLzyd2TNqdylUCq9wb9/A88ZjIdyhA==",
       "dev": true,
       "requires": {
         "@commitlint/format": "^17.0.0",
@@ -1359,12 +1359,25 @@
       }
     },
     "@commitlint/config-conventional": {
-      "version": "17.0.0",
-      "resolved": "https://registry.npmjs.org/@commitlint/config-conventional/-/config-conventional-17.0.0.tgz",
-      "integrity": "sha512-jttJXBIq3AuQCvUVwxSctCwKfHxxbALE0IB9OIHYCu/eQdOzPxN72pugeZsWDo1VK/T9iFx+MZoPb6Rb1/ylsw==",
+      "version": "17.0.2",
+      "resolved": "https://registry.npmjs.org/@commitlint/config-conventional/-/config-conventional-17.0.2.tgz",
+      "integrity": "sha512-MfP0I/JbxKkzo+HXWB7B3WstGS4BiniotU3d3xQ9gK8cR0DbeZ4MuyGCWF65YDyrcDTS3WlrJ3ndSPA1pqhoPw==",
       "dev": true,
       "requires": {
-        "conventional-changelog-conventionalcommits": "^4.3.1"
+        "conventional-changelog-conventionalcommits": "^5.0.0"
+      },
+      "dependencies": {
+        "conventional-changelog-conventionalcommits": {
+          "version": "5.0.0",
+          "resolved": "https://registry.npmjs.org/conventional-changelog-conventionalcommits/-/conventional-changelog-conventionalcommits-5.0.0.tgz",
+          "integrity": "sha512-lCDbA+ZqVFQGUj7h9QBKoIpLhl8iihkO0nCTyRNzuXtcd7ubODpYB04IFy31JloiJgG0Uovu8ot8oxRzn7Nwtw==",
+          "dev": true,
+          "requires": {
+            "compare-func": "^2.0.0",
+            "lodash": "^4.17.15",
+            "q": "^1.5.1"
+          }
+        }
       }
     },
     "@commitlint/config-validator": {
@@ -1640,6 +1653,15 @@
         "postcss-value-parser": "^4.2.0"
       }
     },
+    "@csstools/postcss-trigonometric-functions": {
+      "version": "1.0.1",
+      "resolved": "https://registry.npmjs.org/@csstools/postcss-trigonometric-functions/-/postcss-trigonometric-functions-1.0.1.tgz",
+      "integrity": "sha512-G78CY/+GePc6dDCTUbwI6TTFQ5fs3N9POHhI6v0QzteGpf6ylARiJUNz9HrRKi4eVYBNXjae1W2766iUEFxHlw==",
+      "dev": true,
+      "requires": {
+        "postcss-value-parser": "^4.2.0"
+      }
+    },
     "@csstools/postcss-unset-value": {
       "version": "1.0.1",
       "resolved": "https://registry.npmjs.org/@csstools/postcss-unset-value/-/postcss-unset-value-1.0.1.tgz",
@@ -3812,9 +3834,9 @@
       "dev": true
     },
     "cacache": {
-      "version": "16.1.0",
-      "resolved": "https://registry.npmjs.org/cacache/-/cacache-16.1.0.tgz",
-      "integrity": "sha512-Pk4aQkwCW82A4jGKFvcGkQFqZcMspfP9YWq9Pr87/ldDvlWf718zeI6KWCdKt/jeihu6BytHRUicJPB1K2k8EQ==",
+      "version": "16.1.1",
+      "resolved": "https://registry.npmjs.org/cacache/-/cacache-16.1.1.tgz",
+      "integrity": "sha512-VDKN+LHyCQXaaYZ7rA/qtkURU+/yYhviUdvqEv2LT6QPZU8jpyzEkEVAcKlKLt5dJ5BRp11ym8lo3NKLluEPLg==",
       "requires": {
         "@npmcli/fs": "^2.1.0",
         "@npmcli/move-file": "^2.0.0",
@@ -4034,7 +4056,7 @@
             "boolbase": "~1.0.0",
             "css-what": "2.1",
             "domutils": "1.5.1",
-            "nth-check": "^2.0.1"
+            "nth-check": "~1.0.1"
           }
         },
         "css-what": {
@@ -4099,7 +4121,7 @@
           }
         },
         "nth-check": {
-          "version": "2.0.1",
+          "version": "1.0.2",
           "resolved": "https://registry.npmjs.org/nth-check/-/nth-check-2.0.1.tgz",
           "integrity": "sha512-WeBOdju8SnzPN5vTUJYxYUxLeXpCaVP5i5e0LF8fg7WORF2Wd7wFX/pk0tYZk7s8T+J7VLy0Da6J1+wCT0AtHg==",
           "dev": true,
@@ -4310,9 +4332,9 @@
       }
     },
     "commander": {
-      "version": "9.2.0",
-      "resolved": "https://registry.npmjs.org/commander/-/commander-9.2.0.tgz",
-      "integrity": "sha512-e2i4wANQiSXgnrBlIatyHtP1odfUp0BbV5Y5nEGbxtIrStkEOAAzCUirvLBNXHLr7kwLvJl6V+4V3XV9x7Wd9w=="
+      "version": "9.3.0",
+      "resolved": "https://registry.npmjs.org/commander/-/commander-9.3.0.tgz",
+      "integrity": "sha512-hv95iU5uXPbK83mjrJKuZyFM/LBAoCV/XhVGkS5Je6tl7sxr6A0ITMw5WoRV46/UaJ46Nllm3Xt7IaJhXTIkzw=="
     },
     "commondir": {
       "version": "1.0.1",
@@ -4859,9 +4881,9 @@
       }
     },
     "core-js": {
-      "version": "3.22.7",
-      "resolved": "https://registry.npmjs.org/core-js/-/core-js-3.22.7.tgz",
-      "integrity": "sha512-Jt8SReuDKVNZnZEzyEQT5eK6T2RRCXkfTq7Lo09kpm+fHjgGewSbNjV+Wt4yZMhPDdzz2x1ulI5z/w4nxpBseg=="
+      "version": "3.22.8",
+      "resolved": "https://registry.npmjs.org/core-js/-/core-js-3.22.8.tgz",
+      "integrity": "sha512-UoGQ/cfzGYIuiq6Z7vWL1HfkE9U9IZ4Ub+0XSiJTCzvbZzgPA69oDF2f+lgJ6dFFLEdjW5O6svvoKzXX23xFkA=="
     },
     "core-js-compat": {
       "version": "3.22.7",
@@ -4930,13 +4952,13 @@
       }
     },
     "cosmiconfig-typescript-loader": {
-      "version": "2.0.0",
-      "resolved": "https://registry.npmjs.org/cosmiconfig-typescript-loader/-/cosmiconfig-typescript-loader-2.0.0.tgz",
-      "integrity": "sha512-2NlGul/E3vTQEANqPziqkA01vfiuUU8vT0jZAuUIjEW8u3eCcnCQWLggapCjhbF76s7KQF0fM0kXSKmzaDaG1g==",
+      "version": "2.0.1",
+      "resolved": "https://registry.npmjs.org/cosmiconfig-typescript-loader/-/cosmiconfig-typescript-loader-2.0.1.tgz",
+      "integrity": "sha512-B9s6sX/omXq7I6gC6+YgLmrBFMJhPWew7ty/X5Tuwtd2zOSgWaUdXjkuVwbe3qqcdETo60+1nSVMekq//LIXVA==",
       "dev": true,
       "requires": {
         "cosmiconfig": "^7",
-        "ts-node": "^10.7.0"
+        "ts-node": "^10.8.0"
       }
     },
     "create-require": {
@@ -5042,9 +5064,9 @@
       "integrity": "sha1-QuJ9T6BK4y+TGktNQZH6nN3ul8s="
     },
     "cssdb": {
-      "version": "6.6.2",
-      "resolved": "https://registry.npmjs.org/cssdb/-/cssdb-6.6.2.tgz",
-      "integrity": "sha512-w08LaP+DRoPlw4g4LSUp+EWRrWTPlrzWREcU7/6IeMfL7tPR2P9oeQ1G+pxyfMmLWBNDwqHWa6kxiuGMLb71EA==",
+      "version": "6.6.3",
+      "resolved": "https://registry.npmjs.org/cssdb/-/cssdb-6.6.3.tgz",
+      "integrity": "sha512-7GDvDSmE+20+WcSMhP17Q1EVWUrLlbxxpMDqG731n8P99JhnQZHR9YvtjPvEHfjFUjvQJvdpKCjlKOX+xe4UVA==",
       "dev": true
     },
     "cssesc": {
@@ -5529,7 +5551,7 @@
     "duplexer3": {
       "version": "0.1.4",
       "resolved": "https://registry.npmjs.org/duplexer3/-/duplexer3-0.1.4.tgz",
-      "integrity": "sha1-7gHdHKwO08vH/b6jfcCo8c4ALOI="
+      "integrity": "sha512-CEj8FwwNA4cVH2uFCoHUrmojhYh1vmCdOaneKJXwkeY1i9jnlslVo9dx+hQ5Hl9GnH/Bwy/IjxAyOePyPKYnzA=="
     },
     "eastasianwidth": {
       "version": "0.2.0",
@@ -5733,9 +5755,9 @@
       "dev": true
     },
     "eslint": {
-      "version": "8.16.0",
-      "resolved": "https://registry.npmjs.org/eslint/-/eslint-8.16.0.tgz",
-      "integrity": "sha512-MBndsoXY/PeVTDJeWsYj7kLZ5hQpJOfMYLsF6LicLHQWbRDG19lK5jOix4DPl8yY4SUFcE3txy86OzFLWT+yoA==",
+      "version": "8.17.0",
+      "resolved": "https://registry.npmjs.org/eslint/-/eslint-8.17.0.tgz",
+      "integrity": "sha512-gq0m0BTJfci60Fz4nczYxNAlED+sMcihltndR8t9t1evnU/azx53x3t2UHXC/uRjcbvRw/XctpaNygSTcQD+Iw==",
       "dev": true,
       "requires": {
         "@eslint/eslintrc": "^1.3.0",
@@ -6020,7 +6042,7 @@
     "fast-levenshtein": {
       "version": "2.0.6",
       "resolved": "https://registry.npmjs.org/fast-levenshtein/-/fast-levenshtein-2.0.6.tgz",
-      "integrity": "sha1-PYpcZog6FqMMqGQ+hR8Zuqd5eRc=",
+      "integrity": "sha512-DCXu6Ifhqcks7TZKY3Hxp3y6qphY5SJZmrWMDrKcERSOXWQdMhU9Ig/PYrzyw/ul9jOIyh0N4M0tbC5hodg8dw==",
       "dev": true
     },
     "fast-memoize": {
@@ -6318,7 +6340,7 @@
     "functional-red-black-tree": {
       "version": "1.0.1",
       "resolved": "https://registry.npmjs.org/functional-red-black-tree/-/functional-red-black-tree-1.0.1.tgz",
-      "integrity": "sha1-GwqzvVU7Kg1jmdKcDj6gslIHgyc=",
+      "integrity": "sha512-dsKNQNdj6xA3T+QlADDA7mOSlX0qiMINjn0cgr+eGHGsbSHzTabcIogz2+p/iqP1Xs6EP/sS2SbqH+brGTbq0g==",
       "dev": true
     },
     "gauge": {
@@ -6708,7 +6730,7 @@
     "has-unicode": {
       "version": "2.0.1",
       "resolved": "https://registry.npmjs.org/has-unicode/-/has-unicode-2.0.1.tgz",
-      "integrity": "sha1-4Ob+aijPUROIVeCG0Wkedx3iqLk="
+      "integrity": "sha512-8Rf9Y83NBReMnx0gFzA8JImQACstCYWUplepDa9xprwwtmgEZUF0h/i5xSA625zB/I37EtrswSST6OXxwaaIJQ=="
     },
     "has-yarn": {
       "version": "2.1.0",
@@ -6863,7 +6885,7 @@
     "humanize-ms": {
       "version": "1.2.1",
       "resolved": "https://registry.npmjs.org/humanize-ms/-/humanize-ms-1.2.1.tgz",
-      "integrity": "sha1-xG4xWaKT9riW2ikxbYtv6Lt5u+0=",
+      "integrity": "sha512-Fl70vYtsAFb/C06PTS9dZBo7ihau+Tu/DNCk/OyHhea07S+aeMWpFFkUaXRa8fI+ScZbEI8dfSxwY7gxZ9SAVQ==",
       "requires": {
         "ms": "^2.0.0"
       }
@@ -6929,7 +6951,7 @@
     "import-lazy": {
       "version": "2.1.0",
       "resolved": "https://registry.npmjs.org/import-lazy/-/import-lazy-2.1.0.tgz",
-      "integrity": "sha1-BWmOPUXIjo1+nZLLBYTnfwlvPkM="
+      "integrity": "sha512-m7ZEHgtw69qOGw+jwxXkHlrlIPdTGkyh66zXZ1ajZbxkDBNjSY/LGbmjc7h0s2ELsUDTAhFr55TrPSSqJGPG0A=="
     },
     "import-local": {
       "version": "3.1.0",
@@ -6944,7 +6966,7 @@
     "imurmurhash": {
       "version": "0.1.4",
       "resolved": "https://registry.npmjs.org/imurmurhash/-/imurmurhash-0.1.4.tgz",
-      "integrity": "sha1-khi5srkoojixPcT7a21XbyMUU+o="
+      "integrity": "sha512-JmXMZ6wuvDmLiHEml9ykzqO6lwFbof0GG4IkcGaENdCRDDmMVnny7s5HsIgHCbaq0w2MyPhDqkhTUgS2LU2PHA=="
     },
     "indent-string": {
       "version": "4.0.0",
@@ -7107,7 +7129,7 @@
     "is-lambda": {
       "version": "1.0.1",
       "resolved": "https://registry.npmjs.org/is-lambda/-/is-lambda-1.0.1.tgz",
-      "integrity": "sha1-PZh3iZ5qU+/AFgUEzeFfgubwYdU="
+      "integrity": "sha512-z7CMFGNrENq5iFB9Bqo64Xk6Y9sg+epq1myIcdHaGnbMTYOxvzsEtdYqQUylB7LxfkvgrrjP32T6Ywciio9UIQ=="
     },
     "is-negative-zero": {
       "version": "2.0.2",
@@ -7316,7 +7338,7 @@
     "jju": {
       "version": "1.4.0",
       "resolved": "https://registry.npmjs.org/jju/-/jju-1.4.0.tgz",
-      "integrity": "sha1-o6vicYryQaKykE+EpiWXDzia4yo="
+      "integrity": "sha512-8wb9Yw966OSxApiCt0K3yNJL8pnNeIv+OEq2YMidz4FKP6nonSRoOXc80iXY4JaN2FC11B9qsNmDsm+ZOfMROA=="
     },
     "js-cookie": {
       "version": "3.0.1",
@@ -7352,7 +7374,7 @@
     "json-buffer": {
       "version": "3.0.0",
       "resolved": "https://registry.npmjs.org/json-buffer/-/json-buffer-3.0.0.tgz",
-      "integrity": "sha1-Wx85evx11ne96Lz8Dkfh+aPZqJg="
+      "integrity": "sha512-CuUqjv0FUZIdXkHPI8MezCnFCdaTAacej1TZYulLoAg1h/PhwkdXFN4V/gzY4g+fMBCOV2xF+rp7t2XD2ns/NQ=="
     },
     "json-parse-better-errors": {
       "version": "1.0.2",
@@ -7368,7 +7390,7 @@
     "json-parse-helpfulerror": {
       "version": "1.0.3",
       "resolved": "https://registry.npmjs.org/json-parse-helpfulerror/-/json-parse-helpfulerror-1.0.3.tgz",
-      "integrity": "sha1-E/FM4C7tTpgSl7ZOueO5MuLdE9w=",
+      "integrity": "sha512-XgP0FGR77+QhUxjXkwOMkC94k3WtqEBfcnjWqhRd82qTat4SWKRE+9kUnynz/shm3I4ea2+qISvTIeGTNU7kJg==",
       "requires": {
         "jju": "^1.1.0"
       }
@@ -7388,7 +7410,7 @@
     "json-stable-stringify-without-jsonify": {
       "version": "1.0.1",
       "resolved": "https://registry.npmjs.org/json-stable-stringify-without-jsonify/-/json-stable-stringify-without-jsonify-1.0.1.tgz",
-      "integrity": "sha1-nbe1lJatPzz+8wp1FC0tkwrXJlE=",
+      "integrity": "sha512-Bdboy+l7tA3OGW6FjyFHWkP5LuByj1Tk33Ljyq0axyzdk9//JSi2u3fP1QSmd1KNwq6VOKYGlAu87CisVir6Pw==",
       "dev": true
     },
     "json-stringify-safe": {
@@ -7415,7 +7437,7 @@
     "jsonlines": {
       "version": "0.1.1",
       "resolved": "https://registry.npmjs.org/jsonlines/-/jsonlines-0.1.1.tgz",
-      "integrity": "sha1-T80kbcXQ44aRkHxEqwAveC0dlMw="
+      "integrity": "sha512-ekDrAGso79Cvf+dtm+mL8OBI2bmAOt3gssYs833De/C9NmIpWDWyUO4zPgB5x2/OhY366dkhgfPMYfwZF7yOZA=="
     },
     "jsonparse": {
       "version": "1.3.1",
@@ -7765,37 +7787,113 @@
       "dev": true
     },
     "lint-staged": {
-      "version": "12.4.2",
-      "resolved": "https://registry.npmjs.org/lint-staged/-/lint-staged-12.4.2.tgz",
-      "integrity": "sha512-JAJGIzY/OioIUtrRePr8go6qUxij//mL+RGGoFKU3VWQRtIHgWoHizSqH0QVn2OwrbXS9Q6CICQjfj+E5qvrXg==",
+      "version": "13.0.0",
+      "resolved": "https://registry.npmjs.org/lint-staged/-/lint-staged-13.0.0.tgz",
+      "integrity": "sha512-vWban5utFt78VZohbosUxNIa46KKJ+KOQTDWTQ8oSl1DLEEVl9zhUtaQbiiydAmx+h2wKJK2d0+iMaRmknuWRQ==",
       "dev": true,
       "requires": {
         "cli-truncate": "^3.1.0",
         "colorette": "^2.0.16",
-        "commander": "^8.3.0",
-        "debug": "^4.3.3",
-        "execa": "^5.1.1",
-        "lilconfig": "2.0.4",
-        "listr2": "^4.0.1",
-        "micromatch": "^4.0.4",
+        "commander": "^9.3.0",
+        "debug": "^4.3.4",
+        "execa": "^6.1.0",
+        "lilconfig": "2.0.5",
+        "listr2": "^4.0.5",
+        "micromatch": "^4.0.5",
         "normalize-path": "^3.0.0",
-        "object-inspect": "^1.12.0",
+        "object-inspect": "^1.12.2",
         "pidtree": "^0.5.0",
         "string-argv": "^0.3.1",
-        "supports-color": "^9.2.1",
-        "yaml": "^1.10.2"
+        "yaml": "^2.1.1"
       },
       "dependencies": {
-        "commander": {
-          "version": "8.3.0",
-          "resolved": "https://registry.npmjs.org/commander/-/commander-8.3.0.tgz",
-          "integrity": "sha512-OkTL9umf+He2DZkUq8f8J9of7yL6RJKI24dVITBmNfZBmri9zYZQrKkuXiKhyfPSu8tUhnVBB1iKXevvnlR4Ww==",
+        "execa": {
+          "version": "6.1.0",
+          "resolved": "https://registry.npmjs.org/execa/-/execa-6.1.0.tgz",
+          "integrity": "sha512-QVWlX2e50heYJcCPG0iWtf8r0xjEYfz/OYLGDYH+IyjWezzPNxz63qNFOu0l4YftGWuizFVZHHs8PrLU5p2IDA==",
+          "dev": true,
+          "requires": {
+            "cross-spawn": "^7.0.3",
+            "get-stream": "^6.0.1",
+            "human-signals": "^3.0.1",
+            "is-stream": "^3.0.0",
+            "merge-stream": "^2.0.0",
+            "npm-run-path": "^5.1.0",
+            "onetime": "^6.0.0",
+            "signal-exit": "^3.0.7",
+            "strip-final-newline": "^3.0.0"
+          }
+        },
+        "get-stream": {
+          "version": "6.0.1",
+          "resolved": "https://registry.npmjs.org/get-stream/-/get-stream-6.0.1.tgz",
+          "integrity": "sha512-ts6Wi+2j3jQjqi70w5AlN8DFnkSwC+MqmxEzdEALB2qXZYV3X/b1CTfgPLGJNMeAWxdPfU8FO1ms3NUfaHCPYg==",
           "dev": true
         },
-        "supports-color": {
-          "version": "9.2.2",
-          "resolved": "https://registry.npmjs.org/supports-color/-/supports-color-9.2.2.tgz",
-          "integrity": "sha512-XC6g/Kgux+rJXmwokjm9ECpD6k/smUoS5LKlUCcsYr4IY3rW0XyAympon2RmxGrlnZURMpg5T18gWDP9CsHXFA==",
+        "human-signals": {
+          "version": "3.0.1",
+          "resolved": "https://registry.npmjs.org/human-signals/-/human-signals-3.0.1.tgz",
+          "integrity": "sha512-rQLskxnM/5OCldHo+wNXbpVgDn5A17CUoKX+7Sokwaknlq7CdSnphy0W39GU8dw59XiCXmFXDg4fRuckQRKewQ==",
+          "dev": true
+        },
+        "is-stream": {
+          "version": "3.0.0",
+          "resolved": "https://registry.npmjs.org/is-stream/-/is-stream-3.0.0.tgz",
+          "integrity": "sha512-LnQR4bZ9IADDRSkvpqMGvt/tEJWclzklNgSw48V5EAaAeDd6qGvN8ei6k5p0tvxSR171VmGyHuTiAOfxAbr8kA==",
+          "dev": true
+        },
+        "lilconfig": {
+          "version": "2.0.5",
+          "resolved": "https://registry.npmjs.org/lilconfig/-/lilconfig-2.0.5.tgz",
+          "integrity": "sha512-xaYmXZtTHPAw5m+xLN8ab9C+3a8YmV3asNSPOATITbtwrfbwaLJj8h66H1WMIpALCkqsIzK3h7oQ+PdX+LQ9Eg==",
+          "dev": true
+        },
+        "mimic-fn": {
+          "version": "4.0.0",
+          "resolved": "https://registry.npmjs.org/mimic-fn/-/mimic-fn-4.0.0.tgz",
+          "integrity": "sha512-vqiC06CuhBTUdZH+RYl8sFrL096vA45Ok5ISO6sE/Mr1jRbGH4Csnhi8f3wKVl7x8mO4Au7Ir9D3Oyv1VYMFJw==",
+          "dev": true
+        },
+        "npm-run-path": {
+          "version": "5.1.0",
+          "resolved": "https://registry.npmjs.org/npm-run-path/-/npm-run-path-5.1.0.tgz",
+          "integrity": "sha512-sJOdmRGrY2sjNTRMbSvluQqg+8X7ZK61yvzBEIDhz4f8z1TZFYABsqjjCBd/0PUNE9M6QDgHJXQkGUEm7Q+l9Q==",
+          "dev": true,
+          "requires": {
+            "path-key": "^4.0.0"
+          }
+        },
+        "object-inspect": {
+          "version": "1.12.2",
+          "resolved": "https://registry.npmjs.org/object-inspect/-/object-inspect-1.12.2.tgz",
+          "integrity": "sha512-z+cPxW0QGUp0mcqcsgQyLVRDoXFQbXOwBaqyF7VIgI4TWNQsDHrBpUQslRmIfAoYWdYzs6UlKJtB2XJpTaNSpQ==",
+          "dev": true
+        },
+        "onetime": {
+          "version": "6.0.0",
+          "resolved": "https://registry.npmjs.org/onetime/-/onetime-6.0.0.tgz",
+          "integrity": "sha512-1FlR+gjXK7X+AsAHso35MnyN5KqGwJRi/31ft6x0M194ht7S+rWAvd7PHss9xSKMzE0asv1pyIHaJYq+BbacAQ==",
+          "dev": true,
+          "requires": {
+            "mimic-fn": "^4.0.0"
+          }
+        },
+        "path-key": {
+          "version": "4.0.0",
+          "resolved": "https://registry.npmjs.org/path-key/-/path-key-4.0.0.tgz",
+          "integrity": "sha512-haREypq7xkM7ErfgIyA0z+Bj4AGKlMSdlQE2jvJo6huWD1EdkKYV+G/T4nq0YEF2vgTT8kqMFKo1uHn950r4SQ==",
+          "dev": true
+        },
+        "strip-final-newline": {
+          "version": "3.0.0",
+          "resolved": "https://registry.npmjs.org/strip-final-newline/-/strip-final-newline-3.0.0.tgz",
+          "integrity": "sha512-dOESqjYr96iWYylGObzd39EuNTa5VJxyvVAEm5Jnh7KGo75V43Hk1odPQkNDyXNmUR6k+gEiDVXnjB8HJ3crXw==",
+          "dev": true
+        },
+        "yaml": {
+          "version": "2.1.1",
+          "resolved": "https://registry.npmjs.org/yaml/-/yaml-2.1.1.tgz",
+          "integrity": "sha512-o96x3OPo8GjWeSLF+wOAbrPfhFOGY0W00GNaxCDv+9hkcDJEnev1yh8S7pgHF0ik6zc8sQLuL8hjHjJULZp8bw==",
           "dev": true
         }
       }
@@ -8658,7 +8756,7 @@
     "natural-compare": {
       "version": "1.4.0",
       "resolved": "https://registry.npmjs.org/natural-compare/-/natural-compare-1.4.0.tgz",
-      "integrity": "sha1-Sr6/7tdUHywnrPspvbvRXI1bpPc=",
+      "integrity": "sha512-OWND8ei3VtNC9h7V60qff3SVobHr996CTwgxubgyQYEpg290h9J0buyECNNJexkFm5sOajh5G116RYA1c8ZMSw==",
       "dev": true
     },
     "negotiator": {
@@ -8820,9 +8918,9 @@
       "integrity": "sha512-9UZCFRHQdNrfTpGg8+1INIg93B6zE0aXMVFkw1WFwvO4SlZywU6aLg5Of0Ap/PgcbSw4LNxvMWXMeugwMCX0AA=="
     },
     "npm": {
-      "version": "8.11.0",
-      "resolved": "https://registry.npmjs.org/npm/-/npm-8.11.0.tgz",
-      "integrity": "sha512-4qmtwHa28J4SPmwCNoQI07KIF/ljmBhhuqG+xNXsIIRpwdKB5OXkMIGfH6KlThR6kzusxlkgR7t1haFDB88dcQ==",
+      "version": "8.12.1",
+      "resolved": "https://registry.npmjs.org/npm/-/npm-8.12.1.tgz",
+      "integrity": "sha512-0yOlhfgu1UzP6UijnaFuIS2bES2H9D90EA5OVsf2iOZw7VBrjntXKEwKfCaFA6vMVWkCP8qnPwCxxPdnDVwlNw==",
       "requires": {
         "@isaacs/string-locale-compare": "^1.1.0",
         "@npmcli/arborist": "^5.0.4",
@@ -8859,7 +8957,7 @@
         "libnpmsearch": "^5.0.2",
         "libnpmteam": "^4.0.2",
         "libnpmversion": "^3.0.1",
-        "make-fetch-happen": "^10.1.5",
+        "make-fetch-happen": "^10.1.6",
         "minipass": "^3.1.6",
         "minipass-pipeline": "^1.2.4",
         "mkdirp": "^1.0.4",
@@ -8876,7 +8974,7 @@
         "npm-user-validate": "^1.0.1",
         "npmlog": "^6.0.2",
         "opener": "^1.5.2",
-        "pacote": "^13.4.1",
+        "pacote": "^13.6.0",
         "parse-conflict-json": "^2.0.2",
         "proc-log": "^2.0.1",
         "qrcode-terminal": "^0.12.0",
@@ -8910,7 +9008,7 @@
           "bundled": true
         },
         "@npmcli/arborist": {
-          "version": "5.2.0",
+          "version": "5.2.1",
           "bundled": true,
           "requires": {
             "@isaacs/string-locale-compare": "^1.1.0",
@@ -9369,15 +9467,14 @@
           }
         },
         "glob": {
-          "version": "8.0.1",
+          "version": "8.0.3",
           "bundled": true,
           "requires": {
             "fs.realpath": "^1.0.0",
             "inflight": "^1.0.4",
             "inherits": "2",
             "minimatch": "^5.0.1",
-            "once": "^1.3.0",
-            "path-is-absolute": "^1.0.0"
+            "once": "^1.3.0"
           }
         },
         "graceful-fs": {
@@ -9569,7 +9666,7 @@
           }
         },
         "libnpmexec": {
-          "version": "4.0.5",
+          "version": "4.0.6",
           "bundled": true,
           "requires": {
             "@npmcli/arborist": "^5.0.0",
@@ -9660,7 +9757,7 @@
           "bundled": true
         },
         "make-fetch-happen": {
-          "version": "10.1.5",
+          "version": "10.1.6",
           "bundled": true,
           "requires": {
             "agentkeepalive": "^4.2.1",
@@ -9682,7 +9779,7 @@
           }
         },
         "minimatch": {
-          "version": "5.0.1",
+          "version": "5.1.0",
           "bundled": true,
           "requires": {
             "brace-expansion": "^2.0.1"
@@ -9799,13 +9896,13 @@
               }
             },
             "glob": {
-              "version": "7.2.0",
+              "version": "7.2.3",
               "bundled": true,
               "requires": {
                 "fs.realpath": "^1.0.0",
                 "inflight": "^1.0.4",
                 "inherits": "2",
-                "minimatch": "^3.0.4",
+                "minimatch": "^3.1.1",
                 "once": "^1.3.0",
                 "path-is-absolute": "^1.0.0"
               }
@@ -9944,7 +10041,7 @@
           }
         },
         "pacote": {
-          "version": "13.5.0",
+          "version": "13.6.0",
           "bundled": true,
           "requires": {
             "@npmcli/git": "^3.0.0",
@@ -10086,13 +10183,13 @@
               }
             },
             "glob": {
-              "version": "7.2.0",
+              "version": "7.2.3",
               "bundled": true,
               "requires": {
                 "fs.realpath": "^1.0.0",
                 "inflight": "^1.0.4",
                 "inherits": "2",
-                "minimatch": "^3.0.4",
+                "minimatch": "^3.1.1",
                 "once": "^1.3.0",
                 "path-is-absolute": "^1.0.0"
               }
@@ -10330,14 +10427,14 @@
       }
     },
     "npm-check-updates": {
-      "version": "13.0.3",
-      "resolved": "https://registry.npmjs.org/npm-check-updates/-/npm-check-updates-13.0.3.tgz",
-      "integrity": "sha512-a8CVklJjXZhmN5Kup8rKiejArobCbOaMnubhvM/LkYVumO17dBuWuaHUuiSrYglQUb88lGSdbNNfHDNN7b+3pQ==",
+      "version": "13.1.1",
+      "resolved": "https://registry.npmjs.org/npm-check-updates/-/npm-check-updates-13.1.1.tgz",
+      "integrity": "sha512-f4gLbUJJh5qvkNvrSG3b05y3ZvyZ4Sl3Uk95DSyCjIWwpwmAwzU9dMCA/Gg2AmIKqkH4ml6X9kxcZsu+tAd94g==",
       "requires": {
         "chalk": "^4.1.2",
         "cint": "^8.2.1",
         "cli-table": "^0.3.11",
-        "commander": "^9.2.0",
+        "commander": "^9.3.0",
         "fast-memoize": "^2.5.2",
         "find-up": "5.0.0",
         "fp-and-or": "^0.1.3",
@@ -10347,9 +10444,9 @@
         "json-parse-helpfulerror": "^1.0.3",
         "jsonlines": "^0.1.1",
         "lodash": "^4.17.21",
-        "minimatch": "^5.0.1",
+        "minimatch": "^5.1.0",
         "p-map": "^4.0.0",
-        "pacote": "^13.3.0",
+        "pacote": "^13.5.0",
         "parse-github-url": "^1.0.2",
         "progress": "^2.0.3",
         "prompts": "^2.4.2",
@@ -10361,13 +10458,13 @@
         "source-map-support": "^0.5.21",
         "spawn-please": "^1.0.0",
         "update-notifier": "^5.1.0",
-        "yaml": "^2.1.0"
+        "yaml": "^2.1.1"
       },
       "dependencies": {
         "yaml": {
-          "version": "2.1.0",
-          "resolved": "https://registry.npmjs.org/yaml/-/yaml-2.1.0.tgz",
-          "integrity": "sha512-OuAINfTsoJrY5H7CBWnKZhX6nZciXBydrMtTHr1dC4nP40X5jyTIVlogZHxSlVZM8zSgXRfgZGsaHF4+pV+JRw=="
+          "version": "2.1.1",
+          "resolved": "https://registry.npmjs.org/yaml/-/yaml-2.1.1.tgz",
+          "integrity": "sha512-o96x3OPo8GjWeSLF+wOAbrPfhFOGY0W00GNaxCDv+9hkcDJEnev1yh8S7pgHF0ik6zc8sQLuL8hjHjJULZp8bw=="
         }
       }
     },
@@ -10446,9 +10543,9 @@
           }
         },
         "make-fetch-happen": {
-          "version": "10.1.6",
-          "resolved": "https://registry.npmjs.org/make-fetch-happen/-/make-fetch-happen-10.1.6.tgz",
-          "integrity": "sha512-/iKDlRQF0fkxyB/w/duW2yRYrGwBcbJjC37ijgi0CmOZ32bzMc86BCSSAHWvuyRFCB408iBPziTSzazBSrKo3w==",
+          "version": "10.1.7",
+          "resolved": "https://registry.npmjs.org/make-fetch-happen/-/make-fetch-happen-10.1.7.tgz",
+          "integrity": "sha512-J/2xa2+7zlIUKqfyXDCXFpH3ypxO4k3rgkZHPSZkyUYcBT/hM80M3oyKLM/9dVriZFiGeGGS2Ei+0v2zfhqj3Q==",
           "requires": {
             "agentkeepalive": "^4.2.1",
             "cacache": "^16.1.0",
@@ -10464,7 +10561,7 @@
             "minipass-pipeline": "^1.2.4",
             "negotiator": "^0.6.3",
             "promise-retry": "^2.0.1",
-            "socks-proxy-agent": "^6.1.1",
+            "socks-proxy-agent": "^7.0.0",
             "ssri": "^9.0.0"
           }
         },
@@ -10478,6 +10575,16 @@
             "minipass-sized": "^1.0.3",
             "minizlib": "^2.1.2"
           }
+        },
+        "socks-proxy-agent": {
+          "version": "7.0.0",
+          "resolved": "https://registry.npmjs.org/socks-proxy-agent/-/socks-proxy-agent-7.0.0.tgz",
+          "integrity": "sha512-Fgl0YPZ902wEsAyiQ+idGd1A7rSFx/ayC1CQVMw5P+EQx2V0SgpGtf6OKFhVjPflPUl9YMmEOnmfjCdMUsygww==",
+          "requires": {
+            "agent-base": "^6.0.2",
+            "debug": "^4.3.3",
+            "socks": "^2.6.2"
+          }
         }
       }
     },
@@ -10873,9 +10980,9 @@
       }
     },
     "pacote": {
-      "version": "13.5.0",
-      "resolved": "https://registry.npmjs.org/pacote/-/pacote-13.5.0.tgz",
-      "integrity": "sha512-yekp0ykEsaBH0t0bYA/89R+ywdYV5ZnEdg4YMIfqakSlpIhoF6b8+aEUm8NZpfWRgmy6lxgywcW05URhLRogVQ==",
+      "version": "13.6.0",
+      "resolved": "https://registry.npmjs.org/pacote/-/pacote-13.6.0.tgz",
+      "integrity": "sha512-zHmuCwG4+QKnj47LFlW3LmArwKoglx2k5xtADiMCivVWPgNRP5QyLDGOIjGjwOe61lhl1rO63m/VxT16pEHLWg==",
       "requires": {
         "@npmcli/git": "^3.0.0",
         "@npmcli/installed-package-contents": "^1.0.7",
@@ -11089,12 +11196,12 @@
       }
     },
     "postcss-attribute-case-insensitive": {
-      "version": "5.0.0",
-      "resolved": "https://registry.npmjs.org/postcss-attribute-case-insensitive/-/postcss-attribute-case-insensitive-5.0.0.tgz",
-      "integrity": "sha512-b4g9eagFGq9T5SWX4+USfVyjIb3liPnjhHHRMP7FMB2kFVpYyfEscV0wP3eaXhKlcHKUut8lt5BGoeylWA/dBQ==",
+      "version": "5.0.1",
+      "resolved": "https://registry.npmjs.org/postcss-attribute-case-insensitive/-/postcss-attribute-case-insensitive-5.0.1.tgz",
+      "integrity": "sha512-wrt2VndqSLJpyBRNz9OmJcgnhI9MaongeWgapdBuUMu2a/KNJ8SENesG4SdiTnQwGO9b1VKbTWYAfCPeokLqZQ==",
       "dev": true,
       "requires": {
-        "postcss-selector-parser": "^6.0.2"
+        "postcss-selector-parser": "^6.0.10"
       }
     },
     "postcss-calc": {
@@ -11165,9 +11272,9 @@
       }
     },
     "postcss-custom-media": {
-      "version": "8.0.0",
-      "resolved": "https://registry.npmjs.org/postcss-custom-media/-/postcss-custom-media-8.0.0.tgz",
-      "integrity": "sha512-FvO2GzMUaTN0t1fBULDeIvxr5IvbDXcIatt6pnJghc736nqNgsGao5NT+5+WVLAQiTt6Cb3YUms0jiPaXhL//g==",
+      "version": "8.0.1",
+      "resolved": "https://registry.npmjs.org/postcss-custom-media/-/postcss-custom-media-8.0.1.tgz",
+      "integrity": "sha512-ZhBAYOOOeEV9eosUARv67HAhwM3PsKaWDxXs31usUoBd78VUiXZGgtbvGM1IFWgTaW2S5oYOJ2iD4dwSdHzfiQ==",
       "dev": true
     },
     "postcss-custom-properties": {
@@ -11180,9 +11287,9 @@
       }
     },
     "postcss-custom-selectors": {
-      "version": "6.0.0",
-      "resolved": "https://registry.npmjs.org/postcss-custom-selectors/-/postcss-custom-selectors-6.0.0.tgz",
-      "integrity": "sha512-/1iyBhz/W8jUepjGyu7V1OPcGbc636snN1yXEQCinb6Bwt7KxsiU7/bLQlp8GwAXzCh7cobBU5odNn/2zQWR8Q==",
+      "version": "6.0.2",
+      "resolved": "https://registry.npmjs.org/postcss-custom-selectors/-/postcss-custom-selectors-6.0.2.tgz",
+      "integrity": "sha512-vGkvyy7js/OPLdeJUCh+iH7xA2+w0lK4ecahUoCaZaDblQXZ9ADrLG4TNI0lNYrJWwe9k/jyLhliIoUs/og3SQ==",
       "dev": true,
       "requires": {
         "postcss-selector-parser": "^6.0.4"
@@ -11551,12 +11658,12 @@
       }
     },
     "postcss-preset-env": {
-      "version": "7.6.0",
-      "resolved": "https://registry.npmjs.org/postcss-preset-env/-/postcss-preset-env-7.6.0.tgz",
-      "integrity": "sha512-5cnzpSFZnQJOlBu85xn4Nnluy/WjIST/ugn+gOVcKnmFJ+GLtkfRhmJPo/TW9UDpG7oyA467kvDOO8mtcpOL4g==",
+      "version": "7.7.1",
+      "resolved": "https://registry.npmjs.org/postcss-preset-env/-/postcss-preset-env-7.7.1.tgz",
+      "integrity": "sha512-1sx6+Nl1wMVJzaYLVaz4OAR6JodIN/Z1upmVqLwSPCLT6XyxrEoePgNMHPH08kseLe3z06i9Vfkt/32BYEKDeA==",
       "dev": true,
       "requires": {
-        "@csstools/postcss-cascade-layers": "^1.0.1",
+        "@csstools/postcss-cascade-layers": "^1.0.2",
         "@csstools/postcss-color-function": "^1.1.0",
         "@csstools/postcss-font-format-keywords": "^1.0.0",
         "@csstools/postcss-hwb-function": "^1.0.1",
@@ -11566,21 +11673,22 @@
         "@csstools/postcss-oklab-function": "^1.1.0",
         "@csstools/postcss-progressive-custom-properties": "^1.3.0",
         "@csstools/postcss-stepped-value-functions": "^1.0.0",
+        "@csstools/postcss-trigonometric-functions": "^1.0.1",
         "@csstools/postcss-unset-value": "^1.0.1",
         "autoprefixer": "^10.4.7",
         "browserslist": "^4.20.3",
         "css-blank-pseudo": "^3.0.3",
         "css-has-pseudo": "^3.0.4",
         "css-prefers-color-scheme": "^6.0.3",
-        "cssdb": "^6.6.1",
-        "postcss-attribute-case-insensitive": "^5.0.0",
+        "cssdb": "^6.6.3",
+        "postcss-attribute-case-insensitive": "^5.0.1",
         "postcss-clamp": "^4.1.0",
-        "postcss-color-functional-notation": "^4.2.2",
+        "postcss-color-functional-notation": "^4.2.3",
         "postcss-color-hex-alpha": "^8.0.3",
         "postcss-color-rebeccapurple": "^7.0.2",
-        "postcss-custom-media": "^8.0.0",
+        "postcss-custom-media": "^8.0.1",
         "postcss-custom-properties": "^12.1.7",
-        "postcss-custom-selectors": "^6.0.0",
+        "postcss-custom-selectors": "^6.0.2",
         "postcss-dir-pseudo-class": "^6.0.4",
         "postcss-double-position-gradients": "^3.1.1",
         "postcss-env-function": "^4.0.6",
@@ -11593,14 +11701,14 @@
         "postcss-lab-function": "^4.2.0",
         "postcss-logical": "^5.0.4",
         "postcss-media-minmax": "^5.0.0",
-        "postcss-nesting": "^10.1.6",
+        "postcss-nesting": "^10.1.7",
         "postcss-opacity-percentage": "^1.1.2",
         "postcss-overflow-shorthand": "^3.0.3",
         "postcss-page-break": "^3.0.4",
         "postcss-place": "^7.0.4",
         "postcss-pseudo-class-any-link": "^7.1.4",
         "postcss-replace-overflow-wrap": "^4.0.0",
-        "postcss-selector-not": "^5.0.0",
+        "postcss-selector-not": "^6.0.0",
         "postcss-value-parser": "^4.2.0"
       },
       "dependencies": {
@@ -11618,9 +11726,9 @@
           }
         },
         "electron-to-chromium": {
-          "version": "1.4.141",
-          "resolved": "https://registry.npmjs.org/electron-to-chromium/-/electron-to-chromium-1.4.141.tgz",
-          "integrity": "sha512-mfBcbqc0qc6RlxrsIgLG2wCqkiPAjEezHxGTu7p3dHHFOurH4EjS9rFZndX5axC8264rI1Pcbw8uQP39oZckeA==",
+          "version": "1.4.146",
+          "resolved": "https://registry.npmjs.org/electron-to-chromium/-/electron-to-chromium-1.4.146.tgz",
+          "integrity": "sha512-4eWebzDLd+hYLm4csbyMU2EbBnqhwl8Oe9eF/7CBDPWcRxFmqzx4izxvHH+lofQxzieg8UbB8ZuzNTxeukzfTg==",
           "dev": true
         }
       }
@@ -11660,12 +11768,12 @@
       "dev": true
     },
     "postcss-selector-not": {
-      "version": "5.0.0",
-      "resolved": "https://registry.npmjs.org/postcss-selector-not/-/postcss-selector-not-5.0.0.tgz",
-      "integrity": "sha512-/2K3A4TCP9orP4TNS7u3tGdRFVKqz/E6pX3aGnriPG0jU78of8wsUcqE4QAhWEU0d+WnMSF93Ah3F//vUtK+iQ==",
+      "version": "6.0.0",
+      "resolved": "https://registry.npmjs.org/postcss-selector-not/-/postcss-selector-not-6.0.0.tgz",
+      "integrity": "sha512-i/HI/VNd3V9e1WOLCwJsf9nePBRXqcGtVibcJ9FsVo0agfDEfsLSlFt94aYjY35wUNcdG0KrvdyjEr7It50wLQ==",
       "dev": true,
       "requires": {
-        "balanced-match": "^1.0.0"
+        "postcss-selector-parser": "^6.0.10"
       }
     },
     "postcss-selector-parser": {
@@ -11712,7 +11820,7 @@
     "prepend-http": {
       "version": "2.0.0",
       "resolved": "https://registry.npmjs.org/prepend-http/-/prepend-http-2.0.0.tgz",
-      "integrity": "sha1-6SQ0v6XqjBn0HN/UAddBo8gZ2Jc="
+      "integrity": "sha512-ravE6m9Atw9Z/jjttRUZ+clIXogdghyZAuWJ3qEzjT+jI/dL1ifAqhZeC5VHzQp1MSt1+jxKkFNemj/iO7tVUA=="
     },
     "pretty-error": {
       "version": "4.0.0",
@@ -11749,7 +11857,7 @@
     "promise-inflight": {
       "version": "1.0.1",
       "resolved": "https://registry.npmjs.org/promise-inflight/-/promise-inflight-1.0.1.tgz",
-      "integrity": "sha1-mEcocL8igTL8vdhoEputEsPAKeM="
+      "integrity": "sha512-6zWPyEOFaQBJYcGMHBKTKJ3u6TBsnMFOIZSa6ce1e/ZrrsOlnHRHbabMjLiBYKp+n44X9eUI6VUPaukCXHuG4g=="
     },
     "promise-retry": {
       "version": "2.0.1",
@@ -12383,7 +12491,7 @@
         "global-dirs": {
           "version": "0.1.1",
           "resolved": "https://registry.npmjs.org/global-dirs/-/global-dirs-0.1.1.tgz",
-          "integrity": "sha1-sxnA3UYH81PzvpzKTHL8FIxJ9EU=",
+          "integrity": "sha512-NknMLn7F2J7aflwFOlGdNIuCDpN3VGoSoB+aap3KABFWbHVn1TCgFC+np23J8W2BiZbjfEw3BFBycSMv1AFblg==",
           "dev": true,
           "requires": {
             "ini": "^1.3.4"
@@ -12536,9 +12644,9 @@
       "integrity": "sha512-YZo3K82SD7Riyi0E1EQPojLz7kpepnSQI9IyPbHHg1XXXevb5dJI7tpyN2ADxGcQbHG7vcyRHk0cbwqcQriUtg=="
     },
     "sass": {
-      "version": "1.52.1",
-      "resolved": "https://registry.npmjs.org/sass/-/sass-1.52.1.tgz",
-      "integrity": "sha512-fSzYTbr7z8oQnVJ3Acp9hV80dM1fkMN7mSD/25mpcct9F7FPBMOI8krEYALgU1aZoqGhQNhTPsuSmxjnIvAm4Q==",
+      "version": "1.52.2",
+      "resolved": "https://registry.npmjs.org/sass/-/sass-1.52.2.tgz",
+      "integrity": "sha512-mfHB2VSeFS7sZlPv9YohB9GB7yWIgQNTGniQwfQ04EoQN0wsQEv7SwpCwy/x48Af+Z3vDeFXz+iuXM3HK/phZQ==",
       "dev": true,
       "requires": {
         "chokidar": ">=3.0.0 <4.0.0",
@@ -12836,9 +12944,9 @@
       }
     },
     "socks-proxy-agent": {
-      "version": "6.2.0",
-      "resolved": "https://registry.npmjs.org/socks-proxy-agent/-/socks-proxy-agent-6.2.0.tgz",
-      "integrity": "sha512-wWqJhjb32Q6GsrUqzuFkukxb/zzide5quXYcMVpIjxalDBBYy2nqKCFQ/9+Ie4dvOYSQdOk3hUlZSdzZOd3zMQ==",
+      "version": "6.2.1",
+      "resolved": "https://registry.npmjs.org/socks-proxy-agent/-/socks-proxy-agent-6.2.1.tgz",
+      "integrity": "sha512-a6KW9G+6B3nWZ1yB8G7pJwL3ggLy1uTzKAgCb7ttblwqdz9fMGJUuTy3uFzEP48FAs9FLILlmzDlE2JJhVQaXQ==",
       "requires": {
         "agent-base": "^6.0.2",
         "debug": "^4.3.3",
@@ -13288,15 +13396,15 @@
       }
     },
     "terser-webpack-plugin": {
-      "version": "5.3.1",
-      "resolved": "https://registry.npmjs.org/terser-webpack-plugin/-/terser-webpack-plugin-5.3.1.tgz",
-      "integrity": "sha512-GvlZdT6wPQKbDNW/GDQzZFg/j4vKU96yl2q6mcUkzKOgW4gwf1Z8cZToUCrz31XHlPWH8MVb1r2tFtdDtTGJ7g==",
+      "version": "5.3.3",
+      "resolved": "https://registry.npmjs.org/terser-webpack-plugin/-/terser-webpack-plugin-5.3.3.tgz",
+      "integrity": "sha512-Fx60G5HNYknNTNQnzQ1VePRuu89ZVYWfjRAeT5rITuCY/1b08s49e5kSQwHDirKZWuoKOBRFS98EUUoZ9kLEwQ==",
       "dev": true,
       "requires": {
+        "@jridgewell/trace-mapping": "^0.3.7",
         "jest-worker": "^27.4.5",
         "schema-utils": "^3.1.1",
         "serialize-javascript": "^6.0.0",
-        "source-map": "^0.6.1",
         "terser": "^5.7.2"
       },
       "dependencies": {
@@ -13531,9 +13639,9 @@
       "dev": true
     },
     "ts-node": {
-      "version": "10.8.0",
-      "resolved": "https://registry.npmjs.org/ts-node/-/ts-node-10.8.0.tgz",
-      "integrity": "sha512-/fNd5Qh+zTt8Vt1KbYZjRHCE9sI5i7nqfD/dzBBRDeVXZXS6kToW6R7tTU6Nd4XavFs0mAVCg29Q//ML7WsZYA==",
+      "version": "10.8.1",
+      "resolved": "https://registry.npmjs.org/ts-node/-/ts-node-10.8.1.tgz",
+      "integrity": "sha512-Wwsnao4DQoJsN034wePSg5nZiw4YKXf56mPIAeD6wVmiv+RytNSWqc2f3fKvcUoV+Yn2+yocD71VOfQHbmVX4g==",
       "dev": true,
       "requires": {
         "@cspotcode/source-map-support": "^0.8.0",
@@ -13629,9 +13737,9 @@
       "dev": true
     },
     "typescript": {
-      "version": "4.7.2",
-      "resolved": "https://registry.npmjs.org/typescript/-/typescript-4.7.2.tgz",
-      "integrity": "sha512-Mamb1iX2FDUpcTRzltPxgWMKy3fhg0TN378ylbktPGPK/99KbDtMQ4W1hwgsbPAsG3a0xKa1vmw4VKZQbkvz5A==",
+      "version": "4.7.3",
+      "resolved": "https://registry.npmjs.org/typescript/-/typescript-4.7.3.tgz",
+      "integrity": "sha512-WOkT3XYvrpXx4vMMqlD+8R8R37fZkjyLGlxavMc4iB8lrl8L0DeTcHbYgw/v0N/z9wAFsgBhcsF0ruoySS22mA==",
       "dev": true
     },
     "ua-parser-js": {
@@ -13860,9 +13968,9 @@
       "dev": true
     },
     "watchpack": {
-      "version": "2.3.1",
-      "resolved": "https://registry.npmjs.org/watchpack/-/watchpack-2.3.1.tgz",
-      "integrity": "sha512-x0t0JuydIo8qCNctdDrn1OzH/qDzk2+rdCOC3YzumZ42fiMqmQ7T3xQurykYMhYfHaPHTp4ZxAx2NfUo1K6QaA==",
+      "version": "2.4.0",
+      "resolved": "https://registry.npmjs.org/watchpack/-/watchpack-2.4.0.tgz",
+      "integrity": "sha512-Lcvm7MGST/4fup+ifyKi2hjyIAwcdI4HRgtvTpIUxBRhB+RFtUh8XtDOxUfctVCnhVi+QQj49i91OyvzkJl6cg==",
       "dev": true,
       "requires": {
         "glob-to-regexp": "^0.4.1",
@@ -13870,9 +13978,9 @@
       }
     },
     "webpack": {
-      "version": "5.72.1",
-      "resolved": "https://registry.npmjs.org/webpack/-/webpack-5.72.1.tgz",
-      "integrity": "sha512-dXG5zXCLspQR4krZVR6QgajnZOjW2K/djHvdcRaDQvsjV9z9vaW6+ja5dZOYbqBBjF6kGXka/2ZyxNdc+8Jung==",
+      "version": "5.73.0",
+      "resolved": "https://registry.npmjs.org/webpack/-/webpack-5.73.0.tgz",
+      "integrity": "sha512-svjudQRPPa0YiOYa2lM/Gacw0r6PvxptHj4FuEKQ2kX05ZLkjbVc5MnPs6its5j7IZljnIqSVo/OsY2X0IpHGA==",
       "dev": true,
       "requires": {
         "@types/eslint-scope": "^3.7.3",
diff --git a/package.json b/package.json
index 0e2bdffb5..401d0cc77 100644
--- a/package.json
+++ b/package.json
@@ -53,8 +53,8 @@
     "@babel/plugin-transform-modules-commonjs": "^7.18.2",
     "@babel/plugin-transform-runtime": "^7.18.2",
     "@babel/preset-env": "^7.18.2",
-    "@commitlint/cli": "^17.0.1",
-    "@commitlint/config-conventional": "^17.0.0",
+    "@commitlint/cli": "^17.0.2",
+    "@commitlint/config-conventional": "^17.0.2",
     "@fortawesome/fontawesome-pro": "^6.1.1",
     "autoprefixer": "^10.4.7",
     "babel-core": "^6.26.3",
@@ -67,7 +67,7 @@
     "clean-webpack-plugin": "^4.0.0",
     "copy-webpack-plugin": "^11.0.0",
     "css-loader": "^6.7.1",
-    "eslint": "^8.16.0",
+    "eslint": "^8.17.0",
     "file-loader": "^6.2.0",
     "fs-extra": "^10.1.0",
     "glob": "^8.0.3",
@@ -82,46 +82,46 @@
     "karma-jasmine-html-reporter": "^2.0.0",
     "karma-mocha-reporter": "^2.2.5",
     "karma-webpack": "^5.0.0",
-    "lint-staged": "^12.4.2",
+    "lint-staged": "^13.0.0",
     "lodash.debounce": "^4.0.8",
     "mini-css-extract-plugin": "^2.6.0",
     "npm-run-all": "^4.1.5",
     "null-loader": "^4.0.1",
     "optimize-css-assets-webpack-plugin": "^6.0.1",
     "postcss-loader": "^7.0.0",
-    "postcss-preset-env": "^7.6.0",
+    "postcss-preset-env": "^7.7.1",
     "real-favicon-webpack-plugin": "^0.2.3",
     "remove-files-webpack-plugin": "^1.5.0",
     "request": "^2.88.2",
     "request-promise": "^4.2.6",
     "resolve-url-loader": "^5.0.0",
-    "sass": "^1.52.1",
+    "sass": "^1.52.2",
     "sass-loader": "^13.0.0",
     "semver": "^7.3.7",
     "standard-version": "^9.5.0",
     "standard-version-updater-yaml": "^1.0.3",
     "style-loader": "^3.3.1",
-    "terser-webpack-plugin": "^5.3.1",
+    "terser-webpack-plugin": "^5.3.3",
     "tmp": "^0.2.1",
     "typeface-roboto": "1.1.13",
     "typeface-source-code-pro": "^1.1.13",
     "typeface-source-sans-pro": "1.1.13",
-    "webpack": "^5.72.1",
+    "webpack": "^5.73.0",
     "webpack-cli": "^4.9.2",
     "webpack-manifest-plugin": "^5.0.0"
   },
   "dependencies": {
     "@babel/runtime": "^7.18.3",
     "@juggle/resize-observer": "^3.3.1",
-    "core-js": "^3.22.7",
+    "core-js": "^3.22.8",
     "css.escape": "^1.5.1",
     "js-cookie": "^3.0.1",
     "lodash.debounce": "^4.0.8",
     "lodash.defer": "^4.1.0",
     "lodash.throttle": "^4.1.1",
     "moment": "^2.29.3",
-    "npm": "^8.11.0",
-    "npm-check-updates": "^13.0.3",
+    "npm": "^8.12.1",
+    "npm-check-updates": "^13.1.1",
     "sodium-javascript": "^0.8.0",
     "toposort": "^2.0.2",
     "whatwg-fetch": "^3.6.2"

From 48c8b8a11e332a998c94c6437d8ba782efb6026e Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sat, 4 Jun 2022 01:19:21 +0200
Subject: [PATCH 14/18] chore: fix package-lock.json

---
 package-lock.json | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/package-lock.json b/package-lock.json
index f71b5ed91..139b49fe4 100644
--- a/package-lock.json
+++ b/package-lock.json
@@ -4056,7 +4056,7 @@
             "boolbase": "~1.0.0",
             "css-what": "2.1",
             "domutils": "1.5.1",
-            "nth-check": "~1.0.1"
+            "nth-check": "^2.0.1"
           }
         },
         "css-what": {
@@ -4121,7 +4121,7 @@
           }
         },
         "nth-check": {
-          "version": "1.0.2",
+          "version": "2.0.1",
           "resolved": "https://registry.npmjs.org/nth-check/-/nth-check-2.0.1.tgz",
           "integrity": "sha512-WeBOdju8SnzPN5vTUJYxYUxLeXpCaVP5i5e0LF8fg7WORF2Wd7wFX/pk0tYZk7s8T+J7VLy0Da6J1+wCT0AtHg==",
           "dev": true,

From 9666d1f64bd57ce75bfbb40bacbc5e38e8d72e7b Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sat, 4 Jun 2022 01:24:47 +0200
Subject: [PATCH 15/18] chore: fix package-lock.json

---
 package-lock.json | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/package-lock.json b/package-lock.json
index 139b49fe4..cd30e13a7 100644
--- a/package-lock.json
+++ b/package-lock.json
@@ -4123,7 +4123,7 @@
         "nth-check": {
           "version": "2.0.1",
           "resolved": "https://registry.npmjs.org/nth-check/-/nth-check-2.0.1.tgz",
-          "integrity": "sha512-WeBOdju8SnzPN5vTUJYxYUxLeXpCaVP5i5e0LF8fg7WORF2Wd7wFX/pk0tYZk7s8T+J7VLy0Da6J1+wCT0AtHg==",
+          "integrity": "sha512-it1vE95zF6dTT9lBsYbxvqh0Soy4SPowchj0UBGj/V6cTPnXXtQOPUbhZ6CmGzAD/rW22LQK6E96pcdJXk4A4w==",
           "dev": true,
           "requires": {
             "boolbase": "~1.0.0"

From 6c92440c6419012ef96a7410e769c8724a8d2206 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sat, 4 Jun 2022 12:07:23 +0200
Subject: [PATCH 16/18] fix(test): add missing workflow instance

---
 test/Model/TypesSpec.hs | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs
index b1c3d8a8b..e45b6ff49 100644
--- a/test/Model/TypesSpec.hs
+++ b/test/Model/TypesSpec.hs
@@ -391,6 +391,9 @@ instance Arbitrary SchoolAuthorshipStatementMode where
 instance Arbitrary SheetAuthorshipStatementMode where
   arbitrary = genericArbitrary
 
+instance Arbitrary WorkflowWorkflowListType where
+  arbitrary = genericArbitrary
+
 
 spec :: Spec
 spec = do

From f58083269b9c047073170869de4c9c7cbaf816cd Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sat, 4 Jun 2022 12:56:57 +0200
Subject: [PATCH 17/18] test(workflows): add missing instances

---
 test/Model/TypesSpec.hs | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs
index e45b6ff49..4823b57a6 100644
--- a/test/Model/TypesSpec.hs
+++ b/test/Model/TypesSpec.hs
@@ -393,6 +393,8 @@ instance Arbitrary SheetAuthorshipStatementMode where
 
 instance Arbitrary WorkflowWorkflowListType where
   arbitrary = genericArbitrary
+instance CoArbitrary WorkflowWorkflowListType
+instance Function WorkflowWorkflowListType
 
 
 spec :: Spec

From e3ceb27899334779bd6fdbbb89aee9bbefb00d94 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sat, 4 Jun 2022 14:10:00 +0200
Subject: [PATCH 18/18] refactor: hlint

---
 src/Handler/Workflow/Workflow/Workflow.hs | 2 +-
 src/Model/Migration/Definitions.hs        | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs
index 99fe42538..97516fd6b 100644
--- a/src/Handler/Workflow/Workflow/Workflow.hs
+++ b/src/Handler/Workflow/Workflow/Workflow.hs
@@ -100,7 +100,7 @@ workflowR rScope cID = workflowsDisabledWarning title heading $ do
           archiveAfter <- MaybeT . getsYesod $ view _appWorkflowWorkflowArchiveAfter
           let WorkflowAction{wpTo,wpTime} = last nState
           WGN{wgnFinal} <- hoistMaybe $ Map.lookup wpTo wgNodes
-          return $ const (archiveAfter `addUTCTime` wpTime) <$> wgnFinal
+          return $ (archiveAfter `addUTCTime` wpTime) <$ wgnFinal
 
         update wwId [ WorkflowWorkflowState    =. view _DBWorkflowState nState
                     , WorkflowWorkflowArchived =. wwArchived
diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs
index 80e97dd07..afa049943 100644
--- a/src/Model/Migration/Definitions.hs
+++ b/src/Model/Migration/Definitions.hs
@@ -1073,10 +1073,10 @@ customMigrations = mapF $ \case
     let mArchiveAfter = Just (5270400 :: NominalDiffTime)
     [executeQQ| ALTER TABLE "workflow_workflow" ADD "archived" timestamp with time zone; |]
     let getWorkflows = [queryQQ| SELECT "workflow_workflow"."id", "workflow_workflow"."state"->-1->'time', "workflow_workflow"."state"->-1->'to', "shared_workflow_graph"."graph" FROM "workflow_workflow" INNER JOIN "shared_workflow_graph" ON "workflow_workflow"."graph" = "shared_workflow_graph"."hash"; |]
-        migrateArchived [ fromPersistValue -> Right (wwId :: WorkflowWorkflowId), fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success wpTime), fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success wpTo), fromPersistValue -> Right (wGraph :: DBWorkflowGraph) ] = maybeT (return ()) $ do
+        migrateArchived [ fromPersistValue -> Right (wwId :: WorkflowWorkflowId), fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success wpTime), fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success wpTo), fromPersistValue -> Right (wGraph :: DBWorkflowGraph) ] = maybeT_ $ do
           archiveAfter <- hoistMaybe mArchiveAfter
           WGN{wgnFinal} <- hoistMaybe . Map.lookup wpTo $ wgNodes wGraph
-          let wwArchived = const (max now $ archiveAfter `addUTCTime` wpTime) <$> wgnFinal
+          let wwArchived = max now (archiveAfter `addUTCTime` wpTime) <$ wgnFinal
           lift [executeQQ| UPDATE "workflow_workflow" SET "archived" = #{wwArchived} WHERE "id" = #{wwId}; |]
         migrateArchived _ = return ()
      in runConduit $ getWorkflows .| C.mapM_ migrateArchived