{-# LANGUAGE QuasiQuotes #-}

-- | Host swagger-ui based on WebGear API specifications
module WebGear.Swagger.UI (
  swaggerUI,
) where

import Control.Arrow (returnA, (<+>))
import Data.ByteString (ByteString)
import Data.ByteString.Builder (byteString)
import Data.Text (Text, unpack)
import qualified Network.HTTP.Types as HTTP
import qualified Network.Mime as Mime
import WebGear.Core (
  Body,
  HTML (..),
  Handler (consumeRoute),
  JSON (..),
  PlainText (..),
  RequestHandler,
  RequiredResponseHeader,
  Response (..),
  ResponseBody (ResponseBodyBuilder),
  RoutePath (..),
  Sets,
  StdHandler,
  UnknownContentBody,
  match,
  method,
  ok200,
  pathEnd,
  respondA,
  route,
  setBodyWithoutContentType,
  setHeader,
  unwitnessA,
  (>->),
 )
import qualified WebGear.Swagger.UI.Embedded as Embedded

{- | An API that hosts a few endpoints for swagger-ui.

- @/@ - redirects to @/index.html@
- @/index.html@ - UI entry point for swagger-ui
- @/swagger.json@ - Swagger/OpenAPI specification in json format
- @/...@ - Other UI assets required for swagger-ui
-}
swaggerUI ::
  ( StdHandler h m
  , Sets
      h
      [ RequiredResponseHeader "Content-Type" Text
      , RequiredResponseHeader "Content-Type" Mime.MimeType
      , Body HTML ByteString
      , Body JSON apiSpec
      , UnknownContentBody
      ]
      Response
  ) =>
  -- | Swagger 2.0 or OpenAPI 3.x specification
  apiSpec ->
  RequestHandler h ts
swaggerUI :: forall (h :: * -> * -> *) (m :: * -> *) apiSpec (ts :: [*]).
(StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     RequiredResponseHeader "Content-Type" MimeType, Body HTML MimeType,
     Body JSON apiSpec, UnknownContentBody]
   Response) =>
apiSpec -> RequestHandler h ts
swaggerUI apiSpec
apiSpec =
  forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body HTML MimeType]
   Response) =>
RequestHandler h ts
rootEndpoint
    forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body HTML MimeType]
   Response) =>
RequestHandler h ts
indexHtml
    forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> forall (h :: * -> * -> *) (m :: * -> *) apiSpec (ts :: [*]).
(StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body JSON apiSpec]
   Response) =>
apiSpec -> RequestHandler h ts
swaggerJson apiSpec
apiSpec
    forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     RequiredResponseHeader "Content-Type" MimeType, UnknownContentBody]
   Response) =>
RequestHandler h ts
uiAssets

rootEndpoint ::
  ( StdHandler h m
  , Sets h [RequiredResponseHeader "Content-Type" Text, Body HTML ByteString] Response
  ) =>
  RequestHandler h ts
rootEndpoint :: forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body HTML MimeType]
   Response) =>
RequestHandler h ts
rootEndpoint = forall (h :: * -> * -> *) (ts :: [*]).
(Get h Method Request, ArrowChoice h,
 ArrowError RouteMismatch h) =>
StdMethod -> Middleware h ts (Method : ts)
method StdMethod
HTTP.GET forall a b. (a -> b) -> a -> b
$ forall (h :: * -> * -> *) (ts :: [*]).
(Get h PathEnd Request, ArrowChoice h,
 ArrowError RouteMismatch h) =>
Middleware h ts (PathEnd : ts)
pathEnd forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body HTML MimeType]
   Response) =>
RequestHandler h ts
serveIndexHtml

indexHtml ::
  ( StdHandler h m
  , Sets h [RequiredResponseHeader "Content-Type" Text, Body HTML ByteString] Response
  ) =>
  RequestHandler h ts
indexHtml :: forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body HTML MimeType]
   Response) =>
RequestHandler h ts
indexHtml = [route| HTTP.GET /index.html |] forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body HTML MimeType]
   Response) =>
RequestHandler h ts
serveIndexHtml

serveIndexHtml ::
  ( StdHandler h m
  , Sets h [RequiredResponseHeader "Content-Type" Text, Body HTML ByteString] Response
  ) =>
  RequestHandler h ts
