Merge remote-tracking branch 'origin/master' into wip-note-api

This commit is contained in:
Christian Marie 2015-02-23 10:23:12 +11:00
commit 055655618f
5 changed files with 219 additions and 105 deletions

View file

@ -27,10 +27,15 @@ import Servant
data Greet = Greet { _msg :: Text } data Greet = Greet { _msg :: Text }
deriving (Generic, Show) 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 FromJSON Greet
instance ToJSON 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 -- we provide a sample value for the 'Greet' type
instance ToSample Greet where instance ToSample Greet where
toSample = Just g toSample = Just g
@ -51,8 +56,8 @@ instance ToCapture (Capture "greetid" Text) where
-- API specification -- API specification
type TestApi = type TestApi =
"hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet
:<|> "greet" :> RQBody Greet :> Post Greet :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet
:<|> "delete" :> Capture "greetid" Text :> Delete :<|> "delete" :> Capture "greetid" Text :> Delete
testApi :: Proxy TestApi testApi :: Proxy TestApi

View file

@ -1,12 +1,14 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
import Data.Aeson import Data.Aeson
import Data.Proxy import Data.Proxy
import Data.Text(Text) import Data.String.Conversions
import Data.Text (Text)
import GHC.Generics import GHC.Generics
import Servant.API import Servant.API
import Servant.Docs import Servant.Docs
@ -17,9 +19,15 @@ import Servant.Docs
newtype Greet = Greet Text newtype Greet = Greet Text
deriving (Generic, Show) 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 FromJSON Greet
instance ToJSON Greet instance ToJSON Greet
-- | We can also implement 'MimeRender' for additional formats like 'PlainText'.
instance MimeRender PlainText Greet where
toByteString Proxy (Greet s) = "\"" <> cs s <> "\""
-- We add some useful annotations to our captures, -- We add some useful annotations to our captures,
-- query parameters and request body to make the docs -- query parameters and request body to make the docs
-- really helpful. -- really helpful.
@ -70,12 +78,12 @@ intro2 = DocIntro "This title is below the last"
-- API specification -- API specification
type TestApi = type TestApi =
-- GET /hello/:name?capital={true, false} returns a Greet as JSON -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText
"hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet "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, -- POST /greet with a Greet as JSON in the request body,
-- returns a Greet as JSON -- returns a Greet as JSON
:<|> "greet" :> ReqBody Greet :> Post Greet :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
-- DELETE /greet/:greetid -- DELETE /greet/:greetid
:<|> "greet" :> Capture "greetid" Text :> Delete :<|> "greet" :> Capture "greetid" Text :> Delete

View file

@ -10,24 +10,35 @@ You'll also note that multiple intros are possible.
## POST /greet ## POST /greet
#### Request Body: #### Request:
``` javascript - Supported content types are:
- `application/json`
- Example: `application/json`
```javascript
"Hello, haskeller!" "Hello, haskeller!"
``` ```
#### Response: #### Response:
- Status code 201 - Status code 201
- If you use ?capital=true
``` javascript - Supported content types are:
- `application/json`
- If you use ?capital=true
```javascript
"HELLO, HASKELLER" "HELLO, HASKELLER"
``` ```
- If you use ?capital=false - If you use ?capital=false
``` javascript ```javascript
"Hello, haskeller" "Hello, haskeller"
``` ```
@ -41,7 +52,7 @@ You'll also note that multiple intros are possible.
**hello**: **hello**:
- lang - lang
- **Values**: *en, sv, fr* - **Values**: *en, sv, fr*
- **Description**: Get the greeting message selected language. Default is en. - **Description**: Get the greeting message selected language. Default is en.
@ -49,23 +60,41 @@ You'll also note that multiple intros are possible.
#### GET Parameters: #### GET Parameters:
- capital - capital
- **Values**: *true, false* - **Values**: *true, false*
- **Description**: Get the greeting message in uppercase (true) or not (false).Default is false. - **Description**: Get the greeting message in uppercase (true) or not (false).Default is false.
#### Response: #### Response:
- Status code 200 - Status code 200
- If you use ?capital=true
``` javascript - Supported content types are:
- `application/json`
- `text/plain;charset=utf-8`
- If you use ?capital=true
```javascript
"HELLO, HASKELLER" "HELLO, HASKELLER"
``` ```
- If you use ?capital=false - If you use ?capital=true
``` javascript ```
"HELLO, HASKELLER"
```
- If you use ?capital=false
```javascript
"Hello, haskeller"
```
- If you use ?capital=false
```
"Hello, haskeller" "Hello, haskeller"
``` ```
@ -88,7 +117,8 @@ And some more
#### Response: #### Response:
- Status code 200 - Status code 200
- No response body
- No response body

