Servant docs curl (#1401)

servant-dosc: generate sample curl request
haskell-servant · Aug 19, 2021 · 47bd252 · 47bd252
1 parent 19ec395
commit 47bd252
Show file tree

Hide file tree

Showing 6 changed files with 109 additions and 23 deletions.
diff --git a/.gitignore b/.gitignore
@@ -30,6 +30,7 @@ doc/_build
 doc/venv
 doc/tutorial/static/api.js
 doc/tutorial/static/jq.js
+shell.nix
 
 # nix
 result*

diff --git a/changelog.d/servant-docs-curl b/changelog.d/servant-docs-curl
@@ -0,0 +1,16 @@
+synopsis: Add sample cURL requests to generated documentation
+prs: #1401
+
+description: {
+
+Add sample cURL requests to generated documentation.
+
+Those supplying changes to the Request `header` field manually using
+lenses will need to add a sample bytestring value.
+
+`headers <>~ ["unicorn"]`
+
+becomes
+
+`headers <>~ [("unicorn", "sample value")]`
+}
diff --git a/servant-docs/example/greet.hs b/servant-docs/example/greet.hs
@@ -75,7 +75,7 @@ intro2 = DocIntro "This title is below the last"
 -- API specification
 type TestApi =
        -- GET /hello/:name?capital={true, false}  returns a Greet as JSON or PlainText
-       "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet
+       "hello" :> Capture "name" Text :> Header "X-Num-Fairies" Int :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet
 
        -- POST /greet with a Greet as JSON in the request body,
        --             returns a Greet as JSON
@@ -93,9 +93,9 @@ testApi = Proxy
 extra :: ExtraInfo TestApi
 extra =
     extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $
-             defAction & headers <>~ ["unicorns"]
+             defAction & headers <>~ [("X-Num-Unicorns", "1")]
                        & notes   <>~ [ DocNote "Title" ["This is some text"]
-                                     , DocNote "Second secton" ["And some more"]
+                                     , DocNote "Second section" ["And some more"]
                                      ]
 
 -- Generate the data that lets us have API docs. This
@@ -109,4 +109,4 @@ docsGreet :: API
 docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi
 
 main :: IO ()
-main = putStrLn $ markdown docsGreet
+main = putStrLn $ markdownWith (defRenderingOptions { _renderCurlBasePath = Just "http://localhost:80" }) docsGreet
diff --git a/servant-docs/example/greet.md b/servant-docs/example/greet.md
@@ -51,6 +51,15 @@ You'll also note that multiple intros are possible.
 "Hello, haskeller"
 ```
 
+### Sample Request:
+
+```bash
+curl -XPOST \
+  -H "Content-Type: application/json;charset=utf-8" \
+  -d "\"HELLO, HASKELLER\"" \
+  http://localhost:80/greet
+```
+
 ## DELETE /greet/:greetid
 
 ### Title
@@ -67,7 +76,7 @@ And some more
 
 ### Headers:
 
-- This endpoint is sensitive to the value of the **unicorns** HTTP header.
+- This endpoint is sensitive to the value of the **X-Num-Unicorns** HTTP header.
 
 ### Response:
 
@@ -85,12 +94,24 @@ And some more
 
 ```
 
+### Sample Request:
+
+```bash
+curl -XDELETE \
+  -H "X-Num-Unicorns: 1" \
+  http://localhost:80/greet/:greetid
+```
+
 ## GET /hello/:name
 
 ### Captures:
 
 - *name*: name of the person to greet
 
+### Headers:
+
+- This endpoint is sensitive to the value of the **X-Num-Fairies** HTTP header.
+
 ### GET Parameters:
 
 - capital
@@ -120,3 +141,13 @@ And some more
 ```javascript
 "Hello, haskeller"
 ```
+
+### Sample Request:
+
+```bash
+curl -XGET \
+  -H "X-Num-Fairies: 1729" \
+  http://localhost:80/hello/:name
+```
+
+
diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs
@@ -25,8 +25,8 @@ import           Control.Applicative
 import           Control.Arrow
                  (second)
 import           Control.Lens
-                 (makeLenses, mapped, over, set, traversed, view, (%~), (&),
-                 (.~), (<>~), (^.), (|>))
+                 (makeLenses, mapped, each, over, set, to, toListOf, traversed, view,
+                 _1, (%~), (&), (.~), (<>~), (^.), (|>))
 import qualified Data.ByteString.Char8      as BSC
 import           Data.ByteString.Lazy.Char8
                  (ByteString)
@@ -59,6 +59,9 @@ import           Data.String.Conversions
 import           Data.Text
                  (Text, unpack)
 import           GHC.Generics
+                 (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,
+                 (:*:)((:*:)), (:+:)(L1, R1))
+import qualified GHC.Generics               as G
 import           GHC.TypeLits
 import           Servant.API
 import           Servant.API.ContentTypes
@@ -295,7 +298,7 @@ defResponse = Response
 data Action = Action
   { _authInfo :: [DocAuthentication]         -- user supplied info
   , _captures :: [DocCapture]                -- type collected + user supplied info
-  , _headers  :: [Text]                      -- type collected
+  , _headers  :: [HTTP.Header]               -- type collected
   , _params   :: [DocQueryParam]             -- type collected + user supplied info
   , _fragment :: Maybe DocFragment           -- type collected + user supplied info
   , _notes    :: [DocNote]                   -- user supplied
@@ -356,12 +359,14 @@ data ShowContentTypes = AllContentTypes  -- ^ For each example, show each conten
 --
 --   @since 0.11.1
 data RenderingOptions = RenderingOptions
-  { _requestExamples  :: !ShowContentTypes
+  { _requestExamples    :: !ShowContentTypes
     -- ^ How many content types to display for request body examples?
-  , _responseExamples :: !ShowContentTypes
+  , _responseExamples   :: !ShowContentTypes
     -- ^ How many content types to display for response body examples?
-  , _notesHeading     :: !(Maybe String)
+  , _notesHeading       :: !(Maybe String)
     -- ^ Optionally group all 'notes' together under a common heading.
+  , _renderCurlBasePath :: !(Maybe String)
+    -- ^ Optionally render example curl requests under a common base path (e.g. `http://localhost:80`).
   } deriving (Show)
 
 -- | Default API generation options.
@@ -373,9 +378,10 @@ data RenderingOptions = RenderingOptions
 --   @since 0.11.1
 defRenderingOptions :: RenderingOptions
 defRenderingOptions = RenderingOptions
-  { _requestExamples  = AllContentTypes
-  , _responseExamples = AllContentTypes
-  , _notesHeading     = Nothing
+  { _requestExamples    = AllContentTypes
+  , _responseExamples   = AllContentTypes
+  , _notesHeading       = Nothing
+  , _renderCurlBasePath = Nothing
   }
 
 -- gimme some lenses
@@ -412,7 +418,7 @@ docsWithOptions p = docsFor p (defEndpoint, defAction)
 -- > extra :: ExtraInfo TestApi
 -- > extra =
 -- >     extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
--- >              defAction & headers <>~ ["unicorns"]
+-- >              defAction & headers <>~ [("X-Num-Unicorns", 1)]
 -- >                        & notes   <>~ [ DocNote "Title" ["This is some text"]
 -- >                                      , DocNote "Second section" ["And some more"]
 -- >                                      ]
@@ -507,7 +513,7 @@ samples = map ("",)
 
 -- | Default sample Generic-based inputs/outputs.
 defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
-defaultSamples _ = second to <$> gtoSamples (Proxy :: Proxy (Rep a))
+defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a))
 
 -- | @'ToSample'@ for Generics.
 --
@@ -643,7 +649,7 @@ markdown = markdownWith defRenderingOptions
 --
 --   @since 0.11.1
 markdownWith :: RenderingOptions -> API -> String
-markdownWith RenderingOptions{..}  api = unlines $
+markdownWith RenderingOptions{..} api = unlines $
        introsStr (api ^. apiIntros)
     ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
 
@@ -654,11 +660,12 @@ markdownWith RenderingOptions{..}  api = unlines $
           notesStr (action ^. notes) ++
           authStr (action ^. authInfo) ++
           capturesStr (action ^. captures) ++
-          headersStr (action ^. headers) ++
+          headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) ++
           paramsStr meth (action ^. params) ++
           fragmentStr (action ^. fragment) ++
           rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
           responseStr (action ^. response) ++
+          maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath ++
           []
 
           where str = "## " ++ BSC.unpack meth
@@ -814,7 +821,6 @@ markdownWith RenderingOptions{..}  api = unlines $
                 ("text", "css") -> "css"
                 (_, _) -> ""
 
-
         contentStr mime_type body =
           "" :
           "```" <> markdownForType mime_type :
@@ -839,6 +845,36 @@ markdownWith RenderingOptions{..}  api = unlines $
                   xs        ->
                     formatBodies _responseExamples xs
 
+        curlStr :: Endpoint -> [HTTP.Header] -> [(Text, M.MediaType, ByteString)] -> String -> [String]
+        curlStr endpoint hdrs reqBodies basePath =
+          [  "### Sample Request:"
+          , ""
+          , "```bash"
+          , "curl -X" ++ BSC.unpack (endpoint ^. method) ++ " \\"
+          ] <>
+          maybe [] pure mbMediaTypeStr <>
+          headersStrs <>
+          maybe [] pure mbReqBodyStr <>
+          [  "  " ++ basePath ++ showPath (endpoint ^. path)
+          , "```"
+          , ""
+          ]
+
+          where escapeQuotes :: String -> String
+                escapeQuotes = concatMap $ \c -> case c of
+                  '\"' -> "\\\""
+                  _ -> [c]
+                mbReqBody = listToMaybe reqBodies
+                mbMediaTypeStr = mkMediaTypeStr <$> mbReqBody
+                headersStrs = mkHeaderStr <$> hdrs
+                mbReqBodyStr = mkReqBodyStr <$> mbReqBody
+                mkMediaTypeStr (_, media_type, _) =
+                  "  -H \"Content-Type: " ++ show media_type ++ "\" \\"
+                mkHeaderStr (hdrName, hdrVal) =
+                  "  -H \"" ++ escapeQuotes (cs (CI.original hdrName)) ++ ": " ++
+                  escapeQuotes (cs hdrVal) ++ "\" \\"
+                mkReqBodyStr (_, _, body) = "  -d \"" ++ escapeQuotes (cs body) ++ "\" \\"
+
 -- * Instances
 
 -- | The generated docs for @a ':<|>' b@ just appends the docs
@@ -977,14 +1013,17 @@ instance {-# OVERLAPPING #-}
           status = fromInteger $ natVal (Proxy :: Proxy status)
           p = Proxy :: Proxy a
 
-instance (KnownSymbol sym, HasDocs api)
+instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)
       => HasDocs (Header' mods sym a :> api) where
   docsFor Proxy (endpoint, action) =
     docsFor subApiP (endpoint, action')
 
     where subApiP = Proxy :: Proxy api
-          action' = over headers (|> headername) action
-          headername = T.pack $ symbolVal (Proxy :: Proxy sym)
+          action' = over headers (|> (headerName, headerVal)) action
+          headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy sym)
+          headerVal = case toSample (Proxy :: Proxy a) of
+            Just x -> cs $ toHeader x
+            Nothing -> "<no header sample provided>"
 
 instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
       => HasDocs (QueryParam' mods sym a :> api) where

diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs
@@ -130,7 +130,6 @@ spec = describe "Servant.Docs" $ do
       md `shouldContain` "\"dt1field1\":\"field 1\""
     it "contains response samples - dt1field2" $
       md `shouldContain` "\"dt1field2\":13"
-
     it "contains request body samples" $
       md `shouldContain` "17"