From 3c14343b8889495eff7d0c4d7b9d1522c206b11e Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Thu, 19 Feb 2015 10:59:24 +1100 Subject: [PATCH 01/14] Add content-type params to type constructors --- example/greet.hs | 4 ++-- src/Servant/Docs.hs | 14 +++++++------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/example/greet.hs b/example/greet.hs index 44f9a69a..977ee8bf 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -66,11 +66,11 @@ 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 + "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 diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index 6a4fad31..7809b5a7 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -102,11 +102,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 @@ -154,7 +154,7 @@ module Servant.Docs , module Data.Monoid ) where -import Control.Lens hiding (Action) +import Control.Lens import Data.Aeson import Data.Aeson.Encode.Pretty (encodePretty) import Data.Ord(comparing) @@ -641,7 +641,7 @@ instance HasDocs Delete where action' = action & response.respBody .~ [] & response.respStatus .~ 204 -instance ToSample a => HasDocs (Get a) where +instance ToSample a => HasDocs (Get cts a) where docsFor Proxy (endpoint, action) = single endpoint' action' @@ -658,7 +658,7 @@ 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 => HasDocs (Post cts a) where docsFor Proxy (endpoint, action) = single endpoint' action' @@ -669,7 +669,7 @@ instance ToSample a => HasDocs (Post a) where p = Proxy :: Proxy a -instance ToSample a => HasDocs (Put a) where +instance ToSample a => HasDocs (Put cts a) where docsFor Proxy (endpoint, action) = single endpoint' action' @@ -761,7 +761,7 @@ instance HasDocs Raw where single endpoint action instance (ToSample a, HasDocs sublayout) - => HasDocs (ReqBody a :> sublayout) where + => HasDocs (ReqBody cts a :> sublayout) where docsFor Proxy (endpoint, action) = docsFor sublayoutP (endpoint, action') From 6d85885b4219a80bcc21cc972dba05477350aafe Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Thu, 19 Feb 2015 12:48:10 +1100 Subject: [PATCH 02/14] Add content types to the example --- example/greet.hs | 29 +++++++++++++++++++++-------- servant-docs.cabal | 3 ++- 2 files changed, 23 insertions(+), 9 deletions(-) diff --git a/example/greet.hs b/example/greet.hs index 977ee8bf..28b5e64f 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -1,14 +1,19 @@ -{-# 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 Data.Aeson +import Data.Aeson.Encode.Pretty (encodePretty) import Data.Proxy -import Data.Text(Text) +import Data.Text (Text) +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T import GHC.Generics import Servant.API +import Servant.API.ContentTypes import Servant.Docs -- * Example @@ -20,6 +25,14 @@ newtype Greet = Greet Text instance FromJSON Greet instance ToJSON Greet +instance MimeRender JSON Greet where + toByteString Proxy v = encodePretty v + +instance MimeRender HTML Greet where + toByteString Proxy (Greet s) = "

" <> (c s) <> "

