git.iko.soy/typeable/servant
on master help sign in
typeable/servant/servant-docs/test/Servant/DocsSpec.hs
220 lines 7.9 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE OverloadedStrings #-}
10{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE TypeSynonymInstances #-}
12{-# OPTIONS_GHC -fno-warn-orphans #-}
13{-# OPTIONS_GHC -freduction-depth=100 #-}
15module Servant.DocsSpec where
17import Control.Lens
18 ((&), (<>~))
19import Control.Monad
20 (unless)
21import Control.Monad.Trans.Writer
22 (Writer, runWriter, tell)
23import Data.Aeson
24import Data.List
25 (isInfixOf)
26import Data.Proxy
27import Data.String.Conversions
28 (cs)
29import GHC.Generics
30import Prelude ()
31import Prelude.Compat
32import Test.Tasty
33 (TestName, TestTree, testGroup)
34import Test.Tasty.Golden
35 (goldenVsString)
36import Test.Tasty.HUnit
37 (Assertion, HasCallStack, assertFailure, testCase, (@?=))
39import Servant.API
40import Servant.Docs.Internal
41import Servant.Test.ComprehensiveAPI
43-- * comprehensive api
45-- This declaration simply checks that all instances are in place.
46comprehensiveDocs :: API
47comprehensiveDocs = docs comprehensiveAPI
49instance ToParam (QueryParam' mods "foo" Int) where
50 toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" Normal
51instance ToParam (QueryParam' mods "bar" Int) where
52 toParam _ = DocQueryParam "bar" ["1","2","3"] "QueryParams Int" Normal
53instance ToParam (QueryParams "foo" Int) where
54 toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" List
55instance ToParam (QueryFlag "foo") where
56 toParam _ = DocQueryParam "foo" [] "QueryFlag" Flag
57instance ToCapture (Capture "foo" Int) where
58 toCapture _ = DocCapture "foo" "Capture foo Int"
59instance ToCapture (CaptureAll "foo" Int) where
60 toCapture _ = DocCapture "foo" "Capture all foo Int"
61instance ToFragment (Fragment Int) where
62 toFragment _ = DocFragment "foo" "Fragment Int"
64-- * specs
66spec :: TestTree
67spec = describe "Servant.Docs" $ do
68 golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)
70 describe "markdown" $ do
71 let md1 = markdown (docs (Proxy :: Proxy TestApi1))
72 tests1 md1
73 let md2 = markdown (docs (Proxy :: Proxy TestApi2))
74 tests2 md2
76 describe "markdown with extra info" $ do
77 let
78 extra = extraInfo
79 (Proxy :: Proxy (Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)))
80 (defAction & notes <>~ [DocNote "Get an Integer" ["get an integer in Json or plain text"]])
81 <>
82 extraInfo
83 (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))
84 (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])
85 md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))
86 tests1 md
87 it "contains the extra info provided" $ do
88 md `shouldContain` "Get an Integer"
89 md `shouldContain` "Post data"
90 md `shouldContain` "get an integer in Json or plain text"
91 md `shouldContain` "Posts some Json data"
93 describe "tuple samples" $ do
94 it "looks like expected" $ do
95 (toSample (Proxy :: Proxy (TT, UT))) `shouldBe` Just (TT1,UT1)
96 (toSample (Proxy :: Proxy (TT, UT, UT))) `shouldBe` Just (TT1,UT1,UT1)
97 (toSamples (Proxy :: Proxy (TT, UT))) `shouldBe`
98 [ ("eins, yks",(TT1,UT1)), ("eins, kaks",(TT1,UT2))
99 , ("zwei, yks",(TT2,UT1)), ("zwei, kaks",(TT2,UT2))
100 ]
101 (toSamples (Proxy :: Proxy (TT, UT, UT))) `shouldBe`
102 [ ("eins, yks, yks",(TT1,UT1,UT1))
103 , ("eins, yks, kaks",(TT1,UT1,UT2))
104 , ("zwei, yks, yks",(TT2,UT1,UT1))
105 , ("eins, kaks, yks",(TT1,UT2,UT1))
106 , ("zwei, yks, kaks",(TT2,UT1,UT2))
107 , ("eins, kaks, kaks",(TT1,UT2,UT2))
108 , ("zwei, kaks, yks",(TT2,UT2,UT1))
109 , ("zwei, kaks, kaks",(TT2,UT2,UT2))
110 ]
113 where
114 tests1 md = do
115 it "mentions supported content-types" $ do
116 md `shouldContain` "application/json"
117 md `shouldContain` "text/plain;charset=utf-8"
119 it "mentions status codes" $ do
120 md `shouldContain` "Status code 200"
122 it "has methods as section headers" $ do
123 md `shouldContain` "## POST"
124 md `shouldContain` "## GET"
126 it "mentions headers" $ do
127 md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."
129 it "contains response samples - dt1field1" $
130 md `shouldContain` "\"dt1field1\":\"field 1\""
131 it "contains response samples - dt1field2" $
132 md `shouldContain` "\"dt1field2\":13"
133 it "contains request body samples" $
134 md `shouldContain` "17"
136 it "does not generate any docs mentioning the 'empty-api' path" $
137 md `shouldNotContain` "empty-api"
139 tests2 md = do
140 it "mentions the content-types from both copies of the route" $ do
141 md `shouldContain` "application/json"
142 md `shouldContain` "text/plain;charset=utf-8"
145-- * APIs
147data Datatype1 = Datatype1 { dt1field1 :: String
148 , dt1field2 :: Int
149 } deriving (Eq, Show, Generic)
151instance ToJSON Datatype1
153instance ToSample Datatype1 where
154 toSamples _ = singleSample $ Datatype1 "field 1" 13
156instance ToSample Char where
157 toSamples _ = samples ['a'..'z']
159instance ToSample Int where
160 toSamples _ = singleSample 17
162instance MimeRender PlainText Int where
163 mimeRender _ = cs . show
165type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)
166 :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1
167 :<|> Header "X-Test" Int :> Put '[JSON] Int
168 :<|> "empty-api" :> EmptyAPI
170type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1
171 :<|> "duplicate-endpoint" :> Get '[PlainText] Int
174data TT = TT1 | TT2 deriving (Show, Eq)
175data UT = UT1 | UT2 deriving (Show, Eq)
177instance ToSample TT where
178 toSamples _ = [("eins", TT1), ("zwei", TT2)]
180instance ToSample UT where
181 toSamples _ = [("yks", UT1), ("kaks", UT2)]
183-------------------------------------------------------------------------------
184-- HSpec like DSL for tasty
185-------------------------------------------------------------------------------
187newtype TestTreeM a = TestTreeM (Writer [TestTree] a)
188 deriving (Functor, Applicative, Monad)
190runTestTreeM :: TestTreeM () -> [TestTree]
191runTestTreeM (TestTreeM m) = snd (runWriter m)
193class Describe r where
194 describe :: TestName -> TestTreeM () -> r
196instance a ~ () => Describe (TestTreeM a) where
197 describe n t = TestTreeM $ tell [ describe n t ]
199instance Describe TestTree where
200 describe n t = testGroup n $ runTestTreeM t
202it :: TestName -> Assertion -> TestTreeM ()
203it n assertion = TestTreeM $ tell [ testCase n assertion ]
205shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion
206shouldBe = (@?=)
208shouldContain :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> Assertion
209shouldContain = compareWith (flip isInfixOf) "does not contain"
211shouldNotContain :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> Assertion
212shouldNotContain = compareWith (\x y -> not (isInfixOf y x)) "contains"
214compareWith :: (Show a, Show b, HasCallStack) => (a -> b -> Bool) -> String -> a -> b -> Assertion
215compareWith f msg x y = unless (f x y) $ assertFailure $
216 show x ++ " " ++ msg ++ " " ++ show y
218golden :: TestName -> FilePath -> String -> TestTreeM ()
219golden n fp contents = TestTreeM $ tell
220 [ goldenVsString n fp (return (cs contents)) ]