114 lines
3.9 KiB
Haskell
114 lines
3.9 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module ServantApi.ExternalApis
|
|
( module ServantApi.ExternalApis.Type
|
|
) where
|
|
|
|
import Import.Servant
|
|
|
|
import ServantApi.ExternalApis.Type
|
|
|
|
import qualified Data.HashSet as HashSet
|
|
|
|
|
|
instance ServantApiDispatchUniWorX ExternalApis where
|
|
servantServer' _ = genericServerT ExternalApis
|
|
{ externalApisListR = externalApisList
|
|
, externalApisCreateR = externalApiCreate
|
|
, externalApisInfoR = externalApiInfo
|
|
, externalApisPongR = externalApiPong
|
|
, externalApisDeleteR = externalApiDelete
|
|
}
|
|
|
|
externalApisList :: ServantHandler ExternalApisList
|
|
externalApisList = runDB $ fmap ExternalApisList . lift . toResponse =<< selectList [] [Desc ExternalApiLastAlive]
|
|
where
|
|
toResponse :: [Entity ExternalApi] -> ServantHandler (HashMap CryptoUUIDExternalApi ExternalApiInfo)
|
|
toResponse = foldMapM $ fmap (uncurry singletonMap) . toResponse'
|
|
|
|
toResponse' :: Entity ExternalApi -> ServantHandler (CryptoUUIDExternalApi, ExternalApiInfo)
|
|
toResponse' (Entity eApiId eApi) = (,) <$> encrypt eApiId <*> dbToInfo eApi
|
|
|
|
externalApiCreate :: Maybe ExternalApiCreationRestrictions
|
|
-> BearerToken UniWorX
|
|
-> ExternalApiCreationRequest
|
|
-> ServantHandler (Headers '[Header "Location" URI] ExternalApiCreationResponse)
|
|
externalApiCreate mRestr bearer ExternalApiCreationRequest{..} = do
|
|
now <- liftIO getCurrentTime
|
|
|
|
unless (maybe True matchesRequest mRestr) $
|
|
throwError err403{ errBody = "Bearer restrictions do not permit request" }
|
|
|
|
jwt <- encodeBearer bearer
|
|
|
|
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 @ExternalApisInfoR) eacrId
|
|
|
|
eacrInfo <- set _eaiPublicKeys (eacrPublicKeys & _keys %~ filter (not . isPrivateJwk)) <$> dbToInfo api
|
|
|
|
return $ addHeader location ExternalApiCreationResponse
|
|
{ eacrId
|
|
, 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 <- foldMapM (fmap HashSet.singleton . 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{..}
|