" + where + c = T.encodeUtf8 . T.fromStrict + -- We add some useful annotations to our captures, -- query parameters and request body to make the docs -- really helpful. @@ -66,11 +79,11 @@ 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 '[JSON] Greet + "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, HTML] Greet -- POST /greet with a Greet as JSON in the request body, -- returns a Greet as JSON - :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet + :<|> "greet" :> ReqBody '[JSON,HTML] Greet :> Post '[JSON] Greet -- DELETE /greet/:greetid :<|> "greet" :> Capture "greetid" Text :> Delete diff --git a/servant-docs.cabal b/servant-docs.cabal index 52c06b5b..37de47c4 100644 --- a/servant-docs.cabal +++ b/servant-docs.cabal @@ -32,6 +32,7 @@ library , aeson-pretty < 0.8 , bytestring , hashable + , http-media , lens , servant >= 0.2.1 , string-conversions @@ -46,5 +47,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, aeson-pretty, servant, servant-docs, text default-language: Haskell2010 From dba8689acd4970780346630165d69e88155c5315 Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Thu, 19 Feb 2015 12:53:14 +1100 Subject: [PATCH 03/14] Remove redundant dependencies --- servant-docs.cabal | 2 -- 1 file changed, 2 deletions(-) diff --git a/servant-docs.cabal b/servant-docs.cabal index 37de47c4..c3b91df1 100644 --- a/servant-docs.cabal +++ b/servant-docs.cabal @@ -29,14 +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 From 508b9f979136bafdd048c08c2680c5e6755a0f7d Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Thu, 19 Feb 2015 12:55:00 +1100 Subject: [PATCH 04/14] Generate docs with samples encoded in all types Request and response body documentation now includes sample values encoded in all supported media types. --- src/Servant/Docs.hs | 129 +++++++++++++++++++++++++++----------------- 1 file changed, 80 insertions(+), 49 deletions(-) diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index 7809b5a7..a0097345 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -1,13 +1,16 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# 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 @@ -154,25 +157,27 @@ module Servant.Docs , module Data.Monoid ) where +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 Data.Text as T +import qualified Network.HTTP.Media as M -- | Supported HTTP request methods data Method = DocDELETE -- ^ the DELETE method @@ -315,7 +320,7 @@ data ParamKind = Normal | List | Flag -- > Response {_respStatus = 204, _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]} data Response = Response { _respStatus :: Int - , _respBody :: [(Text, ByteString)] + , _respBody :: [(Text, M.MediaType, ByteString)] } deriving (Eq, Show) -- | Default response: status code 200, no response body. @@ -345,7 +350,7 @@ 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 + , _rqbody :: Maybe [(M.MediaType, ByteString)] -- user supplied , _response :: Response -- user supplied } deriving (Eq, Show) @@ -428,24 +433,38 @@ class HasDocs layout where -- 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. +-- get the corresponding response. 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 + -> Maybe [(M.MediaType, ByteString)] +sampleByteString ctypes@Proxy Proxy = + fmap (amr ctypes) (toSample :: Maybe a) -sampleByteStrings :: forall a. ToSample a => Proxy a -> [(Text, ByteString)] -sampleByteStrings Proxy = samples & traverse._2 %~ encodePretty - - where samples = toSamples :: [(Text, a)] +-- | 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)] + ext t (a,b) = (t,a,b) + enc (t, s) = ext t <$> amr ctypes s + in concatMap enc samples -- | The class that helps us automatically get documentation -- for GET parameters. @@ -574,16 +593,26 @@ markdown api = unlines $ where values = param ^. paramValues - rqbodyStr :: Maybe ByteString -> [String] + rqbodyStr :: Maybe [(M.MediaType, ByteString)]-> [String] rqbodyStr Nothing = [] - rqbodyStr (Just b) = - "#### Request Body:" : - jsonStr b + rqbodyStr (Just b) = concatMap formatBody b - jsonStr b = + formatBody (m, b) = + "#### Request Body: `" <> show (M.mainType m <> "/" <> M.subType 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" + (_, _) -> "" + + contentStr mime_type body = "" : - "``` javascript" : - cs b : + "``` " <> markdownForType mime_type : + cs body : "```" : "" : [] @@ -597,9 +626,9 @@ markdown api = unlines $ where bodies = case resp ^. respBody of [] -> [" - No response body\n"] - [("", r)] -> " - Response body as below." : jsonStr r + [("", 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,14 +670,16 @@ instance HasDocs Delete where action' = action & response.respBody .~ [] & response.respStatus .~ 204 -instance ToSample a => HasDocs (Get cts a) where +instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => 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 + t = Proxy :: Proxy cts p = Proxy :: Proxy a + instance (KnownSymbol sym, HasDocs sublayout) => HasDocs (Header sym a :> sublayout) where docsFor Proxy (endpoint, action) = @@ -658,29 +689,26 @@ instance (KnownSymbol sym, HasDocs sublayout) action' = over headers (|> headername) action headername = pack $ symbolVal (Proxy :: Proxy sym) -instance ToSample a => HasDocs (Post cts a) where +instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => 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.respStatus .~ 201 - + t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance ToSample a => HasDocs (Put cts a) where +instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => 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.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 +783,23 @@ 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) +-- 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) => 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 + t = Proxy :: Proxy cts p = Proxy :: Proxy a instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where From 3451dcf186a647bf05988f18d961fd11fbd608fc Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Thu, 19 Feb 2015 13:03:38 +1100 Subject: [PATCH 05/14] Use string conversions in example --- example/greet.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/example/greet.hs b/example/greet.hs index 28b5e64f..9a5469cb 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -8,9 +8,8 @@ import Data.Aeson import Data.Aeson.Encode.Pretty (encodePretty) import Data.Proxy +import Data.String.Conversions import Data.Text (Text) -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.Encoding as T import GHC.Generics import Servant.API import Servant.API.ContentTypes @@ -26,12 +25,10 @@ instance FromJSON Greet instance ToJSON Greet instance MimeRender JSON Greet where - toByteString Proxy v = encodePretty v + toByteString Proxy = encodePretty instance MimeRender HTML Greet where - toByteString Proxy (Greet s) = "

