feat(external-apis): idents, info, pong, delete, and expiry

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

models/external-apis.model

@@ -1,6 +1,8 @@
 ExternalApi
+  ident UUID Maybe
   authority Jwt
   keys JwkSet
   baseUrl BaseUrl
   config ExternalApiConfig
-  lastAlive UTCTime
+  lastAlive UTCTime
+  UniqueExternalApiIdent ident !force

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

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

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 = '[]

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

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

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

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(..))

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
 

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

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

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 }

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
+  }

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{..}

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

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

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

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

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

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