@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE ConstraintKinds #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE DeriveGeneric #-}
@@ -28,39 +29,13 @@
2829-- type BasicAPI = Get '[PlainText, JSON] Text
2930-- :\<|> "cat" :> Capture ":name" CatName :> Get '[JSON] Cat
3031--
31−-- -- | Swagger schema endpoint.
32−-- type SwaggerSchemaEndpoint = "swagger.js" :> Get '[JSON] Swagger
33−--
34−-- -- | Unhabitated new data type, to be able to refer to API type from the API type.
35−-- data API
36−--
37−-- -- | Underlying API type.
38−-- --
39−-- -- NOTE: place BasicAPI last for it not to override SwaggerSchemaEndpoing and SwaggerUI.
40−-- -- If you place BasicAPI first and it has Raw endpoint at root Swagger schema and UI won't work.
41−-- type API' = SwaggerSchemaEndpoint
42−-- :\<|> 'SwaggerUI' "ui" SwaggerSchemaEndpoint API
32+-- -- | API type with bells and whistles, i.e. schema file and swagger-ui.
33+-- type API = 'SwaggerSchemaUI' "swagger.json" "swagger-ui"
4334-- :\<|> BasicAPI
4435--
45−-- -- Optionally we can do:
46−-- --
47−-- -- type API' = SwaggerSchemaEndpoint
48−-- -- :\<|> BasicAPI
49−-- --
50−-- -- type API = SwaggerUI "ui" SwaggerSchemaEndpoint API'
51−-- -- :\<|> API'
52−--
53−-- -- Unfortunately we have to write these trivial instances.
54−--
55−-- instance HasServer API context where
56−-- type ServerT API m = ServerT API' m
57−-- route _ = route (Proxy :: Proxy API')
58−--
59−-- type instance IsElem' e API = IsElem e API'
60−--
36+-- -- | Servant server for an API
6137-- server :: Server API
62−-- server = pure swaggerDoc
63−-- :\<|> 'swaggerUIServer'
38+-- server = 'swaggerSchemaUIServer' swaggerDoc
6439-- :\<|> (pure "Hello World" :\<|> catEndpoint)
6540-- where
6641-- catEndpoint name = pure $ Cat name False
@@ -68,47 +43,90 @@
6843
6944module Servant.Swagger.UI (
7045 -- * Swagger UI API
71− SwaggerUI,
72− swaggerUIServer,
46+ SwaggerSchemaUI,
47+ SwaggerSchemaUI',
48+ swaggerSchemaUIServer,
7349 -- * Internals
7450 SwaggerUiHtml(..),
7551 ) where
7652
7753import Data.ByteString (ByteString)
7854import Data.FileEmbed (embedStringFile)
79−import Data.Monoid ((<>))
80−import GHC.TypeLits (Symbol)
55+import Data.Swagger (Swagger)
56+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
8157import Network.Wai.Application.Static (embeddedSettings, staticApp)
8258import Servant
8359import Servant.HTML.Blaze (HTML)
84−import Text.Blaze (ToMarkup (..))
8560import Servant.Swagger.UI.Internal
61+import Text.Blaze (ToMarkup (..))
8662
8763import qualified Data.Text as T
8864
89−-- | Swagger API ui.
90−type SwaggerUI (dir :: Symbol) endpoint api = dir :>
91− ( Get '[HTML] (SwaggerUiHtml endpoint api) :<|>
92− "index.html" :> Get '[HTML] (SwaggerUiHtml endpoint api) :<|>
93− Raw)
65+#if MIN_VERSION_servant(0,5,0)
66+import Control.Monad.Trans.Except (ExceptT)
67+#else
68+import Control.Monad.Trans.Either (EitherT)
69+#define ExceptT EitherT
70+#endif
71+
72+-- | Swagger schema + ui api.
73+--
74+-- @SwaggerSchemaUI "swagger-ui" "swagger.json"@ will result into following hierarchy:
75+--
76+-- @
77+-- \/swagger.json
78+-- \/swagger-ui
79+-- \/swagger-ui\/index.html
80+-- \/swagger-ui\/...
81+-- @
82+--
83+type SwaggerSchemaUI (dir :: Symbol) (schema :: Symbol) =
84+ SwaggerSchemaUI' dir (schema :> Get '[JSON] Swagger)
85+
86+-- | Use 'SwaggerSchemaUI'' when you need even more control over
87+-- where @swagger.json@ is served (e.g. subdirectory).
88+type SwaggerSchemaUI' (dir :: Symbol) (api :: *) =
89+ api
90+ :<|> dir :>
91+ ( Get '[HTML] (SwaggerUiHtml dir api)
92+ :<|> "index.html" :> Get '[HTML] (SwaggerUiHtml dir api)
93+ :<|> Raw
94+ )
9495
9596-- | Index file for swagger ui.
9697--
97−-- It's configured by the location of swagger schema.
98−data SwaggerUiHtml endpoint api = SwaggerUiHtml
98+-- It's configured by the location of swagger schema and directory it lives under.
99+--
100+-- Implementation detail: the @index.html@ is prepopulated with parameters
101+-- to find schema file automatically.
102+data SwaggerUiHtml (dir :: Symbol) (api :: *) = SwaggerUiHtml
99103
100−instance (IsElem endpoint api, HasLink endpoint, MkLink endpoint ~ URI)
101− => ToMarkup (SwaggerUiHtml endpoint api) where
102− toMarkup _ = preEscapedToMarkup $
103− T.replace "SWAGGER_URL_PLACEHOLDER" url swaggerUiIndexTemplate
104+instance (KnownSymbol dir, HasLink api, URI ~ MkLink api, IsElem api api)
105+ => ToMarkup (SwaggerUiHtml dir api)
106+ where
107+ toMarkup _ = preEscapedToMarkup
108+ $ T.replace "SERVANT_SWAGGER_UI_SCHEMA" schema
109+ $ T.replace "SERVANT_SWAGGER_UI_DIR" dir
110+ $ swaggerUiIndexTemplate
104111 where
105− uri = safeLink (Proxy :: Proxy api) (Proxy :: Proxy endpoint) :: URI
106− url = T.pack $ "/" <> uriPath uri -- TODO: do we need more?
112+ schema = T.pack $ uriPath $ safeLink proxyApi proxyApi
113+ dir = T.pack $ symbolVal (Proxy :: Proxy dir)
114+ proxyApi = Proxy :: Proxy api
107115
108−-- | Serve Swagger UI on @/<dir>@ using @endpoint@ as Swagger spec source for @api@.
109−swaggerUIServer :: Server (SwaggerUI dir endpoint api)
110−swaggerUIServer = return SwaggerUiHtml :<|> return SwaggerUiHtml :<|> rest
111− where rest = staticApp $ embeddedSettings swaggerUiFiles
116+-- | Serve Swagger UI on @/dir@ using @api@ as a Swagger spec source.
117+--
118+-- @
119+-- swaggerSchemaUIServer :: Swagger -> Server (SwaggerSchemaUI schema dir)
120+-- @
121+swaggerSchemaUIServer
122+ :: (Server api ~ ExceptT ServantErr IO Swagger)
123+ => Swagger -> Server (SwaggerSchemaUI' dir api)
124+swaggerSchemaUIServer swagger = return swagger
125+ :<|> return SwaggerUiHtml
126+ :<|> return SwaggerUiHtml
127+ :<|> rest
128+ where
129+ rest = staticApp $ embeddedSettings swaggerUiFiles
112130
113131swaggerUiIndexTemplate :: T.Text
114132swaggerUiIndexTemplate = $(embedStringFile "index.html.tmpl")