" <> (c s) <> "

" - where - c = T.encodeUtf8 . T.fromStrict + toByteString Proxy (Greet s) = "

" <> cs s <> "

" -- We add some useful annotations to our captures, -- query parameters and request body to make the docs From d62c61224bd7e7869c436ba83bfebfdf91423bb0 Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Thu, 19 Feb 2015 13:15:25 +1100 Subject: [PATCH 06/14] Simplify encoding code slightly --- src/Servant/Docs.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index a0097345..2e32001f 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -462,8 +462,7 @@ sampleByteStrings -> [(Text, M.MediaType, ByteString)] sampleByteStrings ctypes@Proxy Proxy = let samples = toSamples :: [(Text, a)] - ext t (a,b) = (t,a,b) - enc (t, s) = ext t <$> amr ctypes s + enc (t, s) = (\(m,b) -> (t,m,b)) <$> amr ctypes s in concatMap enc samples -- | The class that helps us automatically get documentation From f303f6176a4648f8803c4e4145f186cf50e100df Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Thu, 19 Feb 2015 13:19:29 +1100 Subject: [PATCH 07/14] Simplify encoding code slightly more --- src/Servant/Docs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index 2e32001f..d49ce877 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -462,7 +462,7 @@ sampleByteStrings -> [(Text, M.MediaType, ByteString)] sampleByteStrings ctypes@Proxy Proxy = let samples = toSamples :: [(Text, a)] - enc (t, s) = (\(m,b) -> (t,m,b)) <$> amr ctypes s + enc (t, s) = uncurry (t,,) <$> amr ctypes s in concatMap enc samples -- | The class that helps us automatically get documentation From 921547da609ab696902be3b7ec309838892533fb Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Thu, 19 Feb 2015 13:23:13 +1100 Subject: [PATCH 08/14] Example now depends on string-conversions --- servant-docs.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-docs.cabal b/servant-docs.cabal index c3b91df1..d45cbbbf 100644 --- a/servant-docs.cabal +++ b/servant-docs.cabal @@ -45,5 +45,5 @@ executable greet-docs main-is: greet.hs hs-source-dirs: example ghc-options: -Wall - build-depends: base, aeson, aeson-pretty, servant, servant-docs, text + build-depends: base, aeson, aeson-pretty, servant, servant-docs, string-conversions, text default-language: Haskell2010 From 0daa8d27a5f067ee7bd70b0606f4698fb7a9feec Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Thu, 19 Feb 2015 15:29:04 +1100 Subject: [PATCH 09/14] Add list of supported content types to documentation --- src/Servant/Docs.hs | 115 ++++++++++++++++++++++++++++++-------------- 1 file changed, 79 insertions(+), 36 deletions(-) diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index d49ce877..504b82f6 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -148,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 @@ -304,22 +304,24 @@ 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 + , _respTypes :: [M.MediaType] , _respBody :: [(Text, M.MediaType, ByteString)] } deriving (Eq, Show) @@ -332,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,13 +347,14 @@ defResponse = Response 200 [] -- 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 - , _rqbody :: Maybe [(M.MediaType, ByteString)] -- user supplied - , _response :: Response -- user supplied + { _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, Show) -- Default 'Action'. Has no 'captures', no GET 'params', expects @@ -370,7 +373,8 @@ defAction = [] [] [] - Nothing + [] + [] defResponse -- | Create an API that's comprised of a single endpoint. @@ -449,9 +453,9 @@ sampleByteString :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) => Proxy ctypes -> Proxy a - -> Maybe [(M.MediaType, ByteString)] + -> [(M.MediaType, ByteString)] sampleByteString ctypes@Proxy Proxy = - fmap (amr ctypes) (toSample :: Maybe a) + maybe [] (amr ctypes) (toSample :: Maybe a) -- | Synthesise a list of sample values of a particular type, encoded in the -- specified media types. @@ -465,6 +469,25 @@ sampleByteStrings ctypes@Proxy Proxy = enc (t, s) = uncurry (t,,) <$> amr 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 '[ctype] where + supportedTypes Proxy = [ contentType (Proxy :: Proxy ctype) ] + +instance (Accept ctype, Accept ctype', SupportedTypes rest) + => SupportedTypes (ctype ': ctype' ': rest) where + + supportedTypes Proxy = + [ contentType (Proxy :: Proxy ctype) + , contentType (Proxy :: Proxy ctype') + ] <> supportedTypes (Proxy :: Proxy rest) + -- | The class that helps us automatically get documentation -- for GET parameters. -- @@ -504,7 +527,7 @@ markdown api = unlines $ mxParamsStr (action ^. mxParams) ++ headersStr (action ^. headers) ++ paramsStr (action ^. params) ++ - rqbodyStr (action ^. rqbody) ++ + rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++ responseStr (action ^. response) ++ [] @@ -518,7 +541,7 @@ markdown api = unlines $ introStr i = ("#### " ++ i ^. introTitle) : "" : - intersperse "" (i ^. introBody) ++ + intersperse "" (i ^. introBody) ++ "" : [] @@ -541,6 +564,7 @@ markdown api = unlines $ map captureStr l ++ "" : [] + captureStr cap = "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc) @@ -552,6 +576,7 @@ markdown api = unlines $ map segmentStr l ++ "" : [] + segmentStr :: (String, [DocQueryParam]) -> String segmentStr (segment, l) = unlines $ ("**" ++ segment ++ "**:") : @@ -575,8 +600,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 []) ++ @@ -592,12 +618,20 @@ markdown api = unlines $ where values = param ^. paramValues - rqbodyStr :: Maybe [(M.MediaType, ByteString)]-> [String] - rqbodyStr Nothing = [] - rqbodyStr (Just b) = concatMap formatBody b + 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) = - "#### Request Body: `" <> show (M.mainType m <> "/" <> M.subType m) <> "`" : + "- Example: `" <> cs (M.mainType m <> "/" <> M.subType m) <> "`" : contentStr m b markdownForType mime_type = @@ -606,6 +640,7 @@ markdown api = unlines $ ("application", "xml") -> "xml" ("application", "json") -> "javascript" ("application", "javascript") -> "javascript" + ("text", "css") -> "css" (_, _) -> "" contentStr mime_type body = @@ -620,14 +655,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"] - [("", t, r)] -> " - Response body as below." : contentStr t r + [] -> ["- 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 + concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs -- * Instances @@ -669,16 +706,17 @@ instance HasDocs Delete where action' = action & response.respBody .~ [] & response.respStatus .~ 204 -instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Get cts 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 t p + & response.respTypes .~ supportedTypes t t = Proxy :: Proxy cts p = Proxy :: Proxy a - instance (KnownSymbol sym, HasDocs sublayout) => HasDocs (Header sym a :> sublayout) where docsFor Proxy (endpoint, action) = @@ -688,22 +726,26 @@ instance (KnownSymbol sym, HasDocs sublayout) action' = over headers (|> headername) action headername = pack $ symbolVal (Proxy :: Proxy sym) -instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Post cts 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 t p + & response.respTypes .~ supportedTypes t & response.respStatus .~ 201 t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Put cts 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 t p + & response.respTypes .~ supportedTypes t & response.respStatus .~ 200 t = Proxy :: Proxy cts p = Proxy :: Proxy a @@ -790,7 +832,7 @@ instance HasDocs Raw 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) +instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts) => HasDocs (ReqBody cts a :> sublayout) where docsFor Proxy (endpoint, action) = @@ -798,6 +840,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout) where sublayoutP = Proxy :: Proxy sublayout action' = action & rqbody .~ sampleByteString t p + & rqtypes .~ supportedTypes t t = Proxy :: Proxy cts p = Proxy :: Proxy a From 8087fae18bdf7b3bb23d4693c59a1580acb31618 Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Fri, 20 Feb 2015 08:03:11 +1100 Subject: [PATCH 10/14] amr renamed allMimeRender --- example/greet.hs | 1 - src/Servant/Docs.hs | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/example/greet.hs b/example/greet.hs index 9a5469cb..8e1efaeb 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -12,7 +12,6 @@ import Data.String.Conversions import Data.Text (Text) import GHC.Generics import Servant.API -import Servant.API.ContentTypes import Servant.Docs -- * Example diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index 504b82f6..da3bf67b 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -455,7 +455,7 @@ sampleByteString -> Proxy a -> [(M.MediaType, ByteString)] sampleByteString ctypes@Proxy Proxy = - maybe [] (amr ctypes) (toSample :: Maybe a) + maybe [] (allMimeRender ctypes) (toSample :: Maybe a) -- | Synthesise a list of sample values of a particular type, encoded in the -- specified media types. @@ -466,7 +466,7 @@ sampleByteStrings -> [(Text, M.MediaType, ByteString)] sampleByteStrings ctypes@Proxy Proxy = let samples = toSamples :: [(Text, a)] - enc (t, s) = uncurry (t,,) <$> amr ctypes s + enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s in concatMap enc samples -- | Generate a list of 'MediaType' values describing the content types From 02c4adfd1805268dd229f1c812441dcf0a927257 Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Fri, 20 Feb 2015 08:05:37 +1100 Subject: [PATCH 11/14] Simplify SupportedTypes instances --- src/Servant/Docs.hs | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index da3bf67b..f156f643 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -477,16 +477,10 @@ class SupportedTypes (list :: [*]) where instance SupportedTypes '[] where supportedTypes Proxy = [] -instance (Accept ctype) => SupportedTypes '[ctype] where - supportedTypes Proxy = [ contentType (Proxy :: Proxy ctype) ] - -instance (Accept ctype, Accept ctype', SupportedTypes rest) - => SupportedTypes (ctype ': ctype' ': rest) where - +instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest) + where supportedTypes Proxy = - [ contentType (Proxy :: Proxy ctype) - , contentType (Proxy :: Proxy ctype') - ] <> supportedTypes (Proxy :: Proxy rest) + contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest) -- | The class that helps us automatically get documentation -- for GET parameters. From bdf61e4df941363d0f85fb291c78e266bf7e83d5 Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Sun, 22 Feb 2015 17:18:07 +1100 Subject: [PATCH 12/14] Sample program more sensible and update README --- README.md | 12 ++++++++++-- example/greet.hs | 6 ++++-- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 8adaf0b8..cc27510b 100644 --- a/README.md +++ b/README.md @@ -31,6 +31,14 @@ data Greet = Greet { _msg :: Text } instance FromJSON Greet instance ToJSON Greet +-- we can render a Greeting into JSON using this ToJSON instance +instance MimeRender JSON Greet where + toByteString Proxy = encodePretty + +-- or we can render it to HTML +instance MimeRender HTML Greet where + toByteString Proxy (Greet s) = "

