83 lines
2.6 KiB
Haskell
83 lines
2.6 KiB
Haskell
-- 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
|