From f7bda98b6ad606012e9899b78cab0179dbf6c855 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 8 Nov 2018 15:35:48 +0200 Subject: [PATCH 1/3] Use tasty for servant-docs tests --- servant-docs/servant-docs.cabal | 8 +-- servant-docs/test/Servant/DocsSpec.hs | 71 ++++++++++++++++++++++----- servant-docs/test/Spec.hs | 9 +++- 3 files changed, 73 insertions(+), 15 deletions(-) diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 0b27dc96..66fed9cc 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -93,6 +93,7 @@ test-suite spec -- Dependencies inherited from the library. No need to specify bounds. build-depends: base + , base-compat , aeson , lens , servant @@ -101,7 +102,8 @@ test-suite spec -- Additonal dependencies build-depends: - hspec >= 2.4.4 && < 2.6 + tasty >= 1.1.0.4 && < 1.2, + tasty-golden >= 2.3.2 && < 2.4, + tasty-hunit >= 0.10.0.1 && < 0.11, + transformers >= 0.5.2.0 && < 0.6 - build-tool-depends: - hspec-discover:hspec-discover >=2.4.4 && <2.6 diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 5e5bb449..5a890926 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -1,28 +1,42 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -freduction-depth=100 #-} module Servant.DocsSpec where import Control.Lens +import Control.Monad + (unless) +import Control.Monad.Trans.Writer + (Writer, runWriter, tell) import Data.Aeson +import Data.List + (isInfixOf) import Data.Monoid import Data.Proxy import Data.String.Conversions (cs) import GHC.Generics -import Test.Hspec +import Prelude () +import Prelude.Compat +import Test.Tasty + (TestName, TestTree, testGroup) +import Test.Tasty.HUnit + (Assertion, HasCallStack, assertFailure, testCase, (@?=)) import Servant.API -import Servant.Test.ComprehensiveAPI import Servant.Docs.Internal +import Servant.Test.ComprehensiveAPI -- * comprehensive api @@ -44,7 +58,7 @@ instance ToCapture (CaptureAll "foo" Int) where -- * specs -spec :: Spec +spec :: TestTree spec = describe "Servant.Docs" $ do describe "markdown" $ do @@ -146,3 +160,38 @@ instance ToSample TT where instance ToSample UT where toSamples _ = [("yks", UT1), ("kaks", UT2)] + +------------------------------------------------------------------------------- +-- HSpec like DSL for tasty +------------------------------------------------------------------------------- + +newtype TestTreeM a = TestTreeM (Writer [TestTree] a) + deriving (Functor, Applicative, Monad) + +runTestTreeM :: TestTreeM () -> [TestTree] +runTestTreeM (TestTreeM m) = snd (runWriter m) + +class Describe r where + describe :: TestName -> TestTreeM () -> r + +instance a ~ () => Describe (TestTreeM a) where + describe n t = TestTreeM $ tell [ describe n t ] + +instance Describe TestTree where + describe n t = testGroup n $ runTestTreeM t + +it :: TestName -> Assertion -> TestTreeM () +it n assertion = TestTreeM $ tell [ testCase n assertion ] + +shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion +shouldBe = (@?=) + +shouldContain :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> Assertion +shouldContain = compareWith (flip isInfixOf) "does not contain" + +shouldNotContain :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> Assertion +shouldNotContain = compareWith (\x y -> not (isInfixOf y x)) "contains" + +compareWith :: (Show a, Show b, HasCallStack) => (a -> b -> Bool) -> String -> a -> b -> Assertion +compareWith f msg x y = unless (f x y) $ assertFailure $ + show x ++ " " ++ msg ++ " " ++ show y diff --git a/servant-docs/test/Spec.hs b/servant-docs/test/Spec.hs index a824f8c3..a433410b 100644 --- a/servant-docs/test/Spec.hs +++ b/servant-docs/test/Spec.hs @@ -1 +1,8 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +module Main (main) where + +import Test.Tasty + (defaultMain) +import qualified Servant.DocsSpec + +main :: IO () +main = defaultMain Servant.DocsSpec.spec From 7bed805cf78edb44600a82bf2ca8a819fceac968 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 8 Nov 2018 15:57:04 +0200 Subject: [PATCH 2/3] Golden test for comprehensive API docs --- servant-docs/golden/comprehensive.md | 521 +++++++++++++++++++ servant-docs/servant-docs.cabal | 2 + servant-docs/src/Servant/Docs/Internal.hs | 16 +- servant-docs/test/Servant/DocsSpec.hs | 24 +- servant/src/Servant/Test/ComprehensiveAPI.hs | 50 +- 5 files changed, 577 insertions(+), 36 deletions(-) create mode 100644 servant-docs/golden/comprehensive.md diff --git a/servant-docs/golden/comprehensive.md b/servant-docs/golden/comprehensive.md new file mode 100644 index 00000000..7210143f --- /dev/null +++ b/servant-docs/golden/comprehensive.md @@ -0,0 +1,521 @@ +## GET / + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /capture/:foo + +### Captures: + +- *foo*: Capture foo Int + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /capture-all/:foo + +### Captures: + +- *foo*: Capture all foo Int + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /description + +### foo + + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /flag + +### GET Parameters: + +- foo + - **Description**: QueryFlag + - This parameter is a **flag**. This means no value is expected to be associated to this parameter. + + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /foo + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /get-int + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript +17 +``` + +## GET /header + +### Headers: + +- This endpoint is sensitive to the value of the **foo** HTTP header. + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /header-lenient + +### Headers: + +- This endpoint is sensitive to the value of the **bar** HTTP header. + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /http-version + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /is-secure + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /named-context + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /param + +### GET Parameters: + +- foo + - **Values**: *1, 2, 3* + - **Description**: QueryParams Int + + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /param-lenient + +### GET Parameters: + +- bar + - **Values**: *1, 2, 3* + - **Description**: QueryParams Int + + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /params + +### GET Parameters: + +- foo + - **Values**: *1, 2, 3* + - **Description**: QueryParams Int + - This parameter is a **list**. All GET parameters with the name foo[] will forward their values in a list to the handler. + + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## POST /post-int + +### Response: + +- Status code 204 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript +17 +``` + +## POST /post-no-content + +### Response: + +- Status code 204 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /raw + +### Response: + +- Status code 200 +- Headers: [] + +- No response body + +## GET /remote-host + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /req-body + +### Request: + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript +17 +``` + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /req-body-lenient + +### Request: + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript +17 +``` + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /res-headers + +### Response: + +- Status code 200 +- Headers: [("foo","17")] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /streaming + +### Request: + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- No response body + +## GET /summary + +### foo + + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /vault + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 66fed9cc..a40c635f 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -26,6 +26,8 @@ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: CHANGELOG.md README.md + golden/comprehensive.md + source-repository head type: git location: http://github.com/haskell-servant/servant.git diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 63b2bb61..ae74d42f 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -32,6 +32,8 @@ import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.CaseInsensitive as CI +import Data.Foldable + (toList) import Data.Foldable (fold) import Data.Hashable @@ -958,7 +960,6 @@ instance (KnownSymbol desc, HasDocs api) -- both are even defined) for any particular type. instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api) => HasDocs (ReqBody' mods (ct ': cts) a :> api) where - docsFor Proxy (endpoint, action) opts@DocOptions{..} = docsFor subApiP (endpoint, action') opts @@ -969,8 +970,17 @@ instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api) t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a -instance HasDocs api => HasDocs (StreamBody framing ctype a :> api) where - docsFor Proxy _ _ = error "HasDocs @StreamBody" +-- | TODO: this instance is incomplete. +instance (HasDocs api, Accept ctype) => HasDocs (StreamBody framing ctype a :> api) where + docsFor Proxy (endpoint, action) opts = + docsFor subApiP (endpoint, action') opts + where + subApiP = Proxy :: Proxy api + + action' :: Action + action' = action & rqtypes .~ toList (contentTypes t) + + t = Proxy :: Proxy ctype instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 5a890926..bda291a6 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -15,6 +15,7 @@ module Servant.DocsSpec where import Control.Lens + ((&), (<>~)) import Control.Monad (unless) import Control.Monad.Trans.Writer @@ -22,7 +23,6 @@ import Control.Monad.Trans.Writer import Data.Aeson import Data.List (isInfixOf) -import Data.Monoid import Data.Proxy import Data.String.Conversions (cs) @@ -31,6 +31,8 @@ import Prelude () import Prelude.Compat import Test.Tasty (TestName, TestTree, testGroup) +import Test.Tasty.Golden + (goldenVsString) import Test.Tasty.HUnit (Assertion, HasCallStack, assertFailure, testCase, (@?=)) @@ -41,25 +43,27 @@ import Servant.Test.ComprehensiveAPI -- * comprehensive api -- This declaration simply checks that all instances are in place. -_ = docs comprehensiveAPI +comprehensiveDocs :: API +comprehensiveDocs = docs comprehensiveAPI instance ToParam (QueryParam' mods "foo" Int) where - toParam = error "unused" + toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" Normal instance ToParam (QueryParam' mods "bar" Int) where - toParam = error "unused" + toParam _ = DocQueryParam "bar" ["1","2","3"] "QueryParams Int" Normal instance ToParam (QueryParams "foo" Int) where - toParam = error "unused" + toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" List instance ToParam (QueryFlag "foo") where - toParam = error "unused" + toParam _ = DocQueryParam "foo" [] "QueryFlag" Flag instance ToCapture (Capture "foo" Int) where - toCapture = error "unused" + toCapture _ = DocCapture "foo" "Capture foo Int" instance ToCapture (CaptureAll "foo" Int) where - toCapture = error "unused" + toCapture _ = DocCapture "foo" "Capture all foo Int" -- * specs spec :: TestTree spec = describe "Servant.Docs" $ do + golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs) describe "markdown" $ do let md = markdown (docs (Proxy :: Proxy TestApi1)) @@ -195,3 +199,7 @@ shouldNotContain = compareWith (\x y -> not (isInfixOf y x)) "contains" compareWith :: (Show a, Show b, HasCallStack) => (a -> b -> Bool) -> String -> a -> b -> Assertion compareWith f msg x y = unless (f x y) $ assertFailure $ show x ++ " " ++ msg ++ " " ++ show y + +golden :: TestName -> FilePath -> String -> TestTreeM () +golden n fp contents = TestTreeM $ tell + [ goldenVsString n fp (return (cs contents)) ] diff --git a/servant/src/Servant/Test/ComprehensiveAPI.hs b/servant/src/Servant/Test/ComprehensiveAPI.hs index 768c517e..c300465d 100644 --- a/servant/src/Servant/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/Test/ComprehensiveAPI.hs @@ -16,37 +16,37 @@ type GET = Get '[JSON] NoContent type ComprehensiveAPI = ComprehensiveAPIWithoutRaw :<|> - Raw + "raw" :> Raw comprehensiveAPI :: Proxy ComprehensiveAPI comprehensiveAPI = Proxy type ComprehensiveAPIWithoutRaw = GET :<|> - Get '[JSON] Int :<|> - Capture' '[Description "example description"] "foo" Int :> GET :<|> - Header "foo" Int :> GET :<|> - Header' '[Required, Lenient] "bar" Int :> GET :<|> - HttpVersion :> GET :<|> - IsSecure :> GET :<|> - QueryParam "foo" Int :> GET :<|> - QueryParam' '[Required, Lenient] "bar" Int :> GET :<|> - QueryParams "foo" Int :> GET :<|> - QueryFlag "foo" :> GET :<|> - RemoteHost :> GET :<|> - ReqBody '[JSON] Int :> GET :<|> - ReqBody' '[Lenient] '[JSON] Int :> GET :<|> - Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|> - "foo" :> GET :<|> - Vault :> GET :<|> - Verb 'POST 204 '[JSON] NoContent :<|> - Verb 'POST 204 '[JSON] Int :<|> - StreamBody NetstringFraming JSON (SourceT IO Int) :> Stream 'GET 200 NetstringFraming JSON (SourceT IO Int) :<|> - WithNamedContext "foo" '[] GET :<|> - CaptureAll "foo" Int :> GET :<|> - Summary "foo" :> GET :<|> - Description "foo" :> GET :<|> - EmptyAPI + "get-int" :> Get '[JSON] Int :<|> + "capture" :> Capture' '[Description "example description"] "foo" Int :> GET :<|> + "header" :> Header "foo" Int :> GET :<|> + "header-lenient" :> Header' '[Required, Lenient] "bar" Int :> GET :<|> + "http-version" :> HttpVersion :> GET :<|> + "is-secure" :> IsSecure :> GET :<|> + "param" :> QueryParam "foo" Int :> GET :<|> + "param-lenient" :> QueryParam' '[Required, Lenient] "bar" Int :> GET :<|> + "params" :> QueryParams "foo" Int :> GET :<|> + "flag" :> QueryFlag "foo" :> GET :<|> + "remote-host" :> RemoteHost :> GET :<|> + "req-body" :> ReqBody '[JSON] Int :> GET :<|> + "req-body-lenient" :> ReqBody' '[Lenient] '[JSON] Int :> GET :<|> + "res-headers" :> Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|> + "foo" :> GET :<|> + "vault" :> Vault :> GET :<|> + "post-no-content" :> Verb 'POST 204 '[JSON] NoContent :<|> + "post-int" :> Verb 'POST 204 '[JSON] Int :<|> + "streaming" :> StreamBody NetstringFraming JSON (SourceT IO Int) :> Stream 'GET 200 NetstringFraming JSON (SourceT IO Int) :<|> + "named-context" :> WithNamedContext "foo" '[] GET :<|> + "capture-all" :> CaptureAll "foo" Int :> GET :<|> + "summary" :> Summary "foo" :> GET :<|> + "description" :> Description "foo" :> GET :<|> + "empty-api" :> EmptyAPI comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw comprehensiveAPIWithoutRaw = Proxy From 953747b55ba6f6531ba5d761c285ae20ab3592b5 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 8 Nov 2018 17:12:20 +0200 Subject: [PATCH 3/3] Correct some doctest looking things to be doctests --- servant-docs/src/Servant/Docs/Internal.hs | 74 +++++++++++++---------- 1 file changed, 43 insertions(+), 31 deletions(-) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index ae74d42f..6c96292b 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -76,14 +76,15 @@ import qualified Network.HTTP.Types as HTTP -- or any 'Endpoint' value you want using the 'path' and 'method' -- lenses to tweak. -- --- @ --- λ> 'defEndpoint' --- GET / --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] --- GET /foo --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost' --- POST /foo --- @ +-- >>> defEndpoint +-- "GET" / +-- +-- >>> defEndpoint & path <>~ ["foo"] +-- "GET" /foo +-- +-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost +-- "POST" /foo +-- data Endpoint = Endpoint { _path :: [String] -- type collected , _method :: HTTP.Method -- type collected @@ -104,14 +105,15 @@ showPath ps = concatMap ('/' :) ps -- -- Here's how you can modify it: -- --- @ --- λ> 'defEndpoint' --- GET / --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] --- GET /foo --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost' --- POST /foo --- @ +-- >>> defEndpoint +-- "GET" / +-- +-- >>> defEndpoint & path <>~ ["foo"] +-- "GET" /foo +-- +-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost +-- "POST" /foo +-- defEndpoint :: Endpoint defEndpoint = Endpoint [] HTTP.methodGet @@ -222,12 +224,14 @@ data ParamKind = Normal | List | Flag -- want to write a 'ToSample' instance for the type that'll be represented -- as encoded data in the response. -- --- Can be tweaked with three lenses. +-- Can be tweaked with four lenses. +-- +-- >>> defResponse +-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []} +-- +-- >>> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "application/json", "{ \"status\": \"ok\" }")] +-- Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well",application/json,"{ \"status\": \"ok\" }")], _respHeaders = []} -- --- > λ> defResponse --- > Response {_respStatus = 200, _respTypes = [], _respBody = []} --- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")] --- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]} data Response = Response { _respStatus :: Int , _respTypes :: [M.MediaType] @@ -237,12 +241,14 @@ data Response = Response -- | Default response: status code 200, no response body. -- --- Can be tweaked with two lenses. +-- Can be tweaked with four lenses. +-- +-- >>> defResponse +-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []} +-- +-- >>> defResponse & respStatus .~ 204 +-- Response {_respStatus = 204, _respTypes = [], _respBody = [], _respHeaders = []} -- --- > λ> defResponse --- > Response {_respStatus = 200, _respBody = Nothing} --- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]" --- > Response {_respStatus = 204, _respBody = Just "[]"} defResponse :: Response defResponse = Response { _respStatus = 200 @@ -288,10 +294,12 @@ Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ = -- -- Tweakable with lenses. -- --- > λ> defAction --- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}} --- > λ> defAction & response.respStatus .~ 201 --- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}} +-- >>> defAction +-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}} +-- +-- >>> defAction & response.respStatus .~ 201 +-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}} +-- defAction :: Action defAction = Action [] @@ -359,7 +367,8 @@ makeLenses ''RenderingOptions -- | Generate the docs for a given API that implements 'HasDocs'. This is the -- default way to create documentation. -- --- prop> docs == docsWithOptions defaultDocOptions +-- > docs == docsWithOptions defaultDocOptions +-- docs :: HasDocs api => Proxy api -> API docs p = docsWithOptions p defaultDocOptions @@ -1046,3 +1055,6 @@ instance ToSample a => ToSample (Product a) instance ToSample a => ToSample (First a) instance ToSample a => ToSample (Last a) instance ToSample a => ToSample (Dual a) + +-- $setup +-- >>> :set -XOverloadedStrings