" <> cs s <> "

" + -- we provide a sample value for the 'Greet' type instance ToSample Greet where toSample = Just g @@ -51,8 +59,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,HTML] Greet + :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet :<|> "delete" :> Capture "greetid" Text :> Delete testApi :: Proxy TestApi diff --git a/example/greet.hs b/example/greet.hs index 8e1efaeb..3aca7b24 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -23,9 +23,11 @@ newtype Greet = Greet Text instance FromJSON Greet instance ToJSON Greet +-- | A 'Greet' value can be rendered to 'JSON'. instance MimeRender JSON Greet where toByteString Proxy = encodePretty +-- | A 'Greet' value can be rendered to 'HTML'. instance MimeRender HTML Greet where toByteString Proxy (Greet s) = "

" <> cs s <> "

" @@ -74,12 +76,12 @@ intro2 = DocIntro "This title is below the last" -- API specification 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 HTML "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, HTML] Greet -- POST /greet with a Greet as JSON in the request body, -- returns a Greet as JSON - :<|> "greet" :> ReqBody '[JSON,HTML] Greet :> Post '[JSON] Greet + :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet -- DELETE /greet/:greetid :<|> "greet" :> Capture "greetid" Text :> Delete From 97ff49c3c4fcd395c902cff78bf2cc7e0d69f733 Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Sun, 22 Feb 2015 19:42:38 +1100 Subject: [PATCH 13/14] Replace HTML with PlainText in examples --- README.md | 13 +++++-------- example/greet.hs | 17 +++++++---------- 2 files changed, 12 insertions(+), 18 deletions(-) diff --git a/README.md b/README.md index cc27510b..28c450e7 100644 --- a/README.md +++ b/README.md @@ -27,16 +27,13 @@ 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 render a Greeting into JSON using this ToJSON instance -instance MimeRender JSON Greet where - toByteString Proxy = encodePretty - --- or we can render it to HTML -instance MimeRender HTML Greet where +-- We can also implement 'MimeRender' explicitly for additional formats. +instance MimeRender PlainText Greet where toByteString Proxy (Greet s) = "

