servant-docs 0.3.1 → 0.4.0
raw patch · 7 files changed
+1133/−673 lines, 7 filesdep +bytestring-conversiondep +case-insensitivedep +hspecdep −aeson-prettydep −system-filepathdep ~basedep ~lensdep ~servant
Dependencies added: bytestring-conversion, case-insensitive, hspec, http-media, http-types
Dependencies removed: aeson-pretty, system-filepath
Dependency ranges changed: base, lens, servant
Files
- CHANGELOG.md +12/−0
- README.md +9/−6
- example/greet.hs +63/−16
- servant-docs.cabal +36/−9
- src/Servant/Docs.hs +110/−642
- src/Servant/Docs/Internal.hs +902/−0
- test/Spec.hs +1/−0
CHANGELOG.md view
@@ -1,3 +1,15 @@+0.4+---+* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body+* Allow for extra information to be added to the docs+* Support content-type aware combinators of *servant-0.4*+* Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15)+* Remove ToJSON superclass from ToSample+* Split out Internal module+* Add support for response headers+* Allow `ToSample` to return a different type than it's arguments+* Add Proxy argument to `ToSample`+ 0.3 ---
README.md view
@@ -1,14 +1,12 @@ # servant-docs -[](http://travis-ci.org/haskell-servant/servant-docs)-  Generate API docs for your *servant* webservice. Feel free to also take a look at [servant-pandoc](https://github.com/mpickering/servant-pandoc) which uses this package to target a broad range of output formats using the excellent **pandoc**. ## Example -See [here](https://github.com/haskell-servant/servant-docs/blob/master/example/greet.md) for the output of the following program.+See [here](https://github.com/haskell-servant/servant/tree/master/servant-docs/blob/master/example/greet.md) for the output of the following program. ``` haskell {-# LANGUAGE DataKinds #-}@@ -27,10 +25,15 @@ data Greet = Greet { _msg :: Text } deriving (Generic, Show) --- we get our JSON serialization for free+-- we get our JSON serialization for free. This will be used by the default+-- 'MimeRender' instance for 'JSON'. instance FromJSON Greet instance ToJSON Greet +-- We can also implement 'MimeRender' explicitly for additional formats.+instance MimeRender PlainText Greet where+ toByteString Proxy (Greet s) = "<h1>" <> cs s <> "</h1>"+ -- we provide a sample value for the 'Greet' type instance ToSample Greet where toSample = Just g@@ -51,8 +54,8 @@ -- API specification type TestApi =- "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet- :<|> "greet" :> RQBody Greet :> Post Greet+ "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet+ :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet :<|> "delete" :> Capture "greetid" Text :> Delete testApi :: Proxy TestApi
example/greet.hs view
@@ -1,12 +1,15 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+import Control.Lens import Data.Aeson import Data.Proxy-import Data.Text+import Data.String.Conversions+import Data.Text (Text) import GHC.Generics import Servant.API import Servant.Docs@@ -14,12 +17,18 @@ -- * Example -- | A greet message data type-newtype Greet = Greet { msg :: Text }+newtype Greet = Greet Text deriving (Generic, Show) +-- | We can get JSON support automatically. This will be used to parse+-- and encode a Greeting as 'JSON'. instance FromJSON Greet instance ToJSON Greet +-- | We can also implement 'MimeRender' for additional formats like 'PlainText'.+instance MimeRender PlainText Greet where+ mimeRender Proxy (Greet s) = "\"" <> cs s <> "\""+ -- We add some useful annotations to our captures, -- query parameters and request body to make the docs -- really helpful.@@ -33,7 +42,8 @@ toParam _ = DocQueryParam "capital" ["true", "false"]- "Get the greeting message in uppercase (true) or not (false). Default is false."+ "Get the greeting message in uppercase (true) or not (false).\+ \Default is false." Normal instance ToParam (MatrixParam "lang" String) where@@ -43,34 +53,71 @@ "Get the greeting message selected language. Default is en." Normal -instance ToSample Greet where- toSample = Just $ Greet "Hello, haskeller!"+instance ToSample () () where+ toSample _ = Just () - toSamples =+instance ToSample Greet Greet where+ toSample _ = Just $ Greet "Hello, haskeller!"++ toSamples _ = [ ("If you use ?capital=true", Greet "HELLO, HASKELLER") , ("If you use ?capital=false", Greet "Hello, haskeller") ] +instance ToSample Int Int where+ toSample _ = Just 1729++-- We define some introductory sections, these will appear at the top of the+-- documentation.+--+-- We pass them in with 'docsWith', below. If you only want to add+-- introductions, you may use 'docsWithIntros'+intro1 :: DocIntro+intro1 = DocIntro "On proper introductions." -- The title+ [ "Hello there."+ , "As documentation is usually written for humans, it's often useful \+ \to introduce concepts with a few words." ] -- Elements are paragraphs++intro2 :: DocIntro+intro2 = DocIntro "This title is below the last"+ [ "You'll also note that multiple intros are possible." ]++ -- API specification type TestApi =- -- GET /hello/:name?capital={true, false} returns a Greet as JSON- "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet+ -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText+ "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet -- POST /greet with a Greet as JSON in the request body, -- returns a Greet as JSON- :<|> "greet" :> ReqBody Greet :> Post Greet+ :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet) -- DELETE /greet/:greetid- :<|> "greet" :> Capture "greetid" Text :> Delete+ :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] () testApi :: Proxy TestApi testApi = Proxy +-- Build some extra information for the DELETE /greet/:greetid endpoint. We+-- want to add documentation about a secret unicorn header and some extra+-- notes.+extra :: ExtraInfo TestApi+extra =+ extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] ())) $+ defAction & headers <>~ ["unicorns"]+ & notes <>~ [ DocNote "Title" ["This is some text"]+ , DocNote "Second secton" ["And some more"]+ ]+ -- Generate the data that lets us have API docs. This -- is derived from the type as well as from -- the 'ToCapture', 'ToParam' and 'ToSample' instances from above.+--+-- If you didn't want intros and extra information, you could just call:+--+-- > docs testAPI :: API docsGreet :: API-docsGreet = docs testApi+docsGreet = docsWith [intro1, intro2] extra testApi main :: IO () main = putStrLn $ markdown docsGreet
servant-docs.cabal view
@@ -1,10 +1,12 @@ name: servant-docs-version: 0.3.1+version: 0.4.0 synopsis: generate API docs for your servant webservice description: Library for generating API docs from a servant API definition. . Runnable example <https://github.com/haskell-servant/servant-docs/blob/master/example/greet.hs here>.+ .+ <https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md CHANGELOG> license: BSD3 license-file: LICENSE author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni@@ -15,27 +17,29 @@ cabal-version: >=1.10 tested-with: GHC >= 7.8 homepage: http://haskell-servant.github.io/-Bug-reports: http://github.com/haskell-servant/servant-docs/issues+Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: CHANGELOG.md README.md source-repository head type: git- location: http://github.com/haskell-servant/servant-docs.git+ location: http://github.com/haskell-servant/servant.git library exposed-modules:- Servant.Docs+ Servant.Docs+ , Servant.Docs.Internal build-depends: base >=4.7 && <5- , aeson- , aeson-pretty < 0.8 , bytestring+ , bytestring-conversion+ , case-insensitive , hashable+ , http-media >= 0.6+ , http-types >= 0.7 , lens- , servant >= 0.2.1 && < 0.3+ , servant == 0.4.* , string-conversions- , system-filepath , text , unordered-containers hs-source-dirs: src@@ -46,5 +50,28 @@ main-is: greet.hs hs-source-dirs: example ghc-options: -Wall- build-depends: base, aeson, servant, servant-docs, text+ build-depends:+ base+ , aeson+ , bytestring-conversion+ , lens+ , servant+ , servant-docs+ , string-conversions+ , text default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ ghc-options: -Wall+ build-depends:+ base+ , aeson+ , hspec+ , servant+ , servant-docs+ , string-conversions+ default-language: Haskell2010+
src/Servant/Docs.hs view
@@ -1,23 +1,18 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}- ---------------------------------------------------------------------------------- | This module lets you get API docs for free. It lets generate+-- | This module lets you get API docs for free. It lets you generate -- an 'API' from the type that represents your API using 'docs': -- -- @docs :: 'HasDocs' api => 'Proxy' api -> 'API'@ ----- You can then call 'markdown' on it:+-- Alternatively, if you wish to add one or more introductions to your+-- documentation, use 'docsWithIntros': ----- @markdown :: 'API' -> String@+-- @'docsWithIntros' :: 'HasDocs' api => [DocIntro] -> 'Proxy' api -> 'API'@ --+-- You can then call 'markdown' on the 'API' value:+--+-- @'markdown' :: 'API' -> String@+-- -- or define a custom pretty printer: -- -- @yourPrettyDocs :: 'API' -> String -- or blaze-html's HTML, or ...@@@ -25,65 +20,130 @@ -- The only thing you'll need to do will be to implement some classes -- for your captures, get parameters and request or response bodies. ----- Here's a little (but complete) example that you can run to see the--- markdown pretty printer in action:+-- Here is a complete example that you can run to see the markdown pretty+-- printer in action: ----- > {-# LANGUAGE DataKinds #-}--- > {-# LANGUAGE PolyKinds #-}--- > {-# LANGUAGE TypeFamilies #-}--- > {-# LANGUAGE DeriveGeneric #-}--- > {-# LANGUAGE TypeOperators #-}--- > {-# LANGUAGE FlexibleInstances #-}--- > {-# LANGUAGE OverloadedStrings #-}--- >+-- > {-# LANGUAGE DataKinds #-}+-- > {-# LANGUAGE DeriveGeneric #-}+-- > {-# LANGUAGE FlexibleInstances #-}+-- > {-# LANGUAGE MultiParamTypeClasses #-}+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE TypeOperators #-}+-- > {-# OPTIONS_GHC -fno-warn-orphans #-}+-- > import Data.Aeson -- > import Data.Proxy--- > import Data.Text--- > import Servant+-- > import Data.String.Conversions+-- > import Data.Text (Text)+-- > import GHC.Generics+-- > import Servant.API+-- > import Servant.Docs -- >--- > -- our type for a Greeting message--- > data Greet = Greet { _msg :: Text }+-- > -- * Example+-- >+-- > -- | A greet message data type+-- > newtype Greet = Greet Text -- > deriving (Generic, Show) -- >--- > -- we get our JSON serialization for free+-- > -- | We can get JSON support automatically. This will be used to parse+-- > -- and encode a Greeting as 'JSON'. -- > instance FromJSON Greet -- > instance ToJSON Greet -- >--- > -- we provide a sample value for the 'Greet' type--- > instance ToSample Greet where--- > toSample = Just g+-- > -- | We can also implement 'MimeRender' for additional formats like 'PlainText'.+-- > instance MimeRender PlainText Greet where+-- > toByteString Proxy (Greet s) = "\"" <> cs s <> "\"" -- >--- > where g = Greet "Hello, haskeller!"+-- > -- We add some useful annotations to our captures,+-- > -- query parameters and request body to make the docs+-- > -- really helpful.+-- > instance ToCapture (Capture "name" Text) where+-- > toCapture _ = DocCapture "name" "name of the person to greet" -- >+-- > instance ToCapture (Capture "greetid" Text) where+-- > toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"+-- > -- > instance ToParam (QueryParam "capital" Bool) where -- > toParam _ = -- > DocQueryParam "capital" -- > ["true", "false"]--- > "Get the greeting message in uppercase (true) or not (false). Default is false."+-- > "Get the greeting message in uppercase (true) or not (false).\+-- > \Default is false."+-- > Normal -- >--- > instance ToCapture (Capture "name" Text) where--- > toCapture _ = DocCapture "name" "name of the person to greet"+-- > instance ToParam (MatrixParam "lang" String) where+-- > toParam _ =+-- > DocQueryParam "lang"+-- > ["en", "sv", "fr"]+-- > "Get the greeting message selected language. Default is en."+-- > Normal -- >--- > instance ToCapture (Capture "greetid" Text) where--- > toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"+-- > instance ToSample Greet Greet where+-- > toSample _ = Just $ Greet "Hello, haskeller!" -- >+-- > toSamples _ =+-- > [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")+-- > , ("If you use ?capital=false", Greet "Hello, haskeller")+-- > ]+-- >+-- > -- We define some introductory sections, these will appear at the top of the+-- > -- documentation.+-- > --+-- > -- We pass them in with 'docsWith', below. If you only want to add+-- > -- introductions, you may use 'docsWithIntros'+-- > intro1 :: DocIntro+-- > intro1 = DocIntro "On proper introductions." -- The title+-- > [ "Hello there."+-- > , "As documentation is usually written for humans, it's often useful \+-- > \to introduce concepts with a few words." ] -- Elements are paragraphs+-- >+-- > intro2 :: DocIntro+-- > intro2 = DocIntro "This title is below the last"+-- > [ "You'll also note that multiple intros are possible." ]+-- >+-- > -- > -- API specification -- > type TestApi =--- > "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet--- > :<|> "greet" :> RQBody Greet :> Post Greet--- > :<|> "delete" :> Capture "greetid" Text :> Delete+-- > -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText+-- > "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet -- >+-- > -- POST /greet with a Greet as JSON in the request body,+-- > -- returns a Greet as JSON+-- > :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet+-- >+-- > -- DELETE /greet/:greetid+-- > :<|> "greet" :> Capture "greetid" Text :> Delete+-- > -- > testApi :: Proxy TestApi -- > testApi = Proxy -- >--- > -- Generate the Documentation's ADT--- > greetDocs :: API--- > greetDocs = docs testApi+-- > -- Build some extra information for the DELETE /greet/:greetid endpoint. We+-- > -- want to add documentation about a secret unicorn header and some extra+-- > -- notes.+-- > extra :: ExtraInfo TestApi+-- > extra =+-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $+-- > defAction & headers <>~ ["unicorns"]+-- > & notes <>~ [ DocNote "Title" ["This is some text"]+-- > , DocNote "Second secton" ["And some more"]+-- > ] -- >+-- > -- Generate the data that lets us have API docs. This+-- > -- is derived from the type as well as from+-- > -- the 'ToCapture', 'ToParam' and 'ToSample' instances from above.+-- > --+-- > -- If you didn't want intros and extra information, you could just call:+-- > --+-- > -- > docs testAPI :: API+-- > docsGreet :: API+-- > docsGreet = docsWith [intro1, intro2] extra testApi+-- > -- > main :: IO ()--- > main = putStrLn $ markdown greetDocs+-- > main = putStrLn $ markdown docsGreet module Servant.Docs ( -- * 'HasDocs' class and key functions HasDocs(..), docs, markdown+ -- * Generating docs with extra information+ , ExtraInfo(..), docsWith, docsWithIntros, extraInfo , -- * Classes you need to implement for your types ToSample(..)@@ -95,606 +155,14 @@ , -- * ADTs to represent an 'API' Method(..) , Endpoint, path, method, defEndpoint- , API, emptyAPI+ , API, apiIntros, apiEndpoints, emptyAPI , DocCapture(..), capSymbol, capDesc , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind- , Response, respStatus, respBody, defResponse- , Action, captures, headers, params, rqbody, response, defAction+ , DocNote(..), noteTitle, noteBody+ , DocIntro(..), introTitle, introBody+ , Response(..), respStatus, respTypes, respBody, defResponse+ , Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction , single-- , -- * Useful modules when defining your doc printers- module Control.Lens- , module Data.Monoid ) where -import Control.Lens hiding (Action)-import Data.Aeson-import Data.Aeson.Encode.Pretty (encodePretty)-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Hashable-import Data.HashMap.Strict (HashMap)-import Data.List-import Data.Maybe (listToMaybe)-import Data.Monoid-import Data.Proxy-import Data.Text (Text, pack, unpack)-import Data.String.Conversions-import GHC.Generics-import GHC.TypeLits-import Servant.API--import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T---- | Supported HTTP request methods-data Method = DocDELETE -- ^ the DELETE method- | DocGET -- ^ the GET method- | DocPOST -- ^ the POST method- | DocPUT -- ^ the PUT method- deriving (Eq, Generic)--instance Show Method where- show DocGET = "GET"- show DocPOST = "POST"- show DocDELETE = "DELETE"- show DocPUT = "PUT"--instance Hashable Method---- | An 'Endpoint' type that holds the 'path' and the 'method'.------ Gets used as the key in the 'API' hashmap. Modify 'defEndpoint'--- or any 'Endpoint' value you want using the 'path' and 'method'--- lenses to tweak.------ @--- λ> 'defEndpoint'--- GET /--- λ> 'defEndpoint' & 'path' '<>~' ["foo"]--- GET /foo--- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'--- POST /foo--- @-data Endpoint = Endpoint- { _path :: [String] -- type collected- , _method :: Method -- type collected- } deriving (Eq, Generic)--instance Show Endpoint where- show (Endpoint p m) =- show m ++ " " ++ showPath p---- |--- Render a path as a '/'-delimited string----showPath :: [String] -> String-showPath [] = "/"-showPath ps = concatMap ('/' :) ps---- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET'------ Here's how you can modify it:------ @--- λ> 'defEndpoint'--- GET /--- λ> 'defEndpoint' & 'path' '<>~' ["foo"]--- GET /foo--- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'--- POST /foo--- @-defEndpoint :: Endpoint-defEndpoint = Endpoint [] DocGET--instance Hashable Endpoint---- | Our API type, a good old hashmap from 'Endpoint' to 'Action'-type API = HashMap Endpoint Action---- | An empty 'API'-emptyAPI :: API-emptyAPI = HM.empty---- | A type to represent captures. Holds the name of the capture--- and a description.------ Write a 'ToCapture' instance for your captured types.-data DocCapture = DocCapture- { _capSymbol :: String -- type supplied- , _capDesc :: String -- user supplied- } deriving (Eq, Show)---- | A type to represent a /GET/ parameter from the Query String. Holds its name,--- the possible values (leave empty if there isn't a finite number of them),--- and a description of how it influences the output or behavior.------ Write a 'ToParam' instance for your GET parameter types-data DocQueryParam = DocQueryParam- { _paramName :: String -- type supplied- , _paramValues :: [String] -- user supplied- , _paramDesc :: String -- user supplied- , _paramKind :: ParamKind- } deriving (Eq, Show)----- | Type of GET parameter:------ - Normal corresponds to @QueryParam@, i.e your usual GET parameter--- - List corresponds to @QueryParams@, i.e GET parameters with multiple values--- - Flag corresponds to @QueryFlag@, i.e a value-less GET parameter-data ParamKind = Normal | List | Flag- deriving (Eq, Show)---- | A type to represent an HTTP response. Has an 'Int' status and--- a 'Maybe ByteString' response body. Tweak 'defResponse' using--- the 'respStatus' and 'respBody' lenses if you want.------ If you want to respond with a non-empty response body, you'll most likely--- want to write a 'ToSample' instance for the type that'll be represented--- as some JSON in the response.------ Can be tweaked with two lenses.------ > λ> defResponse--- > Response {_respStatus = 200, _respBody = []}--- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]--- > Response {_respStatus = 204, _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}-data Response = Response- { _respStatus :: Int- , _respBody :: [(Text, ByteString)]- } deriving (Eq, Show)---- | Default response: status code 200, no response body.------ Can be tweaked with two lenses.------ > λ> defResponse--- > Response {_respStatus = 200, _respBody = Nothing}--- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"--- > Response {_respStatus = 204, _respBody = Just "[]"}-defResponse :: Response-defResponse = Response 200 []---- | A datatype that represents everything that can happen--- at an endpoint, with its lenses:------ - List of captures ('captures')--- - List of GET parameters ('params')--- - What the request body should look like, if any is requested ('rqbody')--- - What the response should be if everything goes well ('response')------ You can tweak an 'Action' (like the default 'defAction') with these lenses--- to transform an action and add some information to it.-data Action = Action- { _captures :: [DocCapture] -- type collected + user supplied info- , _headers :: [Text] -- type collected- , _params :: [DocQueryParam] -- type collected + user supplied info- , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info- , _rqbody :: Maybe ByteString -- user supplied- , _response :: Response -- user supplied- } deriving (Eq, Show)---- Default 'Action'. Has no 'captures', no GET 'params', expects--- no request body ('rqbody') and the typical response is 'defResponse'.------ Tweakable with lenses.------ > λ> defAction--- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}--- > λ> defAction & response.respStatus .~ 201--- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}-defAction :: Action-defAction =- Action []- []- []- []- Nothing- defResponse---- | Create an API that's comprised of a single endpoint.--- 'API' is a 'Monoid', so combine multiple endpoints with--- 'mappend' or '<>'.-single :: Endpoint -> Action -> API-single = HM.singleton---- gimme some lenses-makeLenses ''Endpoint-makeLenses ''DocCapture-makeLenses ''DocQueryParam-makeLenses ''Response-makeLenses ''Action---- | Generate the docs for a given API that implements 'HasDocs'.-docs :: HasDocs layout => Proxy layout -> API-docs p = docsFor p (defEndpoint, defAction)---- | The class that abstracts away the impact of API combinators--- on documentation generation.-class HasDocs layout where- docsFor :: Proxy layout -> (Endpoint, Action) -> API---- | The class that lets us display a sample JSON input or output--- when generating documentation for endpoints that either:------ - expect a request body, or--- - return a non empty response body------ Example of an instance:------ > {-# LANGUAGE DeriveGeneric #-}--- > {-# LANGUAGE OverloadedStrings #-}--- >--- > import Data.Aeson--- > import Data.Text--- > import GHC.Generics--- >--- > data Greet = Greet { _msg :: Text }--- > deriving (Generic, Show)--- >--- > instance FromJSON Greet--- > instance ToJSON Greet--- >--- > instance ToSample Greet where--- > toSample = Just g--- >--- > where g = Greet "Hello, haskeller!"------ You can also instantiate this class using 'toSamples' instead of--- 'toSample': it lets you specify different responses along with--- some context (as 'Text') that explains when you're supposed to--- get the corresponding response. -class ToJSON a => ToSample a where- {-# MINIMAL (toSample | toSamples) #-}- toSample :: Maybe a- toSample = fmap snd $ listToMaybe samples- where samples = toSamples :: [(Text, a)]-- toSamples :: [(Text, a)]- toSamples = maybe [] (return . ("",)) s- where s = toSample :: Maybe a--sampleByteString :: forall a. ToSample a => Proxy a -> Maybe ByteString-sampleByteString Proxy = fmap encodePretty (toSample :: Maybe a)--sampleByteStrings :: forall a. ToSample a => Proxy a -> [(Text, ByteString)]-sampleByteStrings Proxy = samples & traverse._2 %~ encodePretty-- where samples = toSamples :: [(Text, a)]---- | The class that helps us automatically get documentation--- for GET parameters.------ Example of an instance:------ > instance ToParam (QueryParam "capital" Bool) where--- > toParam _ =--- > DocQueryParam "capital"--- > ["true", "false"]--- > "Get the greeting message in uppercase (true) or not (false). Default is false."-class ToParam t where- toParam :: Proxy t -> DocQueryParam---- | The class that helps us automatically get documentation--- for URL captures.------ Example of an instance:------ > instance ToCapture (Capture "name" Text) where--- > toCapture _ = DocCapture "name" "name of the person to greet"-class ToCapture c where- toCapture :: Proxy c -> DocCapture---- | Generate documentation in Markdown format for--- the given 'API'.-markdown :: API -> String-markdown = unlines . concat . map (uncurry printEndpoint) . HM.toList-- where printEndpoint :: Endpoint -> Action -> [String]- printEndpoint endpoint action =- str :- replicate len '-' :- "" :- capturesStr (action ^. captures) ++- mxParamsStr (action ^. mxParams) ++- headersStr (action ^. headers) ++- paramsStr (action ^. params) ++- rqbodyStr (action ^. rqbody) ++- responseStr (action ^. response) ++- []-- where str = show (endpoint^.method) ++ " " ++ showPath (endpoint^.path)- len = length str-- capturesStr :: [DocCapture] -> [String]- capturesStr [] = []- capturesStr l =- "**Captures**: " :- "" :- map captureStr l ++- "" :- []- captureStr cap =- "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)-- mxParamsStr :: [(String, [DocQueryParam])] -> [String]- mxParamsStr [] = []- mxParamsStr l =- "**Matrix Parameters**: " :- "" :- map segmentStr l ++- "" :- []- segmentStr :: (String, [DocQueryParam]) -> String- segmentStr (segment, l) = unlines $- ("**" ++ segment ++ "**: ") :- "" :- map paramStr l ++- "" :- []-- headersStr :: [Text] -> [String]- headersStr [] = []- headersStr l = [""] ++ map headerStr l ++ [""]-- where headerStr hname = "- This endpoint is sensitive to the value of the **"- ++ unpack hname ++ "** HTTP header."-- paramsStr :: [DocQueryParam] -> [String]- paramsStr [] = []- paramsStr l =- "**GET Parameters**: " :- "" :- map paramStr l ++- "" :- []- paramStr param = unlines $- (" - " ++ param ^. paramName) :- (if (not (null values) || param ^. paramKind /= Flag)- then [" - **Values**: *" ++ intercalate ", " values ++ "*"]- else []) ++- (" - **Description**: " ++ param ^. paramDesc) :- (if (param ^. paramKind == List)- then [" - This parameter is a **list**. All GET parameters with the name "- ++ param ^. paramName ++ "[] will forward their values in a list to the handler."]- else []) ++- (if (param ^. paramKind == Flag)- then [" - This parameter is a **flag**. This means no value is expected to be associated to this parameter."]- else []) ++- []-- where values = param ^. paramValues-- rqbodyStr :: Maybe ByteString -> [String]- rqbodyStr Nothing = []- rqbodyStr (Just b) =- "**Request Body**: " :- jsonStr b-- jsonStr b =- "" :- "``` javascript" :- cs b :- "```" :- "" :- []-- responseStr :: Response -> [String]- responseStr resp =- "**Response**: " :- "" :- (" - Status code " ++ show (resp ^. respStatus)) :- bodies-- where bodies = case resp ^. respBody of- [] -> [" - No response body\n"]- [("", r)] -> " - Response body as below." : jsonStr r- xs ->- concatMap (\(ctx, r) -> (" - " <> T.unpack ctx) : jsonStr r) xs---- * Instances---- | The generated docs for @a ':<|>' b@ just appends the docs--- for @a@ with the docs for @b@.-instance (HasDocs layout1, HasDocs layout2)- => HasDocs (layout1 :<|> layout2) where-- docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)-- where p1 :: Proxy layout1- p1 = Proxy-- p2 :: Proxy layout2- p2 = Proxy---- | @"books" :> 'Capture' "isbn" Text@ will appear as--- @/books/:isbn@ in the docs.-instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)- => HasDocs (Capture sym a :> sublayout) where-- docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint', action')-- where sublayoutP = Proxy :: Proxy sublayout- captureP = Proxy :: Proxy (Capture sym a)-- action' = over captures (|> toCapture captureP) action- endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint- symP = Proxy :: Proxy sym---instance HasDocs Delete where- docsFor Proxy (endpoint, action) =- single endpoint' action'-- where endpoint' = endpoint & method .~ DocDELETE-- action' = action & response.respBody .~ []- & response.respStatus .~ 204--instance ToSample a => HasDocs (Get a) where- docsFor Proxy (endpoint, action) =- single endpoint' action'-- where endpoint' = endpoint & method .~ DocGET- action' = action & response.respBody .~ sampleByteStrings p- p = Proxy :: Proxy a--instance (KnownSymbol sym, HasDocs sublayout)- => HasDocs (Header sym a :> sublayout) where- docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint, action')-- where sublayoutP = Proxy :: Proxy sublayout- action' = over headers (|> headername) action- headername = pack $ symbolVal (Proxy :: Proxy sym)--instance ToSample a => HasDocs (Post a) where- docsFor Proxy (endpoint, action) =- single endpoint' action'-- where endpoint' = endpoint & method .~ DocPOST-- action' = action & response.respBody .~ sampleByteStrings p- & response.respStatus .~ 201-- p = Proxy :: Proxy a--instance ToSample a => HasDocs (Put a) where- docsFor Proxy (endpoint, action) =- single endpoint' action'-- where endpoint' = endpoint & method .~ DocPUT-- action' = action & response.respBody .~ sampleByteStrings p- & response.respStatus .~ 200-- p = Proxy :: Proxy a---instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)- => HasDocs (QueryParam sym a :> sublayout) where-- docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint, action')-- where sublayoutP = Proxy :: Proxy sublayout- paramP = Proxy :: Proxy (QueryParam sym a)- action' = over params (|> toParam paramP) action--instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout)- => HasDocs (QueryParams sym a :> sublayout) where-- docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint, action')-- where sublayoutP = Proxy :: Proxy sublayout- paramP = Proxy :: Proxy (QueryParams sym a)- action' = over params (|> toParam paramP) action---instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout)- => HasDocs (QueryFlag sym :> sublayout) where-- docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint, action')-- where sublayoutP = Proxy :: Proxy sublayout- paramP = Proxy :: Proxy (QueryFlag sym)- action' = over params (|> toParam paramP) action---instance (KnownSymbol sym, ToParam (MatrixParam sym a), HasDocs sublayout)- => HasDocs (MatrixParam sym a :> sublayout) where-- docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint', action')-- where sublayoutP = Proxy :: Proxy sublayout- paramP = Proxy :: Proxy (MatrixParam sym a)- segment = endpoint ^. (path._last)- segment' = action ^. (mxParams._last._1)- endpoint' = over (path._last) (\p -> p ++ ";" ++ symbolVal symP ++ "=<value>") endpoint-- action' = if segment' /= segment- -- This is the first matrix parameter for this segment, insert a new entry into the mxParams list- then over mxParams (|> (segment, [toParam paramP])) action- -- We've already inserted a matrix parameter for this segment, append to the existing list- else action & mxParams._last._2 <>~ [toParam paramP]- symP = Proxy :: Proxy sym---instance (KnownSymbol sym, {- ToParam (MatrixParams sym a), -} HasDocs sublayout)- => HasDocs (MatrixParams sym a :> sublayout) where-- docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint', action)-- where sublayoutP = Proxy :: Proxy sublayout- endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP ++ "=<value>"]) endpoint- symP = Proxy :: Proxy sym---instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)- => HasDocs (MatrixFlag sym :> sublayout) where-- docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint', action)-- where sublayoutP = Proxy :: Proxy sublayout-- endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint- symP = Proxy :: Proxy sym---instance HasDocs Raw where- docsFor _proxy (endpoint, action) =- single endpoint action--instance (ToSample a, HasDocs sublayout)- => HasDocs (ReqBody a :> sublayout) where-- docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint, action')-- where sublayoutP = Proxy :: Proxy sublayout-- action' = action & rqbody .~ sampleByteString p- p = Proxy :: Proxy a--instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where-- docsFor Proxy (endpoint, action) =- docsFor sublayoutP (endpoint', action)-- where sublayoutP = Proxy :: Proxy sublayout- endpoint' = endpoint & path <>~ [symbolVal pa]- pa = Proxy :: Proxy path--{----- | Serve your API's docs as markdown embedded in an html \<pre> tag.------ > type MyApi = "users" :> Get [User]--- > :<|> "docs :> Raw--- >--- > apiProxy :: Proxy MyApi--- > apiProxy = Proxy--- >--- > server :: Server MyApi--- > server = listUsers--- > :<|> serveDocumentation apiProxy-serveDocumentation :: HasDocs api => Proxy api -> Server Raw-serveDocumentation proxy _request respond =- respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy--toHtml :: String -> String-toHtml md =- "<html>" ++- "<body>" ++- "<pre>" ++- md ++- "</pre>" ++- "</body>" ++- "</html>"--}+import Servant.Docs.Internal
+ src/Servant/Docs/Internal.hs view
@@ -0,0 +1,902 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+#if !MIN_VERSION_base(4,8,0)+{-# LANGUAGE OverlappingInstances #-}+#endif+module Servant.Docs.Internal where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Lens+import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.CaseInsensitive as CI+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Ord (comparing)+import Data.Proxy+import Data.ByteString.Conversion (ToByteString, toByteString)+import Data.String.Conversions+import Data.Text (Text, pack, unpack)+import GHC.Exts (Constraint)+import GHC.Generics+import GHC.TypeLits+import Servant.API+import Servant.API.ContentTypes+import Servant.Utils.Links++import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Network.HTTP.Media as M+import qualified Network.HTTP.Types as HTTP++-- | Supported HTTP request methods+data Method = DocDELETE -- ^ the DELETE method+ | DocGET -- ^ the GET method+ | DocPOST -- ^ the POST method+ | DocPUT -- ^ the PUT method+ deriving (Eq, Ord, Generic)++instance Show Method where+ show DocGET = "GET"+ show DocPOST = "POST"+ show DocDELETE = "DELETE"+ show DocPUT = "PUT"++instance Hashable Method++-- | An 'Endpoint' type that holds the 'path' and the 'method'.+--+-- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint'+-- or any 'Endpoint' value you want using the 'path' and 'method'+-- lenses to tweak.+--+-- @+-- λ> 'defEndpoint'+-- GET /+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]+-- GET /foo+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'+-- POST /foo+-- @+data Endpoint = Endpoint+ { _path :: [String] -- type collected+ , _method :: Method -- type collected+ } deriving (Eq, Ord, Generic)++instance Show Endpoint where+ show (Endpoint p m) =+ show m ++ " " ++ showPath p++-- |+-- Render a path as a '/'-delimited string+--+showPath :: [String] -> String+showPath [] = "/"+showPath ps = concatMap ('/' :) ps++-- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET'+--+-- Here's how you can modify it:+--+-- @+-- λ> 'defEndpoint'+-- GET /+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]+-- GET /foo+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'+-- POST /foo+-- @+defEndpoint :: Endpoint+defEndpoint = Endpoint [] DocGET++instance Hashable Endpoint++-- | Our API documentation type, a product of top-level information and a good+-- old hashmap from 'Endpoint' to 'Action'+data API = API+ { _apiIntros :: [DocIntro]+ , _apiEndpoints :: HashMap Endpoint Action+ } deriving (Eq, Show)++instance Monoid API where+ API a1 b1 `mappend` API a2 b2 = API (a1 <> a2) (b1 <> b2)+ mempty = API mempty mempty++-- | An empty 'API'+emptyAPI :: API+emptyAPI = mempty++-- | A type to represent captures. Holds the name of the capture+-- and a description.+--+-- Write a 'ToCapture' instance for your captured types.+data DocCapture = DocCapture+ { _capSymbol :: String -- type supplied+ , _capDesc :: String -- user supplied+ } deriving (Eq, Ord, Show)++-- | A type to represent a /GET/ parameter from the Query String. Holds its name,+-- the possible values (leave empty if there isn't a finite number of them),+-- and a description of how it influences the output or behavior.+--+-- Write a 'ToParam' instance for your GET parameter types+data DocQueryParam = DocQueryParam+ { _paramName :: String -- type supplied+ , _paramValues :: [String] -- user supplied+ , _paramDesc :: String -- user supplied+ , _paramKind :: ParamKind+ } deriving (Eq, Ord, Show)++-- | An introductory paragraph for your documentation. You can pass these to+-- 'docsWithIntros'.+data DocIntro = DocIntro+ { _introTitle :: String -- ^ Appears above the intro blob+ , _introBody :: [String] -- ^ Each String is a paragraph.+ } deriving (Eq, Show)++instance Ord DocIntro where+ compare = comparing _introTitle++-- | A type to represent extra notes that may be attached to an 'Action'.+--+-- This is intended to be used when writing your own HasDocs instances to+-- add extra sections to your endpoint's documentation.+data DocNote = DocNote+ { _noteTitle :: String+ , _noteBody :: [String]+ } deriving (Eq, Ord, Show)++-- | Type of extra information that a user may wish to "union" with their+-- documentation.+--+-- These are intended to be built using extraInfo.+-- Multiple ExtraInfo may be combined with the monoid instance.+newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action)+instance Monoid (ExtraInfo a) where+ mempty = ExtraInfo mempty+ ExtraInfo a `mappend` ExtraInfo b =+ ExtraInfo $ HM.unionWith combineAction a b++-- | Type of GET parameter:+--+-- - Normal corresponds to @QueryParam@, i.e your usual GET parameter+-- - List corresponds to @QueryParams@, i.e GET parameters with multiple values+-- - Flag corresponds to @QueryFlag@, i.e a value-less GET parameter+data ParamKind = Normal | List | Flag+ deriving (Eq, Ord, Show)++-- | A type to represent an HTTP response. Has an 'Int' status, a list of+-- possible 'MediaType's, and a list of example 'ByteString' response bodies.+-- Tweak 'defResponse' using the 'respStatus', 'respTypes' and 'respBody'+-- lenses if you want.+--+-- If you want to respond with a non-empty response body, you'll most likely+-- want to write a 'ToSample' instance for the type that'll be represented+-- as encoded data in the response.+--+-- Can be tweaked with three lenses.+--+-- > λ> defResponse+-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}+-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]+-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}+data Response = Response+ { _respStatus :: Int+ , _respTypes :: [M.MediaType]+ , _respBody :: [(Text, M.MediaType, ByteString)]+ , _respHeaders :: [HTTP.Header]+ } deriving (Eq, Ord, Show)++-- | Default response: status code 200, no response body.+--+-- Can be tweaked with two lenses.+--+-- > λ> defResponse+-- > Response {_respStatus = 200, _respBody = Nothing}+-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"+-- > Response {_respStatus = 204, _respBody = Just "[]"}+defResponse :: Response+defResponse = Response+ { _respStatus = 200+ , _respTypes = []+ , _respBody = []+ , _respHeaders = []+ }++-- | A datatype that represents everything that can happen+-- at an endpoint, with its lenses:+--+-- - List of captures ('captures')+-- - List of GET parameters ('params')+-- - What the request body should look like, if any is requested ('rqbody')+-- - What the response should be if everything goes well ('response')+--+-- You can tweak an 'Action' (like the default 'defAction') with these lenses+-- to transform an action and add some information to it.+data Action = Action+ { _captures :: [DocCapture] -- type collected + user supplied info+ , _headers :: [Text] -- type collected+ , _params :: [DocQueryParam] -- type collected + user supplied info+ , _notes :: [DocNote] -- user supplied+ , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info+ , _rqtypes :: [M.MediaType] -- type collected+ , _rqbody :: [(M.MediaType, ByteString)] -- user supplied+ , _response :: Response -- user supplied+ } deriving (Eq, Ord, Show)++-- | Combine two Actions, we can't make a monoid as merging Response breaks the+-- laws.+--+-- As such, we invent a non-commutative, left associative operation+-- 'combineAction' to mush two together taking the response, body and content+-- types from the very left.+combineAction :: Action -> Action -> Action+Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =+ Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp++-- Default 'Action'. Has no 'captures', no GET 'params', expects+-- no request body ('rqbody') and the typical response is 'defResponse'.+--+-- Tweakable with lenses.+--+-- > λ> defAction+-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}+-- > λ> defAction & response.respStatus .~ 201+-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}+defAction :: Action+defAction =+ Action []+ []+ []+ []+ []+ []+ []+ defResponse++-- | Create an API that's comprised of a single endpoint.+-- 'API' is a 'Monoid', so combine multiple endpoints with+-- 'mappend' or '<>'.+single :: Endpoint -> Action -> API+single e a = API mempty (HM.singleton e a)++-- gimme some lenses+makeLenses ''API+makeLenses ''Endpoint+makeLenses ''DocCapture+makeLenses ''DocQueryParam+makeLenses ''DocIntro+makeLenses ''DocNote+makeLenses ''Response+makeLenses ''Action++-- | Generate the docs for a given API that implements 'HasDocs'. This is the+-- default way to create documentation.+docs :: HasDocs layout => Proxy layout -> API+docs p = docsFor p (defEndpoint, defAction)++-- | Closed type family, check if endpoint is exactly within API.++-- We aren't sure what affects how an Endpoint is built up, so we require an+-- exact match.+type family IsIn (endpoint :: *) (api :: *) :: Constraint where+ IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)+ IsIn (e :> sa) (e :> sb) = IsIn sa sb+ IsIn e e = ()++-- | Create an 'ExtraInfo' that is garunteed to be within the given API layout.+--+-- The safety here is to ensure that you only add custom documentation to an+-- endpoint that actually exists within your API.+--+-- > extra :: ExtraInfo TestApi+-- > extra =+-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $+-- > defAction & headers <>~ ["unicorns"]+-- > & notes <>~ [ DocNote "Title" ["This is some text"]+-- > , DocNote "Second secton" ["And some more"]+-- > ]++extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)+ => Proxy endpoint -> Action -> ExtraInfo layout+extraInfo p action =+ let api = docsFor p (defEndpoint, defAction)+ -- Assume one endpoint, HasLink constraint means that we should only ever+ -- point at one endpoint.+ in ExtraInfo $ api ^. apiEndpoints & traversed .~ action++-- | Generate documentation given some extra introductions (in the form of+-- 'DocInfo') and some extra endpoint documentation (in the form of+-- 'ExtraInfo'.+--+-- The extra introductions will be prepended to the top of the documentation,+-- before the specific endpoint documentation. The extra endpoint documentation+-- will be "unioned" with the automatically generated endpoint documentation.+--+-- You are expected to build up the ExtraInfo with the Monoid instance and+-- 'extraInfo'.+--+-- If you only want to add an introduction, use 'docsWithIntros'.+docsWith :: HasDocs layout => [DocIntro] -> ExtraInfo layout -> Proxy layout -> API+docsWith intros (ExtraInfo endpoints) p =+ docs p & apiIntros <>~ intros+ & apiEndpoints %~ HM.unionWith combineAction endpoints+++-- | Generate the docs for a given API that implements 'HasDocs' with with any+-- number of introduction(s)+docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API+docsWithIntros intros = docsWith intros mempty++-- | The class that abstracts away the impact of API combinators+-- on documentation generation.+class HasDocs layout where+ docsFor :: Proxy layout -> (Endpoint, Action) -> API++-- | The class that lets us display a sample input or output in the supported+-- content-types when generating documentation for endpoints that either:+--+-- - expect a request body, or+-- - return a non empty response body+--+-- Example of an instance:+--+-- > {-# LANGUAGE DeriveGeneric #-}+-- > {-# LANGUAGE OverloadedStrings #-}+-- >+-- > import Data.Aeson+-- > import Data.Text+-- > import GHC.Generics+-- >+-- > data Greet = Greet { _msg :: Text }+-- > deriving (Generic, Show)+-- >+-- > instance FromJSON Greet+-- > instance ToJSON Greet+-- >+-- > instance ToSample Greet Greet where+-- > toSample _ = Just g+-- >+-- > where g = Greet "Hello, haskeller!"+--+-- You can also instantiate this class using 'toSamples' instead of+-- 'toSample': it lets you specify different responses along with+-- some context (as 'Text') that explains when you're supposed to+-- get the corresponding response.+class ToSample a b | a -> b where+ {-# MINIMAL (toSample | toSamples) #-}+ toSample :: Proxy a -> Maybe b+ toSample _ = snd <$> listToMaybe samples+ where samples = toSamples (Proxy :: Proxy a)++ toSamples :: Proxy a -> [(Text, b)]+ toSamples _ = maybe [] (return . ("",)) s+ where s = toSample (Proxy :: Proxy a)++instance ToSample a b => ToSample (Headers ls a) b where+ toSample _ = toSample (Proxy :: Proxy a)+ toSamples _ = toSamples (Proxy :: Proxy a)+++class AllHeaderSamples ls where+ allHeaderToSample :: Proxy ls -> [HTTP.Header]++instance AllHeaderSamples '[] where+ allHeaderToSample _ = []++instance (ToByteString l, AllHeaderSamples ls, ToSample l l, KnownSymbol h)+ => AllHeaderSamples (Header h l ': ls) where+ allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) :+ allHeaderToSample (Proxy :: Proxy ls)+ where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)+ mkHeader (Just x) = (headerName, cs $ toByteString x)+ mkHeader Nothing = (headerName, "<no header sample provided>")++-- | Synthesise a sample value of a type, encoded in the specified media types.+sampleByteString+ :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)+ => Proxy ctypes+ -> Proxy a+ -> [(M.MediaType, ByteString)]+sampleByteString ctypes@Proxy Proxy =+ maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a)++-- | Synthesise a list of sample values of a particular type, encoded in the+-- specified media types.+sampleByteStrings+ :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)+ => Proxy ctypes+ -> Proxy a+ -> [(Text, M.MediaType, ByteString)]+sampleByteStrings ctypes@Proxy Proxy =+ let samples = toSamples (Proxy :: Proxy a)+ enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s+ in concatMap enc samples++-- | Generate a list of 'MediaType' values describing the content types+-- accepted by an API component.+class SupportedTypes (list :: [*]) where+ supportedTypes :: Proxy list -> [M.MediaType]++instance SupportedTypes '[] where+ supportedTypes Proxy = []++instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest)+ where+ supportedTypes Proxy =+ contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest)++-- | The class that helps us automatically get documentation+-- for GET parameters.+--+-- Example of an instance:+--+-- > instance ToParam (QueryParam "capital" Bool) where+-- > toParam _ =+-- > DocQueryParam "capital"+-- > ["true", "false"]+-- > "Get the greeting message in uppercase (true) or not (false). Default is false."+class ToParam t where+ toParam :: Proxy t -> DocQueryParam++-- | The class that helps us automatically get documentation+-- for URL captures.+--+-- Example of an instance:+--+-- > instance ToCapture (Capture "name" Text) where+-- > toCapture _ = DocCapture "name" "name of the person to greet"+class ToCapture c where+ toCapture :: Proxy c -> DocCapture++-- | Generate documentation in Markdown format for+-- the given 'API'.+markdown :: API -> String+markdown api = unlines $+ introsStr (api ^. apiIntros)+ ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)++ where printEndpoint :: Endpoint -> Action -> [String]+ printEndpoint endpoint action =+ str :+ "" :+ notesStr (action ^. notes) +++ capturesStr (action ^. captures) +++ mxParamsStr (action ^. mxParams) +++ headersStr (action ^. headers) +++ paramsStr (action ^. params) +++ rqbodyStr (action ^. rqtypes) (action ^. rqbody) +++ responseStr (action ^. response) +++ []++ where str = "## " ++ show (endpoint^.method)+ ++ " " ++ showPath (endpoint^.path)++ introsStr :: [DocIntro] -> [String]+ introsStr = concatMap introStr++ introStr :: DocIntro -> [String]+ introStr i =+ ("## " ++ i ^. introTitle) :+ "" :+ intersperse "" (i ^. introBody) +++ "" :+ []++ notesStr :: [DocNote] -> [String]+ notesStr = concatMap noteStr++ noteStr :: DocNote -> [String]+ noteStr nt =+ ("#### " ++ nt ^. noteTitle) :+ "" :+ intersperse "" (nt ^. noteBody) +++ "" :+ []++ capturesStr :: [DocCapture] -> [String]+ capturesStr [] = []+ capturesStr l =+ "#### Captures:" :+ "" :+ map captureStr l +++ "" :+ []++ captureStr cap =+ "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)++ mxParamsStr :: [(String, [DocQueryParam])] -> [String]+ mxParamsStr [] = []+ mxParamsStr l =+ "#### Matrix Parameters:" :+ "" :+ map segmentStr l+ segmentStr :: (String, [DocQueryParam]) -> String+ segmentStr (segment, l) = unlines $+ ("**" ++ segment ++ "**:") :+ "" :+ map paramStr l +++ "" :+ []++ headersStr :: [Text] -> [String]+ headersStr [] = []+ headersStr l = [""] ++ map headerStr l ++ [""]++ where headerStr hname = "- This endpoint is sensitive to the value of the **"+ ++ unpack hname ++ "** HTTP header."++ paramsStr :: [DocQueryParam] -> [String]+ paramsStr [] = []+ paramsStr l =+ "#### GET Parameters:" :+ "" :+ map paramStr l +++ "" :+ []++ paramStr param = unlines $+ ("- " ++ param ^. paramName) :+ (if (not (null values) || param ^. paramKind /= Flag)+ then [" - **Values**: *" ++ intercalate ", " values ++ "*"]+ else []) +++ (" - **Description**: " ++ param ^. paramDesc) :+ (if (param ^. paramKind == List)+ then [" - This parameter is a **list**. All GET parameters with the name "+ ++ param ^. paramName ++ "[] will forward their values in a list to the handler."]+ else []) +++ (if (param ^. paramKind == Flag)+ then [" - This parameter is a **flag**. This means no value is expected to be associated to this parameter."]+ else []) +++ []++ where values = param ^. paramValues++ rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]+ rqbodyStr [] [] = []+ rqbodyStr types samples =+ ["#### Request:", ""]+ <> formatTypes types+ <> concatMap formatBody samples++ formatTypes [] = []+ formatTypes ts = ["- Supported content types are:", ""]+ <> map (\t -> " - `" <> show t <> "`") ts+ <> [""]++ formatBody (m, b) =+ "- Example: `" <> cs (show m) <> "`" :+ contentStr m b++ markdownForType mime_type =+ case (M.mainType mime_type, M.subType mime_type) of+ ("text", "html") -> "html"+ ("application", "xml") -> "xml"+ ("application", "json") -> "javascript"+ ("application", "javascript") -> "javascript"+ ("text", "css") -> "css"+ (_, _) -> ""++ contentStr mime_type body =+ "" :+ "```" <> markdownForType mime_type :+ cs body :+ "```" :+ "" :+ []++ responseStr :: Response -> [String]+ responseStr resp =+ "#### Response:" :+ "" :+ ("- Status code " ++ show (resp ^. respStatus)) :+ ("- Headers: " ++ show (resp ^. respHeaders)) :+ "" :+ formatTypes (resp ^. respTypes) +++ bodies++ where bodies = case resp ^. respBody of+ [] -> ["- No response body\n"]+ [("", t, r)] -> "- Response body as below." : contentStr t r+ xs ->+ concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs++-- * Instances++-- | The generated docs for @a ':<|>' b@ just appends the docs+-- for @a@ with the docs for @b@.+instance (HasDocs layout1, HasDocs layout2)+ => HasDocs (layout1 :<|> layout2) where++ docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)++ where p1 :: Proxy layout1+ p1 = Proxy++ p2 :: Proxy layout2+ p2 = Proxy++-- | @"books" :> 'Capture' "isbn" Text@ will appear as+-- @/books/:isbn@ in the docs.+instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)+ => HasDocs (Capture sym a :> sublayout) where++ docsFor Proxy (endpoint, action) =+ docsFor sublayoutP (endpoint', action')++ where sublayoutP = Proxy :: Proxy sublayout+ captureP = Proxy :: Proxy (Capture sym a)++ action' = over captures (|> toCapture captureP) action+ endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint+ symP = Proxy :: Proxy sym+++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLe #-}+#endif+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)+ => HasDocs (Delete cts a) where+ docsFor Proxy (endpoint, action) =+ single endpoint' action'++ where endpoint' = endpoint & method .~ DocDELETE+ action' = action & response.respBody .~ sampleByteStrings t p+ & response.respTypes .~ supportedTypes t+ t = Proxy :: Proxy cts+ p = Proxy :: Proxy a++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts+ , AllHeaderSamples ls , GetHeaders (HList ls) )+ => HasDocs (Delete cts (Headers ls a)) where+ docsFor Proxy (endpoint, action) =+ single endpoint' action'++ where hdrs = allHeaderToSample (Proxy :: Proxy ls)+ endpoint' = endpoint & method .~ DocDELETE+ action' = action & response.respBody .~ sampleByteStrings t p+ & response.respTypes .~ supportedTypes t+ & response.respHeaders .~ hdrs+ t = Proxy :: Proxy cts+ p = Proxy :: Proxy a++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLe #-}+#endif+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)+ => HasDocs (Get cts a) where+ docsFor Proxy (endpoint, action) =+ single endpoint' action'++ where endpoint' = endpoint & method .~ DocGET+ action' = action & response.respBody .~ sampleByteStrings t p+ & response.respTypes .~ supportedTypes t+ t = Proxy :: Proxy cts+ p = Proxy :: Proxy a++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts+ , AllHeaderSamples ls , GetHeaders (HList ls) )+ => HasDocs (Get cts (Headers ls a)) where+ docsFor Proxy (endpoint, action) =+ single endpoint' action'++ where hdrs = allHeaderToSample (Proxy :: Proxy ls)+ endpoint' = endpoint & method .~ DocGET+ action' = action & response.respBody .~ sampleByteStrings t p+ & response.respTypes .~ supportedTypes t+ & response.respHeaders .~ hdrs+ t = Proxy :: Proxy cts+ p = Proxy :: Proxy a++instance (KnownSymbol sym, HasDocs sublayout)+ => HasDocs (Header sym a :> sublayout) where+ docsFor Proxy (endpoint, action) =+ docsFor sublayoutP (endpoint, action')++ where sublayoutP = Proxy :: Proxy sublayout+ action' = over headers (|> headername) action+ headername = pack $ symbolVal (Proxy :: Proxy sym)++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLE #-}+#endif+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)+ => HasDocs (Post cts a) where+ docsFor Proxy (endpoint, action) =+ single endpoint' action'++ where endpoint' = endpoint & method .~ DocPOST+ action' = action & response.respBody .~ sampleByteStrings t p+ & response.respTypes .~ supportedTypes t+ & response.respStatus .~ 201+ t = Proxy :: Proxy cts+ p = Proxy :: Proxy a++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts+ , AllHeaderSamples ls , GetHeaders (HList ls) )+ => HasDocs (Post cts (Headers ls a)) where+ docsFor Proxy (endpoint, action) =+ single endpoint' action'++ where hdrs = allHeaderToSample (Proxy :: Proxy ls)+ endpoint' = endpoint & method .~ DocPOST+ action' = action & response.respBody .~ sampleByteStrings t p+ & response.respTypes .~ supportedTypes t+ & response.respStatus .~ 201+ & response.respHeaders .~ hdrs+ t = Proxy :: Proxy cts+ p = Proxy :: Proxy a++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPABLE #-}+#endif+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)+ => HasDocs (Put cts a) where+ docsFor Proxy (endpoint, action) =+ single endpoint' action'++ where endpoint' = endpoint & method .~ DocPUT+ action' = action & response.respBody .~ sampleByteStrings t p+ & response.respTypes .~ supportedTypes t+ & response.respStatus .~ 200+ t = Proxy :: Proxy cts+ p = Proxy :: Proxy a++instance+#if MIN_VERSION_base(4,8,0)+ {-# OVERLAPPING #-}+#endif+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts+ , AllHeaderSamples ls , GetHeaders (HList ls) )+ => HasDocs (Put cts (Headers ls a)) where+ docsFor Proxy (endpoint, action) =+ single endpoint' action'++ where hdrs = allHeaderToSample (Proxy :: Proxy ls)+ endpoint' = endpoint & method .~ DocPUT+ action' = action & response.respBody .~ sampleByteStrings t p+ & response.respTypes .~ supportedTypes t+ & response.respStatus .~ 200+ & response.respHeaders .~ hdrs+ t = Proxy :: Proxy cts+ p = Proxy :: Proxy a++instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)+ => HasDocs (QueryParam sym a :> sublayout) where++ docsFor Proxy (endpoint, action) =+ docsFor sublayoutP (endpoint, action')++ where sublayoutP = Proxy :: Proxy sublayout+ paramP = Proxy :: Proxy (QueryParam sym a)+ action' = over params (|> toParam paramP) action++instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout)+ => HasDocs (QueryParams sym a :> sublayout) where++ docsFor Proxy (endpoint, action) =+ docsFor sublayoutP (endpoint, action')++ where sublayoutP = Proxy :: Proxy sublayout+ paramP = Proxy :: Proxy (QueryParams sym a)+ action' = over params (|> toParam paramP) action+++instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout)+ => HasDocs (QueryFlag sym :> sublayout) where++ docsFor Proxy (endpoint, action) =+ docsFor sublayoutP (endpoint, action')++ where sublayoutP = Proxy :: Proxy sublayout+ paramP = Proxy :: Proxy (QueryFlag sym)+ action' = over params (|> toParam paramP) action+++instance (KnownSymbol sym, ToParam (MatrixParam sym a), HasDocs sublayout)+ => HasDocs (MatrixParam sym a :> sublayout) where++ docsFor Proxy (endpoint, action) =+ docsFor sublayoutP (endpoint', action')++ where sublayoutP = Proxy :: Proxy sublayout+ paramP = Proxy :: Proxy (MatrixParam sym a)+ segment = endpoint ^. (path._last)+ segment' = action ^. (mxParams._last._1)+ endpoint' = over (path._last) (\p -> p ++ ";" ++ symbolVal symP ++ "=<value>") endpoint++ action' = if segment' /= segment+ -- This is the first matrix parameter for this segment, insert a new entry into the mxParams list+ then over mxParams (|> (segment, [toParam paramP])) action+ -- We've already inserted a matrix parameter for this segment, append to the existing list+ else action & mxParams._last._2 <>~ [toParam paramP]+ symP = Proxy :: Proxy sym+++instance (KnownSymbol sym, {- ToParam (MatrixParams sym a), -} HasDocs sublayout)+ => HasDocs (MatrixParams sym a :> sublayout) where++ docsFor Proxy (endpoint, action) =+ docsFor sublayoutP (endpoint', action)++ where sublayoutP = Proxy :: Proxy sublayout+ endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP ++ "=<value>"]) endpoint+ symP = Proxy :: Proxy sym+++instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)+ => HasDocs (MatrixFlag sym :> sublayout) where++ docsFor Proxy (endpoint, action) =+ docsFor sublayoutP (endpoint', action)++ where sublayoutP = Proxy :: Proxy sublayout++ endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint+ symP = Proxy :: Proxy sym++instance HasDocs Raw where+ docsFor _proxy (endpoint, action) =+ single endpoint action++-- TODO: We use 'AllMimeRender' here because we need to be able to show the+-- example data. However, there's no reason to believe that the instances of+-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that+-- both are even defined) for any particular type.+instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, HasDocs sublayout+ , SupportedTypes cts)+ => HasDocs (ReqBody cts a :> sublayout) where++ docsFor Proxy (endpoint, action) =+ docsFor sublayoutP (endpoint, action')++ where sublayoutP = Proxy :: Proxy sublayout+ action' = action & rqbody .~ sampleByteString t p+ & rqtypes .~ supportedTypes t+ t = Proxy :: Proxy cts+ p = Proxy :: Proxy a++instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where++ docsFor Proxy (endpoint, action) =+ docsFor sublayoutP (endpoint', action)++ where sublayoutP = Proxy :: Proxy sublayout+ endpoint' = endpoint & path <>~ [symbolVal pa]+ pa = Proxy :: Proxy path+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}