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