" <> cs s <> "

" -- we provide a sample value for the 'Greet' type @@ -59,7 +56,7 @@ instance ToCapture (Capture "greetid" Text) where -- API specification type TestApi = - "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,HTML] Greet + "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet :<|> "delete" :> Capture "greetid" Text :> Delete diff --git a/example/greet.hs b/example/greet.hs index 3aca7b24..10019f90 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -6,7 +6,6 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} import Data.Aeson -import Data.Aeson.Encode.Pretty (encodePretty) import Data.Proxy import Data.String.Conversions import Data.Text (Text) @@ -20,16 +19,14 @@ 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 --- | A 'Greet' value can be rendered to 'JSON'. -instance MimeRender JSON Greet where - toByteString Proxy = encodePretty - --- | A 'Greet' value can be rendered to 'HTML'. -instance MimeRender HTML Greet where - toByteString Proxy (Greet s) = "

" <> cs s <> "

" +-- | 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 @@ -76,8 +73,8 @@ intro2 = DocIntro "This title is below the last" -- API specification type TestApi = - -- GET /hello/:name?capital={true, false} returns a Greet as JSON or HTML - "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, HTML] 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 From fc5802fe7fba1b10112b4b34647c0083a28b57de Mon Sep 17 00:00:00 2001 From: Thomas Sutton Date: Mon, 23 Feb 2015 09:38:19 +1100 Subject: [PATCH 14/14] Show, rather than convert, media types --- servant-docs.cabal | 2 +- src/Servant/Docs.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-docs.cabal b/servant-docs.cabal index d45cbbbf..32c18230 100644 --- a/servant-docs.cabal +++ b/servant-docs.cabal @@ -45,5 +45,5 @@ executable greet-docs main-is: greet.hs hs-source-dirs: example ghc-options: -Wall - build-depends: base, aeson, aeson-pretty, servant, servant-docs, string-conversions, text + build-depends: base, aeson, servant, servant-docs, string-conversions, text default-language: Haskell2010 diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index f156f643..6a3e5e59 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -625,7 +625,7 @@ markdown api = unlines $ <> [""] formatBody (m, b) = - "- Example: `" <> cs (M.mainType m <> "/" <> M.subType m) <> "`" : + "- Example: `" <> cs (show m) <> "`" : contentStr m b markdownForType mime_type =