diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,15 @@ -0.4.3 ------ -* docsWith will no longer eat your documentation (https://github.com/haskell-servant/servant/pull/124) +0.5 +---- + +* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators +* Support maximum samples setting with new `DocOptions` type (used by `docsWithOptions` and `docsWith`) +* Remove redundant second parameter of ToSample +* Add Generic-based default implementation for `ToSample` class +* Add more `ToSamples` instances: `Bool`, `Ordering`, tuples (up to 7), `[]`, `Maybe`, `Either`, `Const`, `ZipList` and some monoids +* Move `toSample` out of `ToSample` class +* Add a few helper functions to define `toSamples` +* Remove matrix params. +* Added support for Basic authentication 0.4 --- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ ## Example -See [here](https://github.com/haskell-servant/servant/tree/master/servant-docs/blob/master/example/greet.md) for the output of the following program. +See [here](https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.md) for the output of the following program. ``` haskell {-# LANGUAGE DataKinds #-} diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/example/greet.hs b/example/greet.hs --- a/example/greet.hs +++ b/example/greet.hs @@ -46,26 +46,14 @@ \Default is false." Normal -instance ToParam (MatrixParam "lang" String) where - toParam _ = - DocQueryParam "lang" - ["en", "sv", "fr"] - "Get the greeting message selected language. Default is en." - Normal - -instance ToSample () () where - toSample _ = Just () - -instance ToSample Greet Greet where - toSample _ = Just $ Greet "Hello, haskeller!" - +instance ToSample Greet where 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 +instance ToSample Int where + toSamples _ = singleSample 1729 -- We define some introductory sections, these will appear at the top of the -- documentation. @@ -86,7 +74,7 @@ -- API specification type TestApi = -- 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 + "hello" :> 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 @@ -117,7 +105,7 @@ -- -- > docs testAPI :: API docsGreet :: API -docsGreet = docsWith [intro1, intro2] extra testApi +docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi main :: IO () main = putStrLn $ markdown docsGreet diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h new file mode 100644 --- /dev/null +++ b/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-docs.cabal b/servant-docs.cabal --- a/servant-docs.cabal +++ b/servant-docs.cabal @@ -1,5 +1,5 @@ name: servant-docs -version: 0.4.4.7 +version: 0.5 synopsis: generate API docs for your servant webservice description: Library for generating API docs from a servant API definition. @@ -9,9 +9,9 @@ license: BSD3 license-file: LICENSE -author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni -maintainer: alpmestan@gmail.com -copyright: 2014-2015 Zalora South East Asia Pte Ltd +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple cabal-version: >=1.10 @@ -19,6 +19,7 @@ homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: + include/*.h CHANGELOG.md README.md source-repository head @@ -29,8 +30,11 @@ exposed-modules: Servant.Docs , Servant.Docs.Internal + , Servant.Docs.Internal.Pretty build-depends: base >=4.7 && <5 + , aeson + , aeson-pretty , bytestring , bytestring-conversion , case-insensitive @@ -38,13 +42,15 @@ , http-media >= 0.6 , http-types >= 0.7 , lens - , servant == 0.4.* + , servant == 0.5.* , string-conversions , text , unordered-containers + , control-monad-omega == 0.3.* hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable greet-docs main-is: greet.hs @@ -64,6 +70,7 @@ test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs + other-modules: Servant.DocsSpec hs-source-dirs: test ghc-options: -Wall build-depends: diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -20,142 +20,28 @@ -- 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 is a complete example that you can run to see the markdown pretty --- printer in action: --- --- > {-# 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.String.Conversions --- > import Data.Text (Text) --- > import GHC.Generics --- > import Servant.API --- > import Servant.Docs --- > --- > -- * Example --- > --- > -- | A greet message data type --- > 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. --- > 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." --- > Normal --- > --- > instance ToParam (MatrixParam "lang" String) where --- > toParam _ = --- > DocQueryParam "lang" --- > ["en", "sv", "fr"] --- > "Get the greeting message selected language. Default is en." --- > Normal --- > --- > 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 = --- > -- 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 '[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 = docsWith [intro1, intro2] extra testApi --- > --- > main :: IO () --- > main = putStrLn $ markdown docsGreet +-- See example/greet.hs for an example. module Servant.Docs ( -- * 'HasDocs' class and key functions - HasDocs(..), docs, markdown + HasDocs(..), docs, pretty, markdown -- * Generating docs with extra information - , ExtraInfo(..), docsWith, docsWithIntros, extraInfo + , docsWith, docsWithIntros, docsWithOptions + , ExtraInfo(..), extraInfo + , DocOptions(..) , defaultDocOptions, maxSamples , -- * Classes you need to implement for your types ToSample(..) + , toSample + , noSamples + , singleSample + , samples , sampleByteString , sampleByteStrings , ToParam(..) , ToCapture(..) , -- * ADTs to represent an 'API' - Method(..) - , Endpoint, path, method, defEndpoint + Endpoint, path, method, defEndpoint , API, apiIntros, apiEndpoints, emptyAPI , DocCapture(..), capSymbol, capDesc , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind @@ -167,3 +53,4 @@ ) where import Servant.Docs.Internal +import Servant.Docs.Internal.Pretty diff --git a/src/Servant/Docs/Internal.hs b/src/Servant/Docs/Internal.hs --- a/src/Servant/Docs/Internal.hs +++ b/src/Servant/Docs/Internal.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -8,25 +9,25 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" module Servant.Docs.Internal where -#if !MIN_VERSION_base(4,8,0) import Control.Applicative -#endif -import Control.Lens (makeLenses, over, traversed, (%~), - (&), (.~), (<>~), (^.), _1, _2, - _last, (|>)) +import Control.Arrow (second) +import Control.Lens (makeLenses, mapped, over, traversed, view, (%~), + (&), (.~), (<>~), (^.), (|>)) +import qualified Control.Monad.Omega as Omega import Data.ByteString.Conversion (ToByteString, toByteString) import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BSC import qualified Data.CaseInsensitive as CI import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) @@ -36,7 +37,7 @@ import Data.Ord (comparing) import Data.Proxy (Proxy(Proxy)) import Data.String.Conversions (cs) -import Data.Text (Text, pack, unpack) +import Data.Text (Text, unpack) import GHC.Exts (Constraint) import GHC.Generics import GHC.TypeLits @@ -49,21 +50,6 @@ 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' @@ -75,12 +61,12 @@ -- GET / -- λ> 'defEndpoint' & 'path' '<>~' ["foo"] -- GET /foo --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST' +-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost' -- POST /foo -- @ data Endpoint = Endpoint - { _path :: [String] -- type collected - , _method :: Method -- type collected + { _path :: [String] -- type collected + , _method :: HTTP.Method -- type collected } deriving (Eq, Ord, Generic) instance Show Endpoint where @@ -94,7 +80,7 @@ showPath [] = "/" showPath ps = concatMap ('/' :) ps --- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET' +-- | An 'Endpoint' whose path is `"/"` and whose method is @GET@ -- -- Here's how you can modify it: -- @@ -103,11 +89,11 @@ -- GET / -- λ> 'defEndpoint' & 'path' '<>~' ["foo"] -- GET /foo --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST' +-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost' -- POST /foo -- @ defEndpoint :: Endpoint -defEndpoint = Endpoint [] DocGET +defEndpoint = Endpoint [] HTTP.methodGet instance Hashable Endpoint @@ -154,6 +140,12 @@ , _introBody :: [String] -- ^ Each String is a paragraph. } deriving (Eq, Show) +-- | A type to represent Authentication information about an endpoint. +data DocAuthentication = DocAuthentication + { _authIntro :: String + , _authDataRequired :: String + } deriving (Eq, Ord, Show) + instance Ord DocIntro where compare = comparing _introTitle @@ -177,6 +169,16 @@ ExtraInfo a `mappend` ExtraInfo b = ExtraInfo $ HM.unionWith combineAction a b +-- | Documentation options. +data DocOptions = DocOptions + { _maxSamples :: Int -- ^ Maximum samples allowed. + } deriving (Show) + +-- | Default documentation options. +defaultDocOptions :: DocOptions +defaultDocOptions = DocOptions + { _maxSamples = 5 } + -- | Type of GET parameter: -- -- - Normal corresponds to @QueryParam@, i.e your usual GET parameter @@ -234,7 +236,8 @@ -- 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 + { _authInfo :: [DocAuthentication] -- user supplied info + , _captures :: [DocCapture] -- type collected + user supplied info , _headers :: [Text] -- type collected , _params :: [DocQueryParam] -- type collected + user supplied info , _notes :: [DocNote] -- user supplied @@ -251,8 +254,8 @@ -- '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 +Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ = + Action (a <> a') (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'. @@ -272,6 +275,7 @@ [] [] [] + [] defResponse -- | Create an API that's comprised of a single endpoint. @@ -281,6 +285,8 @@ single e a = API mempty (HM.singleton e a) -- gimme some lenses +makeLenses ''DocAuthentication +makeLenses ''DocOptions makeLenses ''API makeLenses ''Endpoint makeLenses ''DocCapture @@ -292,9 +298,15 @@ -- | Generate the docs for a given API that implements 'HasDocs'. This is the -- default way to create documentation. +-- +-- prop> docs == docsWithOptions defaultDocOptions docs :: HasDocs layout => Proxy layout -> API -docs p = docsFor p (defEndpoint, defAction) +docs p = docsWithOptions p defaultDocOptions +-- | Generate the docs for a given API that implements 'HasDocs'. +docsWithOptions :: HasDocs layout => Proxy layout -> DocOptions -> API +docsWithOptions 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 @@ -320,7 +332,7 @@ extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint) => Proxy endpoint -> Action -> ExtraInfo layout extraInfo p action = - let api = docsFor p (defEndpoint, defAction) + let api = docsFor p (defEndpoint, defAction) defaultDocOptions -- Assume one endpoint, HasLink constraint means that we should only ever -- point at one endpoint. in ExtraInfo $ api ^. apiEndpoints & traversed .~ action @@ -337,21 +349,22 @@ -- '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 (flip combineAction) endpoints +docsWith :: HasDocs layout => DocOptions -> [DocIntro] -> ExtraInfo layout -> Proxy layout -> API +docsWith opts intros (ExtraInfo endpoints) p = + docsWithOptions p opts + & apiIntros <>~ intros + & apiEndpoints %~ HM.unionWith (flip 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 +docsWithIntros intros = docsWith defaultDocOptions 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 + docsFor :: Proxy layout -> (Endpoint, Action) -> DocOptions -> API -- | The class that lets us display a sample input or output in the supported -- content-types when generating documentation for endpoints that either: @@ -374,8 +387,8 @@ -- > instance FromJSON Greet -- > instance ToJSON Greet -- > --- > instance ToSample Greet Greet where --- > toSample _ = Just g +-- > instance ToSample Greet where +-- > toSamples _ = singleSample g -- > -- > where g = Greet "Hello, haskeller!" -- @@ -383,30 +396,74 @@ -- '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) +class ToSample a where + toSamples :: Proxy a -> [(Text, a)] + default toSamples :: (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)] + toSamples = defaultSamples - toSamples :: Proxy a -> [(Text, b)] - toSamples _ = maybe [] (return . ("",)) s - where s = toSample (Proxy :: Proxy a) +-- | Sample input or output (if there is at least one). +toSample :: forall a. ToSample a => Proxy a -> Maybe a +toSample _ = snd <$> listToMaybe (toSamples (Proxy :: Proxy a)) -instance ToSample a b => ToSample (Headers ls a) b where - toSample _ = toSample (Proxy :: Proxy a) - toSamples _ = toSamples (Proxy :: Proxy a) +-- | No samples. +noSamples :: [(Text, a)] +noSamples = empty +-- | Single sample without description. +singleSample :: a -> [(Text, a)] +singleSample x = [("", x)] +-- | Samples without documentation. +samples :: [a] -> [(Text, a)] +samples = map ("",) + +-- | Default sample Generic-based inputs/outputs. +defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)] +defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a)) + +-- | @'ToSample'@ for Generics. +-- +-- The use of @'Omega'@ allows for more productive sample generation. +class GToSample t where + gtoSamples :: proxy t -> Omega.Omega (Text, t x) + +instance GToSample U1 where + gtoSamples _ = Omega.each (singleSample U1) + +instance GToSample V1 where + gtoSamples _ = empty + +instance (GToSample p, GToSample q) => GToSample (p :*: q) where + gtoSamples _ = render <$> ps <*> qs + where + ps = gtoSamples (Proxy :: Proxy p) + qs = gtoSamples (Proxy :: Proxy q) + render (ta, a) (tb, b) + | T.null ta || T.null tb = (ta <> tb, a :*: b) + | otherwise = (ta <> ", " <> tb, a :*: b) + +instance (GToSample p, GToSample q) => GToSample (p :+: q) where + gtoSamples _ = lefts <|> rights + where + lefts = second L1 <$> gtoSamples (Proxy :: Proxy p) + rights = second R1 <$> gtoSamples (Proxy :: Proxy q) + +instance ToSample a => GToSample (K1 i a) where + gtoSamples _ = second K1 <$> Omega.each (toSamples (Proxy :: Proxy a)) + +instance (GToSample f) => GToSample (M1 i a f) where + gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f) + + class AllHeaderSamples ls where allHeaderToSample :: Proxy ls -> [HTTP.Header] instance AllHeaderSamples '[] where allHeaderToSample _ = [] -instance (ToByteString l, AllHeaderSamples ls, ToSample l l, KnownSymbol h) +instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h) => AllHeaderSamples (Header h l ': ls) where - allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) : + 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) @@ -414,8 +471,8 @@ -- | 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 + :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a) + => Proxy (ct ': cts) -> Proxy a -> [(M.MediaType, ByteString)] sampleByteString ctypes@Proxy Proxy = @@ -424,27 +481,14 @@ -- | 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 + :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a) + => Proxy (ct ': cts) -> Proxy a -> [(Text, M.MediaType, ByteString)] sampleByteStrings ctypes@Proxy Proxy = - let samples = toSamples (Proxy :: Proxy a) + 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) + in concatMap enc samples' -- | The class that helps us automatically get documentation -- for GET parameters. @@ -469,6 +513,10 @@ class ToCapture c where toCapture :: Proxy c -> DocCapture +-- | The class that helps us get documentation for authenticated endpoints +class ToAuthInfo a where + toAuthInfo :: Proxy a -> DocAuthentication + -- | Generate documentation in Markdown format for -- the given 'API'. markdown :: API -> String @@ -481,15 +529,15 @@ str : "" : notesStr (action ^. notes) ++ + authStr (action ^. authInfo) ++ 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) + where str = "## " ++ BSC.unpack (endpoint^.method) ++ " " ++ showPath (endpoint^.path) introsStr :: [DocIntro] -> [String] @@ -514,6 +562,20 @@ "" : [] + + authStr :: [DocAuthentication] -> [String] + authStr auths = + let authIntros = mapped %~ view authIntro $ auths + clientInfos = mapped %~ view authDataRequired $ auths + in "#### Authentication": + "": + unlines authIntros : + "": + "Clients must supply the following data" : + unlines clientInfos : + "" : + [] + capturesStr :: [DocCapture] -> [String] capturesStr [] = [] capturesStr l = @@ -526,20 +588,6 @@ 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 ++ [""] @@ -575,10 +623,10 @@ rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String] rqbodyStr [] [] = [] - rqbodyStr types samples = + rqbodyStr types s = ["#### Request:", ""] <> formatTypes types - <> concatMap formatBody samples + <> concatMap formatBody s formatTypes [] = [] formatTypes ts = ["- Supported content types are:", ""] @@ -626,7 +674,8 @@ -- | The generated docs for @a ':<|>' b@ just appends the docs -- for @a@ with the docs for @b@. -instance (HasDocs layout1, HasDocs layout2) +instance OVERLAPPABLE_ + (HasDocs layout1, HasDocs layout2) => HasDocs (layout1 :<|> layout2) where docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action) @@ -653,70 +702,38 @@ 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) = +instance OVERLAPPABLE_ + (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status + , ReflectMethod method) + => HasDocs (Verb method status (ct ': cts) a) where + docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' - where endpoint' = endpoint & method .~ DocGET - action' = action & response.respBody .~ sampleByteStrings t p - & response.respTypes .~ supportedTypes t - t = Proxy :: Proxy cts + where endpoint' = endpoint & method .~ method' + action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) + & response.respTypes .~ allMime t + & response.respStatus .~ status + t = Proxy :: Proxy (ct ': cts) + method' = reflectMethod (Proxy :: Proxy method) + status = fromInteger $ natVal (Proxy :: Proxy status) 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) = +instance OVERLAPPING_ + (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status + , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls)) + => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where + docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocGET - action' = action & response.respBody .~ sampleByteStrings t p - & response.respTypes .~ supportedTypes t + where endpoint' = endpoint & method .~ method' + action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) + & response.respTypes .~ allMime t + & response.respStatus .~ status & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) + hdrs = allHeaderToSample (Proxy :: Proxy ls) + method' = reflectMethod (Proxy :: Proxy method) + status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a instance (KnownSymbol sym, HasDocs sublayout) @@ -726,77 +743,7 @@ 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 + headername = T.pack $ symbolVal (Proxy :: Proxy sym) instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) => HasDocs (QueryParam sym a :> sublayout) where @@ -830,67 +777,24 @@ 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 ++ "=") 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 ++ "="]) 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) = + 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 +instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout) + => HasDocs (ReqBody (ct ': 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 + & rqtypes .~ allMime t + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where @@ -902,3 +806,58 @@ endpoint' = endpoint & path <>~ [symbolVal pa] pa = Proxy :: Proxy path +instance HasDocs sublayout => HasDocs (RemoteHost :> sublayout) where + docsFor Proxy ep = + docsFor (Proxy :: Proxy sublayout) ep + +instance HasDocs sublayout => HasDocs (IsSecure :> sublayout) where + docsFor Proxy ep = + docsFor (Proxy :: Proxy sublayout) ep + +instance HasDocs sublayout => HasDocs (HttpVersion :> sublayout) where + docsFor Proxy ep = + docsFor (Proxy :: Proxy sublayout) ep + +instance HasDocs sublayout => HasDocs (Vault :> sublayout) where + docsFor Proxy ep = + docsFor (Proxy :: Proxy sublayout) ep + +instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where + docsFor Proxy = docsFor (Proxy :: Proxy sublayout) + +instance (ToAuthInfo (BasicAuth realm usr), HasDocs sublayout) => HasDocs (BasicAuth realm usr :> sublayout) where + docsFor Proxy (endpoint, action) = + docsFor (Proxy :: Proxy sublayout) (endpoint, action') + where + authProxy = Proxy :: Proxy (BasicAuth realm usr) + action' = over authInfo (|> toAuthInfo authProxy) action + +-- ToSample instances for simple types +instance ToSample () +instance ToSample Bool +instance ToSample Ordering + +-- polymorphic ToSample instances +instance (ToSample a, ToSample b) => ToSample (a, b) +instance (ToSample a, ToSample b, ToSample c) => ToSample (a, b, c) +instance (ToSample a, ToSample b, ToSample c, ToSample d) => ToSample (a, b, c, d) +instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e) => ToSample (a, b, c, d, e) +instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f) => ToSample (a, b, c, d, e, f) +instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f, ToSample g) => ToSample (a, b, c, d, e, f, g) + +instance ToSample a => ToSample (Maybe a) +instance (ToSample a, ToSample b) => ToSample (Either a b) +instance ToSample a => ToSample [a] + +-- ToSample instances for Control.Applicative types +instance ToSample a => ToSample (Const a b) +instance ToSample a => ToSample (ZipList a) + +-- ToSample instances for Data.Monoid newtypes +instance ToSample All +instance ToSample Any +instance ToSample a => ToSample (Sum a) +instance ToSample a => ToSample (Product a) +instance ToSample a => ToSample (First a) +instance ToSample a => ToSample (Last a) +instance ToSample a => ToSample (Dual a) diff --git a/src/Servant/Docs/Internal/Pretty.hs b/src/Servant/Docs/Internal/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Docs/Internal/Pretty.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +module Servant.Docs.Internal.Pretty where + +import Data.Aeson (ToJSON(..)) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Proxy (Proxy(Proxy)) +import Network.HTTP.Media ((//)) +import Servant.API + +-- | PrettyJSON content type. +data PrettyJSON + +instance Accept PrettyJSON where + contentType _ = "application" // "json" + +instance ToJSON a => MimeRender PrettyJSON a where + mimeRender _ = encodePretty + +-- | Prettify generated JSON documentation. +-- +-- @ +-- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI)) +-- @ +pretty :: Proxy layout -> Proxy (Pretty layout) +pretty Proxy = Proxy + +-- | Replace all JSON content types with PrettyJSON. +-- Kind-polymorphic so it can operate on kinds @*@ and @[*]@. +type family Pretty (layout :: k) :: k where + Pretty (x :<|> y) = Pretty x :<|> Pretty y + Pretty (x :> y) = Pretty x :> Pretty y + Pretty (Get cs r) = Get (Pretty cs) r + Pretty (Post cs r) = Post (Pretty cs) r + Pretty (Put cs r) = Put (Pretty cs) r + Pretty (Delete cs r) = Delete (Pretty cs) r + Pretty (Patch cs r) = Patch (Pretty cs) r + Pretty (ReqBody cs r) = ReqBody (Pretty cs) r + Pretty (JSON ': xs) = PrettyJSON ': xs + Pretty (x ': xs) = x ': Pretty xs + Pretty x = x diff --git a/test/Servant/DocsSpec.hs b/test/Servant/DocsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/DocsSpec.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.DocsSpec where + +import Control.Lens +import Data.Aeson +import Data.Monoid +import Data.Proxy +import Data.String.Conversions (cs) +import GHC.Generics +import Test.Hspec + +import Servant.API +import Servant.API.Internal.Test.ComprehensiveAPI +import Servant.Docs.Internal + +-- * comprehensive api + +-- This declaration simply checks that all instances are in place. +_ = docs comprehensiveAPI + +instance ToParam (QueryParam "foo" Int) where + toParam = error "unused" +instance ToParam (QueryParams "foo" Int) where + toParam = error "unused" +instance ToParam (QueryFlag "foo") where + toParam = error "unused" +instance ToCapture (Capture "foo" Int) where + toCapture = error "unused" + +-- * specs + +spec :: Spec +spec = describe "Servant.Docs" $ do + + describe "markdown" $ do + let md = markdown (docs (Proxy :: Proxy TestApi1)) + tests md + + describe "markdown with extra info" $ do + let + extra = extraInfo + (Proxy :: Proxy (Get '[JSON, PlainText] (Headers '[Header "Location" String] Int))) + (defAction & notes <>~ [DocNote "Get an Integer" ["get an integer in Json or plain text"]]) + <> + extraInfo + (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1)) + (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]]) + md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1)) + tests md + it "contains the extra info provided" $ do + md `shouldContain` "Get an Integer" + md `shouldContain` "Post data" + md `shouldContain` "get an integer in Json or plain text" + md `shouldContain` "Posts some Json data" + + describe "tuple samples" $ do + it "looks like expected" $ do + (toSample (Proxy :: Proxy (TT, UT))) `shouldBe` Just (TT1,UT1) + (toSample (Proxy :: Proxy (TT, UT, UT))) `shouldBe` Just (TT1,UT1,UT1) + (toSamples (Proxy :: Proxy (TT, UT))) `shouldBe` + [ ("eins, yks",(TT1,UT1)), ("eins, kaks",(TT1,UT2)) + , ("zwei, yks",(TT2,UT1)), ("zwei, kaks",(TT2,UT2)) + ] + (toSamples (Proxy :: Proxy (TT, UT, UT))) `shouldBe` + [ ("eins, yks, yks",(TT1,UT1,UT1)) + , ("eins, yks, kaks",(TT1,UT1,UT2)) + , ("zwei, yks, yks",(TT2,UT1,UT1)) + , ("eins, kaks, yks",(TT1,UT2,UT1)) + , ("zwei, yks, kaks",(TT2,UT1,UT2)) + , ("eins, kaks, kaks",(TT1,UT2,UT2)) + , ("zwei, kaks, yks",(TT2,UT2,UT1)) + , ("zwei, kaks, kaks",(TT2,UT2,UT2)) + ] + + + where + tests md = do + it "mentions supported content-types" $ do + md `shouldContain` "application/json" + md `shouldContain` "text/plain;charset=utf-8" + + it "mentions status codes" $ do + md `shouldContain` "Status code 200" + + it "has methods as section headers" $ do + md `shouldContain` "## POST" + md `shouldContain` "## GET" + + it "mentions headers" $ do + md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header." + + it "contains response samples" $ + md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}" + it "contains request body samples" $ + md `shouldContain` "17" + + +-- * APIs + +data Datatype1 = Datatype1 { dt1field1 :: String + , dt1field2 :: Int + } deriving (Eq, Show, Generic) + +instance ToJSON Datatype1 + +instance ToSample Datatype1 where + toSamples _ = singleSample $ Datatype1 "field 1" 13 + +instance ToSample Char where + toSamples _ = samples ['a'..'z'] + +instance ToSample Int where + toSamples _ = singleSample 17 + +instance MimeRender PlainText Int where + mimeRender _ = cs . show + +type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) + :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1 + :<|> Header "X-Test" Int :> Put '[JSON] Int + +data TT = TT1 | TT2 deriving (Show, Eq) +data UT = UT1 | UT2 deriving (Show, Eq) + +instance ToSample TT where + toSamples _ = [("eins", TT1), ("zwei", TT2)] + +instance ToSample UT where + toSamples _ = [("yks", UT1), ("kaks", UT2)]