From 5a011b53d1e7aef75d2254635185a1a6c3ba4e1c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Tue, 28 Oct 2014 12:55:07 +0800 Subject: [PATCH 1/4] made travis file work --- servant.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant.cabal b/servant.cabal index dcd2f797..6fc60278 100644 --- a/servant.cabal +++ b/servant.cabal @@ -29,7 +29,7 @@ library -- other-modules: -- other-extensions: build-depends: - base >=4 && <5 + base >=4.7 && <5 , either , aeson , bytestring From 4ebc4944c277e82baf2b27961990175681fac299 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Tue, 28 Oct 2014 09:04:27 +0100 Subject: [PATCH 2/4] Add automatic doc generation support, including instances for all our API combinators so far --- example/greet.hs | 24 ++- example/greet.md | 51 +++++ servant.cabal | 7 +- src/Servant/API/Capture.hs | 15 ++ src/Servant/API/Get.hs | 10 + src/Servant/API/GetParam.hs | 16 +- src/Servant/API/Post.hs | 13 ++ src/Servant/API/RQBody.hs | 12 ++ src/Servant/API/Sub.hs | 9 + src/Servant/API/Union.hs | 14 +- src/Servant/Docs.hs | 403 ++++++++++++++++++++++++++++++++++++ 11 files changed, 569 insertions(+), 5 deletions(-) create mode 100644 example/greet.md create mode 100644 src/Servant/Docs.hs diff --git a/example/greet.hs b/example/greet.hs index 4a02e67b..363c67ca 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -3,7 +3,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} import Control.Concurrent (forkIO, killThread) import Control.Monad.Trans.Either @@ -18,16 +20,31 @@ import Network.Wai.Handler.Warp import Servant.API import Servant.Client +import Servant.Docs import Servant.Server -- * Example -data Greet = Greet { msg :: Text } +data Greet = Greet { _msg :: Text } deriving (Generic, Show) instance FromJSON Greet instance ToJSON Greet +instance ToCapture (Capture "name" Text) where + toCapture _ = DocCapture "name" "name of the person to greet" + +instance ToParam (GetParam "capital" Bool) where + toParam _ = + DocGetParam "capital" + ["true", "false"] + "Get the greeting message in uppercase (true) or not (false). Default is false." + +instance ToSample Greet where + toSample Proxy = Just (encode g) + + where g = Greet "Hello, haskeller!" + -- API specification type TestApi = "hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet @@ -58,6 +75,9 @@ getGreet :<|> postGreet = clientApi test :: Application test = serve testApi server +docsGreet :: API +docsGreet = docs testApi + -- Run the server runTestServer :: Port -> IO () runTestServer port = run port test @@ -72,3 +92,5 @@ main = do let g = Greet "yo" print =<< runEitherT (postGreet g uri) killThread tid + putStrLn "\n---------\n" + printMarkdown docsGreet diff --git a/example/greet.md b/example/greet.md new file mode 100644 index 00000000..219e70ff --- /dev/null +++ b/example/greet.md @@ -0,0 +1,51 @@ +POST /greet +----------- + +**Request Body**: + +``` javascript +{"msg":"Hello, haskeller!"} +``` + +**Response**: + + - Status code 201 + - Response body as below. + +``` javascript +{"msg":"Hello, haskeller!"} +``` + +GET /hello/:name +---------------- + +**Captures**: + +- *name*: name of the person to greet + +**GET Parameters**: + + - capital + - **Values**: *true, false* + - **Description**: Get the greeting message in uppercase (true) or not (false). Default is false. + +**Response**: + + - Status code 200 + - Response body as below. + +``` javascript +{"msg":"Hello, haskeller!"} +``` + +DELETE /delete/:greetid +----------------------- + +**Captures**: + +- *greetid*: identifier of the greet msg to remove + +**Response**: + + - Status code 204 + - No response body diff --git a/servant.cabal b/servant.cabal index 5ca134d5..211ac233 100644 --- a/servant.cabal +++ b/servant.cabal @@ -16,6 +16,7 @@ library exposed-modules: Servant Servant.Client + Servant.Docs Servant.Server Servant.Text Servant.API @@ -43,6 +44,9 @@ library , warp , transformers , text + , lens + , unordered-containers + , hashable hs-source-dirs: src default-language: Haskell2010 ghc-options: -O0 -Wall @@ -67,7 +71,7 @@ test-suite spec ghc-options: -Wall -Werror -fno-warn-name-shadowing -fno-warn-missing-signatures default-language: Haskell2010 - hs-source-dirs: src, test + hs-source-dirs: test main-is: Spec.hs build-depends: base == 4.* @@ -80,6 +84,7 @@ test-suite spec , http-client , http-types , network-uri >= 2.6 + , servant , string-conversions , text , transformers diff --git a/src/Servant/API/Capture.hs b/src/Servant/API/Capture.hs index 1794498f..36c5e3ec 100644 --- a/src/Servant/API/Capture.hs +++ b/src/Servant/API/Capture.hs @@ -1,6 +1,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} module Servant.API.Capture where @@ -11,6 +12,7 @@ import GHC.TypeLits import Network.Wai import Servant.API.Sub import Servant.Client +import Servant.Docs import Servant.Server import Servant.Text @@ -48,3 +50,16 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout) appendToPath p req where p = unpack (toText val) + +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 diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs index a4eaf65e..f1a2a116 100644 --- a/src/Servant/API/Get.hs +++ b/src/Servant/API/Get.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Servant.API.Get where import Control.Monad @@ -12,6 +13,7 @@ import Network.HTTP.Types import Network.URI import Network.Wai import Servant.Client +import Servant.Docs import Servant.Server import qualified Network.HTTP.Client as Client @@ -43,3 +45,11 @@ instance FromJSON result => HasClient (Get result) where left ("HTTP GET request failed with status: " ++ show (Client.responseStatus innerResponse)) maybe (left "HTTP GET request returned invalid json") return $ decode' (Client.responseBody innerResponse) + +instance ToSample a => HasDocs (Get a) where + docsFor Proxy (endpoint, action) = + single endpoint' action' + + where endpoint' = endpoint & method .~ DocGET + action' = action & response.respBody .~ toSample p + p = Proxy :: Proxy a diff --git a/src/Servant/API/GetParam.hs b/src/Servant/API/GetParam.hs index c0eacec3..93587c53 100644 --- a/src/Servant/API/GetParam.hs +++ b/src/Servant/API/GetParam.hs @@ -1,6 +1,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} module Servant.API.GetParam where @@ -13,6 +14,7 @@ import Network.HTTP.Types import Network.Wai import Servant.API.Sub import Servant.Client +import Servant.Docs import Servant.Server import Servant.Text @@ -28,7 +30,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) route Proxy subserver globalPathInfo request respond = do let querytext = parseQueryText $ rawQueryString request param = - case lookup paramName querytext of + case lookup paramname querytext of Nothing -> Nothing -- param absent from the query string Just Nothing -> Nothing -- param present with no value -> Nothing Just (Just v) -> fromText v -- if present, we try to convert to @@ -36,7 +38,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) route (Proxy :: Proxy sublayout) (subserver param) globalPathInfo request respond - where paramName = cs $ symbolVal (Proxy :: Proxy sym) + where paramname = cs $ symbolVal (Proxy :: Proxy sym) instance (KnownSymbol sym, ToText a, HasClient sublayout) => HasClient (GetParam sym a :> sublayout) where @@ -52,3 +54,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout) where pname = pack pname' pname' = symbolVal (Proxy :: Proxy sym) mparamText = fmap toText mparam + +instance (KnownSymbol sym, ToParam (GetParam sym a), HasDocs sublayout) + => HasDocs (GetParam sym a :> sublayout) where + + docsFor Proxy (endpoint, action) = + docsFor sublayoutP (endpoint, action') + + where sublayoutP = Proxy :: Proxy sublayout + paramP = Proxy :: Proxy (GetParam sym a) + action' = over params (|> toParam paramP) action diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs index 5bee0ccc..bd556d33 100644 --- a/src/Servant/API/Post.hs +++ b/src/Servant/API/Post.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Servant.API.Post where import Control.Monad @@ -12,6 +13,7 @@ import Network.HTTP.Types import Network.URI import Network.Wai import Servant.Client +import Servant.Docs import Servant.Server import qualified Network.HTTP.Client as Client @@ -49,3 +51,14 @@ instance FromJSON a => HasClient (Post a) where maybe (left "HTTP POST request returned invalid json") return $ decode' (Client.responseBody innerResponse) + +instance ToSample a => HasDocs (Post a) where + docsFor Proxy (endpoint, action) = + single endpoint' action' + + where endpoint' = endpoint & method .~ DocPOST + + action' = action & response.respBody .~ toSample p + & response.respStatus .~ 201 + + p = Proxy :: Proxy a diff --git a/src/Servant/API/RQBody.hs b/src/Servant/API/RQBody.hs index caa2c1dc..c05bdc25 100644 --- a/src/Servant/API/RQBody.hs +++ b/src/Servant/API/RQBody.hs @@ -11,6 +11,7 @@ import Data.Proxy import Network.Wai import Servant.API.Sub import Servant.Client +import Servant.Docs import Servant.Server -- * Request Body support @@ -37,3 +38,14 @@ instance (ToJSON a, HasClient sublayout) clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy sublayout) $ setRQBody (encode body) req + +instance (ToSample a, HasDocs sublayout) + => HasDocs (RQBody a :> sublayout) where + + docsFor Proxy (endpoint, action) = + docsFor sublayoutP (endpoint, action') + + where sublayoutP = Proxy :: Proxy sublayout + + action' = action & rqbody .~ toSample p + p = Proxy :: Proxy a diff --git a/src/Servant/API/Sub.hs b/src/Servant/API/Sub.hs index f7ba499e..7a9958b1 100644 --- a/src/Servant/API/Sub.hs +++ b/src/Servant/API/Sub.hs @@ -9,6 +9,7 @@ import Data.String.Conversions import GHC.TypeLits import Network.Wai import Servant.Client +import Servant.Docs import Servant.Server -- | The contained API (second argument) can be found under @("/" ++ path)@ @@ -37,3 +38,11 @@ instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout where p = symbolVal (Proxy :: Proxy path) +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 diff --git a/src/Servant/API/Union.hs b/src/Servant/API/Union.hs index 87278a83..d92451ca 100644 --- a/src/Servant/API/Union.hs +++ b/src/Servant/API/Union.hs @@ -5,6 +5,7 @@ module Servant.API.Union where import Data.Proxy import Servant.Client +import Servant.Docs import Servant.Server -- | Union of two APIs, first takes precedence in case of overlap. @@ -17,10 +18,21 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where route (Proxy :: Proxy a) a globalPathInfo request $ \ mResponse -> case mResponse of Nothing -> route (Proxy :: Proxy b) b globalPathInfo request respond - Just response -> respond $ Just response + Just resp -> respond $ Just resp instance (HasClient a, HasClient b) => HasClient (a :<|> b) where type Client (a :<|> b) = Client a :<|> Client b clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy a) req :<|> clientWithRoute (Proxy :: Proxy b) req + +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 diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs new file mode 100644 index 00000000..a52f028d --- /dev/null +++ b/src/Servant/Docs.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Servant.Docs +-- License : BSD-style +-- Maintainer : alpmestan@gmail.com +-- Stability : provisional +-- Portability : TH, TypeFamilies, DeriveGeneric +-- +-- 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 'printMarkdown' on it: +-- +-- @printMarkdown :: 'API' -> IO ()@ +-- +-- or define a custom pretty printer: +-- +-- @yourPrettyDocs :: 'API' -> IO () -- 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 +-- > import Servant.Docs +-- > +-- > -- 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 Proxy = Just (encode g) +-- > +-- > where g = Greet "Hello, haskeller!" +-- > +-- > instance ToParam (GetParam "capital" Bool) where +-- > toParam _ = +-- > DocGetParam "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 :> GetParam "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 = printMarkdown greetDocs +module Servant.Docs + ( -- * 'HasDocs' class and key functions + HasDocs(..), docs, printMarkdown + + , -- * Classes you need to implement for your types + ToSample(..), ToParam(..), ToCapture(..) + + , -- * ADTs to represent an 'API' + Method(..) + , Endpoint, path, method, defEndpoint + , API, emptyAPI + , DocCapture(..), capSymbol, capDesc + , DocGetParam(..), paramName, paramValues, paramDesc + , Response, respStatus, respBody, defResponse + , Action, captures, params, rqbody, response, defAction + , single + + , -- * Useful modules when defining your own instances + module Control.Lens + , module Data.Monoid + ) where + +import Control.Lens hiding (Action) +import Control.Monad (when) +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 GHC.Generics + +import qualified Data.ByteString.Lazy.Char8 as LB +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 /GET/ parameters. 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 DocGetParam = DocGetParam + { _paramName :: String -- type supplied + , _paramValues :: [String] -- user supplied + , _paramDesc :: String -- user supplied + } 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 :: [DocGetParam] -- 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 ''DocGetParam +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 Proxy = Just (encode g) +-- > +-- > where g = Greet "Hello, haskeller!" +class ToJSON a => ToSample a where + toSample :: Proxy a -> Maybe ByteString + +-- | The class that helps us automatically get documentation +-- for GET parameters. +-- +-- Example of an instance: +-- +-- > instance ToParam (GetParam "capital" Bool) where +-- > toParam _ = +-- > DocGetParam "capital" +-- > ["true", "false"] +-- > "Get the greeting message in uppercase (true) or not (false). Default is false." +class ToParam t where + toParam :: Proxy t -> DocGetParam + +-- | 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 + +-- | Print documentation in Markdown format for +-- the given 'API', on standard output. +printMarkdown :: API -> IO () +printMarkdown = imapM_ printEndpoint + + where printEndpoint endpoint action = do + putStrLn $ str + putStrLn $ replicate len '-' + putStrLn "" + capturesStr (action ^. captures) + paramsStr (action ^. params) + rqbodyStr (action ^. rqbody) + responseStr (action ^. response) + + where str = show (endpoint^.method) ++ " " ++ endpoint^.path + len = length str + + capturesStr :: [DocCapture] -> IO () + capturesStr [] = return () + capturesStr l = do + putStrLn "**Captures**: " + putStrLn "" + mapM_ captureStr l + putStrLn "" + captureStr cap = + putStrLn $ "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc) + + paramsStr :: [DocGetParam] -> IO () + paramsStr [] = return () + paramsStr l = do + putStrLn "**GET Parameters**: " + putStrLn "" + mapM_ paramStr l + putStrLn "" + paramStr param = do + putStrLn $ " - " ++ param ^. paramName + when (not $ null values) $ + putStrLn $ " - **Values**: *" ++ intercalate ", " values ++ "*" + putStrLn $ " - **Description**: " ++ param ^. paramDesc + + where values = param ^. paramValues + + rqbodyStr :: Maybe ByteString -> IO () + rqbodyStr Nothing = return () + rqbodyStr (Just b) = do + putStrLn "**Request Body**: " + jsonStr b + + jsonStr b = do + putStrLn "" + putStrLn "``` javascript" + LB.putStrLn b + putStrLn "```" + putStrLn "" + + responseStr :: Response -> IO () + responseStr resp = do + putStrLn $ "**Response**: " + putStrLn $ "" + putStrLn $ " - Status code " ++ show (resp ^. respStatus) + resp ^. respBody & + maybe (putStrLn " - No response body") + (\b -> putStrLn " - Response body as below." >> jsonStr b) + \ No newline at end of file From 97d4133eb1a1d5ccbe858c96c1b67d3a0048e633 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Tue, 28 Oct 2014 09:14:10 +0100 Subject: [PATCH 3/4] add client, server and docs support for the DELETE HTTP method --- example/greet.hs | 13 +++++++-- servant.cabal | 1 + src/Servant.hs | 2 ++ src/Servant/API.hs | 2 ++ src/Servant/API/Delete.hs | 58 +++++++++++++++++++++++++++++++++++++++ src/Servant/Docs.hs | 2 +- 6 files changed, 75 insertions(+), 3 deletions(-) create mode 100644 src/Servant/API/Delete.hs diff --git a/example/greet.hs b/example/greet.hs index 363c67ca..882d582a 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -34,6 +34,9 @@ instance ToJSON Greet 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 (GetParam "capital" Bool) where toParam _ = DocGetParam "capital" @@ -49,13 +52,14 @@ instance ToSample Greet where type TestApi = "hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet :<|> "greet" :> RQBody Greet :> Post Greet + :<|> "delete" :> Capture "greetid" Text :> Delete testApi :: Proxy TestApi testApi = Proxy -- Server-side handlers server :: Server TestApi -server = hello :<|> greet +server = hello :<|> greet :<|> delete where hello name Nothing = hello name (Just False) hello name (Just False) = return . Greet $ "Hello, " <> name @@ -63,18 +67,22 @@ server = hello :<|> greet greet = return + delete _ = return () + -- Client-side query functions clientApi :: Client TestApi clientApi = client testApi getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet postGreet :: Greet -> URI -> EitherT String IO Greet -getGreet :<|> postGreet = clientApi +deleteGreet :: Text -> URI -> EitherT String IO () +getGreet :<|> postGreet :<|> deleteGreet = clientApi -- Turn the server into a WAI app test :: Application test = serve testApi server +-- Documentation docsGreet :: API docsGreet = docs testApi @@ -91,6 +99,7 @@ main = do print =<< runEitherT (getGreet "alp" (Just False) uri) let g = Greet "yo" print =<< runEitherT (postGreet g uri) + print =<< runEitherT (deleteGreet "blah" uri) killThread tid putStrLn "\n---------\n" printMarkdown docsGreet diff --git a/servant.cabal b/servant.cabal index 211ac233..86e8c7c6 100644 --- a/servant.cabal +++ b/servant.cabal @@ -21,6 +21,7 @@ library Servant.Text Servant.API Servant.API.Capture + Servant.API.Delete Servant.API.Get Servant.API.GetParam Servant.API.Post diff --git a/src/Servant.hs b/src/Servant.hs index ac2e4a1e..0ec0da89 100644 --- a/src/Servant.hs +++ b/src/Servant.hs @@ -1,11 +1,13 @@ module Servant ( module Servant.API , module Servant.Client + , module Servant.Docs , module Servant.Server , module Servant.Text ) where import Servant.API import Servant.Client +import Servant.Docs import Servant.Server import Servant.Text diff --git a/src/Servant/API.hs b/src/Servant/API.hs index c35d845e..9fd1eb9b 100644 --- a/src/Servant/API.hs +++ b/src/Servant/API.hs @@ -1,5 +1,6 @@ module Servant.API ( module Servant.API.Capture + , module Servant.API.Delete , module Servant.API.Get , module Servant.API.GetParam , module Servant.API.Post @@ -9,6 +10,7 @@ module Servant.API ) where import Servant.API.Capture +import Servant.API.Delete import Servant.API.Get import Servant.API.GetParam import Servant.API.Post diff --git a/src/Servant/API/Delete.hs b/src/Servant/API/Delete.hs new file mode 100644 index 00000000..aaa80b14 --- /dev/null +++ b/src/Servant/API/Delete.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.API.Delete where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.Proxy +import Data.String.Conversions +import Network.HTTP.Types +import Network.URI +import Network.Wai +import Servant.Client +import Servant.Docs +import Servant.Server + +import qualified Network.HTTP.Client as Client + +-- | Endpoint for DELETE requests. +data Delete + +instance HasServer Delete where + type Server Delete = EitherT (Int, String) IO () + + route Proxy action _globalPathInfo request respond + | null (pathInfo request) && requestMethod request == methodDelete = do + e <- runEitherT action + respond $ Just $ case e of + Right () -> + responseLBS status204 [] "" + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | otherwise = respond Nothing + +instance HasClient Delete where + type Client Delete = URI -> EitherT String IO () + + clientWithRoute Proxy req uri = do + partialRequest <- liftIO $ reqToRequest req uri + + let request = partialRequest { Client.method = methodDelete + } + + innerResponse <- liftIO . __withGlobalManager $ \ manager -> + Client.httpLbs request manager + + when (Client.responseStatus innerResponse /= status204) $ + left ("HTTP DELETE request failed with status: " ++ show (Client.responseStatus innerResponse)) + +instance HasDocs Delete where + docsFor Proxy (endpoint, action) = + single endpoint' action' + + where endpoint' = endpoint & method .~ DocDELETE + + action' = action & response.respBody .~ Nothing + & response.respStatus .~ 204 diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index a52f028d..2d72ea8b 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -398,6 +398,6 @@ printMarkdown = imapM_ printEndpoint putStrLn $ "" putStrLn $ " - Status code " ++ show (resp ^. respStatus) resp ^. respBody & - maybe (putStrLn " - No response body") + maybe (putStrLn " - No response body\n") (\b -> putStrLn " - Response body as below." >> jsonStr b) \ No newline at end of file From 1181eb8d5ea523cff15cf839a457a154e33e34af Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Tue, 28 Oct 2014 09:17:28 +0100 Subject: [PATCH 4/4] add client, server and docs support for PUT --- servant.cabal | 1 + src/Servant/API.hs | 4 ++- src/Servant/API/Put.hs | 64 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 68 insertions(+), 1 deletion(-) create mode 100644 src/Servant/API/Put.hs diff --git a/servant.cabal b/servant.cabal index 86e8c7c6..3ccee0c8 100644 --- a/servant.cabal +++ b/servant.cabal @@ -25,6 +25,7 @@ library Servant.API.Get Servant.API.GetParam Servant.API.Post + Servant.API.Put Servant.API.Raw Servant.API.RQBody Servant.API.Sub diff --git a/src/Servant/API.hs b/src/Servant/API.hs index 9fd1eb9b..14ed106e 100644 --- a/src/Servant/API.hs +++ b/src/Servant/API.hs @@ -4,6 +4,7 @@ module Servant.API , module Servant.API.Get , module Servant.API.GetParam , module Servant.API.Post + , module Servant.API.Put , module Servant.API.RQBody , module Servant.API.Sub , module Servant.API.Union @@ -14,6 +15,7 @@ import Servant.API.Delete import Servant.API.Get import Servant.API.GetParam import Servant.API.Post +import Servant.API.Put import Servant.API.RQBody import Servant.API.Sub -import Servant.API.Union \ No newline at end of file +import Servant.API.Union diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs new file mode 100644 index 00000000..7148504a --- /dev/null +++ b/src/Servant/API/Put.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.API.Put where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Proxy +import Data.String.Conversions +import Network.HTTP.Types +import Network.URI +import Network.Wai +import Servant.Client +import Servant.Docs +import Servant.Server + +import qualified Network.HTTP.Client as Client + +-- | Endpoint for PUT requests. +data Put a + +instance ToJSON a => HasServer (Put a) where + type Server (Put a) = EitherT (Int, String) IO a + + route Proxy action _globalPathInfo request respond + | null (pathInfo request) && requestMethod request == methodPut = do + e <- runEitherT action + respond $ Just $ case e of + Right out -> + responseLBS ok200 [("Content-Type", "application/json")] (encode out) + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | otherwise = respond Nothing + +instance FromJSON a => HasClient (Put a) where + type Client (Put a) = URI -> EitherT String IO a + + clientWithRoute Proxy req uri = do + partialRequest <- liftIO $ reqToRequest req uri + + let request = partialRequest { Client.method = methodPut + } + + innerResponse <- liftIO . __withGlobalManager $ \ manager -> + Client.httpLbs request manager + + when (Client.responseStatus innerResponse /= ok200) $ + left ("HTTP PUT request failed with status: " ++ show (Client.responseStatus innerResponse)) + + maybe (left "HTTP PUT request returned invalid json") return $ + decode' (Client.responseBody innerResponse) + +instance ToSample a => HasDocs (Put a) where + docsFor Proxy (endpoint, action) = + single endpoint' action' + + where endpoint' = endpoint & method .~ DocPUT + + action' = action & response.respBody .~ toSample p + & response.respStatus .~ 200 + + p = Proxy :: Proxy a