feat(external-apis): create new external api registrations

2020-04-07 13:54:39 +02:00 · 2020-04-07 13:54:39 +02:00 · 559f9db7d5
commit 559f9db7d5
parent 4216785e90
13 changed files with 361 additions and 46 deletions
--- a/src/Data/HashSet/Instances.hs
+++ 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])
--- 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
--- 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
--- a/src/Foundation/Servant/Types.hs
+++ 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"]]
--- 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)

--- 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(..))
--- 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
--- 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
+  }
--- a/src/Network/URI/Instances.hs
+++ 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|]
+    ]
--- 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
+      ]
--- 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
--- 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
--- 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