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