first shot at splitting servant into servant, servant-client and servant-docs

2014-11-27 18:28:01 +01:00 · 2014-11-27 18:28:01 +01:00 · 7fa44d3769
commit 7fa44d3769
3 changed files with 687 additions and 0 deletions
--- a/example/greet.hs
+++ 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
--- a/servant-docs.cabal
+++ 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
--- a/src/Servant/Docs.hs
+++ 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 \<pre> 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 =
+  "<html>" ++
+  "<body>" ++
+  "<pre>" ++
+  md ++
+  "</pre>" ++
+  "</body>" ++
+  "</html>"
+-}