-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Handler.Swagger
  ( getSwaggerR, getSwaggerJsonR
  ) where

import Import hiding (host, Response, Scheme(..))
import ServantApi

import Data.Swagger
import Data.Swagger.Declare (Declare)
import Servant.Swagger
  
import Development.GitRev

import Network.URI

import Text.Read (readMaybe)


genSwagger :: Handler Swagger
genSwagger = do
  app <- getYesod
  let
    docMR :: RenderMessage UniWorX msg => msg -> Text
    docMR = renderMessage app . otoList $ selectLanguages appLanguages ["en"]
  root <- getApprootText approot app <$> waiRequest
  let applyApproot = do
        URI{..} <- fmap rectify . parseURIReference $ unpack root
        let mbScheme = do
              str <- assertM (not . null) $ stripSuffix ":" uriScheme
              case str of
                "https" -> return Https
                "http"  -> return Http
                _other  -> mzero
            applyAuthority = do
              URIAuth{..} <- uriAuthority
              let mbPort = readMaybe . fromMaybe "" $ stripPrefix ":" uriPort
              return $
                host ?~ Host uriRegName mbPort
        return $ \x -> x
          & fromMaybe id applyAuthority
          & schemes .~ fmap pure mbScheme
          & basePath ?~ bool id (ensurePrefix "/") (is _Just mbScheme || is _Just uriAuthority) uriPath
      errorResponses :: Map HttpStatusCode (Declare (Definitions Schema) Response)
      errorResponses = mconcat
        [ singletonMap 500 $ return mempty
        , singletonMap 400 $ return mempty
        , singletonMap 401 $ return mempty
        , singletonMap 403 $ return mempty
        , singletonMap 405 $ return mempty
        ]
        
  tos <- toTextUrl $ LegalR :#: ("terms-of-use" :: Text)
  c <- toTextUrl HelpR

  let supportContact = mempty
        & name .~ addressName supportAddress
        & email ?~ addressEmail supportAddress
        & url ?~ URL c
        where
          supportAddress = appMailSupport $ appSettings' app

  return $ toSwagger uniworxApi
    & info.title .~ docMR MsgLogo
    & info.description ?~ docMR MsgInvitationUniWorXTip
    & info.termsOfService ?~ tos
    & info.contact ?~ supportContact
    & info.version .~ $gitDescribe
    & fromMaybe id applyApproot
    & appEndo (ifoldMap ((Endo .) . setResponseWith const) errorResponses)


getSwaggerR :: Handler TypedContent
getSwaggerR = selectRep $ do
  provideRep $ toPrettyJSON <$> genSwagger
  provideRep $ toYAML       <$> genSwagger

getSwaggerJsonR :: Handler Void
getSwaggerJsonR = redirect SwaggerR