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 DeriveGeneric #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
import Control.Concurrent (forkIO, killThread)
|
||||
import Control.Monad.Trans.Either
|
||||
import Data.Aeson
|
||||
import Data.Monoid
|
||||
import Data.Proxy
|
||||
|
|
@ -18,10 +13,7 @@ import GHC.Generics
|
|||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
|
||||
import Servant.API
|
||||
import Servant.Client
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
import Servant
|
||||
|
||||
-- * Example
|
||||
|
||||
|
|
@ -32,25 +24,6 @@ newtype Greet = Greet { msg :: Text }
|
|||
instance FromJSON Greet
|
||||
instance ToJSON Greet
|
||||
|
||||
-- We add some useful annotations to our captures,
|
||||
-- query parameters and request body to make the docs
|
||||
-- really helpful.
|
||||
instance ToCapture (Capture "name" Text) where
|
||||
toCapture _ = DocCapture "name" "name of the person to greet"
|
||||
|
||||
instance ToCapture (Capture "greetid" Text) where
|
||||
toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"
|
||||
|
||||
instance ToParam (QueryParam "capital" Bool) where
|
||||
toParam _ =
|
||||
DocQueryParam "capital"
|
||||
["true", "false"]
|
||||
"Get the greeting message in uppercase (true) or not (false). Default is false."
|
||||
Normal
|
||||
|
||||
instance ToSample Greet where
|
||||
toSample = Just $ Greet "Hello, haskeller!"
|
||||
|
||||
-- API specification
|
||||
type TestApi =
|
||||
-- GET /hello/:name?capital={true, false} returns a Greet as JSON
|
||||
|
|
@ -83,30 +56,11 @@ server = helloH :<|> postGreetH :<|> deleteGreetH
|
|||
|
||||
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,
|
||||
-- more precisely by the Servant.Server module.
|
||||
test :: Application
|
||||
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' comes from Network.Wai.Handler.Warp
|
||||
|
|
@ -115,21 +69,4 @@ runTestServer port = run port test
|
|||
|
||||
-- Put this all to work!
|
||||
main :: IO ()
|
||||
main = do
|
||||
-- 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
|
||||
main = runTestServer 8001
|
||||
|
|
|
|||
|
|
@ -26,40 +26,30 @@ library
|
|||
Servant.API.Raw
|
||||
Servant.API.ReqBody
|
||||
Servant.API.Sub
|
||||
Servant.Client
|
||||
Servant.Common.BaseUrl
|
||||
Servant.Common.Req
|
||||
Servant.Common.Text
|
||||
Servant.Docs
|
||||
Servant.QQ
|
||||
Servant.Server
|
||||
Servant.Utils.Links
|
||||
Servant.Utils.StaticFiles
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, either
|
||||
, aeson
|
||||
, attoparsec
|
||||
, bytestring
|
||||
, exceptions
|
||||
, string-conversions
|
||||
, split
|
||||
, http-client
|
||||
, either
|
||||
, http-types
|
||||
, network-uri >= 2.6
|
||||
, parsec
|
||||
, safe
|
||||
, split
|
||||
, string-conversions
|
||||
, system-filepath
|
||||
, template-haskell
|
||||
, text
|
||||
, transformers
|
||||
, wai
|
||||
, wai-app-static
|
||||
, warp
|
||||
, parsec
|
||||
, safe
|
||||
, transformers
|
||||
, template-haskell
|
||||
, text
|
||||
, system-filepath
|
||||
, lens
|
||||
, unordered-containers
|
||||
, hashable
|
||||
, system-filepath
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -O0 -Wall
|
||||
|
|
@ -75,7 +65,6 @@ executable greet
|
|||
, aeson
|
||||
, warp
|
||||
, wai
|
||||
, either
|
||||
, text
|
||||
|
||||
test-suite spec
|
||||
|
|
@ -89,13 +78,11 @@ test-suite spec
|
|||
base == 4.*
|
||||
, aeson
|
||||
, bytestring
|
||||
, deepseq
|
||||
, directory
|
||||
, either
|
||||
, exceptions
|
||||
, hspec == 2.*
|
||||
, hspec-wai
|
||||
, http-client
|
||||
, http-types
|
||||
, network >= 2.6
|
||||
, QuickCheck
|
||||
|
|
|
|||
|
|
@ -5,10 +5,6 @@ module Servant (
|
|||
module Servant.API,
|
||||
-- | For implementing servers for servant APIs.
|
||||
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
|
||||
module Servant.Common.Text,
|
||||
-- | Utilities on top of the servant core
|
||||
|
|
@ -21,9 +17,7 @@ module Servant (
|
|||
|
||||
import Data.Proxy
|
||||
import Servant.API
|
||||
import Servant.Client
|
||||
import Servant.Common.Text
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
import Servant.QQ
|
||||
import Servant.Utils.Links
|
||||
|
|
|
|||
|
|
@ -3,9 +3,8 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Servant.API.Alternative where
|
||||
|
||||
import Data.Monoid
|
||||
import Data.Proxy
|
||||
import Servant.Client
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
-- | 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
|
||||
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 Network.Wai
|
||||
import Servant.API.Sub
|
||||
import Servant.Client
|
||||
import Servant.Common.Req
|
||||
import Servant.Common.Text
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
-- | 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
|
||||
|
||||
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 Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Servant.Client
|
||||
import Servant.Common.Req
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
-- | Combinator for DELETE requests.
|
||||
|
|
@ -49,22 +46,3 @@ instance HasServer Delete where
|
|||
| null (pathInfo request) && requestMethod request /= methodDelete =
|
||||
respond $ failWith WrongMethod
|
||||
| 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 Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Servant.Client
|
||||
import Servant.Common.Req
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
-- | 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 =
|
||||
respond $ failWith WrongMethod
|
||||
| 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 Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Servant.Client
|
||||
import Servant.Common.Req
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
-- | 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 =
|
||||
respond $ failWith WrongMethod
|
||||
| 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 Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Servant.Client
|
||||
import Servant.Common.Req
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
-- | Endpoint for PUT requests, usually used to update a ressource.
|
||||
|
|
@ -53,24 +50,3 @@ instance ToJSON a => HasServer (Put a) where
|
|||
respond $ failWith WrongMethod
|
||||
|
||||
| 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 #-}
|
||||
module Servant.API.QueryParam where
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
|
|
@ -15,10 +14,7 @@ import GHC.TypeLits
|
|||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Servant.API.Sub
|
||||
import Servant.Client
|
||||
import Servant.Common.Req
|
||||
import Servant.Common.Text
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
-- | 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)
|
||||
|
||||
-- | 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
|
||||
-- and try to extract it as a value of type @[a]@. This is typically
|
||||
-- meant to support query string parameters of the form
|
||||
|
|
@ -173,57 +119,6 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
|
|||
convert Nothing = Nothing
|
||||
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
|
||||
-- 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'.
|
||||
|
|
@ -265,48 +160,3 @@ instance (KnownSymbol sym, HasServer sublayout)
|
|||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
examine v | v == "true" || v == "1" || v == "" = True
|
||||
| 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 #-}
|
||||
module Servant.API.Raw where
|
||||
|
||||
import Control.Monad.Trans.Either
|
||||
import Data.ByteString.Lazy
|
||||
import Data.Proxy
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Servant.Client
|
||||
import Servant.Common.Req
|
||||
import Servant.Docs hiding (Method)
|
||||
import Servant.Server
|
||||
|
||||
-- | Endpoint for plugging in your own Wai 'Application's.
|
||||
|
|
@ -36,17 +30,3 @@ instance HasServer Raw where
|
|||
type Server Raw = Application
|
||||
route Proxy rawApplication request respond =
|
||||
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 Network.Wai
|
||||
import Servant.API.Sub
|
||||
import Servant.Client
|
||||
import Servant.Common.Req
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
-- | Extract the request body as a value of type @a@.
|
||||
|
|
@ -50,42 +47,3 @@ instance (FromJSON a, HasServer sublayout)
|
|||
case mrqbody of
|
||||
Nothing -> respond $ failWith InvalidBody
|
||||
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 GHC.TypeLits
|
||||
import Network.Wai
|
||||
import Servant.Client
|
||||
import Servant.Common.Req
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
-- | 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
|
||||
|
||||
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
|
||||
-- and your API's docs.
|
||||
-- | This module defines a sever-side handler that lets you serve static files.
|
||||
--
|
||||
-- - 'serveDirectory' lets you serve anything that lives under a particular
|
||||
-- directory on your filesystem.
|
||||
-- - 'serveDocumentation' lets you serve the markdown-version of the docs for
|
||||
-- your API.
|
||||
module Servant.Utils.StaticFiles (
|
||||
serveDirectory,
|
||||
serveDocumentation,
|
||||
) where
|
||||
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import Filesystem.Path.CurrentOS (decodeString)
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Network.Wai.Application.Static
|
||||
|
||||
import Servant.API.Raw
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
-- | Serve anything under the specified directory as a 'Raw' endpoint.
|
||||
|
|
@ -44,28 +37,3 @@ import Servant.Server
|
|||
serveDirectory :: FilePath -> Server Raw
|
||||
serveDirectory 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.Sub
|
||||
import Servant.API.Alternative
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
|
||||
|
|
@ -43,8 +42,6 @@ data Person = Person {
|
|||
|
||||
instance ToJSON Person
|
||||
instance FromJSON Person
|
||||
instance ToSample Person where
|
||||
toSample = Just alice
|
||||
|
||||
alice :: Person
|
||||
alice = Person "Alice" 42
|
||||
|
|
|
|||
Loading…
Reference in a new issue