From 7fa44d3769059769b34d79cb34c65ecae521f834 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Thu, 27 Nov 2014 18:28:01 +0100 Subject: [PATCH] first shot at splitting servant into servant, servant-client and servant-docs --- example/greet.hs | 62 +++++ servant-docs.cabal | 37 +++ src/Servant/Docs.hs | 588 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 687 insertions(+) create mode 100644 example/greet.hs create mode 100644 servant-docs.cabal create mode 100644 src/Servant/Docs.hs diff --git a/example/greet.hs b/example/greet.hs new file mode 100644 index 00000000..aac8052b --- /dev/null +++ b/example/greet.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +import Data.Aeson +import Data.Text +import GHC.Generics +import Servant +import Servant.Docs + +-- * Example + +-- | A greet message data type +newtype Greet = Greet { msg :: Text } + deriving (Generic, Show) + +instance FromJSON Greet +instance ToJSON Greet + +-- 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 ToSample Greet where + toSample = Just $ Greet "Hello, haskeller!" + +-- API specification +type TestApi = + -- GET /hello/:name?capital={true, false} returns a Greet as JSON + "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet + + -- POST /greet with a Greet as JSON in the request body, + -- returns a Greet as JSON + :<|> "greet" :> ReqBody Greet :> Post Greet + + -- DELETE /greet/:greetid + :<|> "greet" :> Capture "greetid" Text :> Delete + +testApi :: Proxy TestApi +testApi = Proxy + +-- 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. +docsGreet :: API +docsGreet = docs testApi + +main :: IO () +main = putStrLn $ markdown docsGreet \ No newline at end of file diff --git a/servant-docs.cabal b/servant-docs.cabal new file mode 100644 index 00000000..473eda11 --- /dev/null +++ b/servant-docs.cabal @@ -0,0 +1,37 @@ +name: servant-docs +version: 0.2 +-- synopsis: +-- description: +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni +maintainer: alpmestan@gmail.com +copyright: 2014 Zalora South East Asia Pte Ltd +category: Web +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC >= 7.8 + +library + exposed-modules: + Servant.Docs + build-depends: + base >=4.7 && <5 + , aeson + , bytestring + , hashable + , lens + , servant + , string-conversions + , system-filepath + , unordered-containers + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -O0 -Wall + +executable greet-docs + main-is: greet.hs + hs-source-dirs: example + ghc-options: -O0 -Wall + build-depends: base, aeson, servant, servant-docs, text + default-language: Haskell2010 diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs new file mode 100644 index 00000000..f8e08c83 --- /dev/null +++ b/src/Servant/Docs.hs @@ -0,0 +1,588 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +------------------------------------------------------------------------------- +-- | This module lets you get API docs for free. It lets generate +-- an 'API' from the type that represents your API using 'docs': +-- +-- @docs :: 'HasDocs' api => 'Proxy' api -> 'API'@ +-- +-- You can then call 'markdown' on it: +-- +-- @markdown :: 'API' -> String@ +-- +-- or define a custom pretty printer: +-- +-- @yourPrettyDocs :: 'API' -> String -- or blaze-html's HTML, or ...@ +-- +-- 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's a little (but complete) example that you can run to see the +-- markdown pretty printer in action: +-- +-- > {-# LANGUAGE DataKinds #-} +-- > {-# LANGUAGE PolyKinds #-} +-- > {-# LANGUAGE TypeFamilies #-} +-- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE TypeOperators #-} +-- > {-# LANGUAGE FlexibleInstances #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Data.Proxy +-- > import Data.Text +-- > import Servant +-- > +-- > -- our type for a Greeting message +-- > data Greet = Greet { _msg :: Text } +-- > deriving (Generic, Show) +-- > +-- > -- we get our JSON serialization for free +-- > instance FromJSON Greet +-- > instance ToJSON Greet +-- > +-- > -- we provide a sample value for the 'Greet' type +-- > instance ToSample Greet where +-- > toSample = Just g +-- > +-- > where g = Greet "Hello, haskeller!" +-- > +-- > instance ToParam (QueryParam "capital" Bool) where +-- > toParam _ = +-- > DocQueryParam "capital" +-- > ["true", "false"] +-- > "Get the greeting message in uppercase (true) or not (false). Default is false." +-- > +-- > 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" +-- > +-- > -- API specification +-- > type TestApi = +-- > "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet +-- > :<|> "greet" :> RQBody Greet :> Post Greet +-- > :<|> "delete" :> Capture "greetid" Text :> Delete +-- > +-- > testApi :: Proxy TestApi +-- > testApi = Proxy +-- > +-- > -- Generate the Documentation's ADT +-- > greetDocs :: API +-- > greetDocs = docs testApi +-- > +-- > main :: IO () +-- > main = putStrLn $ markdown greetDocs +module Servant.Docs + ( -- * 'HasDocs' class and key functions + HasDocs(..), docs, markdown + + {- , -- * Serving the documentation + serveDocumentation -} + + , -- * Classes you need to implement for your types + ToSample(..) + , sampleByteString + , ToParam(..) + , ToCapture(..) + + , -- * ADTs to represent an 'API' + Method(..) + , Endpoint, path, method, defEndpoint + , API, emptyAPI + , DocCapture(..), capSymbol, capDesc + , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind + , Response, respStatus, respBody, defResponse + , Action, captures, params, rqbody, response, defAction + , single + + , -- * Useful modules when defining your doc printers + module Control.Lens + , module Data.Monoid + ) where + +import Control.Lens hiding (Action) +import Data.Aeson +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import Data.List +import Data.Monoid +import Data.Proxy +import Data.String.Conversions +import GHC.Generics +import GHC.TypeLits +import Servant + +import qualified Data.HashMap.Strict as HM + +-- | Supported HTTP request methods +data Method = DocDELETE -- ^ the DELETE method + | DocGET -- ^ the GET method + | DocPOST -- ^ the POST method + | DocPUT -- ^ the PUT method + deriving (Eq, 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' +-- 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' '.~' 'DocPOST' +-- POST /foo +-- @ +data Endpoint = Endpoint + { _path :: String -- type collected + , _method :: Method -- type collected + } deriving (Eq, Generic) + +instance Show Endpoint where + show (Endpoint p m) = + show m ++ " " ++ p + +-- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET' +-- +-- Here's how you can modify it: +-- +-- @ +-- λ> 'defEndpoint' +-- GET / +-- λ> 'defEndpoint' & 'path' '<>~' "foo" +-- GET /foo +-- λ> 'defEndpoint' & 'path' '<>~' "foo" & 'method' '.~' 'DocPOST' +-- POST /foo +-- @ +defEndpoint :: Endpoint +defEndpoint = Endpoint "/" DocGET + +instance Hashable Endpoint + +-- | Our API type, a good old hashmap from 'Endpoint' to 'Action' +type API = HashMap Endpoint Action + +-- | An empty 'API' +emptyAPI :: API +emptyAPI = HM.empty + +-- | A type to represent captures. Holds the name of the capture +-- and a description. +-- +-- Write a 'ToCapture' instance for your captured types. +data DocCapture = DocCapture + { _capSymbol :: String -- type supplied + , _capDesc :: String -- user supplied + } deriving (Eq, Show) + +-- | A type to represent a /GET/ parameter from the Query String. Holds its name, +-- the possible values (leave empty if there isn't a finite number of them), +-- and a description of how it influences the output or behavior. +-- +-- Write a 'ToParam' instance for your GET parameter types +data DocQueryParam = DocQueryParam + { _paramName :: String -- type supplied + , _paramValues :: [String] -- user supplied + , _paramDesc :: String -- user supplied + , _paramKind :: ParamKind + } deriving (Eq, Show) + +-- | Type of GET parameter: +-- +-- - Normal corresponds to @QueryParam@, i.e your usual GET parameter +-- - List corresponds to @QueryParams@, i.e GET parameters with multiple values +-- - Flag corresponds to @QueryFlag@, i.e a value-less GET parameter +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. +-- +-- 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. +-- +-- Can be tweaked with two lenses. +-- +-- > λ> defResponse +-- > Response {_respStatus = 200, _respBody = Nothing} +-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]" +-- > Response {_respStatus = 204, _respBody = Just "[]"} +data Response = Response + { _respStatus :: Int + , _respBody :: Maybe ByteString + } deriving (Eq, Show) + +-- | Default response: status code 200, no response body. +-- +-- Can be tweaked with two lenses. +-- +-- > λ> defResponse +-- > Response {_respStatus = 200, _respBody = Nothing} +-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]" +-- > Response {_respStatus = 204, _respBody = Just "[]"} +defResponse :: Response +defResponse = Response 200 Nothing + +-- | A datatype that represents everything that can happen +-- at an endpoint, with its lenses: +-- +-- - List of captures ('captures') +-- - List of GET parameters ('params') +-- - What the request body should look like, if any is requested ('rqbody') +-- - What the response should be if everything goes well ('response') +-- +-- 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 + , _params :: [DocQueryParam] -- type collected + user supplied info + , _rqbody :: Maybe ByteString -- user supplied + , _response :: Response -- user supplied + } deriving (Eq, Show) + +-- Default 'Action'. Has no 'captures', no GET 'params', expects +-- no request body ('rqbody') and the typical response is 'defResponse'. +-- +-- Tweakable with lenses. +-- +-- > λ> defAction +-- > Action {_captures = [], _params = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}} +-- > λ> defAction & response.respStatus .~ 201 +-- > Action {_captures = [], _params = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}} +defAction :: Action +defAction = + Action [] + [] + Nothing + defResponse + +-- | Create an API that's comprised of a single endpoint. +-- 'API' is a 'Monoid', so combine multiple endpoints with +-- 'mappend' or '<>'. +single :: Endpoint -> Action -> API +single = HM.singleton + +-- gimme some lenses +makeLenses ''Endpoint +makeLenses ''DocCapture +makeLenses ''DocQueryParam +makeLenses ''Response +makeLenses ''Action + +-- | Generate the docs for a given API that implements 'HasDocs'. +docs :: HasDocs layout => Proxy layout -> API +docs p = docsFor p (defEndpoint, defAction) + +-- | The class that abstracts away the impact of API combinators +-- on documentation generation. +class HasDocs layout where + docsFor :: Proxy layout -> (Endpoint, Action) -> API + +-- | The class that lets us display a sample JSON input or output +-- when generating documentation for endpoints that either: +-- +-- - expect a request body, or +-- - return a non empty response body +-- +-- Example of an instance: +-- +-- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Data.Aeson +-- > import Data.Text +-- > import GHC.Generics +-- > +-- > data Greet = Greet { _msg :: Text } +-- > deriving (Generic, Show) +-- > +-- > instance FromJSON Greet +-- > instance ToJSON Greet +-- > +-- > instance ToSample Greet where +-- > toSample = Just g +-- > +-- > where g = Greet "Hello, haskeller!" +class ToJSON a => ToSample a where + toSample :: Maybe a + +instance ToSample () where + toSample = Just () + +sampleByteString :: forall a . ToSample a => Proxy a -> Maybe ByteString +sampleByteString Proxy = fmap encode (toSample :: Maybe a) + +-- | The class that helps us automatically get documentation +-- for GET parameters. +-- +-- Example of an instance: +-- +-- > instance ToParam (QueryParam "capital" Bool) where +-- > toParam _ = +-- > DocQueryParam "capital" +-- > ["true", "false"] +-- > "Get the greeting message in uppercase (true) or not (false). Default is false." +class ToParam t where + toParam :: Proxy t -> DocQueryParam + +-- | The class that helps us automatically get documentation +-- for URL captures. +-- +-- Example of an instance: +-- +-- > instance ToCapture (Capture "name" Text) where +-- > toCapture _ = DocCapture "name" "name of the person to greet" +class ToCapture c where + toCapture :: Proxy c -> DocCapture + +-- | Generate documentation in Markdown format for +-- the given 'API'. +markdown :: API -> String +markdown = unlines . concat . map (uncurry printEndpoint) . HM.toList + + where printEndpoint :: Endpoint -> Action -> [String] + printEndpoint endpoint action = + str : + replicate len '-' : + "" : + capturesStr (action ^. captures) ++ + paramsStr (action ^. params) ++ + rqbodyStr (action ^. rqbody) ++ + responseStr (action ^. response) ++ + [] + + where str = show (endpoint^.method) ++ " " ++ endpoint^.path + len = length str + + capturesStr :: [DocCapture] -> [String] + capturesStr [] = [] + capturesStr l = + "**Captures**: " : + "" : + map captureStr l ++ + "" : + [] + captureStr cap = + "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc) + + paramsStr :: [DocQueryParam] -> [String] + paramsStr [] = [] + paramsStr l = + "**GET Parameters**: " : + "" : + map paramStr l ++ + "" : + [] + paramStr param = unlines $ + (" - " ++ param ^. paramName) : + (if (not (null values) || param ^. paramKind /= Flag) + then [" - **Values**: *" ++ intercalate ", " values ++ "*"] + else []) ++ + (" - **Description**: " ++ param ^. paramDesc) : + (if (param ^. paramKind == List) + then [" - This parameter is a **list**. All GET parameters with the name " + ++ param ^. paramName ++ "[] will forward their values in a list to the handler."] + else []) ++ + (if (param ^. paramKind == Flag) + then [" - This parameter is a **flag**. This means no value is expected to be associated to this parameter."] + else []) ++ + [] + + where values = param ^. paramValues + + rqbodyStr :: Maybe ByteString -> [String] + rqbodyStr Nothing = [] + rqbodyStr (Just b) = + "**Request Body**: " : + jsonStr b + + jsonStr b = + "" : + "``` javascript" : + cs b : + "```" : + "" : + [] + + responseStr :: Response -> [String] + responseStr resp = + "**Response**: " : + "" : + (" - Status code " ++ show (resp ^. respStatus)) : + (resp ^. respBody & + maybe [" - No response body\n"] + (\b -> " - Response body as below." : jsonStr b)) + +-- * Instances + +-- | The generated docs for @a ':<|>' b@ just appends the docs +-- for @a@ with the docs for @b@. +instance (HasDocs layout1, HasDocs layout2) + => HasDocs (layout1 :<|> layout2) where + + docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action) + + where p1 :: Proxy layout1 + p1 = Proxy + + p2 :: Proxy layout2 + p2 = Proxy + +-- | @"books" :> 'Capture' "isbn" Text@ will appear as +-- @/books/:isbn@ in the docs. +instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout) + => HasDocs (Capture sym a :> sublayout) where + + docsFor Proxy (endpoint, action) = + docsFor sublayoutP (endpoint', action') + + where sublayoutP = Proxy :: Proxy sublayout + captureP = Proxy :: Proxy (Capture sym a) + + action' = over captures (|> toCapture captureP) action + endpoint' = over path (\p -> p++"/:"++symbolVal symP) endpoint + symP = Proxy :: Proxy sym + + +instance HasDocs Delete where + docsFor Proxy (endpoint, action) = + single endpoint' action' + + where endpoint' = endpoint & method .~ DocDELETE + + action' = action & response.respBody .~ Nothing + & response.respStatus .~ 204 + +instance ToSample a => HasDocs (Get a) where + docsFor Proxy (endpoint, action) = + single endpoint' action' + + where endpoint' = endpoint & method .~ DocGET + action' = action & response.respBody .~ sampleByteString p + p = Proxy :: Proxy a + +instance ToSample a => HasDocs (Post a) where + docsFor Proxy (endpoint, action) = + single endpoint' action' + + where endpoint' = endpoint & method .~ DocPOST + + action' = action & response.respBody .~ sampleByteString p + & response.respStatus .~ 201 + + p = Proxy :: Proxy a + +instance ToSample a => HasDocs (Put a) where + docsFor Proxy (endpoint, action) = + single endpoint' action' + + where endpoint' = endpoint & method .~ DocPUT + + action' = action & response.respBody .~ sampleByteString p + & response.respStatus .~ 200 + + p = Proxy :: Proxy a + + +instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) + => HasDocs (QueryParam sym a :> sublayout) where + + docsFor Proxy (endpoint, action) = + docsFor sublayoutP (endpoint, action') + + where sublayoutP = Proxy :: Proxy sublayout + paramP = Proxy :: Proxy (QueryParam sym a) + action' = over params (|> toParam paramP) action + +instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout) + => HasDocs (QueryParams sym a :> sublayout) where + + docsFor Proxy (endpoint, action) = + docsFor sublayoutP (endpoint, action') + + where sublayoutP = Proxy :: Proxy sublayout + paramP = Proxy :: Proxy (QueryParams sym a) + action' = over params (|> toParam paramP) action + + +instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout) + => HasDocs (QueryFlag sym :> sublayout) where + + docsFor Proxy (endpoint, action) = + docsFor sublayoutP (endpoint, action') + + where sublayoutP = Proxy :: Proxy sublayout + paramP = Proxy :: Proxy (QueryFlag sym) + action' = over params (|> toParam paramP) action + +instance HasDocs Raw where + docsFor _proxy (endpoint, action) = + single endpoint action + +instance (ToSample a, HasDocs sublayout) + => HasDocs (ReqBody a :> sublayout) where + + docsFor Proxy (endpoint, action) = + docsFor sublayoutP (endpoint, action') + + where sublayoutP = Proxy :: Proxy sublayout + + action' = action & rqbody .~ sampleByteString p + p = Proxy :: Proxy a + +instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where + + docsFor Proxy (endpoint, action) = + docsFor sublayoutP (endpoint', action) + + where sublayoutP = Proxy :: Proxy sublayout + endpoint' = endpoint & path <>~ symbolVal pa + pa = Proxy :: Proxy path + +{- + +-- | Serve your API's docs as markdown embedded in an html \
 tag.
+--
+-- > type MyApi = "users" :> Get [User]
+-- >         :<|> "docs   :> Raw
+-- >
+-- > apiProxy :: Proxy MyApi
+-- > apiProxy = Proxy
+-- >
+-- > server :: Server MyApi
+-- > server = listUsers
+-- >     :<|> serveDocumentation apiProxy
+serveDocumentation :: HasDocs api => Proxy api -> Server Raw
+serveDocumentation proxy _request respond =
+  respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy
+
+toHtml :: String -> String
+toHtml md =
+  "" ++
+  "" ++
+  "
" ++
+  md ++
+  "
" ++
+  "" ++
+  ""
+-}
\ No newline at end of file