serveIndexHtml :: forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body HTML MimeType]
   Response) =>
RequestHandler h ts
serveIndexHtml = proc With Request ts
_request ->
  forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body, RequiredResponseHeader "Content-Type" Text]
   Response,
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 HTML
HTML -< MimeType
Embedded.indexHtmlFile

swaggerJson ::
  ( StdHandler h m
  , Sets h [RequiredResponseHeader "Content-Type" Text, Body JSON apiSpec] Response
  ) =>
  -- | Swagger 2.0 or OpenAPI 3.x specification
  apiSpec ->
  RequestHandler h ts
swaggerJson :: forall (h :: * -> * -> *) (m :: * -> *) apiSpec (ts :: [*]).
(StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text, Body JSON apiSpec]
   Response) =>
apiSpec -> RequestHandler h ts
swaggerJson apiSpec
apiSpec =
  [route| HTTP.GET /swagger.json |]
    forall a b. (a -> b) -> a -> b
$ proc With Request (PathEnd : Path : Method : ts)
_request -> forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body, RequiredResponseHeader "Content-Type" Text]
   Response,
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.ok200 JSON
JSON -< apiSpec
apiSpec

uiAssets ::
  ( StdHandler h m
  , Sets
      h
      [ RequiredResponseHeader "Content-Type" Text
      , RequiredResponseHeader "Content-Type" Mime.MimeType
      , UnknownContentBody
      ]
      Response
  ) =>
  RequestHandler h ts
uiAssets :: forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
(StdHandler h m,
 Sets
   h
   '[RequiredResponseHeader "Content-Type" Text,
     RequiredResponseHeader "Content-Type" MimeType, UnknownContentBody]
   Response) =>
RequestHandler h ts
uiAssets =
  [match| HTTP.GET / |]
    forall a b. (a -> b) -> a -> b
$ proc With Request (Method : ts)
_request -> do
      RoutePath [Text]
path <- forall (h :: * -> * -> *) (m :: * -> *) a.
Handler h m =>
h RoutePath a -> h () a
consumeRoute forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()
      case [Text]
path of
        [Text
filename] ->
          case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Text -> String
unpack Text
filename) [(String, MimeType)]
Embedded.uiAssetsDir of
            Maybe MimeType
Nothing -> h () Response
notFound -< ()
            Just MimeType
content -> do
              let contentType :: MimeType
contentType = Text -> MimeType
Mime.defaultMimeLookup Text
filename
              (forall (h :: * -> * -> *).
Set h Status Response =>
h () (With Response '[Status])
ok200 -< ())
                forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> (\With Response '[Status]
resp -> forall (h :: * -> * -> *) (ts :: [*]).
Set h UnknownContentBody Response =>
h (With Response ts, ResponseBody)
  (With Response (UnknownContentBody : ts))
setBodyWithoutContentType -< (With Response '[Status]
resp, Builder -> ResponseBody
ResponseBodyBuilder forall a b. (a -> b) -> a -> b
$ MimeType -> Builder
byteString MimeType
content))
                forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> (\With Response '[UnknownContentBody, Status]
resp -> forall (name :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
Set h (ResponseHeader 'Required name val) Response =>
h (With Response ts, val)
  (With Response (ResponseHeader 'Required name val : ts))
setHeader @"Content-Type" -< (With Response '[UnknownContentBody, Status]
resp, MimeType
contentType))
                forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> (\With
  Response
  '[RequiredResponseHeader "Content-Type" MimeType,
    UnknownContentBody, Status]
resp -> forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (With Response ts) Response
unwitnessA -< With
  Response
  '[RequiredResponseHeader "Content-Type" MimeType,
    UnknownContentBody, Status]
resp)
        [Text]
_ -> h () Response
notFound -< ()
  where
    notFound :: h () Response
notFound = proc () -> do
      forall body mt (h :: * -> * -> *) (m :: * -> *).
(Handler h m,
 Sets
   h
   '[Status, Body mt body, RequiredResponseHeader "Content-Type" Text]
   Response,
 MIMEType mt) =>
Status -> mt -> h body Response
respondA Status
HTTP.notFound404 PlainText
PlainText -< Text
"" :: Text