{-# LANGUAGE QuasiQuotes #-}
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
swaggerUI ::
( StdHandler h m
, Sets
h
[ RequiredResponseHeader "Content-Type" Text
, RequiredResponseHeader "Content-Type" Mime.MimeType
, Body HTML ByteString
, Body JSON apiSpec
, UnknownContentBody
]
Response
) =>
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
) =>
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