first shot at splitting servant into servant, servant-client and servant-docs
This commit is contained in:
Alp Mestanogullari
parent
9923d1773e
commit
67abcff47f
21 changed files with 13 additions and 1460 deletions
|
|
@ -3,13 +3,8 @@
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
||||||
|
|
||||||
import Control.Concurrent (forkIO, killThread)
|
|
||||||
import Control.Monad.Trans.Either
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
|
|
@ -18,10 +13,7 @@ import GHC.Generics
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Network.Wai.Handler.Warp
|
import Network.Wai.Handler.Warp
|
||||||
|
|
||||||
import Servant.API
|
import Servant
|
||||||
import Servant.Client
|
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
|
||||||
|
|
||||||
-- * Example
|
-- * Example
|
||||||
|
|
||||||
|
|
@ -32,25 +24,6 @@ newtype Greet = Greet { msg :: Text }
|
||||||
instance FromJSON Greet
|
instance FromJSON Greet
|
||||||
instance ToJSON 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
|
-- API specification
|
||||||
type TestApi =
|
type TestApi =
|
||||||
-- GET /hello/:name?capital={true, false} returns a Greet as JSON
|
-- GET /hello/:name?capital={true, false} returns a Greet as JSON
|
||||||
|
|
@ -83,30 +56,11 @@ server = helloH :<|> postGreetH :<|> deleteGreetH
|
||||||
|
|
||||||
deleteGreetH _ = return ()
|
deleteGreetH _ = return ()
|
||||||
|
|
||||||
-- Client-side querying functions
|
|
||||||
--
|
|
||||||
-- They're all derived automatically from the type, and glued together
|
|
||||||
-- with :<|> just like in the type and for the server handlers, except
|
|
||||||
-- that we don't have to implement them!
|
|
||||||
clientApi :: Client TestApi
|
|
||||||
clientApi = client testApi
|
|
||||||
|
|
||||||
getGreet :: Text -> Maybe Bool -> BaseUrl -> EitherT String IO Greet
|
|
||||||
postGreet :: Greet -> BaseUrl -> EitherT String IO Greet
|
|
||||||
deleteGreet :: Text -> BaseUrl -> EitherT String IO ()
|
|
||||||
getGreet :<|> postGreet :<|> deleteGreet = clientApi
|
|
||||||
|
|
||||||
-- Turn the server into a WAI app. 'serve' is provided by servant,
|
-- Turn the server into a WAI app. 'serve' is provided by servant,
|
||||||
-- more precisely by the Servant.Server module.
|
-- more precisely by the Servant.Server module.
|
||||||
test :: Application
|
test :: Application
|
||||||
test = serve testApi server
|
test = serve testApi server
|
||||||
|
|
||||||
-- 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
|
|
||||||
|
|
||||||
-- Run the server.
|
-- Run the server.
|
||||||
--
|
--
|
||||||
-- 'run' comes from Network.Wai.Handler.Warp
|
-- 'run' comes from Network.Wai.Handler.Warp
|
||||||
|
|
@ -115,21 +69,4 @@ runTestServer port = run port test
|
||||||
|
|
||||||
-- Put this all to work!
|
-- Put this all to work!
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = runTestServer 8001
|
||||||
-- we start the server, binding it to port 8001
|
|
||||||
tid <- forkIO $ runTestServer 8001
|
|
||||||
|
|
||||||
-- we tell the client where to find it
|
|
||||||
let uri = BaseUrl Http "localhost" 8001
|
|
||||||
|
|
||||||
-- we run a couple of requests against the server
|
|
||||||
print =<< runEitherT (getGreet "alp" (Just True) uri)
|
|
||||||
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"
|
|
||||||
|
|
||||||
-- we print the markdown docs
|
|
||||||
putStrLn $ markdown docsGreet
|
|
||||||
|
|
|
||||||
|
|
@ -26,40 +26,30 @@ library
|
||||||
Servant.API.Raw
|
Servant.API.Raw
|
||||||
Servant.API.ReqBody
|
Servant.API.ReqBody
|
||||||
Servant.API.Sub
|
Servant.API.Sub
|
||||||
Servant.Client
|
|
||||||
Servant.Common.BaseUrl
|
|
||||||
Servant.Common.Req
|
|
||||||
Servant.Common.Text
|
Servant.Common.Text
|
||||||
Servant.Docs
|
|
||||||
Servant.QQ
|
Servant.QQ
|
||||||
Servant.Server
|
Servant.Server
|
||||||
Servant.Utils.Links
|
Servant.Utils.Links
|
||||||
Servant.Utils.StaticFiles
|
Servant.Utils.StaticFiles
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.7 && <5
|
base >=4.7 && <5
|
||||||
, either
|
|
||||||
, aeson
|
, aeson
|
||||||
, attoparsec
|
, attoparsec
|
||||||
, bytestring
|
, bytestring
|
||||||
, exceptions
|
, either
|
||||||
, string-conversions
|
|
||||||
, split
|
|
||||||
, http-client
|
|
||||||
, http-types
|
, http-types
|
||||||
, network-uri >= 2.6
|
, network-uri >= 2.6
|
||||||
|
, parsec
|
||||||
|
, safe
|
||||||
|
, split
|
||||||
|
, string-conversions
|
||||||
|
, system-filepath
|
||||||
|
, template-haskell
|
||||||
|
, text
|
||||||
|
, transformers
|
||||||
, wai
|
, wai
|
||||||
, wai-app-static
|
, wai-app-static
|
||||||
, warp
|
, warp
|
||||||
, parsec
|
|
||||||
, safe
|
|
||||||
, transformers
|
|
||||||
, template-haskell
|
|
||||||
, text
|
|
||||||
, system-filepath
|
|
||||||
, lens
|
|
||||||
, unordered-containers
|
|
||||||
, hashable
|
|
||||||
, system-filepath
|
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -O0 -Wall
|
ghc-options: -O0 -Wall
|
||||||
|
|
@ -75,7 +65,6 @@ executable greet
|
||||||
, aeson
|
, aeson
|
||||||
, warp
|
, warp
|
||||||
, wai
|
, wai
|
||||||
, either
|
|
||||||
, text
|
, text
|
||||||
|
|
||||||
test-suite spec
|
test-suite spec
|
||||||
|
|
@ -89,13 +78,11 @@ test-suite spec
|
||||||
base == 4.*
|
base == 4.*
|
||||||
, aeson
|
, aeson
|
||||||
, bytestring
|
, bytestring
|
||||||
, deepseq
|
|
||||||
, directory
|
, directory
|
||||||
, either
|
, either
|
||||||
, exceptions
|
, exceptions
|
||||||
, hspec == 2.*
|
, hspec == 2.*
|
||||||
, hspec-wai
|
, hspec-wai
|
||||||
, http-client
|
|
||||||
, http-types
|
, http-types
|
||||||
, network >= 2.6
|
, network >= 2.6
|
||||||
, QuickCheck
|
, QuickCheck
|
||||||
|
|
|
||||||
|
|
@ -5,10 +5,6 @@ module Servant (
|
||||||
module Servant.API,
|
module Servant.API,
|
||||||
-- | For implementing servers for servant APIs.
|
-- | For implementing servers for servant APIs.
|
||||||
module Servant.Server,
|
module Servant.Server,
|
||||||
-- | For accessing servant APIs as API clients.
|
|
||||||
module Servant.Client,
|
|
||||||
-- | For generating documentation for servant APIs.
|
|
||||||
module Servant.Docs,
|
|
||||||
-- | Using your types in request paths and query string parameters
|
-- | Using your types in request paths and query string parameters
|
||||||
module Servant.Common.Text,
|
module Servant.Common.Text,
|
||||||
-- | Utilities on top of the servant core
|
-- | Utilities on top of the servant core
|
||||||
|
|
@ -21,9 +17,7 @@ module Servant (
|
||||||
|
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Servant.API
|
import Servant.API
|
||||||
import Servant.Client
|
|
||||||
import Servant.Common.Text
|
import Servant.Common.Text
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
import Servant.QQ
|
import Servant.QQ
|
||||||
import Servant.Utils.Links
|
import Servant.Utils.Links
|
||||||
|
|
|
||||||
|
|
@ -3,9 +3,8 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
module Servant.API.Alternative where
|
module Servant.API.Alternative where
|
||||||
|
|
||||||
|
import Data.Monoid
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Servant.Client
|
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
-- | Union of two APIs, first takes precedence in case of overlap.
|
-- | Union of two APIs, first takes precedence in case of overlap.
|
||||||
|
|
@ -38,35 +37,3 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
|
||||||
|
|
||||||
where pa = Proxy :: Proxy a
|
where pa = Proxy :: Proxy a
|
||||||
pb = Proxy :: Proxy b
|
pb = Proxy :: Proxy b
|
||||||
|
|
||||||
-- | A client querying function for @a ':<|>' b@ will actually hand you
|
|
||||||
-- one function for querying @a@ and another one for querying @b@,
|
|
||||||
-- stitching them together with ':<|>', which really is just like a pair.
|
|
||||||
--
|
|
||||||
-- > type MyApi = "books" :> Get [Book] -- GET /books
|
|
||||||
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
|
|
||||||
-- >
|
|
||||||
-- > myApi :: Proxy MyApi
|
|
||||||
-- > myApi = Proxy
|
|
||||||
-- >
|
|
||||||
-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
|
|
||||||
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
|
|
||||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
|
||||||
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
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
|
|
|
||||||
|
|
@ -11,10 +11,7 @@ import Data.Text
|
||||||
import GHC.TypeLits
|
import GHC.TypeLits
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Servant.API.Sub
|
import Servant.API.Sub
|
||||||
import Servant.Client
|
|
||||||
import Servant.Common.Req
|
|
||||||
import Servant.Common.Text
|
import Servant.Common.Text
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
-- | Capture a value from the request path under a certain type @a@.
|
-- | Capture a value from the request path under a certain type @a@.
|
||||||
|
|
@ -61,49 +58,3 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
|
||||||
_ -> respond $ failWith NotFound
|
_ -> respond $ failWith NotFound
|
||||||
|
|
||||||
where captureProxy = Proxy :: Proxy (Capture capture a)
|
where captureProxy = Proxy :: Proxy (Capture capture a)
|
||||||
|
|
||||||
-- | If you use a 'Capture' in one of your endpoints in your API,
|
|
||||||
-- the corresponding querying function will automatically take
|
|
||||||
-- an additional argument of the type specified by your 'Capture'.
|
|
||||||
-- That function will take care of inserting a textual representation
|
|
||||||
-- of this value at the right place in the request path.
|
|
||||||
--
|
|
||||||
-- You can control how values for this type are turned into
|
|
||||||
-- text by specifying a 'ToText' instance for your type.
|
|
||||||
--
|
|
||||||
-- Example:
|
|
||||||
--
|
|
||||||
-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
|
|
||||||
-- >
|
|
||||||
-- > myApi :: Proxy MyApi
|
|
||||||
-- > myApi = Proxy
|
|
||||||
-- >
|
|
||||||
-- > getBook :: Text -> BaseUrl -> EitherT String IO Book
|
|
||||||
-- > getBook = client myApi
|
|
||||||
-- > -- then you can just use "getBook" to query that endpoint
|
|
||||||
instance (KnownSymbol capture, ToText a, HasClient sublayout)
|
|
||||||
=> HasClient (Capture capture a :> sublayout) where
|
|
||||||
|
|
||||||
type Client (Capture capture a :> sublayout) =
|
|
||||||
a -> Client sublayout
|
|
||||||
|
|
||||||
clientWithRoute Proxy req val =
|
|
||||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
|
||||||
appendToPath p req
|
|
||||||
|
|
||||||
where p = unpack (toText val)
|
|
||||||
|
|
||||||
-- | @"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
|
|
||||||
|
|
|
||||||
|
|
@ -10,9 +10,6 @@ import Data.String.Conversions
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Servant.Client
|
|
||||||
import Servant.Common.Req
|
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
-- | Combinator for DELETE requests.
|
-- | Combinator for DELETE requests.
|
||||||
|
|
@ -49,22 +46,3 @@ instance HasServer Delete where
|
||||||
| null (pathInfo request) && requestMethod request /= methodDelete =
|
| null (pathInfo request) && requestMethod request /= methodDelete =
|
||||||
respond $ failWith WrongMethod
|
respond $ failWith WrongMethod
|
||||||
| otherwise = respond $ failWith NotFound
|
| otherwise = respond $ failWith NotFound
|
||||||
|
|
||||||
-- | If you have a 'Delete' endpoint in your API, the client
|
|
||||||
-- side querying function that is created when calling 'client'
|
|
||||||
-- will just require an argument that specifies the scheme, host
|
|
||||||
-- and port to send the request to.
|
|
||||||
instance HasClient Delete where
|
|
||||||
type Client Delete = BaseUrl -> EitherT String IO ()
|
|
||||||
|
|
||||||
clientWithRoute Proxy req host =
|
|
||||||
performRequestJSON methodDelete req 204 host
|
|
||||||
|
|
||||||
instance HasDocs Delete where
|
|
||||||
docsFor Proxy (endpoint, action) =
|
|
||||||
single endpoint' action'
|
|
||||||
|
|
||||||
where endpoint' = endpoint & method .~ DocDELETE
|
|
||||||
|
|
||||||
action' = action & response.respBody .~ Nothing
|
|
||||||
& response.respStatus .~ 204
|
|
||||||
|
|
|
||||||
|
|
@ -11,9 +11,6 @@ import Data.String.Conversions
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Servant.Client
|
|
||||||
import Servant.Common.Req
|
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
-- | Endpoint for simple GET requests. Serves the result as JSON.
|
-- | Endpoint for simple GET requests. Serves the result as JSON.
|
||||||
|
|
@ -48,20 +45,3 @@ instance ToJSON result => HasServer (Get result) where
|
||||||
| null (pathInfo request) && requestMethod request /= methodGet =
|
| null (pathInfo request) && requestMethod request /= methodGet =
|
||||||
respond $ failWith WrongMethod
|
respond $ failWith WrongMethod
|
||||||
| otherwise = respond $ failWith NotFound
|
| otherwise = respond $ failWith NotFound
|
||||||
|
|
||||||
-- | If you have a 'Get' endpoint in your API, the client
|
|
||||||
-- side querying function that is created when calling 'client'
|
|
||||||
-- will just require an argument that specifies the scheme, host
|
|
||||||
-- and port to send the request to.
|
|
||||||
instance FromJSON result => HasClient (Get result) where
|
|
||||||
type Client (Get result) = BaseUrl -> EitherT String IO result
|
|
||||||
clientWithRoute Proxy req host =
|
|
||||||
performRequestJSON methodGet req 200 host
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
|
||||||
|
|
@ -11,9 +11,6 @@ import Data.String.Conversions
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Servant.Client
|
|
||||||
import Servant.Common.Req
|
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
-- | Endpoint for POST requests. The type variable represents the type of the
|
-- | Endpoint for POST requests. The type variable represents the type of the
|
||||||
|
|
@ -54,24 +51,3 @@ instance ToJSON a => HasServer (Post a) where
|
||||||
| null (pathInfo request) && requestMethod request /= methodPost =
|
| null (pathInfo request) && requestMethod request /= methodPost =
|
||||||
respond $ failWith WrongMethod
|
respond $ failWith WrongMethod
|
||||||
| otherwise = respond $ failWith NotFound
|
| otherwise = respond $ failWith NotFound
|
||||||
|
|
||||||
-- | If you have a 'Post' endpoint in your API, the client
|
|
||||||
-- side querying function that is created when calling 'client'
|
|
||||||
-- will just require an argument that specifies the scheme, host
|
|
||||||
-- and port to send the request to.
|
|
||||||
instance FromJSON a => HasClient (Post a) where
|
|
||||||
type Client (Post a) = BaseUrl -> EitherT String IO a
|
|
||||||
|
|
||||||
clientWithRoute Proxy req uri =
|
|
||||||
performRequestJSON methodPost req 201 uri
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
|
||||||
|
|
@ -11,9 +11,6 @@ import Data.String.Conversions
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Servant.Client
|
|
||||||
import Servant.Common.Req
|
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
-- | Endpoint for PUT requests, usually used to update a ressource.
|
-- | Endpoint for PUT requests, usually used to update a ressource.
|
||||||
|
|
@ -53,24 +50,3 @@ instance ToJSON a => HasServer (Put a) where
|
||||||
respond $ failWith WrongMethod
|
respond $ failWith WrongMethod
|
||||||
|
|
||||||
| otherwise = respond $ failWith NotFound
|
| otherwise = respond $ failWith NotFound
|
||||||
|
|
||||||
-- | If you have a 'Put' endpoint in your API, the client
|
|
||||||
-- side querying function that is created when calling 'client'
|
|
||||||
-- will just require an argument that specifies the scheme, host
|
|
||||||
-- and port to send the request to.
|
|
||||||
instance FromJSON a => HasClient (Put a) where
|
|
||||||
type Client (Put a) = BaseUrl -> EitherT String IO a
|
|
||||||
|
|
||||||
clientWithRoute Proxy req host =
|
|
||||||
performRequestJSON methodPut req 200 host
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
|
||||||
|
|
@ -7,7 +7,6 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
module Servant.API.QueryParam where
|
module Servant.API.QueryParam where
|
||||||
|
|
||||||
import Data.List
|
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Data.String.Conversions
|
import Data.String.Conversions
|
||||||
|
|
@ -15,10 +14,7 @@ import GHC.TypeLits
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Servant.API.Sub
|
import Servant.API.Sub
|
||||||
import Servant.Client
|
|
||||||
import Servant.Common.Req
|
|
||||||
import Servant.Common.Text
|
import Servant.Common.Text
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
-- | Lookup the value associated to the @sym@ query string parameter
|
-- | Lookup the value associated to the @sym@ query string parameter
|
||||||
|
|
@ -70,56 +66,6 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
|
||||||
|
|
||||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||||
|
|
||||||
-- | If you use a 'QueryParam' in one of your endpoints in your API,
|
|
||||||
-- the corresponding querying function will automatically take
|
|
||||||
-- an additional argument of the type specified by your 'QueryParam',
|
|
||||||
-- enclosed in Maybe.
|
|
||||||
--
|
|
||||||
-- If you give Nothing, nothing will be added to the query string.
|
|
||||||
--
|
|
||||||
-- If you give a non-'Nothing' value, this function will take care
|
|
||||||
-- of inserting a textual representation of this value in the query string.
|
|
||||||
--
|
|
||||||
-- You can control how values for your type are turned into
|
|
||||||
-- text by specifying a 'ToText' instance for your type.
|
|
||||||
--
|
|
||||||
-- Example:
|
|
||||||
--
|
|
||||||
-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
|
|
||||||
-- >
|
|
||||||
-- > myApi :: Proxy MyApi
|
|
||||||
-- > myApi = Proxy
|
|
||||||
-- >
|
|
||||||
-- > getBooksBy :: Maybe Text -> BaseUrl -> EitherT String IO [Book]
|
|
||||||
-- > getBooksBy = client myApi
|
|
||||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
|
||||||
-- > -- 'getBooksBy Nothing' for all books
|
|
||||||
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
|
|
||||||
instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
|
||||||
=> HasClient (QueryParam sym a :> sublayout) where
|
|
||||||
|
|
||||||
type Client (QueryParam sym a :> sublayout) =
|
|
||||||
Maybe a -> Client sublayout
|
|
||||||
|
|
||||||
-- if mparam = Nothing, we don't add it to the query string
|
|
||||||
clientWithRoute Proxy req mparam =
|
|
||||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
|
||||||
appendToQueryString pname mparamText req
|
|
||||||
|
|
||||||
where pname = cs pname'
|
|
||||||
pname' = symbolVal (Proxy :: Proxy sym)
|
|
||||||
mparamText = fmap toText mparam
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
-- | Lookup the values associated to the @sym@ query string parameter
|
-- | Lookup the values associated to the @sym@ query string parameter
|
||||||
-- and try to extract it as a value of type @[a]@. This is typically
|
-- and try to extract it as a value of type @[a]@. This is typically
|
||||||
-- meant to support query string parameters of the form
|
-- meant to support query string parameters of the form
|
||||||
|
|
@ -173,57 +119,6 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
|
||||||
convert Nothing = Nothing
|
convert Nothing = Nothing
|
||||||
convert (Just v) = fromText v
|
convert (Just v) = fromText v
|
||||||
|
|
||||||
-- | If you use a 'QueryParams' in one of your endpoints in your API,
|
|
||||||
-- the corresponding querying function will automatically take
|
|
||||||
-- an additional argument, a list of values of the type specified
|
|
||||||
-- by your 'QueryParams'.
|
|
||||||
--
|
|
||||||
-- If you give an empty list, nothing will be added to the query string.
|
|
||||||
--
|
|
||||||
-- Otherwise, this function will take care
|
|
||||||
-- of inserting a textual representation of your values in the query string,
|
|
||||||
-- under the same query string parameter name.
|
|
||||||
--
|
|
||||||
-- You can control how values for your type are turned into
|
|
||||||
-- text by specifying a 'ToText' instance for your type.
|
|
||||||
--
|
|
||||||
-- Example:
|
|
||||||
--
|
|
||||||
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
|
|
||||||
-- >
|
|
||||||
-- > myApi :: Proxy MyApi
|
|
||||||
-- > myApi = Proxy
|
|
||||||
-- >
|
|
||||||
-- > getBooksBy :: [Text] -> BaseUrl -> EitherT String IO [Book]
|
|
||||||
-- > getBooksBy = client myApi
|
|
||||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
|
||||||
-- > -- 'getBooksBy []' for all books
|
|
||||||
-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
|
|
||||||
-- > -- to get all books by Asimov and Heinlein
|
|
||||||
instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
|
||||||
=> HasClient (QueryParams sym a :> sublayout) where
|
|
||||||
|
|
||||||
type Client (QueryParams sym a :> sublayout) =
|
|
||||||
[a] -> Client sublayout
|
|
||||||
|
|
||||||
clientWithRoute Proxy req paramlist =
|
|
||||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
|
||||||
foldl' (\ value req' -> appendToQueryString pname req' value) req paramlist'
|
|
||||||
|
|
||||||
where pname = cs pname'
|
|
||||||
pname' = symbolVal (Proxy :: Proxy sym)
|
|
||||||
paramlist' = map (Just . toText) paramlist
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
-- | Lookup a potentially value-less query string parameter
|
-- | Lookup a potentially value-less query string parameter
|
||||||
-- with boolean semantics. If the param @sym@ is there without any value,
|
-- with boolean semantics. If the param @sym@ is there without any value,
|
||||||
-- or if it's there with value "true" or "1", it's interpreted as 'True'.
|
-- or if it's there with value "true" or "1", it's interpreted as 'True'.
|
||||||
|
|
@ -265,48 +160,3 @@ instance (KnownSymbol sym, HasServer sublayout)
|
||||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||||
examine v | v == "true" || v == "1" || v == "" = True
|
examine v | v == "true" || v == "1" || v == "" = True
|
||||||
| otherwise = False
|
| otherwise = False
|
||||||
|
|
||||||
-- | If you use a 'QueryFlag' in one of your endpoints in your API,
|
|
||||||
-- the corresponding querying function will automatically take
|
|
||||||
-- an additional 'Bool' argument.
|
|
||||||
--
|
|
||||||
-- If you give 'False', nothing will be added to the query string.
|
|
||||||
--
|
|
||||||
-- Otherwise, this function will insert a value-less query string
|
|
||||||
-- parameter under the name associated to your 'QueryFlag'.
|
|
||||||
--
|
|
||||||
-- Example:
|
|
||||||
--
|
|
||||||
-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]
|
|
||||||
-- >
|
|
||||||
-- > myApi :: Proxy MyApi
|
|
||||||
-- > myApi = Proxy
|
|
||||||
-- >
|
|
||||||
-- > getBooks :: Bool -> BaseUrl -> EitherT String IO [Book]
|
|
||||||
-- > getBooks = client myApi
|
|
||||||
-- > -- then you can just use "getBooks" to query that endpoint.
|
|
||||||
-- > -- 'getBooksBy False' for all books
|
|
||||||
-- > -- 'getBooksBy True' to only get _already published_ books
|
|
||||||
instance (KnownSymbol sym, HasClient sublayout)
|
|
||||||
=> HasClient (QueryFlag sym :> sublayout) where
|
|
||||||
|
|
||||||
type Client (QueryFlag sym :> sublayout) =
|
|
||||||
Bool -> Client sublayout
|
|
||||||
|
|
||||||
clientWithRoute Proxy req flag =
|
|
||||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
|
||||||
if flag
|
|
||||||
then appendToQueryString paramname Nothing req
|
|
||||||
else req
|
|
||||||
|
|
||||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
|
||||||
|
|
@ -3,14 +3,8 @@
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
module Servant.API.Raw where
|
module Servant.API.Raw where
|
||||||
|
|
||||||
import Control.Monad.Trans.Either
|
|
||||||
import Data.ByteString.Lazy
|
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Network.HTTP.Types
|
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Servant.Client
|
|
||||||
import Servant.Common.Req
|
|
||||||
import Servant.Docs hiding (Method)
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
-- | Endpoint for plugging in your own Wai 'Application's.
|
-- | Endpoint for plugging in your own Wai 'Application's.
|
||||||
|
|
@ -36,17 +30,3 @@ instance HasServer Raw where
|
||||||
type Server Raw = Application
|
type Server Raw = Application
|
||||||
route Proxy rawApplication request respond =
|
route Proxy rawApplication request respond =
|
||||||
rawApplication request (respond . succeedWith)
|
rawApplication request (respond . succeedWith)
|
||||||
|
|
||||||
-- | Pick a 'Method' and specify where the server you want to query is. You get
|
|
||||||
-- back the status code and the response body as a 'ByteString'.
|
|
||||||
instance HasClient Raw where
|
|
||||||
type Client Raw = Method -> BaseUrl -> EitherT String IO (Int, ByteString)
|
|
||||||
|
|
||||||
clientWithRoute :: Proxy Raw -> Req -> Client Raw
|
|
||||||
clientWithRoute Proxy req httpMethod host =
|
|
||||||
performRequest httpMethod req (const True) host
|
|
||||||
|
|
||||||
|
|
||||||
instance HasDocs Raw where
|
|
||||||
docsFor _proxy (endpoint, action) =
|
|
||||||
single endpoint action
|
|
||||||
|
|
|
||||||
|
|
@ -10,9 +10,6 @@ import Data.Aeson
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Servant.API.Sub
|
import Servant.API.Sub
|
||||||
import Servant.Client
|
|
||||||
import Servant.Common.Req
|
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
-- | Extract the request body as a value of type @a@.
|
-- | Extract the request body as a value of type @a@.
|
||||||
|
|
@ -50,42 +47,3 @@ instance (FromJSON a, HasServer sublayout)
|
||||||
case mrqbody of
|
case mrqbody of
|
||||||
Nothing -> respond $ failWith InvalidBody
|
Nothing -> respond $ failWith InvalidBody
|
||||||
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
|
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
|
||||||
|
|
||||||
-- | If you use a 'ReqBody' in one of your endpoints in your API,
|
|
||||||
-- the corresponding querying function will automatically take
|
|
||||||
-- an additional argument of the type specified by your 'ReqBody'.
|
|
||||||
-- That function will take care of encoding this argument as JSON and
|
|
||||||
-- of using it as the request body.
|
|
||||||
--
|
|
||||||
-- All you need is for your type to have a 'ToJSON' instance.
|
|
||||||
--
|
|
||||||
-- Example:
|
|
||||||
--
|
|
||||||
-- > type MyApi = "books" :> ReqBody Book :> Post Book
|
|
||||||
-- >
|
|
||||||
-- > myApi :: Proxy MyApi
|
|
||||||
-- > myApi = Proxy
|
|
||||||
-- >
|
|
||||||
-- > addBook :: Book -> BaseUrl -> EitherT String IO Book
|
|
||||||
-- > addBook = client myApi
|
|
||||||
-- > -- then you can just use "addBook" to query that endpoint
|
|
||||||
instance (ToJSON a, HasClient sublayout)
|
|
||||||
=> HasClient (ReqBody a :> sublayout) where
|
|
||||||
|
|
||||||
type Client (ReqBody a :> sublayout) =
|
|
||||||
a -> Client sublayout
|
|
||||||
|
|
||||||
clientWithRoute Proxy req body =
|
|
||||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
|
||||||
setRQBody (encode body) req
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
|
||||||
|
|
@ -8,9 +8,6 @@ import Data.Proxy
|
||||||
import Data.String.Conversions
|
import Data.String.Conversions
|
||||||
import GHC.TypeLits
|
import GHC.TypeLits
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Servant.Client
|
|
||||||
import Servant.Common.Req
|
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
-- | The contained API (second argument) can be found under @("/" ++ path)@
|
-- | The contained API (second argument) can be found under @("/" ++ path)@
|
||||||
|
|
@ -37,22 +34,3 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout
|
||||||
_ -> respond $ failWith NotFound
|
_ -> respond $ failWith NotFound
|
||||||
|
|
||||||
where proxyPath = Proxy :: Proxy path
|
where proxyPath = Proxy :: Proxy path
|
||||||
|
|
||||||
-- | Make the querying function append @path@ to the request path.
|
|
||||||
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
|
|
||||||
type Client (path :> sublayout) = Client sublayout
|
|
||||||
|
|
||||||
clientWithRoute Proxy req =
|
|
||||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
|
||||||
appendToPath p req
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
|
||||||
|
|
@ -1,39 +0,0 @@
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
-- | This module provides 'client' which can automatically generate
|
|
||||||
-- querying functions for each endpoint just from the type representing your
|
|
||||||
-- API.
|
|
||||||
module Servant.Client
|
|
||||||
( client
|
|
||||||
, HasClient(..)
|
|
||||||
, module Servant.Common.BaseUrl
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.Proxy
|
|
||||||
|
|
||||||
import Servant.Common.BaseUrl
|
|
||||||
import Servant.Common.Req
|
|
||||||
|
|
||||||
-- * Accessing APIs as a Client
|
|
||||||
|
|
||||||
-- | 'client' allows you to produce operations to query an API from a client.
|
|
||||||
--
|
|
||||||
-- > type MyApi = "books" :> Get [Book] -- GET /books
|
|
||||||
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
|
|
||||||
-- >
|
|
||||||
-- > myApi :: Proxy MyApi
|
|
||||||
-- > myApi = Proxy
|
|
||||||
-- >
|
|
||||||
-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
|
|
||||||
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
|
|
||||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
|
||||||
client :: HasClient layout => Proxy layout -> Client layout
|
|
||||||
client p = clientWithRoute p defReq
|
|
||||||
|
|
||||||
-- | This class lets us define how each API combinator
|
|
||||||
-- influences the creation of an HTTP request. Use 'client'
|
|
||||||
-- directly, this class implements the client-side
|
|
||||||
-- behavior of each combinator but you don't have to worry about it.
|
|
||||||
class HasClient layout where
|
|
||||||
type Client layout :: *
|
|
||||||
clientWithRoute :: Proxy layout -> Req -> Client layout
|
|
||||||
|
|
@ -1,55 +0,0 @@
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
|
||||||
module Servant.Common.BaseUrl where
|
|
||||||
|
|
||||||
import Data.List
|
|
||||||
import GHC.Generics
|
|
||||||
import Network.URI
|
|
||||||
import Safe
|
|
||||||
import Text.Read
|
|
||||||
|
|
||||||
-- | URI scheme to use
|
|
||||||
data Scheme =
|
|
||||||
Http -- ^ http://
|
|
||||||
| Https -- ^ https://
|
|
||||||
deriving (Show, Eq, Ord, Generic)
|
|
||||||
|
|
||||||
-- | Simple data type to represent the target of HTTP requests
|
|
||||||
-- for servant's automatically-generated clients.
|
|
||||||
data BaseUrl = BaseUrl
|
|
||||||
{ baseUrlScheme :: Scheme -- ^ URI scheme to use
|
|
||||||
, baseUrlHost :: String -- ^ host (eg "haskell.org")
|
|
||||||
, baseUrlPort :: Int -- ^ port (eg 80)
|
|
||||||
} deriving (Show, Eq, Ord, Generic)
|
|
||||||
|
|
||||||
showBaseUrl :: BaseUrl -> String
|
|
||||||
showBaseUrl (BaseUrl urlscheme host port) =
|
|
||||||
schemeString ++ "//" ++ host ++ portString
|
|
||||||
where
|
|
||||||
schemeString = case urlscheme of
|
|
||||||
Http -> "http:"
|
|
||||||
Https -> "https:"
|
|
||||||
portString = case (urlscheme, port) of
|
|
||||||
(Http, 80) -> ""
|
|
||||||
(Https, 443) -> ""
|
|
||||||
_ -> ":" ++ show port
|
|
||||||
|
|
||||||
parseBaseUrl :: String -> Either String BaseUrl
|
|
||||||
parseBaseUrl s = case parseURI (removeTrailingSlash s) of
|
|
||||||
-- This is a rather hacky implementation and should be replaced with something
|
|
||||||
-- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
|
|
||||||
Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
|
|
||||||
Right (BaseUrl Http host port)
|
|
||||||
Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->
|
|
||||||
Right (BaseUrl Http host 80)
|
|
||||||
Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
|
|
||||||
Right (BaseUrl Https host port)
|
|
||||||
Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
|
|
||||||
Right (BaseUrl Https host 443)
|
|
||||||
_ -> if "://" `isInfixOf` s
|
|
||||||
then Left ("invalid base url: " ++ s)
|
|
||||||
else parseBaseUrl ("http://" ++ s)
|
|
||||||
where
|
|
||||||
removeTrailingSlash str = case lastMay str of
|
|
||||||
Just '/' -> init str
|
|
||||||
_ -> str
|
|
||||||
|
|
@ -1,132 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
module Servant.Common.Req where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Catch (MonadThrow)
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Trans.Either
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.Aeson.Parser
|
|
||||||
import Data.Aeson.Types
|
|
||||||
import Data.Attoparsec.ByteString
|
|
||||||
import Data.ByteString.Lazy
|
|
||||||
import Data.String.Conversions
|
|
||||||
import Data.Text
|
|
||||||
import Network.HTTP.Client
|
|
||||||
import Network.HTTP.Types
|
|
||||||
import Network.URI
|
|
||||||
import Servant.Common.BaseUrl
|
|
||||||
import System.IO.Unsafe
|
|
||||||
|
|
||||||
import qualified Network.HTTP.Client as Client
|
|
||||||
|
|
||||||
data Req = Req
|
|
||||||
{ reqPath :: String
|
|
||||||
, qs :: QueryText
|
|
||||||
, reqBody :: ByteString
|
|
||||||
}
|
|
||||||
|
|
||||||
defReq :: Req
|
|
||||||
defReq = Req "" [] ""
|
|
||||||
|
|
||||||
appendToPath :: String -> Req -> Req
|
|
||||||
appendToPath p req =
|
|
||||||
req { reqPath = reqPath req ++ "/" ++ p }
|
|
||||||
|
|
||||||
appendToQueryString :: Text -- ^ param name
|
|
||||||
-> Maybe Text -- ^ param value
|
|
||||||
-> Req
|
|
||||||
-> Req
|
|
||||||
appendToQueryString pname pvalue req =
|
|
||||||
req { qs = qs req ++ [(pname, pvalue)]
|
|
||||||
}
|
|
||||||
|
|
||||||
setRQBody :: ByteString -> Req -> Req
|
|
||||||
setRQBody b req = req { reqBody = b }
|
|
||||||
|
|
||||||
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
|
|
||||||
reqToRequest req (BaseUrl reqScheme reqHost reqPort) = fmap (setrqb . setQS ) $ parseUrl url
|
|
||||||
|
|
||||||
where url = show $ nullURI { uriScheme = case reqScheme of
|
|
||||||
Http -> "http:"
|
|
||||||
Https -> "https:"
|
|
||||||
, uriAuthority = Just $
|
|
||||||
URIAuth { uriUserInfo = ""
|
|
||||||
, uriRegName = reqHost
|
|
||||||
, uriPort = ":" ++ show reqPort
|
|
||||||
}
|
|
||||||
, uriPath = reqPath req
|
|
||||||
}
|
|
||||||
|
|
||||||
setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }
|
|
||||||
setQS = setQueryString $ queryTextToQuery (qs req)
|
|
||||||
|
|
||||||
|
|
||||||
-- * performing requests
|
|
||||||
|
|
||||||
{-# NOINLINE __manager #-}
|
|
||||||
__manager :: MVar Manager
|
|
||||||
__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)
|
|
||||||
|
|
||||||
__withGlobalManager :: (Manager -> IO a) -> IO a
|
|
||||||
__withGlobalManager action = modifyMVar __manager $ \ manager -> do
|
|
||||||
result <- action manager
|
|
||||||
return (manager, result)
|
|
||||||
|
|
||||||
|
|
||||||
displayHttpRequest :: Method -> String
|
|
||||||
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
|
|
||||||
|
|
||||||
|
|
||||||
performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString)
|
|
||||||
performRequest reqMethod req isWantedStatus reqHost = do
|
|
||||||
partialRequest <- liftIO $ reqToRequest req reqHost
|
|
||||||
|
|
||||||
let request = partialRequest { Client.method = reqMethod
|
|
||||||
, checkStatus = \ _status _headers _cookies -> Nothing
|
|
||||||
}
|
|
||||||
|
|
||||||
eResponse <- liftIO $ __withGlobalManager $ \ manager ->
|
|
||||||
catchStatusCodeException $
|
|
||||||
Client.httpLbs request manager
|
|
||||||
case eResponse of
|
|
||||||
Left status ->
|
|
||||||
left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
|
|
||||||
|
|
||||||
Right response -> do
|
|
||||||
let status = Client.responseStatus response
|
|
||||||
unless (isWantedStatus (statusCode status)) $
|
|
||||||
left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
|
|
||||||
return $ (statusCode status, Client.responseBody response)
|
|
||||||
where
|
|
||||||
showStatus (Status code message) =
|
|
||||||
show code ++ " - " ++ cs message
|
|
||||||
|
|
||||||
|
|
||||||
performRequestJSON :: FromJSON result =>
|
|
||||||
Method -> Req -> Int -> BaseUrl -> EitherT String IO result
|
|
||||||
performRequestJSON reqMethod req wantedStatus reqHost = do
|
|
||||||
(_status, respBody) <- performRequest reqMethod req (== wantedStatus) reqHost
|
|
||||||
either
|
|
||||||
(\ message -> left (displayHttpRequest reqMethod ++ " returned invalid json: " ++ message))
|
|
||||||
return
|
|
||||||
(decodeLenient respBody)
|
|
||||||
|
|
||||||
|
|
||||||
catchStatusCodeException :: IO a -> IO (Either Status a)
|
|
||||||
catchStatusCodeException action =
|
|
||||||
catch (Right <$> action) $ \e ->
|
|
||||||
case e of
|
|
||||||
Client.StatusCodeException status _ _ -> return $ Left status
|
|
||||||
exc -> throwIO exc
|
|
||||||
|
|
||||||
-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
|
|
||||||
-- objects and arrays.
|
|
||||||
decodeLenient :: FromJSON a => ByteString -> Either String a
|
|
||||||
decodeLenient input = do
|
|
||||||
v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
|
|
||||||
parseEither parseJSON v
|
|
||||||
|
|
@ -1,426 +0,0 @@
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# 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:
|
|
||||||
--
|
|
||||||
-- @printMarkdown :: '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
|
|
||||||
|
|
||||||
, -- * 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 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))
|
|
||||||
|
|
@ -1,24 +1,17 @@
|
||||||
-- | This module defines sever-side handlers that let you serve static files
|
-- | This module defines a sever-side handler that lets you serve static files.
|
||||||
-- and your API's docs.
|
|
||||||
--
|
--
|
||||||
-- - 'serveDirectory' lets you serve anything that lives under a particular
|
-- - 'serveDirectory' lets you serve anything that lives under a particular
|
||||||
-- directory on your filesystem.
|
-- directory on your filesystem.
|
||||||
-- - 'serveDocumentation' lets you serve the markdown-version of the docs for
|
|
||||||
-- your API.
|
|
||||||
module Servant.Utils.StaticFiles (
|
module Servant.Utils.StaticFiles (
|
||||||
serveDirectory,
|
serveDirectory,
|
||||||
serveDocumentation,
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Proxy
|
|
||||||
import Data.String.Conversions
|
import Data.String.Conversions
|
||||||
import Filesystem.Path.CurrentOS (decodeString)
|
import Filesystem.Path.CurrentOS (decodeString)
|
||||||
import Network.HTTP.Types
|
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Network.Wai.Application.Static
|
import Network.Wai.Application.Static
|
||||||
|
|
||||||
import Servant.API.Raw
|
import Servant.API.Raw
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
-- | Serve anything under the specified directory as a 'Raw' endpoint.
|
-- | Serve anything under the specified directory as a 'Raw' endpoint.
|
||||||
|
|
@ -44,28 +37,3 @@ import Servant.Server
|
||||||
serveDirectory :: FilePath -> Server Raw
|
serveDirectory :: FilePath -> Server Raw
|
||||||
serveDirectory documentRoot =
|
serveDirectory documentRoot =
|
||||||
staticApp (defaultFileServerSettings (decodeString (documentRoot ++ "/")))
|
staticApp (defaultFileServerSettings (decodeString (documentRoot ++ "/")))
|
||||||
|
|
||||||
-- | 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>"
|
|
||||||
|
|
|
||||||
|
|
@ -1,203 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE GADTs #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
|
||||||
|
|
||||||
module Servant.ClientSpec where
|
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad.Trans.Either
|
|
||||||
import Data.ByteString.Lazy (ByteString)
|
|
||||||
import Data.Char
|
|
||||||
import Data.Foldable (forM_)
|
|
||||||
import Data.Proxy
|
|
||||||
import Data.Typeable
|
|
||||||
import Network.HTTP.Types
|
|
||||||
import Network.Socket
|
|
||||||
import Network.Wai
|
|
||||||
import Network.Wai.Handler.Warp
|
|
||||||
import Test.Hspec
|
|
||||||
import Test.Hspec.QuickCheck
|
|
||||||
import Test.QuickCheck
|
|
||||||
|
|
||||||
import Servant.API
|
|
||||||
import Servant.Client
|
|
||||||
import Servant.Server
|
|
||||||
|
|
||||||
import Servant.ServerSpec
|
|
||||||
|
|
||||||
type Api =
|
|
||||||
"get" :> Get Person
|
|
||||||
:<|> "capture" :> Capture "name" String :> Get Person
|
|
||||||
:<|> "body" :> ReqBody Person :> Post Person
|
|
||||||
:<|> "param" :> QueryParam "name" String :> Get Person
|
|
||||||
:<|> "params" :> QueryParams "names" String :> Get [Person]
|
|
||||||
:<|> "flag" :> QueryFlag "flag" :> Get Bool
|
|
||||||
:<|> "rawSuccess" :> Raw
|
|
||||||
:<|> "rawFailure" :> Raw
|
|
||||||
:<|> "multiple" :>
|
|
||||||
Capture "first" String :>
|
|
||||||
QueryParam "second" Int :>
|
|
||||||
QueryFlag "third" :>
|
|
||||||
ReqBody [(String, [Rational])] :>
|
|
||||||
Get (String, Maybe Int, Bool, [(String, [Rational])])
|
|
||||||
api :: Proxy Api
|
|
||||||
api = Proxy
|
|
||||||
|
|
||||||
server :: Application
|
|
||||||
server = serve api (
|
|
||||||
return alice
|
|
||||||
:<|> (\ name -> return $ Person name 0)
|
|
||||||
:<|> return
|
|
||||||
:<|> (\ name -> case name of
|
|
||||||
Just "alice" -> return alice
|
|
||||||
Just name -> left (400, name ++ " not found")
|
|
||||||
Nothing -> left (400, "missing parameter"))
|
|
||||||
:<|> (\ names -> return (zipWith Person names [0..]))
|
|
||||||
:<|> return
|
|
||||||
:<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
|
|
||||||
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
|
|
||||||
:<|> \ a b c d -> return (a, b, c, d)
|
|
||||||
)
|
|
||||||
|
|
||||||
withServer :: (BaseUrl -> IO a) -> IO a
|
|
||||||
withServer action = withWaiDaemon (return server) action
|
|
||||||
|
|
||||||
getGet :: BaseUrl -> EitherT String IO Person
|
|
||||||
getCapture :: String -> BaseUrl -> EitherT String IO Person
|
|
||||||
getBody :: Person -> BaseUrl -> EitherT String IO Person
|
|
||||||
getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person
|
|
||||||
getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person]
|
|
||||||
getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool
|
|
||||||
getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)
|
|
||||||
getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)
|
|
||||||
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
|
|
||||||
-> BaseUrl
|
|
||||||
-> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])])
|
|
||||||
( getGet
|
|
||||||
:<|> getCapture
|
|
||||||
:<|> getBody
|
|
||||||
:<|> getQueryParam
|
|
||||||
:<|> getQueryParams
|
|
||||||
:<|> getQueryFlag
|
|
||||||
:<|> getRawSuccess
|
|
||||||
:<|> getRawFailure
|
|
||||||
:<|> getMultiple)
|
|
||||||
= client api
|
|
||||||
|
|
||||||
spec :: Spec
|
|
||||||
spec = do
|
|
||||||
it "Servant.API.Get" $ withServer $ \ host -> do
|
|
||||||
runEitherT (getGet host) `shouldReturn` Right alice
|
|
||||||
|
|
||||||
it "Servant.API.Capture" $ withServer $ \ host -> do
|
|
||||||
runEitherT (getCapture "Paula" host) `shouldReturn` Right (Person "Paula" 0)
|
|
||||||
|
|
||||||
it "Servant.API.ReqBody" $ withServer $ \ host -> do
|
|
||||||
let p = Person "Clara" 42
|
|
||||||
runEitherT (getBody p host) `shouldReturn` Right p
|
|
||||||
|
|
||||||
it "Servant.API.QueryParam" $ withServer $ \ host -> do
|
|
||||||
runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice
|
|
||||||
Left result <- runEitherT (getQueryParam (Just "bob") host)
|
|
||||||
result `shouldContain` "bob not found"
|
|
||||||
|
|
||||||
it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do
|
|
||||||
runEitherT (getQueryParams [] host) `shouldReturn` Right []
|
|
||||||
runEitherT (getQueryParams ["alice", "bob"] host)
|
|
||||||
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
|
||||||
|
|
||||||
context "Servant.API.QueryParam.QueryFlag" $
|
|
||||||
forM_ [False, True] $ \ flag ->
|
|
||||||
it (show flag) $ withServer $ \ host -> do
|
|
||||||
runEitherT (getQueryFlag flag host) `shouldReturn` Right flag
|
|
||||||
|
|
||||||
it "Servant.API.Raw on success" $ withServer $ \ host -> do
|
|
||||||
runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess")
|
|
||||||
|
|
||||||
it "Servant.API.Raw on failure" $ withServer $ \ host -> do
|
|
||||||
runEitherT (getRawFailure methodGet host) `shouldReturn` Right (400, "rawFailure")
|
|
||||||
|
|
||||||
modifyMaxSuccess (const 20) $ do
|
|
||||||
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
|
|
||||||
property $ forAllShrink pathGen shrink $ \ a -> \ b c d ->
|
|
||||||
ioProperty $ do
|
|
||||||
withServer $ \ host -> do
|
|
||||||
result <- runEitherT (getMultiple a b c d host)
|
|
||||||
return $
|
|
||||||
result === Right (a, b, c, d)
|
|
||||||
|
|
||||||
|
|
||||||
context "client correctly handles error status codes" $ do
|
|
||||||
let test :: WrappedApi -> Spec
|
|
||||||
test (WrappedApi api) =
|
|
||||||
it (show (typeOf api)) $
|
|
||||||
withWaiDaemon (return (serve api (left (500, "error message")))) $
|
|
||||||
\ host -> do
|
|
||||||
let getResponse :: BaseUrl -> EitherT String IO ()
|
|
||||||
getResponse = client api
|
|
||||||
Left result <- runEitherT (getResponse host)
|
|
||||||
result `shouldContain` "error message"
|
|
||||||
mapM_ test $
|
|
||||||
(WrappedApi (Proxy :: Proxy Delete)) :
|
|
||||||
(WrappedApi (Proxy :: Proxy (Get ()))) :
|
|
||||||
(WrappedApi (Proxy :: Proxy (Post ()))) :
|
|
||||||
(WrappedApi (Proxy :: Proxy (Put ()))) :
|
|
||||||
[]
|
|
||||||
|
|
||||||
data WrappedApi where
|
|
||||||
WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
|
|
||||||
HasClient api, Client api ~ (BaseUrl -> EitherT String IO ()),
|
|
||||||
Typeable api) =>
|
|
||||||
Proxy api -> WrappedApi
|
|
||||||
|
|
||||||
|
|
||||||
-- * utils
|
|
||||||
|
|
||||||
withWaiDaemon :: IO Application -> (BaseUrl -> IO a) -> IO a
|
|
||||||
withWaiDaemon mkApplication action = do
|
|
||||||
application <- mkApplication
|
|
||||||
bracket (acquire application) free (\ (_, _, baseUrl) -> action baseUrl)
|
|
||||||
where
|
|
||||||
acquire application = do
|
|
||||||
(notifyStart, waitForStart) <- lvar
|
|
||||||
(notifyKilled, waitForKilled) <- lvar
|
|
||||||
thread <- forkIO $ (do
|
|
||||||
(krakenPort, socket) <- openTestSocket
|
|
||||||
let settings =
|
|
||||||
setPort krakenPort $ -- set here just for consistency, shouldn't be
|
|
||||||
-- used (it's set in the socket)
|
|
||||||
setBeforeMainLoop (notifyStart krakenPort)
|
|
||||||
defaultSettings
|
|
||||||
runSettingsSocket settings socket application)
|
|
||||||
`finally` notifyKilled ()
|
|
||||||
krakenPort <- waitForStart
|
|
||||||
let baseUrl = (BaseUrl Http "localhost" 80){baseUrlPort = krakenPort}
|
|
||||||
return (thread, waitForKilled, baseUrl)
|
|
||||||
free (thread, waitForKilled, _) = do
|
|
||||||
killThread thread
|
|
||||||
waitForKilled
|
|
||||||
|
|
||||||
lvar :: IO (a -> IO (), IO a)
|
|
||||||
lvar = do
|
|
||||||
mvar <- newEmptyMVar
|
|
||||||
let put = putMVar mvar
|
|
||||||
wait = readMVar mvar
|
|
||||||
return (put, wait)
|
|
||||||
|
|
||||||
openTestSocket :: IO (Port, Socket)
|
|
||||||
openTestSocket = do
|
|
||||||
s <- socket AF_INET Stream defaultProtocol
|
|
||||||
localhost <- inet_addr "127.0.0.1"
|
|
||||||
bind s (SockAddrInet aNY_PORT localhost)
|
|
||||||
listen s 1
|
|
||||||
port <- socketPort s
|
|
||||||
return (fromIntegral port, s)
|
|
||||||
|
|
||||||
pathGen :: Gen String
|
|
||||||
pathGen = listOf $ elements $
|
|
||||||
filter (not . (`elem` "?%[]/#")) $
|
|
||||||
filter isPrint $
|
|
||||||
map chr [0..127]
|
|
||||||
|
|
@ -1,69 +0,0 @@
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
||||||
module Servant.Common.BaseUrlSpec where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.DeepSeq
|
|
||||||
import Test.Hspec
|
|
||||||
import Test.QuickCheck
|
|
||||||
|
|
||||||
import Servant.Common.BaseUrl
|
|
||||||
|
|
||||||
spec :: Spec
|
|
||||||
spec = do
|
|
||||||
describe "showBaseUrl" $ do
|
|
||||||
it "shows a BaseUrl" $ do
|
|
||||||
showBaseUrl (BaseUrl Http "foo.com" 80) `shouldBe` "http://foo.com"
|
|
||||||
|
|
||||||
it "shows a https BaseUrl" $ do
|
|
||||||
showBaseUrl (BaseUrl Https "foo.com" 443) `shouldBe` "https://foo.com"
|
|
||||||
|
|
||||||
describe "httpBaseUrl" $ do
|
|
||||||
it "allows to construct default http BaseUrls" $ do
|
|
||||||
BaseUrl Http "bar" 80 `shouldBe` BaseUrl Http "bar" 80
|
|
||||||
|
|
||||||
describe "parseBaseUrl" $ do
|
|
||||||
it "is total" $ do
|
|
||||||
property $ \ string ->
|
|
||||||
deepseq (fmap show (parseBaseUrl string)) True
|
|
||||||
|
|
||||||
it "is the inverse of showBaseUrl" $ do
|
|
||||||
property $ \ baseUrl ->
|
|
||||||
counterexample (showBaseUrl baseUrl) $
|
|
||||||
parseBaseUrl (showBaseUrl baseUrl) ===
|
|
||||||
Right baseUrl
|
|
||||||
|
|
||||||
it "allows trailing slashes" $ do
|
|
||||||
parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80)
|
|
||||||
|
|
||||||
context "urls without scheme" $ do
|
|
||||||
it "assumes http" $ do
|
|
||||||
parseBaseUrl "foo.com" `shouldBe` Right (BaseUrl Http "foo.com" 80)
|
|
||||||
|
|
||||||
it "allows port numbers" $ do
|
|
||||||
parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080)
|
|
||||||
|
|
||||||
it "rejects ftp urls" $ do
|
|
||||||
parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft
|
|
||||||
|
|
||||||
instance Arbitrary BaseUrl where
|
|
||||||
arbitrary = BaseUrl <$>
|
|
||||||
elements [Http, Https] <*>
|
|
||||||
hostNameGen <*>
|
|
||||||
portGen
|
|
||||||
where
|
|
||||||
-- this does not perfectly mirror the url standard, but I hope it's good
|
|
||||||
-- enough.
|
|
||||||
hostNameGen = do
|
|
||||||
let letters = ['a' .. 'z'] ++ ['A' .. 'Z']
|
|
||||||
first <- elements letters
|
|
||||||
middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-'])
|
|
||||||
last <- elements letters
|
|
||||||
return (first : middle ++ [last])
|
|
||||||
portGen = frequency $
|
|
||||||
(1, return 80) :
|
|
||||||
(1, return 443) :
|
|
||||||
(1, choose (1, 20000)) :
|
|
||||||
[]
|
|
||||||
|
|
||||||
isLeft :: Either a b -> Bool
|
|
||||||
isLeft = either (const True) (const False)
|
|
||||||
|
|
@ -29,7 +29,6 @@ import Servant.API.QueryParam
|
||||||
import Servant.API.Raw
|
import Servant.API.Raw
|
||||||
import Servant.API.Sub
|
import Servant.API.Sub
|
||||||
import Servant.API.Alternative
|
import Servant.API.Alternative
|
||||||
import Servant.Docs
|
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -43,8 +42,6 @@ data Person = Person {
|
||||||
|
|
||||||
instance ToJSON Person
|
instance ToJSON Person
|
||||||
instance FromJSON Person
|
instance FromJSON Person
|
||||||
instance ToSample Person where
|
|
||||||
toSample = Just alice
|
|
||||||
|
|
||||||
alice :: Person
|
alice :: Person
|
||||||
alice = Person "Alice" 42
|
alice = Person "Alice" 42
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue