Merge remote-tracking branch 'origin' into tutorial
This commit is contained in:
Sönke Hahn
commit
57d0261fdf
25 changed files with 292 additions and 277 deletions
1
.ghci
1
.ghci
|
|
@ -1 +0,0 @@
|
|||
:set -itest -isrc -packagehspec2
|
||||
|
|
@ -6,7 +6,7 @@ HEAD
|
|||
* Added support for `path` on `BaseUrl`.
|
||||
* `client` now takes an explicit `Manager` argument.
|
||||
* Use `http-api-data` instead of `Servant.Common.Text`
|
||||
* Client functions now consider any 2xx succesful.
|
||||
* Client functions now consider any 2xx successful.
|
||||
* Remove matrix params.
|
||||
|
||||
0.4.1
|
||||
|
|
|
|||
|
|
@ -115,7 +115,7 @@ api :: Proxy Api
|
|||
api = Proxy
|
||||
|
||||
server :: Application
|
||||
server = serve api EmptyConfig (
|
||||
server = serve api (
|
||||
return alice
|
||||
:<|> return NoContent
|
||||
:<|> (\ name -> return $ Person name 0)
|
||||
|
|
@ -142,7 +142,7 @@ failApi :: Proxy FailApi
|
|||
failApi = Proxy
|
||||
|
||||
failServer :: Application
|
||||
failServer = serve failApi EmptyConfig (
|
||||
failServer = serve failApi (
|
||||
(\ _request respond -> respond $ responseLBS ok200 [] "")
|
||||
:<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
|
||||
:<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
|
||||
|
|
@ -232,7 +232,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
|||
|
||||
wrappedApiSpec :: Spec
|
||||
wrappedApiSpec = describe "error status codes" $ do
|
||||
let serveW api = serve api EmptyConfig $ throwE $ ServantErr 500 "error message" "" []
|
||||
let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
|
||||
context "are correctly handled by the client" $
|
||||
let test :: (WrappedApi, String) -> Spec
|
||||
test (WrappedApi api, desc) =
|
||||
|
|
|
|||
|
|
@ -2,3 +2,4 @@ HEAD
|
|||
-----
|
||||
* Use the `text` package instead of `String`.
|
||||
* Extract javascript-oblivious types and helpers to *servant-foreign*
|
||||
* Typed-languages support
|
||||
|
|
|
|||
|
|
@ -1,36 +1,50 @@
|
|||
-- | Generalizes all the data needed to make code generation work with
|
||||
-- arbitrary programming languages.
|
||||
module Servant.Foreign
|
||||
( HasForeign(..)
|
||||
, HasForeignType(..)
|
||||
( ArgType(..)
|
||||
, HeaderArg(..)
|
||||
, QueryArg(..)
|
||||
, Req(..)
|
||||
, Segment(..)
|
||||
, SegmentType(..)
|
||||
, Url(..)
|
||||
-- aliases
|
||||
, Path
|
||||
, ForeignType
|
||||
, Arg
|
||||
, FunctionName
|
||||
, QueryArg(..)
|
||||
, HeaderArg(..)
|
||||
, ArgType(..)
|
||||
, Req
|
||||
-- lenses
|
||||
, reqUrl
|
||||
, reqMethod
|
||||
, reqHeaders
|
||||
, reqBody
|
||||
, reqReturnType
|
||||
, reqFuncName
|
||||
, path
|
||||
, queryStr
|
||||
, argName
|
||||
, argType
|
||||
-- prisms
|
||||
, _HeaderArg
|
||||
, _ReplaceHeaderArg
|
||||
, _Static
|
||||
, _Cap
|
||||
, _Normal
|
||||
, _Flag
|
||||
, _List
|
||||
-- rest of it
|
||||
, HasForeign(..)
|
||||
, HasForeignType(..)
|
||||
, HasNoForeignType
|
||||
, GenerateList(..)
|
||||
, NoTypes
|
||||
, captureArg
|
||||
, defReq
|
||||
, isCapture
|
||||
, concatCase
|
||||
, snakeCase
|
||||
, camelCase
|
||||
-- lenses
|
||||
, argType
|
||||
, argName
|
||||
, isCapture
|
||||
, funcName
|
||||
, path
|
||||
, reqUrl
|
||||
, reqBody
|
||||
, reqHeaders
|
||||
, reqMethod
|
||||
, reqReturnType
|
||||
, segment
|
||||
, queryStr
|
||||
, defReq
|
||||
, listFromAPI
|
||||
, GenerateList(..)
|
||||
, NoTypes
|
||||
-- re-exports
|
||||
, module Servant.API
|
||||
) where
|
||||
|
|
|
|||
|
|
@ -19,17 +19,19 @@
|
|||
-- arbitrary programming languages.
|
||||
module Servant.Foreign.Internal where
|
||||
|
||||
import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))
|
||||
import qualified Data.Char as C
|
||||
import Control.Lens (makeLenses, makePrisms, (%~), (&), (.~), (<>~))
|
||||
import qualified Data.Char as C
|
||||
import Data.Proxy
|
||||
import Data.Text
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import GHC.Exts (Constraint)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import GHC.Exts (Constraint)
|
||||
import GHC.TypeLits
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Prelude hiding (concat)
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Prelude hiding (concat)
|
||||
import Servant.API
|
||||
|
||||
type FunctionName = [Text]
|
||||
|
||||
-- | Function name builder that simply concat each part together
|
||||
concatCase :: FunctionName -> Text
|
||||
concatCase = concat
|
||||
|
|
@ -49,36 +51,50 @@ camelCase = camelCase' . Prelude.map (replace "-" "")
|
|||
capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name
|
||||
|
||||
type ForeignType = Text
|
||||
|
||||
type Arg = (Text, ForeignType)
|
||||
|
||||
newtype Segment = Segment { _segment :: SegmentType }
|
||||
data SegmentType
|
||||
= Static Text
|
||||
-- ^ a static path segment. like "/foo"
|
||||
| Cap Arg
|
||||
-- ^ a capture. like "/:userid"
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SegmentType = Static Text -- ^ a static path segment. like "/foo"
|
||||
| Cap Arg -- ^ a capture. like "/:userid"
|
||||
makePrisms ''SegmentType
|
||||
|
||||
newtype Segment = Segment { unSegment :: SegmentType }
|
||||
deriving (Eq, Show)
|
||||
|
||||
makePrisms ''Segment
|
||||
|
||||
type Path = [Segment]
|
||||
|
||||
data ArgType =
|
||||
Normal
|
||||
data ArgType
|
||||
= Normal
|
||||
| Flag
|
||||
| List
|
||||
deriving (Eq, Show)
|
||||
|
||||
makePrisms ''ArgType
|
||||
|
||||
data QueryArg = QueryArg
|
||||
{ _argName :: Arg
|
||||
, _argType :: ArgType
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data HeaderArg = HeaderArg
|
||||
{ headerArg :: Arg
|
||||
}
|
||||
| ReplaceHeaderArg
|
||||
{ headerArg :: Arg
|
||||
, headerPattern :: Text
|
||||
} deriving (Eq, Show)
|
||||
makeLenses ''QueryArg
|
||||
|
||||
data HeaderArg = HeaderArg
|
||||
{ headerArg :: Arg }
|
||||
| ReplaceHeaderArg
|
||||
{ headerArg :: Arg
|
||||
, headerPattern :: Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
makeLenses ''HeaderArg
|
||||
|
||||
makePrisms ''HeaderArg
|
||||
|
||||
data Url = Url
|
||||
{ _path :: Path
|
||||
|
|
@ -88,7 +104,7 @@ data Url = Url
|
|||
defUrl :: Url
|
||||
defUrl = Url [] []
|
||||
|
||||
type FunctionName = [Text]
|
||||
makeLenses ''Url
|
||||
|
||||
data Req = Req
|
||||
{ _reqUrl :: Url
|
||||
|
|
@ -96,12 +112,9 @@ data Req = Req
|
|||
, _reqHeaders :: [HeaderArg]
|
||||
, _reqBody :: Maybe ForeignType
|
||||
, _reqReturnType :: ForeignType
|
||||
, _funcName :: FunctionName
|
||||
, _reqFuncName :: FunctionName
|
||||
} deriving (Eq, Show)
|
||||
|
||||
makeLenses ''QueryArg
|
||||
makeLenses ''Segment
|
||||
makeLenses ''Url
|
||||
makeLenses ''Req
|
||||
|
||||
isCapture :: Segment -> Bool
|
||||
|
|
@ -155,66 +168,66 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where
|
|||
-- >
|
||||
--
|
||||
class HasForeignType lang a where
|
||||
typeFor :: Proxy lang -> Proxy a -> ForeignType
|
||||
typeFor :: Proxy lang -> Proxy a -> ForeignType
|
||||
|
||||
data NoTypes
|
||||
|
||||
instance HasForeignType NoTypes a where
|
||||
typeFor _ _ = empty
|
||||
instance HasForeignType NoTypes ftype where
|
||||
typeFor _ _ = empty
|
||||
|
||||
type HasNoForeignType = HasForeignType NoTypes
|
||||
|
||||
class HasForeign lang (layout :: *) where
|
||||
type Foreign layout :: *
|
||||
foreignFor :: Proxy lang -> Proxy layout -> Req -> Foreign layout
|
||||
|
||||
instance (HasForeign lang a, HasForeign lang b)
|
||||
=> HasForeign lang (a :<|> b) where
|
||||
=> HasForeign lang (a :<|> b) where
|
||||
type Foreign (a :<|> b) = Foreign a :<|> Foreign b
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
foreignFor lang (Proxy :: Proxy a) req
|
||||
:<|> foreignFor lang (Proxy :: Proxy b) req
|
||||
|
||||
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
|
||||
=> HasForeign lang (Capture sym a :> sublayout) where
|
||||
instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout)
|
||||
=> HasForeign lang (Capture sym ftype :> sublayout) where
|
||||
type Foreign (Capture sym a :> sublayout) = Foreign sublayout
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
foreignFor lang (Proxy :: Proxy sublayout) $
|
||||
req & reqUrl.path <>~ [Segment (Cap arg)]
|
||||
& funcName %~ (++ ["by", str])
|
||||
|
||||
& reqFuncName %~ (++ ["by", str])
|
||||
where
|
||||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
arg = (str, typeFor lang (Proxy :: Proxy a))
|
||||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
arg = (str, typeFor lang (Proxy :: Proxy ftype))
|
||||
|
||||
instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
|
||||
=> HasForeign lang (Verb method status list a) where
|
||||
=> HasForeign lang (Verb method status list a) where
|
||||
type Foreign (Verb method status list a) = Req
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
req & funcName %~ (methodLC :)
|
||||
req & reqFuncName %~ (methodLC :)
|
||||
& reqMethod .~ method
|
||||
& reqReturnType .~ retType
|
||||
where
|
||||
retType = typeFor lang (Proxy :: Proxy a)
|
||||
method = reflectMethod (Proxy :: Proxy method)
|
||||
methodLC = toLower $ decodeUtf8 method
|
||||
retType = typeFor lang (Proxy :: Proxy a)
|
||||
method = reflectMethod (Proxy :: Proxy method)
|
||||
methodLC = toLower $ decodeUtf8 method
|
||||
|
||||
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
|
||||
=> HasForeign lang (Header sym a :> sublayout) where
|
||||
=> HasForeign lang (Header sym a :> sublayout) where
|
||||
type Foreign (Header sym a :> sublayout) = Foreign sublayout
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
foreignFor lang subP $ req
|
||||
& reqHeaders <>~ [HeaderArg arg]
|
||||
|
||||
where
|
||||
hname = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
arg = (hname, typeFor lang (Proxy :: Proxy a))
|
||||
subP = Proxy :: Proxy sublayout
|
||||
hname = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
arg = (hname, typeFor lang (Proxy :: Proxy a))
|
||||
subP = Proxy :: Proxy sublayout
|
||||
|
||||
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
|
||||
=> HasForeign lang (QueryParam sym a :> sublayout) where
|
||||
=> HasForeign lang (QueryParam sym a :> sublayout) where
|
||||
type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
|
|
@ -222,38 +235,37 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
|
|||
req & reqUrl.queryStr <>~ [QueryArg arg Normal]
|
||||
|
||||
where
|
||||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
arg = (str, typeFor lang (Proxy :: Proxy a))
|
||||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
arg = (str, typeFor lang (Proxy :: Proxy a))
|
||||
|
||||
instance (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout)
|
||||
=> HasForeign lang (QueryParams sym a :> sublayout) where
|
||||
instance
|
||||
(KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout)
|
||||
=> HasForeign lang (QueryParams sym a :> sublayout) where
|
||||
type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
foreignFor lang (Proxy :: Proxy sublayout) $
|
||||
req & reqUrl.queryStr <>~ [QueryArg arg List]
|
||||
|
||||
where
|
||||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
arg = (str, typeFor lang (Proxy :: Proxy [a]))
|
||||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
arg = (str, typeFor lang (Proxy :: Proxy [a]))
|
||||
|
||||
instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang sublayout)
|
||||
=> HasForeign lang (QueryFlag sym :> sublayout) where
|
||||
instance
|
||||
(KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout)
|
||||
=> HasForeign lang (QueryFlag sym :> sublayout) where
|
||||
type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
foreignFor lang (Proxy :: Proxy sublayout) $
|
||||
req & reqUrl.queryStr <>~ [QueryArg arg Flag]
|
||||
|
||||
where
|
||||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
arg = (str, typeFor lang (Proxy :: Proxy a))
|
||||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
arg = (str, typeFor lang (Proxy :: Proxy Bool))
|
||||
|
||||
instance HasForeign lang Raw where
|
||||
type Foreign Raw = HTTP.Method -> Req
|
||||
|
||||
foreignFor _ Proxy req method =
|
||||
req & funcName %~ ((toLower $ decodeUtf8 method) :)
|
||||
req & reqFuncName %~ ((toLower $ decodeUtf8 method) :)
|
||||
& reqMethod .~ method
|
||||
|
||||
instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout)
|
||||
|
|
@ -271,19 +283,21 @@ instance (KnownSymbol path, HasForeign lang sublayout)
|
|||
foreignFor lang Proxy req =
|
||||
foreignFor lang (Proxy :: Proxy sublayout) $
|
||||
req & reqUrl.path <>~ [Segment (Static str)]
|
||||
& funcName %~ (++ [str])
|
||||
|
||||
& reqFuncName %~ (++ [str])
|
||||
where
|
||||
str = Data.Text.map (\c -> if c == '.' then '_' else c)
|
||||
. pack . symbolVal $ (Proxy :: Proxy path)
|
||||
str =
|
||||
Data.Text.map (\c -> if c == '.' then '_' else c)
|
||||
. pack . symbolVal $ (Proxy :: Proxy path)
|
||||
|
||||
instance HasForeign lang sublayout => HasForeign lang (RemoteHost :> sublayout) where
|
||||
instance HasForeign lang sublayout
|
||||
=> HasForeign lang (RemoteHost :> sublayout) where
|
||||
type Foreign (RemoteHost :> sublayout) = Foreign sublayout
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
foreignFor lang (Proxy :: Proxy sublayout) req
|
||||
|
||||
instance HasForeign lang sublayout => HasForeign lang (IsSecure :> sublayout) where
|
||||
instance HasForeign lang sublayout
|
||||
=> HasForeign lang (IsSecure :> sublayout) where
|
||||
type Foreign (IsSecure :> sublayout) = Foreign sublayout
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
|
|
@ -302,7 +316,8 @@ instance HasForeign lang sublayout =>
|
|||
|
||||
foreignFor lang Proxy = foreignFor lang (Proxy :: Proxy sublayout)
|
||||
|
||||
instance HasForeign lang sublayout => HasForeign lang (HttpVersion :> sublayout) where
|
||||
instance HasForeign lang sublayout
|
||||
=> HasForeign lang (HttpVersion :> sublayout) where
|
||||
type Foreign (HttpVersion :> sublayout) = Foreign sublayout
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
|
|
@ -317,10 +332,15 @@ class GenerateList reqs where
|
|||
instance GenerateList Req where
|
||||
generateList r = [r]
|
||||
|
||||
instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> rest) where
|
||||
instance (GenerateList start, GenerateList rest)
|
||||
=> GenerateList (start :<|> rest) where
|
||||
generateList (start :<|> rest) = (generateList start) ++ (generateList rest)
|
||||
|
||||
-- | Generate the necessary data for codegen as a list, each 'Req'
|
||||
-- describing one endpoint from your API type.
|
||||
listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req]
|
||||
listFromAPI
|
||||
:: (HasForeign lang api, GenerateList (Foreign api))
|
||||
=> Proxy lang
|
||||
-> Proxy api
|
||||
-> [Req]
|
||||
listFromAPI lang p = generateList (foreignFor lang p defReq)
|
||||
|
|
|
|||
|
|
@ -15,7 +15,6 @@ module Servant.ForeignSpec where
|
|||
import Data.Monoid ((<>))
|
||||
import Data.Proxy
|
||||
import Servant.Foreign
|
||||
import Servant.Foreign.Internal
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
|
|
@ -35,15 +34,19 @@ camelCaseSpec = describe "camelCase" $ do
|
|||
data LangX
|
||||
|
||||
instance HasForeignType LangX () where
|
||||
typeFor _ _ = "voidX"
|
||||
typeFor _ _ = "voidX"
|
||||
|
||||
instance HasForeignType LangX Int where
|
||||
typeFor _ _ = "intX"
|
||||
typeFor _ _ = "intX"
|
||||
|
||||
instance HasForeignType LangX Bool where
|
||||
typeFor _ _ = "boolX"
|
||||
typeFor _ _ = "boolX"
|
||||
|
||||
instance OVERLAPPING_ HasForeignType LangX String where
|
||||
typeFor _ _ = "stringX"
|
||||
typeFor _ _ = "stringX"
|
||||
|
||||
instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where
|
||||
typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a)
|
||||
typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a)
|
||||
|
||||
type TestApi
|
||||
= "test" :> Header "header" [String] :> QueryFlag "flag" :> Get '[JSON] Int
|
||||
|
|
@ -56,58 +59,57 @@ testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy TestApi)
|
|||
|
||||
listFromAPISpec :: Spec
|
||||
listFromAPISpec = describe "listFromAPI" $ do
|
||||
it "generates 4 endpoints for TestApi" $ do
|
||||
length testApi `shouldBe` 4
|
||||
it "generates 4 endpoints for TestApi" $ do
|
||||
length testApi `shouldBe` 4
|
||||
|
||||
let [getReq, postReq, putReq, deleteReq] = testApi
|
||||
let [getReq, postReq, putReq, deleteReq] = testApi
|
||||
|
||||
it "collects all info for get request" $ do
|
||||
shouldBe getReq $ defReq
|
||||
{ _reqUrl = Url
|
||||
[ Segment $ Static "test" ]
|
||||
[ QueryArg ("flag", "boolX") Flag ]
|
||||
, _reqMethod = "GET"
|
||||
, _reqHeaders = [HeaderArg ("header", "listX of stringX")]
|
||||
, _reqBody = Nothing
|
||||
, _reqReturnType = "intX"
|
||||
, _funcName = ["get", "test"]
|
||||
}
|
||||
it "collects all info for get request" $ do
|
||||
shouldBe getReq $ defReq
|
||||
{ _reqUrl = Url
|
||||
[ Segment $ Static "test" ]
|
||||
[ QueryArg ("flag", "boolX") Flag ]
|
||||
, _reqMethod = "GET"
|
||||
, _reqHeaders = [HeaderArg ("header", "listX of stringX")]
|
||||
, _reqBody = Nothing
|
||||
, _reqReturnType = "intX"
|
||||
, _reqFuncName = ["get", "test"]
|
||||
}
|
||||
|
||||
it "collects all info for post request" $ do
|
||||
shouldBe postReq $ defReq
|
||||
{ _reqUrl = Url
|
||||
[ Segment $ Static "test" ]
|
||||
[ QueryArg ("param", "intX") Normal ]
|
||||
, _reqMethod = "POST"
|
||||
, _reqHeaders = []
|
||||
, _reqBody = Just "listX of stringX"
|
||||
, _reqReturnType = "voidX"
|
||||
, _funcName = ["post", "test"]
|
||||
}
|
||||
it "collects all info for post request" $ do
|
||||
shouldBe postReq $ defReq
|
||||
{ _reqUrl = Url
|
||||
[ Segment $ Static "test" ]
|
||||
[ QueryArg ("param", "intX") Normal ]
|
||||
, _reqMethod = "POST"
|
||||
, _reqHeaders = []
|
||||
, _reqBody = Just "listX of stringX"
|
||||
, _reqReturnType = "voidX"
|
||||
, _reqFuncName = ["post", "test"]
|
||||
}
|
||||
|
||||
it "collects all info for put request" $ do
|
||||
shouldBe putReq $ defReq
|
||||
{ _reqUrl = Url
|
||||
[ Segment $ Static "test" ]
|
||||
-- Shoud this be |intX| or |listX of intX| ?
|
||||
[ QueryArg ("params", "listX of intX") List ]
|
||||
, _reqMethod = "PUT"
|
||||
, _reqHeaders = []
|
||||
, _reqBody = Just "stringX"
|
||||
, _reqReturnType = "voidX"
|
||||
, _funcName = ["put", "test"]
|
||||
}
|
||||
|
||||
it "collects all info for delete request" $ do
|
||||
shouldBe deleteReq $ defReq
|
||||
{ _reqUrl = Url
|
||||
[ Segment $ Static "test"
|
||||
, Segment $ Cap ("id", "intX") ]
|
||||
[]
|
||||
, _reqMethod = "DELETE"
|
||||
, _reqHeaders = []
|
||||
, _reqBody = Nothing
|
||||
, _reqReturnType = "voidX"
|
||||
, _funcName = ["delete", "test", "by", "id"]
|
||||
}
|
||||
it "collects all info for put request" $ do
|
||||
shouldBe putReq $ defReq
|
||||
{ _reqUrl = Url
|
||||
[ Segment $ Static "test" ]
|
||||
-- Shoud this be |intX| or |listX of intX| ?
|
||||
[ QueryArg ("params", "listX of intX") List ]
|
||||
, _reqMethod = "PUT"
|
||||
, _reqHeaders = []
|
||||
, _reqBody = Just "stringX"
|
||||
, _reqReturnType = "voidX"
|
||||
, _reqFuncName = ["put", "test"]
|
||||
}
|
||||
|
||||
it "collects all info for delete request" $ do
|
||||
shouldBe deleteReq $ defReq
|
||||
{ _reqUrl = Url
|
||||
[ Segment $ Static "test"
|
||||
, Segment $ Cap ("id", "intX") ]
|
||||
[]
|
||||
, _reqMethod = "DELETE"
|
||||
, _reqHeaders = []
|
||||
, _reqBody = Nothing
|
||||
, _reqReturnType = "voidX"
|
||||
, _reqFuncName = ["delete", "test", "by", "id"]
|
||||
}
|
||||
|
|
|
|||
|
|
@ -128,7 +128,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>
|
|||
|
||||
fsep = if hasService then ":" else " ="
|
||||
|
||||
fname = namespace <> (functionNameBuilder opts $ req ^. funcName)
|
||||
fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName)
|
||||
|
||||
method = req ^. reqMethod
|
||||
url = if url' == "'" then "'/'" else url'
|
||||
|
|
|
|||
|
|
@ -116,7 +116,7 @@ generateAxiosJSWith aopts opts req = "\n" <>
|
|||
where
|
||||
hasNoModule = moduleName opts == ""
|
||||
|
||||
fname = namespace <> (functionNameBuilder opts $ req ^. funcName)
|
||||
fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName)
|
||||
|
||||
method = T.toLower . decodeUtf8 $ req ^. reqMethod
|
||||
url = if url' == "'" then "'/'" else url'
|
||||
|
|
|
|||
|
|
@ -51,12 +51,19 @@ type JavaScriptGenerator = [Req] -> Text
|
|||
-- customize the output
|
||||
data CommonGeneratorOptions = CommonGeneratorOptions
|
||||
{
|
||||
functionNameBuilder :: FunctionName -> Text -- ^ function generating function names
|
||||
, requestBody :: Text -- ^ name used when a user want to send the request body (to let you redefine it)
|
||||
, successCallback :: Text -- ^ name of the callback parameter when the request was successful
|
||||
, errorCallback :: Text -- ^ name of the callback parameter when the request reported an error
|
||||
, moduleName :: Text -- ^ namespace on which we define the foreign function (empty mean local var)
|
||||
, urlPrefix :: Text -- ^ a prefix we should add to the Url in the codegen
|
||||
functionNameBuilder :: FunctionName -> Text
|
||||
-- ^ function generating function names
|
||||
, requestBody :: Text
|
||||
-- ^ name used when a user want to send the request body
|
||||
-- (to let you redefine it)
|
||||
, successCallback :: Text
|
||||
-- ^ name of the callback parameter when the request was successful
|
||||
, errorCallback :: Text
|
||||
-- ^ name of the callback parameter when the request reported an error
|
||||
, moduleName :: Text
|
||||
-- ^ namespace on which we define the foreign function (empty mean local var)
|
||||
, urlPrefix :: Text
|
||||
-- ^ a prefix we should add to the Url in the codegen
|
||||
}
|
||||
|
||||
-- | Default options.
|
||||
|
|
|
|||
|
|
@ -81,7 +81,7 @@ generateJQueryJSWith opts req = "\n" <>
|
|||
namespace = if (moduleName opts) == ""
|
||||
then "var "
|
||||
else (moduleName opts) <> "."
|
||||
fname = namespace <> (functionNameBuilder opts $ req ^. funcName)
|
||||
fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName)
|
||||
|
||||
method = req ^. reqMethod
|
||||
url = if url' == "'" then "'/'" else url'
|
||||
|
|
|
|||
|
|
@ -93,7 +93,7 @@ generateVanillaJSWith opts req = "\n" <>
|
|||
namespace = if moduleName opts == ""
|
||||
then "var "
|
||||
else (moduleName opts) <> "."
|
||||
fname = namespace <> (functionNameBuilder opts $ req ^. funcName)
|
||||
fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName)
|
||||
|
||||
method = req ^. reqMethod
|
||||
url = if url' == "'" then "'/'" else url'
|
||||
|
|
|
|||
|
|
@ -20,4 +20,4 @@ api :: Proxy API
|
|||
api = Proxy
|
||||
|
||||
main :: IO ()
|
||||
main = run 8080 (serve api EmptyConfig $ mock api Proxy)
|
||||
main = run 8080 (serve api $ mock api Proxy)
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
#include "overlapping-compat.h"
|
||||
|
|
@ -67,7 +67,6 @@ import Network.HTTP.Types.Status
|
|||
import Network.Wai
|
||||
import Servant
|
||||
import Servant.API.ContentTypes
|
||||
import Servant.Server.Internal.Config
|
||||
import Test.QuickCheck.Arbitrary (Arbitrary (..), vector)
|
||||
import Test.QuickCheck.Gen (Gen, generate)
|
||||
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ spec = do
|
|||
context "Get" $ do
|
||||
let api :: Proxy (Get '[JSON] Body)
|
||||
api = Proxy
|
||||
app = serve api EmptyConfig (mock api Proxy)
|
||||
app = serve api (mock api Proxy)
|
||||
with (return app) $ do
|
||||
it "serves arbitrary response bodies" $ do
|
||||
get "/" `shouldRespondWith` 200{
|
||||
|
|
@ -65,7 +65,7 @@ spec = do
|
|||
withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body))
|
||||
withoutHeader = Proxy
|
||||
toApp :: (HasMock api '[]) => Proxy api -> IO Application
|
||||
toApp api = return $ serve api EmptyConfig (mock api (Proxy :: Proxy '[]))
|
||||
toApp api = return $ serve api (mock api (Proxy :: Proxy '[]))
|
||||
with (toApp withHeader) $ do
|
||||
it "serves arbitrary response bodies" $ do
|
||||
get "/" `shouldRespondWith` 200{
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ server = helloH :<|> postGreetH :<|> deleteGreetH
|
|||
-- Turn the server into a WAI app. 'serve' is provided by servant,
|
||||
-- more precisely by the Servant.Server module.
|
||||
test :: Application
|
||||
test = serve testApi EmptyConfig server
|
||||
test = serve testApi server
|
||||
|
||||
-- Run the server.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
|
@ -8,6 +9,7 @@
|
|||
module Servant.Server
|
||||
( -- * Run a wai application from an API
|
||||
serve
|
||||
, serveWithConfig
|
||||
|
||||
, -- * Construct a wai Application from an API
|
||||
toApplication
|
||||
|
|
@ -104,18 +106,18 @@ import Servant.Server.Internal.Enter
|
|||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > config :: Config '[]
|
||||
-- > config = EmptyConfig
|
||||
-- >
|
||||
-- > app :: Application
|
||||
-- > app = serve myApi config server
|
||||
-- > app = serve myApi server
|
||||
-- >
|
||||
-- > main :: IO ()
|
||||
-- > main = Network.Wai.Handler.Warp.run 8080 app
|
||||
--
|
||||
serve :: (HasServer layout config)
|
||||
serve :: (HasServer layout '[]) => Proxy layout -> Server layout -> Application
|
||||
serve p = serveWithConfig p EmptyConfig
|
||||
|
||||
serveWithConfig :: (HasServer layout config)
|
||||
=> Proxy layout -> Config config -> Server layout -> Application
|
||||
serve p config server = toApplication (runRouter (route p config d))
|
||||
serveWithConfig p config server = toApplication (runRouter (route p config d))
|
||||
where
|
||||
d = Delayed r r r (\ _ _ -> Route server)
|
||||
r = return (Route ())
|
||||
|
|
|
|||
|
|
@ -158,7 +158,7 @@ methodCheck method request
|
|||
acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())
|
||||
acceptCheck proxy accH
|
||||
| canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()
|
||||
| otherwise = return $ Fail err406
|
||||
| otherwise = return $ FailFatal err406
|
||||
|
||||
methodRouter :: (AllCTRender ctypes a)
|
||||
=> Method -> Proxy ctypes -> Status
|
||||
|
|
|
|||
|
|
@ -11,14 +11,8 @@ module Servant.Server.Internal.RoutingApplication where
|
|||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad.Trans.Except (ExceptT, runExceptT)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.IORef (newIORef, readIORef,
|
||||
writeIORef)
|
||||
import Network.Wai (Application, Request,
|
||||
Response, ResponseReceived,
|
||||
requestBody,
|
||||
strictRequestBody)
|
||||
Response, ResponseReceived)
|
||||
import Servant.Server.Internal.ServantErr
|
||||
|
||||
type RoutingApplication =
|
||||
|
|
@ -33,34 +27,8 @@ data RouteResult a =
|
|||
| Route !a
|
||||
deriving (Eq, Show, Read, Functor)
|
||||
|
||||
data ReqBodyState = Uncalled
|
||||
| Called !B.ByteString
|
||||
| Done !B.ByteString
|
||||
|
||||
toApplication :: RoutingApplication -> Application
|
||||
toApplication ra request respond = do
|
||||
reqBodyRef <- newIORef Uncalled
|
||||
-- We may need to consume the requestBody more than once. In order to
|
||||
-- maintain the illusion that 'requestBody' works as expected,
|
||||
-- 'ReqBodyState' is introduced, and the complete body is memoized and
|
||||
-- returned as many times as requested with empty "Done" marker chunks in
|
||||
-- between.
|
||||
-- See https://github.com/haskell-servant/servant/issues/3
|
||||
let memoReqBody = do
|
||||
ior <- readIORef reqBodyRef
|
||||
case ior of
|
||||
Uncalled -> do
|
||||
r <- BL.toStrict <$> strictRequestBody request
|
||||
writeIORef reqBodyRef $ Done r
|
||||
return r
|
||||
Called bs -> do
|
||||
writeIORef reqBodyRef $ Done bs
|
||||
return bs
|
||||
Done bs -> do
|
||||
writeIORef reqBodyRef $ Called bs
|
||||
return B.empty
|
||||
|
||||
ra request{ requestBody = memoReqBody } routingRespond
|
||||
toApplication ra request respond = ra request routingRespond
|
||||
where
|
||||
routingRespond :: RouteResult Response -> IO ResponseReceived
|
||||
routingRespond (Fail err) = respond $ responseServantErr err
|
||||
|
|
@ -98,10 +66,10 @@ toApplication ra request respond = do
|
|||
--
|
||||
-- There are two reasons:
|
||||
--
|
||||
-- 1. Currently, the order in which we perform checks coincides
|
||||
-- with the error we will generate. This is because during checks,
|
||||
-- once an error occurs, we do not perform any subsequent checks,
|
||||
-- but rather return this error.
|
||||
-- 1. In a straight-forward implementation, the order in which we
|
||||
-- perform checks will determine the error we generate. This is
|
||||
-- because once an error occurs, we would abort and not perform
|
||||
-- any subsequent checks, but rather return the current error.
|
||||
--
|
||||
-- This is not a necessity: we could continue doing other checks,
|
||||
-- and choose the preferred error. However, that would in general
|
||||
|
|
@ -159,7 +127,7 @@ data Delayed :: * -> * where
|
|||
-> Delayed c
|
||||
|
||||
instance Functor Delayed where
|
||||
fmap f (Delayed a b c g) = Delayed a b c ((fmap.fmap.fmap) f g)
|
||||
fmap f (Delayed a b c g) = Delayed a b c ((fmap . fmap . fmap) f g)
|
||||
|
||||
-- | Add a capture to the end of the capture block.
|
||||
addCapture :: Delayed (a -> b)
|
||||
|
|
@ -240,9 +208,9 @@ runAction :: Delayed (ExceptT ServantErr IO a)
|
|||
-> IO r
|
||||
runAction action respond k = runDelayed action >>= go >>= respond
|
||||
where
|
||||
go (Fail e) = return $ Fail e
|
||||
go (Fail e) = return $ Fail e
|
||||
go (FailFatal e) = return $ FailFatal e
|
||||
go (Route a) = do
|
||||
go (Route a) = do
|
||||
e <- runExceptT a
|
||||
case e of
|
||||
Left err -> return . Route $ responseServantErr err
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ errorOrderServer = \_ _ -> throwE err402
|
|||
|
||||
errorOrderSpec :: Spec
|
||||
errorOrderSpec = describe "HTTP error order"
|
||||
$ with (return $ serve errorOrderApi EmptyConfig errorOrderServer) $ do
|
||||
$ with (return $ serve errorOrderApi errorOrderServer) $ do
|
||||
let badContentType = (hContentType, "text/plain")
|
||||
badAccept = (hAccept, "text/plain")
|
||||
badMethod = methodGet
|
||||
|
|
@ -89,7 +89,7 @@ prioErrorsApi = Proxy
|
|||
prioErrorsSpec :: Spec
|
||||
prioErrorsSpec = describe "PrioErrors" $ do
|
||||
let server = return
|
||||
with (return $ serve prioErrorsApi EmptyConfig server) $ do
|
||||
with (return $ serve prioErrorsApi server) $ do
|
||||
let check (mdescr, method) path (cdescr, ctype, body) resp =
|
||||
it fulldescr $
|
||||
Test.Hspec.Wai.request method path [(hContentType, ctype)] body
|
||||
|
|
@ -154,7 +154,7 @@ errorRetryServer
|
|||
|
||||
errorRetrySpec :: Spec
|
||||
errorRetrySpec = describe "Handler search"
|
||||
$ with (return $ serve errorRetryApi EmptyConfig errorRetryServer) $ do
|
||||
$ with (return $ serve errorRetryApi errorRetryServer) $ do
|
||||
|
||||
let jsonCT = (hContentType, "application/json")
|
||||
jsonAccept = (hAccept, "application/json")
|
||||
|
|
@ -168,6 +168,10 @@ errorRetrySpec = describe "Handler search"
|
|||
request methodGet "a" [jsonCT, jsonAccept] jsonBody
|
||||
`shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }
|
||||
|
||||
it "should not continue when body cannot be decoded" $ do
|
||||
request methodPost "a" [jsonCT, jsonAccept] "a string"
|
||||
`shouldRespondWith` 400
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Error Choice {{{
|
||||
|
|
@ -194,7 +198,7 @@ errorChoiceServer = return 0
|
|||
|
||||
errorChoiceSpec :: Spec
|
||||
errorChoiceSpec = describe "Multiple handlers return errors"
|
||||
$ with (return $ serve errorChoiceApi EmptyConfig errorChoiceServer) $ do
|
||||
$ with (return $ serve errorChoiceApi errorChoiceServer) $ do
|
||||
|
||||
it "should respond with 404 if no path matches" $ do
|
||||
request methodGet "" [] "" `shouldRespondWith` 404
|
||||
|
|
|
|||
|
|
@ -48,12 +48,12 @@ combinedReaderServer = enter fReader combinedReaderServer'
|
|||
|
||||
enterSpec :: Spec
|
||||
enterSpec = describe "Enter" $ do
|
||||
with (return (serve readerAPI EmptyConfig readerServer)) $ do
|
||||
with (return (serve readerAPI readerServer)) $ do
|
||||
|
||||
it "allows running arbitrary monads" $ do
|
||||
get "int" `shouldRespondWith` "1797"
|
||||
post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }
|
||||
|
||||
with (return (serve combinedAPI EmptyConfig combinedReaderServer)) $ do
|
||||
with (return (serve combinedAPI combinedReaderServer)) $ do
|
||||
it "allows combnation of enters" $ do
|
||||
get "bool" `shouldRespondWith` "true"
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ testServer s = return s
|
|||
|
||||
oneEntryApp :: Application
|
||||
oneEntryApp =
|
||||
serve (Proxy :: Proxy OneEntryAPI) config testServer
|
||||
serveWithConfig (Proxy :: Proxy OneEntryAPI) config testServer
|
||||
where
|
||||
config :: Config '[String]
|
||||
config = "configEntry" :. EmptyConfig
|
||||
|
|
@ -40,7 +40,7 @@ type OneEntryTwiceAPI =
|
|||
"bar" :> ExtractFromConfig :> Get '[JSON] String
|
||||
|
||||
oneEntryTwiceApp :: Application
|
||||
oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $
|
||||
oneEntryTwiceApp = serveWithConfig (Proxy :: Proxy OneEntryTwiceAPI) config $
|
||||
testServer :<|>
|
||||
testServer
|
||||
where
|
||||
|
|
@ -68,7 +68,7 @@ type InjectAPI =
|
|||
Get '[JSON] String
|
||||
|
||||
injectApp :: Application
|
||||
injectApp = serve (Proxy :: Proxy InjectAPI) config $
|
||||
injectApp = serveWithConfig (Proxy :: Proxy InjectAPI) config $
|
||||
(\ s -> return s) :<|>
|
||||
(\ s -> return ("tagged: " ++ s))
|
||||
where
|
||||
|
|
@ -90,7 +90,7 @@ type WithBirdfaceAPI =
|
|||
"bar" :> ExtractFromConfig :> Get '[JSON] String
|
||||
|
||||
withBirdfaceApp :: Application
|
||||
withBirdfaceApp = serve (Proxy :: Proxy WithBirdfaceAPI) config $
|
||||
withBirdfaceApp = serveWithConfig (Proxy :: Proxy WithBirdfaceAPI) config $
|
||||
testServer :<|>
|
||||
testServer
|
||||
where
|
||||
|
|
@ -112,7 +112,7 @@ type NamedConfigAPI =
|
|||
ExtractFromConfig :> Get '[JSON] String)
|
||||
|
||||
namedConfigApp :: Application
|
||||
namedConfigApp = serve (Proxy :: Proxy NamedConfigAPI) config return
|
||||
namedConfigApp = serveWithConfig (Proxy :: Proxy NamedConfigAPI) config return
|
||||
where
|
||||
config :: Config '[NamedConfig "sub" '[String]]
|
||||
config = NamedConfig ("descend" :. EmptyConfig) :. EmptyConfig
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,
|
|||
StdMethod (..), Verb, addHeader)
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||
import Servant.Server (ServantErr (..), Server, err404,
|
||||
serve, Config(EmptyConfig))
|
||||
serve, serveWithConfig, Config(EmptyConfig))
|
||||
import Test.Hspec (Spec, context, describe, it,
|
||||
shouldBe, shouldContain)
|
||||
import Test.Hspec.Wai (get, liftIO, matchHeaders,
|
||||
|
|
@ -67,7 +67,7 @@ import Servant.Server.Internal.Config
|
|||
-- * comprehensive api test
|
||||
|
||||
-- This declaration simply checks that all instances are in place.
|
||||
_ = serve comprehensiveAPI comprehensiveApiConfig
|
||||
_ = serveWithConfig comprehensiveAPI comprehensiveApiConfig
|
||||
|
||||
comprehensiveApiConfig :: Config '[NamedConfig "foo" '[]]
|
||||
comprehensiveApiConfig = NamedConfig EmptyConfig :. EmptyConfig
|
||||
|
|
@ -112,7 +112,7 @@ verbSpec = describe "Servant.API.Verb" $ do
|
|||
wrongMethod m = if m == methodPatch then methodPost else methodPatch
|
||||
test desc api method (status :: Int) = context desc $
|
||||
|
||||
with (return $ serve api EmptyConfig server) $ do
|
||||
with (return $ serve api server) $ do
|
||||
|
||||
-- HEAD and 214/215 need not return bodies
|
||||
unless (status `elem` [214, 215] || method == methodHead) $
|
||||
|
|
@ -187,7 +187,7 @@ captureServer legs = case legs of
|
|||
captureSpec :: Spec
|
||||
captureSpec = do
|
||||
describe "Servant.API.Capture" $ do
|
||||
with (return (serve captureApi EmptyConfig captureServer)) $ do
|
||||
with (return (serve captureApi captureServer)) $ do
|
||||
|
||||
it "can capture parts of the 'pathInfo'" $ do
|
||||
response <- get "/2"
|
||||
|
|
@ -198,7 +198,6 @@ captureSpec = do
|
|||
|
||||
with (return (serve
|
||||
(Proxy :: Proxy (Capture "captured" String :> Raw))
|
||||
EmptyConfig
|
||||
(\ "captured" request_ respond ->
|
||||
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
|
||||
it "strips the captured path snippet from pathInfo" $ do
|
||||
|
|
@ -232,7 +231,7 @@ queryParamSpec :: Spec
|
|||
queryParamSpec = do
|
||||
describe "Servant.API.QueryParam" $ do
|
||||
it "allows retrieving simple GET parameters" $
|
||||
(flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params1 = "?name=bob"
|
||||
response1 <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params1,
|
||||
|
|
@ -244,7 +243,7 @@ queryParamSpec = do
|
|||
}
|
||||
|
||||
it "allows retrieving lists in GET parameters" $
|
||||
(flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params2 = "?names[]=bob&names[]=john"
|
||||
response2 <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params2,
|
||||
|
|
@ -258,7 +257,7 @@ queryParamSpec = do
|
|||
|
||||
|
||||
it "allows retrieving value-less GET parameters" $
|
||||
(flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params3 = "?capitalize"
|
||||
response3 <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params3,
|
||||
|
|
@ -310,7 +309,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do
|
|||
mkReq method x = Test.Hspec.Wai.request method x
|
||||
[(hContentType, "application/json;charset=utf-8")]
|
||||
|
||||
with (return $ serve reqBodyApi EmptyConfig server) $ do
|
||||
with (return $ serve reqBodyApi server) $ do
|
||||
|
||||
it "passes the argument to the handler" $ do
|
||||
response <- mkReq methodPost "" (encode alice)
|
||||
|
|
@ -343,13 +342,13 @@ headerSpec = describe "Servant.API.Header" $ do
|
|||
expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
|
||||
expectsString Nothing = error "Expected a string"
|
||||
|
||||
with (return (serve headerApi EmptyConfig expectsInt)) $ do
|
||||
with (return (serve headerApi expectsInt)) $ do
|
||||
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")]
|
||||
|
||||
it "passes the header to the handler (Int)" $
|
||||
delete' "/" "" `shouldRespondWith` 200
|
||||
|
||||
with (return (serve headerApi EmptyConfig expectsString)) $ do
|
||||
with (return (serve headerApi expectsString)) $ do
|
||||
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")]
|
||||
|
||||
it "passes the header to the handler (String)" $
|
||||
|
|
@ -373,7 +372,7 @@ rawSpec :: Spec
|
|||
rawSpec = do
|
||||
describe "Servant.API.Raw" $ do
|
||||
it "runs applications" $ do
|
||||
(flip runSession) (serve rawApi EmptyConfig (rawApplication (const (42 :: Integer)))) $ do
|
||||
(flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
|
||||
response <- Network.Wai.Test.request defaultRequest{
|
||||
pathInfo = ["foo"]
|
||||
}
|
||||
|
|
@ -381,7 +380,7 @@ rawSpec = do
|
|||
simpleBody response `shouldBe` "42"
|
||||
|
||||
it "gets the pathInfo modified" $ do
|
||||
(flip runSession) (serve rawApi EmptyConfig (rawApplication pathInfo)) $ do
|
||||
(flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
|
||||
response <- Network.Wai.Test.request defaultRequest{
|
||||
pathInfo = ["foo", "bar"]
|
||||
}
|
||||
|
|
@ -415,7 +414,7 @@ alternativeServer =
|
|||
alternativeSpec :: Spec
|
||||
alternativeSpec = do
|
||||
describe "Servant.API.Alternative" $ do
|
||||
with (return $ serve alternativeApi EmptyConfig alternativeServer) $ do
|
||||
with (return $ serve alternativeApi alternativeServer) $ do
|
||||
|
||||
it "unions endpoints" $ do
|
||||
response <- get "/foo"
|
||||
|
|
@ -450,7 +449,7 @@ responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"
|
|||
|
||||
responseHeadersSpec :: Spec
|
||||
responseHeadersSpec = describe "ResponseHeaders" $ do
|
||||
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) EmptyConfig responseHeadersServer) $ do
|
||||
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
|
||||
|
||||
let methods = [methodGet, methodPost, methodPut, methodPatch]
|
||||
|
||||
|
|
@ -516,7 +515,7 @@ miscServ = versionHandler
|
|||
hostHandler = return . show
|
||||
|
||||
miscCombinatorSpec :: Spec
|
||||
miscCombinatorSpec = with (return $ serve miscApi EmptyConfig miscServ) $
|
||||
miscCombinatorSpec = with (return $ serve miscApi miscServ) $
|
||||
describe "Misc. combinators for request inspection" $ do
|
||||
it "Successfully gets the HTTP version specified in the request" $
|
||||
go "/version" "\"HTTP/1.0\""
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ import Test.Hspec (Spec, around_, describe, it)
|
|||
import Test.Hspec.Wai (get, shouldRespondWith, with)
|
||||
|
||||
import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
|
||||
import Servant.Server (Server, serve, Config(EmptyConfig))
|
||||
import Servant.Server (Server, serve)
|
||||
import Servant.ServerSpec (Person (Person))
|
||||
import Servant.Utils.StaticFiles (serveDirectory)
|
||||
|
||||
|
|
@ -29,7 +29,7 @@ api :: Proxy Api
|
|||
api = Proxy
|
||||
|
||||
app :: Application
|
||||
app = serve api EmptyConfig server
|
||||
app = serve api server
|
||||
|
||||
server :: Server Api
|
||||
server =
|
||||
|
|
|
|||
|
|
@ -34,15 +34,15 @@ data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) a
|
|||
-- the relevant information is summarily presented here.
|
||||
|
||||
-- | 'GET' with 200 status code.
|
||||
type Get contentTypes a = Verb 'GET 200 contentTypes a
|
||||
type Get = Verb 'GET 200
|
||||
-- | 'POST' with 200 status code.
|
||||
type Post contentTypes a = Verb 'POST 200 contentTypes a
|
||||
type Post = Verb 'POST 200
|
||||
-- | 'PUT' with 200 status code.
|
||||
type Put contentTypes a = Verb 'PUT 200 contentTypes a
|
||||
type Put = Verb 'PUT 200
|
||||
-- | 'DELETE' with 200 status code.
|
||||
type Delete contentTypes a = Verb 'DELETE 200 contentTypes a
|
||||
type Delete = Verb 'DELETE 200
|
||||
-- | 'PATCH' with 200 status code.
|
||||
type Patch contentTypes a = Verb 'PATCH 200 contentTypes a
|
||||
type Patch = Verb 'PATCH 200
|
||||
|
||||
-- * Other responses
|
||||
|
||||
|
|
@ -58,7 +58,7 @@ type Patch contentTypes a = Verb 'PATCH 200 contentTypes a
|
|||
|
||||
-- | 'POST' with 201 status code.
|
||||
--
|
||||
type PostCreated contentTypes a = Verb 'POST 201 contentTypes a
|
||||
type PostCreated = Verb 'POST 201
|
||||
|
||||
|
||||
-- ** 202 Accepted
|
||||
|
|
@ -69,15 +69,15 @@ type PostCreated contentTypes a = Verb 'POST 201 contentTypes a
|
|||
-- estimate of when the processing will be finished.
|
||||
|
||||
-- | 'GET' with 202 status code.
|
||||
type GetAccepted contentTypes a = Verb 'GET 202 contentTypes a
|
||||
type GetAccepted = Verb 'GET 202
|
||||
-- | 'POST' with 202 status code.
|
||||
type PostAccepted contentTypes a = Verb 'POST 202 contentTypes a
|
||||
type PostAccepted = Verb 'POST 202
|
||||
-- | 'DELETE' with 202 status code.
|
||||
type DeleteAccepted contentTypes a = Verb 'DELETE 202 contentTypes a
|
||||
type DeleteAccepted = Verb 'DELETE 202
|
||||
-- | 'PATCH' with 202 status code.
|
||||
type PatchAccepted contentTypes a = Verb 'PATCH 202 contentTypes a
|
||||
type PatchAccepted = Verb 'PATCH 202
|
||||
-- | 'PUT' with 202 status code.
|
||||
type PutAccepted contentTypes a = Verb 'PUT 202 contentTypes a
|
||||
type PutAccepted = Verb 'PUT 202
|
||||
|
||||
|
||||
-- ** 203 Non-Authoritative Information
|
||||
|
|
@ -86,15 +86,15 @@ type PutAccepted contentTypes a = Verb 'PUT 202 contentTypes a
|
|||
-- information may come from a third-party.
|
||||
|
||||
-- | 'GET' with 203 status code.
|
||||
type GetNonAuthoritative contentTypes a = Verb 'GET 203 contentTypes a
|
||||
type GetNonAuthoritative = Verb 'GET 203
|
||||
-- | 'POST' with 203 status code.
|
||||
type PostNonAuthoritative contentTypes a = Verb 'POST 203 contentTypes a
|
||||
type PostNonAuthoritative = Verb 'POST 203
|
||||
-- | 'DELETE' with 203 status code.
|
||||
type DeleteNonAuthoritative contentTypes a = Verb 'DELETE 203 contentTypes a
|
||||
type DeleteNonAuthoritative = Verb 'DELETE 203
|
||||
-- | 'PATCH' with 203 status code.
|
||||
type PatchNonAuthoritative contentTypes a = Verb 'PATCH 203 contentTypes a
|
||||
type PatchNonAuthoritative = Verb 'PATCH 203
|
||||
-- | 'PUT' with 203 status code.
|
||||
type PutNonAuthoritative contentTypes a = Verb 'PUT 203 contentTypes a
|
||||
type PutNonAuthoritative = Verb 'PUT 203
|
||||
|
||||
|
||||
-- ** 204 No Content
|
||||
|
|
@ -105,15 +105,15 @@ type PutNonAuthoritative contentTypes a = Verb 'PUT 203 contentTypes a
|
|||
-- If the document view should be reset, use @205 Reset Content@.
|
||||
|
||||
-- | 'GET' with 204 status code.
|
||||
type GetNoContent contentTypes noContent = Verb 'GET 204 contentTypes noContent
|
||||
type GetNoContent = Verb 'GET 204
|
||||
-- | 'POST' with 204 status code.
|
||||
type PostNoContent contentTypes noContent = Verb 'POST 204 contentTypes noContent
|
||||
type PostNoContent = Verb 'POST 204
|
||||
-- | 'DELETE' with 204 status code.
|
||||
type DeleteNoContent contentTypes noContent = Verb 'DELETE 204 contentTypes noContent
|
||||
type DeleteNoContent = Verb 'DELETE 204
|
||||
-- | 'PATCH' with 204 status code.
|
||||
type PatchNoContent contentTypes noContent = Verb 'PATCH 204 contentTypes noContent
|
||||
type PatchNoContent = Verb 'PATCH 204
|
||||
-- | 'PUT' with 204 status code.
|
||||
type PutNoContent contentTypes noContent = Verb 'PUT 204 contentTypes noContent
|
||||
type PutNoContent = Verb 'PUT 204
|
||||
|
||||
|
||||
-- ** 205 Reset Content
|
||||
|
|
@ -124,15 +124,15 @@ type PutNoContent contentTypes noContent = Verb 'PUT 204 contentTypes noContent
|
|||
-- If the document view should not be reset, use @204 No Content@.
|
||||
|
||||
-- | 'GET' with 205 status code.
|
||||
type GetResetContent contentTypes noContent = Verb 'GET 205 contentTypes noContent
|
||||
type GetResetContent = Verb 'GET 205
|
||||
-- | 'POST' with 205 status code.
|
||||
type PostResetContent contentTypes noContent = Verb 'POST 205 contentTypes noContent
|
||||
type PostResetContent = Verb 'POST 205
|
||||
-- | 'DELETE' with 205 status code.
|
||||
type DeleteResetContent contentTypes noContent = Verb 'DELETE 205 contentTypes noContent
|
||||
type DeleteResetContent = Verb 'DELETE 205
|
||||
-- | 'PATCH' with 205 status code.
|
||||
type PatchResetContent contentTypes noContent = Verb 'PATCH 205 contentTypes noContent
|
||||
type PatchResetContent = Verb 'PATCH 205
|
||||
-- | 'PUT' with 205 status code.
|
||||
type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noContent
|
||||
type PutResetContent = Verb 'PUT 205
|
||||
|
||||
|
||||
-- ** 206 Partial Content
|
||||
|
|
@ -144,7 +144,7 @@ type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noConte
|
|||
-- RFC7233 Section 4.1>
|
||||
|
||||
-- | 'GET' with 206 status code.
|
||||
type GetPartialContent contentTypes noContent = Verb 'GET 206 contentTypes noContent
|
||||
type GetPartialContent = Verb 'GET 206
|
||||
|
||||
|
||||
class ReflectMethod a where
|
||||
|
|
|
|||
Loading…
Reference in a new issue