View file

@ -29,13 +29,12 @@ library
build-depends: build-depends:
base >=4.7 && <5 base >=4.7 && <5
, aeson , aeson
, aeson-pretty < 0.8
, bytestring , bytestring
, hashable , hashable
, http-media
, lens , lens
, servant >= 0.2.1 , servant >= 0.2.1
, string-conversions , string-conversions
, system-filepath
, text , text
, unordered-containers , unordered-containers
hs-source-dirs: src hs-source-dirs: src
@ -46,5 +45,5 @@ executable greet-docs
main-is: greet.hs main-is: greet.hs
hs-source-dirs: example hs-source-dirs: example
ghc-options: -Wall ghc-options: -Wall
build-depends: base, aeson, servant, servant-docs, text build-depends: base, aeson, servant, servant-docs, string-conversions, text
default-language: Haskell2010 default-language: Haskell2010

View file

@ -37,15 +37,17 @@
-- Here's a little (but complete) example that you can run to see the -- Here's a little (but complete) example that you can run to see the
-- markdown pretty printer in action: -- markdown pretty printer in action:
-- --
-- > {-# LANGUAGE DataKinds #-} -- > {-# LANGUAGE DataKinds #-}
-- > {-# LANGUAGE DeriveGeneric #-} -- > {-# LANGUAGE DeriveGeneric #-}
-- > {-# LANGUAGE TypeOperators #-} -- > {-# LANGUAGE FlexibleInstances #-}
-- > {-# LANGUAGE FlexibleInstances #-} -- > {-# LANGUAGE MultiParamTypeClasses #-}
-- > {-# LANGUAGE OverloadedStrings #-} -- > {-# LANGUAGE OverloadedStrings #-}
-- > {-# LANGUAGE TypeOperators #-}
-- > {-# OPTIONS_GHC -fno-warn-orphans #-} -- > {-# OPTIONS_GHC -fno-warn-orphans #-}
-- > import Data.Aeson -- > import Data.Aeson
-- > import Data.Proxy -- > import Data.Proxy
-- > import Data.Text(Text) -- > import Data.String.Conversions
-- > import Data.Text (Text)
-- > import GHC.Generics -- > import GHC.Generics
-- > import Servant.API -- > import Servant.API
-- > import Servant.Docs -- > import Servant.Docs
@ -56,9 +58,15 @@
-- > newtype Greet = Greet Text -- > newtype Greet = Greet Text
-- > deriving (Generic, Show) -- > 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 FromJSON Greet
-- > instance ToJSON Greet -- > instance ToJSON Greet
-- > -- >
-- > -- | We can also implement 'MimeRender' for additional formats like 'PlainText'.
-- > instance MimeRender PlainText Greet where
-- > toByteString Proxy (Greet s) = "\"" <> cs s <> "\""
-- >
-- > -- We add some useful annotations to our captures, -- > -- We add some useful annotations to our captures,
-- > -- query parameters and request body to make the docs -- > -- query parameters and request body to make the docs
-- > -- really helpful. -- > -- really helpful.
@ -109,12 +117,12 @@
-- > -- >
-- > -- API specification -- > -- API specification
-- > type TestApi = -- > type TestApi =
-- > -- GET /hello/:name?capital={true, false} returns a Greet as JSON -- > -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText
-- > "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet -- > "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, -- > -- POST /greet with a Greet as JSON in the request body,
-- > -- returns a Greet as JSON -- > -- returns a Greet as JSON
-- > :<|> "greet" :> ReqBody Greet :> Post Greet -- > :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
-- > -- >
-- > -- DELETE /greet/:greetid -- > -- DELETE /greet/:greetid
-- > :<|> "greet" :> Capture "greetid" Text :> Delete -- > :<|> "greet" :> Capture "greetid" Text :> Delete
@ -166,8 +174,8 @@ module Servant.Docs
, DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
, DocNote(..), noteTitle, noteBody , DocNote(..), noteTitle, noteBody
, DocIntro(..) , DocIntro(..)
, Response, respStatus, respBody, defResponse , Response, respStatus, respTypes, respBody, defResponse
, Action, captures, headers, notes, params, rqbody, response, defAction , Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction
, single , single
, -- * Useful modules when defining your doc printers , -- * Useful modules when defining your doc printers
@ -175,27 +183,29 @@ module Servant.Docs
, module Data.Monoid , module Data.Monoid
) where ) where
import Control.Applicative
import Control.Lens hiding (Action) import Control.Lens hiding (Action)
import Data.Aeson import Data.Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Ord(comparing)
import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Hashable import Data.Hashable
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.List import Data.List
import Data.Maybe (listToMaybe) import Data.Maybe
import Data.Monoid import Data.Monoid
import Data.Ord (comparing)
import Data.Proxy import Data.Proxy
import Data.Text (Text, pack, unpack)
import Data.String.Conversions import Data.String.Conversions
import Data.Text (Text, pack, unpack)
import GHC.Generics import GHC.Generics
import GHC.TypeLits import GHC.TypeLits
import GHC.Exts(Constraint) import GHC.Exts(Constraint)
import Servant.API import Servant.API
import Servant.Utils.Links import Servant.Utils.Links
import Servant.API.ContentTypes
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T import qualified Data.Text as T
import qualified Network.HTTP.Media as M
-- | Supported HTTP request methods -- | Supported HTTP request methods
data Method = DocDELETE -- ^ the DELETE method data Method = DocDELETE -- ^ the DELETE method
@ -333,23 +343,25 @@ instance Monoid (ExtraInfo a) where
data ParamKind = Normal | List | Flag data ParamKind = Normal | List | Flag
deriving (Eq, Show) deriving (Eq, Show)
-- | A type to represent an HTTP response. Has an 'Int' status and -- | A type to represent an HTTP response. Has an 'Int' status, a list of
-- a 'Maybe ByteString' response body. Tweak 'defResponse' using -- possible 'MediaType's, and a list of example 'ByteString' response bodies.
-- the 'respStatus' and 'respBody' lenses if you want. -- 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 -- 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 -- want to write a 'ToSample' instance for the type that'll be represented
-- as some JSON in the response. -- as encoded data in the response.
-- --
-- Can be tweaked with two lenses. -- Can be tweaked with three lenses.
-- --
-- > λ> defResponse -- > λ> defResponse
-- > Response {_respStatus = 200, _respBody = []} -- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")] -- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
-- > Response {_respStatus = 204, _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]} -- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
data Response = Response data Response = Response
{ _respStatus :: Int { _respStatus :: Int
, _respBody :: [(Text, ByteString)] , _respTypes :: [M.MediaType]
, _respBody :: [(Text, M.MediaType, ByteString)]
} deriving (Eq, Show) } deriving (Eq, Show)
-- | Default response: status code 200, no response body. -- | Default response: status code 200, no response body.
@ -361,7 +373,7 @@ data Response = Response
-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]" -- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
-- > Response {_respStatus = 204, _respBody = Just "[]"} -- > Response {_respStatus = 204, _respBody = Just "[]"}
defResponse :: Response defResponse :: Response
defResponse = Response 200 [] defResponse = Response 200 [] []
-- | A datatype that represents everything that can happen -- | A datatype that represents everything that can happen
-- at an endpoint, with its lenses: -- at an endpoint, with its lenses:
@ -374,23 +386,25 @@ defResponse = Response 200 []
-- You can tweak an 'Action' (like the default 'defAction') with these lenses -- You can tweak an 'Action' (like the default 'defAction') with these lenses
-- to transform an action and add some information to it. -- to transform an action and add some information to it.
data Action = Action data Action = Action
{ _captures :: [DocCapture] -- type collected + user supplied info { _captures :: [DocCapture] -- type collected + user supplied info
, _headers :: [Text] -- type collected , _headers :: [Text] -- type collected
, _params :: [DocQueryParam] -- type collected + user supplied info , _params :: [DocQueryParam] -- type collected + user supplied info
, _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info , _notes :: [DocNote] -- user supplied
, _notes :: [DocNote] -- user supplied , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
, _rqbody :: Maybe ByteString -- user supplied , _rqtypes :: [M.MediaType] -- type collected
, _response :: Response -- user supplied , _rqbody :: [(M.MediaType, ByteString)] -- user supplied
, _response :: Response -- user supplied
} deriving (Eq, Show) } deriving (Eq, Show)
-- | Combine two Actions, we can't make a monoid as merging Response breaks the -- | Combine two Actions, we can't make a monoid as merging Response breaks the
-- laws. -- laws.
-- --
-- As such, we invent a non-commutative, left associative operation -- As such, we invent a non-commutative, left associative operation
-- 'combineAction' to mush two together taking the response from the very left. -- 'combineAction' to mush two together taking the response, body and content
-- types from the very left.
combineAction :: Action -> Action -> Action combineAction :: Action -> Action -> Action
Action c h p m n r resp `combineAction` Action c' h' p' m' n' r' _ = Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =
Action (c <> c') (h <> h') (p <> p') (m <> m') (n <> n') (r <> r') resp Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
-- Default 'Action'. Has no 'captures', no GET 'params', expects -- Default 'Action'. Has no 'captures', no GET 'params', expects
-- no request body ('rqbody') and the typical response is 'defResponse'. -- no request body ('rqbody') and the typical response is 'defResponse'.
@ -408,7 +422,8 @@ defAction =
[] []
[] []
[] []
Nothing []
[]
defResponse defResponse
-- | Create an API that's comprised of a single endpoint. -- | Create an API that's comprised of a single endpoint.
@ -455,7 +470,7 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
-- > ] -- > ]
extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint) extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
=> Proxy endpoint -> Action -> ExtraInfo layout => Proxy endpoint -> Action -> ExtraInfo layout
extraInfo p action = extraInfo p action =
let api = docsFor p (defEndpoint, defAction) let api = docsFor p (defEndpoint, defAction)
-- Assume one endpoint, HasLink constraint means that we should only ever -- Assume one endpoint, HasLink constraint means that we should only ever
@ -527,20 +542,46 @@ class HasDocs layout where
class ToJSON a => ToSample a where class ToJSON a => ToSample a where
{-# MINIMAL (toSample | toSamples) #-} {-# MINIMAL (toSample | toSamples) #-}
toSample :: Maybe a toSample :: Maybe a
toSample = fmap snd $ listToMaybe samples toSample = snd <$> listToMaybe samples
where samples = toSamples :: [(Text, a)] where samples = toSamples :: [(Text, a)]
toSamples :: [(Text, a)] toSamples :: [(Text, a)]
toSamples = maybe [] (return . ("",)) s toSamples = maybe [] (return . ("",)) s
where s = toSample :: Maybe a where s = toSample :: Maybe a
sampleByteString :: forall a. ToSample a => Proxy a -> Maybe ByteString -- | Synthesise a sample value of a type, encoded in the specified media types.
sampleByteString Proxy = fmap encodePretty (toSample :: Maybe a) sampleByteString
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
=> Proxy ctypes
-> Proxy a
-> [(M.MediaType, ByteString)]
sampleByteString ctypes@Proxy Proxy =
maybe [] (allMimeRender ctypes) (toSample :: Maybe a)
sampleByteStrings :: forall a. ToSample a => Proxy a -> [(Text, ByteString)] -- | Synthesise a list of sample values of a particular type, encoded in the
sampleByteStrings Proxy = samples & traverse._2 %~ encodePretty -- specified media types.
sampleByteStrings
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
=> Proxy ctypes
-> Proxy a
-> [(Text, M.MediaType, ByteString)]
sampleByteStrings ctypes@Proxy Proxy =
let samples = toSamples :: [(Text, a)]
enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
in concatMap enc samples
where samples = toSamples :: [(Text, a)] -- | 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 -- | The class that helps us automatically get documentation
-- for GET parameters. -- for GET parameters.
@ -581,7 +622,7 @@ markdown api = unlines $
mxParamsStr (action ^. mxParams) ++ mxParamsStr (action ^. mxParams) ++
headersStr (action ^. headers) ++ headersStr (action ^. headers) ++
paramsStr (action ^. params) ++ paramsStr (action ^. params) ++
rqbodyStr (action ^. rqbody) ++ rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
responseStr (action ^. response) ++ responseStr (action ^. response) ++
[] []
@ -595,7 +636,7 @@ markdown api = unlines $
introStr i = introStr i =
("#### " ++ i ^. introTitle) : ("#### " ++ i ^. introTitle) :
"" : "" :
intersperse "" (i ^. introBody) ++ intersperse "" (i ^. introBody) ++
"" : "" :
[] []
@ -618,6 +659,7 @@ markdown api = unlines $
map captureStr l ++ map captureStr l ++
"" : "" :
[] []
captureStr cap = captureStr cap =
"- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc) "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
@ -650,8 +692,9 @@ markdown api = unlines $
map paramStr l ++ map paramStr l ++
"" : "" :
[] []
paramStr param = unlines $ paramStr param = unlines $
(" - " ++ param ^. paramName) : ("- " ++ param ^. paramName) :
(if (not (null values) || param ^. paramKind /= Flag) (if (not (null values) || param ^. paramKind /= Flag)
then [" - **Values**: *" ++ intercalate ", " values ++ "*"] then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
else []) ++ else []) ++
@ -667,16 +710,35 @@ markdown api = unlines $
where values = param ^. paramValues where values = param ^. paramValues
rqbodyStr :: Maybe ByteString -> [String] rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]
rqbodyStr Nothing = [] rqbodyStr [] [] = []
rqbodyStr (Just b) = rqbodyStr types samples =
"#### Request Body:" : ["#### Request:", ""]
jsonStr b <> formatTypes types
<> concatMap formatBody samples
jsonStr b = 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 =
"" : "" :
"``` javascript" : "```" <> markdownForType mime_type :
cs b : cs body :
"```" : "```" :
"" : "" :
[] []
@ -685,14 +747,16 @@ markdown api = unlines $
responseStr resp = responseStr resp =
"#### Response:" : "#### Response:" :
"" : "" :
(" - Status code " ++ show (resp ^. respStatus)) : ("- Status code " ++ show (resp ^. respStatus)) :
"" :
formatTypes (resp ^. respTypes) ++
bodies bodies
where bodies = case resp ^. respBody of where bodies = case resp ^. respBody of
[] -> [" - No response body\n"] [] -> ["- No response body\n"]
[("", r)] -> " - Response body as below." : jsonStr r [("", t, r)] -> "- Response body as below." : contentStr t r
xs -> xs ->
concatMap (\(ctx, r) -> (" - " <> T.unpack ctx) : jsonStr r) xs concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs
-- * Instances -- * Instances
@ -734,12 +798,15 @@ instance HasDocs Delete where
action' = action & response.respBody .~ [] action' = action & response.respBody .~ []
& response.respStatus .~ 204 & response.respStatus .~ 204
instance ToSample a => HasDocs (Get a) where instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
=> HasDocs (Get cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocGET where endpoint' = endpoint & method .~ DocGET
action' = action & response.respBody .~ sampleByteStrings p action' = action & response.respBody .~ sampleByteStrings t p
& response.respTypes .~ supportedTypes t
t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance (KnownSymbol sym, HasDocs sublayout) instance (KnownSymbol sym, HasDocs sublayout)
@ -751,29 +818,30 @@ instance (KnownSymbol sym, HasDocs sublayout)
action' = over headers (|> headername) action action' = over headers (|> headername) action
headername = pack $ symbolVal (Proxy :: Proxy sym) headername = pack $ symbolVal (Proxy :: Proxy sym)
instance ToSample a => HasDocs (Post a) where instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
=> HasDocs (Post cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocPOST where endpoint' = endpoint & method .~ DocPOST
action' = action & response.respBody .~ sampleByteStrings t p
action' = action & response.respBody .~ sampleByteStrings p & response.respTypes .~ supportedTypes t
& response.respStatus .~ 201 & response.respStatus .~ 201
t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance ToSample a => HasDocs (Put a) where instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
=> HasDocs (Put cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocPUT where endpoint' = endpoint & method .~ DocPUT
action' = action & response.respBody .~ sampleByteStrings t p
action' = action & response.respBody .~ sampleByteStrings p & response.respTypes .~ supportedTypes t
& response.respStatus .~ 200 & response.respStatus .~ 200
t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
=> HasDocs (QueryParam sym a :> sublayout) where => HasDocs (QueryParam sym a :> sublayout) where
@ -848,20 +916,24 @@ instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)
endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint
symP = Proxy :: Proxy sym symP = Proxy :: Proxy sym
instance HasDocs Raw where instance HasDocs Raw where
docsFor _proxy (endpoint, action) = docsFor _proxy (endpoint, action) =
single endpoint action single endpoint action
instance (ToSample a, HasDocs sublayout) -- TODO: We use 'AllMimeRender' here because we need to be able to show the
=> HasDocs (ReqBody a :> sublayout) where -- 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, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts)
=> HasDocs (ReqBody cts a :> sublayout) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action') docsFor sublayoutP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout where sublayoutP = Proxy :: Proxy sublayout
action' = action & rqbody .~ sampleByteString t p
action' = action & rqbody .~ sampleByteString p & rqtypes .~ supportedTypes t
t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where