eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #12 from anchor/jkarni/content-types

Browse source 
Extend servant-docs to support content types
This commit is contained in:
Christian Marie 2015-02-23 09:52:55 +11:00
commit 5df017267e
4 changed files with 169 additions and 90 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
README.md
View file

@ -27,10 +27,15 @@ import Servant
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 +56,8 @@ instance ToCapture (Capture "greetid" Text) where
-- 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

18
example/greet.hs
View file

@ -1,12 +1,14 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
import Data.Aeson
import Data.Proxy
import Data.Text(Text)
import Data.String.Conversions
import Data.Text (Text)
import GHC.Generics
import Servant.API
import Servant.Docs
@ -17,9 +19,15 @@ import Servant.Docs
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
toByteString Proxy (Greet s) = "\"" <> cs s <> "\""
-- We add some useful annotations to our captures,
-- query parameters and request body to make the docs
-- really helpful.
@ -65,12 +73,12 @@ intro2 = DocIntro "This title is below the last"
-- 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] Greet
-- DELETE /greet/:greetid
:<|> "greet" :> Capture "greetid" Text :> Delete

5
servant-docs.cabal
View file

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

187
src/Servant/Docs.hs
View file

@ -1,13 +1,16 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-------------------------------------------------------------------------------
-- | This module lets you get API docs for free. It lets generate
@ -102,11 +105,11 @@
-- > -- 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
-- > "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] 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] Greet
-- >
-- > -- DELETE /greet/:greetid
-- > :<|> "greet" :> Capture "greetid" Text :> Delete
@ -145,8 +148,8 @@ module Servant.Docs
, DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
, DocNote(..), noteTitle, noteBody
, DocIntro(..)
, Response, respStatus, respBody, defResponse
, Action, captures, headers, notes, params, rqbody, response, defAction
, Response, respStatus, respTypes, respBody, defResponse
, Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction
, single
, -- * Useful modules when defining your doc printers
@ -154,25 +157,27 @@ module Servant.Docs
, module Data.Monoid
) where
import Control.Lens hiding (Action)
import Control.Applicative
import Control.Lens
import Data.Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Ord(comparing)
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Hashable
import Data.HashMap.Strict (HashMap)
import Data.List
import Data.Maybe (listToMaybe)
import Data.Maybe
import Data.Monoid
import Data.Ord (comparing)
import Data.Proxy
import Data.Text (Text, pack, unpack)
import Data.String.Conversions
import Data.Text (Text, pack, unpack)
import GHC.Generics
import GHC.TypeLits
import Servant.API
import Servant.API.ContentTypes
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Network.HTTP.Media as M
-- | Supported HTTP request methods
data Method = DocDELETE -- ^ the DELETE method
@ -299,23 +304,25 @@ data DocNote = DocNote
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.
-- | 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 some JSON in the response.
-- as encoded data in the response.
--
-- Can be tweaked with two lenses.
-- Can be tweaked with three lenses.
--
-- > λ> defResponse
-- > Response {_respStatus = 200, _respBody = []}
-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
-- > λ> 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
{ _respStatus :: Int
, _respBody :: [(Text, ByteString)]
, _respTypes :: [M.MediaType]
, _respBody :: [(Text, M.MediaType, ByteString)]
} deriving (Eq, Show)
-- | Default response: status code 200, no response body.
@ -327,7 +334,7 @@ data Response = Response
-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
-- > Response {_respStatus = 204, _respBody = Just "[]"}
defResponse :: Response
defResponse = Response 200 []
defResponse = Response 200 [] []
-- | A datatype that represents everything that can happen
-- at an endpoint, with its lenses:
@ -345,7 +352,8 @@ data Action = Action
, _params :: [DocQueryParam] -- type collected + user supplied info
, _notes :: [DocNote] -- user supplied
, _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
, _rqbody :: Maybe ByteString -- user supplied
, _rqtypes :: [M.MediaType] -- type collected
, _rqbody :: [(M.MediaType, ByteString)] -- user supplied
, _response :: Response -- user supplied
} deriving (Eq, Show)
@ -365,7 +373,8 @@ defAction =
[]
[]
[]
Nothing
[]
[]
defResponse
-- | Create an API that's comprised of a single endpoint.
@ -432,20 +441,46 @@ class HasDocs layout where
class ToJSON a => ToSample a where
{-# MINIMAL (toSample | toSamples) #-}
toSample :: Maybe a
toSample = fmap snd $ listToMaybe samples
toSample = 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)
-- | Synthesise a sample value of a type, encoded in the specified media types.
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)]
sampleByteStrings Proxy = samples & traverse._2 %~ encodePretty
-- | Synthesise a list of sample values of a particular type, encoded in the
-- 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
-- for GET parameters.
@ -486,7 +521,7 @@ markdown api = unlines $
mxParamsStr (action ^. mxParams) ++
headersStr (action ^. headers) ++
paramsStr (action ^. params) ++
rqbodyStr (action ^. rqbody) ++
rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
responseStr (action ^. response) ++
[]
@ -523,6 +558,7 @@ markdown api = unlines $
map captureStr l ++
"" :
[]
captureStr cap =
"- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
@ -534,6 +570,7 @@ markdown api = unlines $
map segmentStr l ++
"" :
[]
segmentStr :: (String, [DocQueryParam]) -> String
segmentStr (segment, l) = unlines $
("**" ++ segment ++ "**:") :
@ -557,8 +594,9 @@ markdown api = unlines $
map paramStr l ++
"" :
[]
paramStr param = unlines $
(" - " ++ param ^. paramName) :
("- " ++ param ^. paramName) :
(if (not (null values) || param ^. paramKind /= Flag)
then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
else []) ++
@ -574,16 +612,35 @@ markdown api = unlines $
where values = param ^. paramValues
rqbodyStr :: Maybe ByteString -> [String]
rqbodyStr Nothing = []
rqbodyStr (Just b) =
"#### Request Body:" :
jsonStr b
rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]
rqbodyStr [] [] = []
rqbodyStr types samples =
["#### Request:", ""]
<> 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" :
cs b :
"``` " <> markdownForType mime_type :
cs body :
"```" :
"" :
[]
@ -592,14 +649,16 @@ markdown api = unlines $
responseStr resp =
"#### Response:" :
"" :
(" - Status code " ++ show (resp ^. respStatus)) :
("- Status code " ++ show (resp ^. respStatus)) :
"" :
formatTypes (resp ^. respTypes) ++
bodies
where bodies = case resp ^. respBody of
[] -> [" - No response body\n"]
[("", r)] -> " - Response body as below." : jsonStr r
[] -> ["- No response body\n"]
[("", t, r)] -> "- Response body as below." : contentStr t r
xs ->
concatMap (\(ctx, r) -> (" - " <> T.unpack ctx) : jsonStr r) xs
concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs
-- * Instances
@ -641,12 +700,15 @@ instance HasDocs Delete where
action' = action & response.respBody .~ []
& 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) =
single endpoint' action'
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
instance (KnownSymbol sym, HasDocs sublayout)
@ -658,29 +720,30 @@ instance (KnownSymbol sym, HasDocs sublayout)
action' = over headers (|> headername) action
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) =
single endpoint' action'
where endpoint' = endpoint & method .~ DocPOST
action' = action & response.respBody .~ sampleByteStrings p
action' = action & response.respBody .~ sampleByteStrings t p
& response.respTypes .~ supportedTypes t
& response.respStatus .~ 201
t = Proxy :: Proxy cts
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) =
single endpoint' action'
where endpoint' = endpoint & method .~ DocPUT
action' = action & response.respBody .~ sampleByteStrings p
action' = action & response.respBody .~ sampleByteStrings t p
& response.respTypes .~ supportedTypes t
& response.respStatus .~ 200
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
=> HasDocs (QueryParam sym a :> sublayout) where
@ -755,20 +818,24 @@ instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs 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
-- 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, IsNonEmpty cts, AllMimeRender cts a, 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 p
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