From 90679e00952ee4d6df584b52ceba99c0216e222e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 8 Apr 2020 16:07:11 +0200 Subject: [PATCH] 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