From 1aeee3ef9403251fbc500ee3e3df91f699ed54b3 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 26 Jan 2016 14:43:15 +0100 Subject: [PATCH 01/12] Remove memoReqBody. --- servant-server/src/Servant/Server/Internal.hs | 2 +- .../Server/Internal/RoutingApplication.hs | 28 +------------------ 2 files changed, 2 insertions(+), 28 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 1b2c19a2..daf44640 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -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 diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index bcb563df..05814fe6 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -33,34 +33,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 From 3bd3eff488a382ece37a481cc28547c5721ab187 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 26 Jan 2016 18:47:34 +0100 Subject: [PATCH 02/12] Add test for failing 400 --- servant-server/test/Servant/Server/ErrorSpec.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 745b47d9..5314f37e 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -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 {{{ From c532ecffd5ceb932486673edb2db3e644d904b65 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 28 Jan 2016 11:07:36 +0100 Subject: [PATCH 03/12] Small doc fix. --- .../src/Servant/Server/Internal/RoutingApplication.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index bcb563df..e0fb5246 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -98,10 +98,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 From 2934bac40c5d2b54c59f3531732e039c9c9393ee Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 28 Jan 2016 11:07:59 +0100 Subject: [PATCH 04/12] Small whitespace fix. --- .../src/Servant/Server/Internal/RoutingApplication.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index e0fb5246..72f51bf7 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -159,7 +159,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) From 927009408bbda1bfb6756f59e220cd6cfb5ed833 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 28 Jan 2016 11:08:22 +0100 Subject: [PATCH 05/12] Small whitespace fix. --- .../src/Servant/Server/Internal/RoutingApplication.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 72f51bf7..3112c640 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -240,9 +240,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 From 23a31a89355f4cd3d7b0bb6f12eb85a721b9645f Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 28 Jan 2016 11:46:16 +0100 Subject: [PATCH 06/12] Eta-reduce the verb-synonyms. --- servant/src/Servant/API/Verbs.hs | 54 ++++++++++++++++---------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index 4915fdaf..1369d9f3 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -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 From e6e13fde8452dac7651033d52d99001ad627b9ab Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Thu, 11 Feb 2016 13:41:34 +0300 Subject: [PATCH 07/12] Make servant-foreign code nicer * non-messy imports * got rid of most long lines (>80 chars) * prisms for sum types and newtypes(we use lens anyway, so why not) * consistent indentation --- servant-foreign/src/Servant/Foreign.hs | 58 ++++--- .../src/Servant/Foreign/Internal.hs | 154 ++++++++++-------- servant-foreign/test/Servant/ForeignSpec.hs | 114 ++++++------- servant-js/src/Servant/JS/Angular.hs | 2 +- servant-js/src/Servant/JS/Axios.hs | 2 +- servant-js/src/Servant/JS/Internal.hs | 19 ++- servant-js/src/Servant/JS/JQuery.hs | 2 +- servant-js/src/Servant/JS/Vanilla.hs | 2 +- 8 files changed, 198 insertions(+), 155 deletions(-) diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs index 5054e69f..33ac2732 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -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 diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index bb2e4b1e..369d5b76 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -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) diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index 06e722cc..0e279994 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -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"] + } diff --git a/servant-js/src/Servant/JS/Angular.hs b/servant-js/src/Servant/JS/Angular.hs index 8530b03f..4d647225 100644 --- a/servant-js/src/Servant/JS/Angular.hs +++ b/servant-js/src/Servant/JS/Angular.hs @@ -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' diff --git a/servant-js/src/Servant/JS/Axios.hs b/servant-js/src/Servant/JS/Axios.hs index 25e92df3..c8540efe 100644 --- a/servant-js/src/Servant/JS/Axios.hs +++ b/servant-js/src/Servant/JS/Axios.hs @@ -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' diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index 481536ad..61c33e0f 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -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. diff --git a/servant-js/src/Servant/JS/JQuery.hs b/servant-js/src/Servant/JS/JQuery.hs index 71147006..dfd3ddc0 100644 --- a/servant-js/src/Servant/JS/JQuery.hs +++ b/servant-js/src/Servant/JS/JQuery.hs @@ -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' diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index f623e2a6..386a0d2e 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -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' From e1947b9b4050f8079416ec137f1b51758e1ae1ae Mon Sep 17 00:00:00 2001 From: Daniel Gasienica Date: Wed, 17 Feb 2016 21:13:31 -0800 Subject: [PATCH 08/12] Fix minor typo: succesful --> successful --- servant-client/CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 2c9f5279..d6ffc14b 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -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 From e35b4211c4eb98a2c0eb950acff5109f02245901 Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Thu, 18 Feb 2016 09:34:42 +0300 Subject: [PATCH 09/12] update servant-foreign changelog --- servant-foreign/CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/servant-foreign/CHANGELOG.md b/servant-foreign/CHANGELOG.md index 5d242065..2fcd5fb7 100644 --- a/servant-foreign/CHANGELOG.md +++ b/servant-foreign/CHANGELOG.md @@ -2,3 +2,4 @@ HEAD ----- * Use the `text` package instead of `String`. * Extract javascript-oblivious types and helpers to *servant-foreign* +* Typed-languages support From 1e5bdd6545541a995b162db2214e1b158473e830 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 18 Feb 2016 15:49:26 +0100 Subject: [PATCH 10/12] Delete .ghci file. --- .ghci | 1 - 1 file changed, 1 deletion(-) delete mode 100644 .ghci diff --git a/.ghci b/.ghci deleted file mode 100644 index 93d9b991..00000000 --- a/.ghci +++ /dev/null @@ -1 +0,0 @@ -:set -itest -isrc -packagehspec2 From f137972e5d397fe20b57b73a4fb67e8ff9101422 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 18 Feb 2016 16:36:24 +0100 Subject: [PATCH 11/12] Add 'serveWithConfig'. And keep the old signature for 'serve' --- servant-client/test/Servant/ClientSpec.hs | 6 ++-- .../auth-combinator/auth-combinator.hs | 2 +- .../socket-io-chat/socket-io-chat.hs | 2 +- servant-examples/tutorial/T1.hs | 2 +- servant-examples/tutorial/T10.hs | 2 +- servant-examples/tutorial/T2.hs | 2 +- servant-examples/tutorial/T3.hs | 2 +- servant-examples/tutorial/T4.hs | 2 +- servant-examples/tutorial/T5.hs | 2 +- servant-examples/tutorial/T6.hs | 2 +- servant-examples/tutorial/T7.hs | 2 +- servant-examples/tutorial/T9.hs | 2 +- .../wai-middleware/wai-middleware.hs | 2 +- servant-mock/example/main.hs | 2 +- servant-mock/src/Servant/Mock.hs | 17 +++++----- servant-mock/test/Servant/MockSpec.hs | 4 +-- servant-server/example/greet.hs | 2 +- servant-server/src/Servant/Server.hs | 14 +++++---- .../Server/Internal/RoutingApplication.hs | 8 +---- .../test/Servant/Server/ErrorSpec.hs | 8 ++--- .../test/Servant/Server/Internal/EnterSpec.hs | 4 +-- .../test/Servant/Server/UsingConfigSpec.hs | 10 +++--- servant-server/test/Servant/ServerSpec.hs | 31 +++++++++---------- .../test/Servant/Utils/StaticFilesSpec.hs | 4 +-- 24 files changed, 64 insertions(+), 70 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 4cb1ef4c..2bca7c13 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -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) = diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index f2cebb4f..635c39b0 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -82,7 +82,7 @@ main :: IO () main = do dbConnection <- initDB let config = dbConnection :. EmptyConfig - run 8080 (serve api config server) + run 8080 (serveWithConfig api config server) {- Sample session: $ curl http://localhost:8080/ diff --git a/servant-examples/socket-io-chat/socket-io-chat.hs b/servant-examples/socket-io-chat/socket-io-chat.hs index 4f5e649a..1250d8fe 100644 --- a/servant-examples/socket-io-chat/socket-io-chat.hs +++ b/servant-examples/socket-io-chat/socket-io-chat.hs @@ -38,7 +38,7 @@ server sHandler = socketIOHandler app :: WaiMonad () -> Application -app sHandler = serve api EmptyConfig $ server sHandler +app sHandler = serve api $ server sHandler port :: Int port = 3001 diff --git a/servant-examples/tutorial/T1.hs b/servant-examples/tutorial/T1.hs index 2473e7c8..97bbecb8 100644 --- a/servant-examples/tutorial/T1.hs +++ b/servant-examples/tutorial/T1.hs @@ -42,4 +42,4 @@ server :: Server UserAPI server = return users app :: Application -app = serve userAPI EmptyConfig server +app = serve userAPI server diff --git a/servant-examples/tutorial/T10.hs b/servant-examples/tutorial/T10.hs index 859ff2cb..be5da4cf 100644 --- a/servant-examples/tutorial/T10.hs +++ b/servant-examples/tutorial/T10.hs @@ -68,4 +68,4 @@ server = T3.server :<|> serveDocs plain = ("Content-Type", "text/plain") app :: Application -app = serve api EmptyConfig server +app = serve api server diff --git a/servant-examples/tutorial/T2.hs b/servant-examples/tutorial/T2.hs index bd311330..fc49d256 100644 --- a/servant-examples/tutorial/T2.hs +++ b/servant-examples/tutorial/T2.hs @@ -49,4 +49,4 @@ server = return users :<|> return isaac app :: Application -app = serve userAPI EmptyConfig server +app = serve userAPI server diff --git a/servant-examples/tutorial/T3.hs b/servant-examples/tutorial/T3.hs index 4a56b946..7b5bdeb3 100644 --- a/servant-examples/tutorial/T3.hs +++ b/servant-examples/tutorial/T3.hs @@ -81,4 +81,4 @@ server = position marketing clientinfo = return (emailForClient clientinfo) app :: Application -app = serve api EmptyConfig server +app = serve api server diff --git a/servant-examples/tutorial/T4.hs b/servant-examples/tutorial/T4.hs index b86c8cb2..69cbf951 100644 --- a/servant-examples/tutorial/T4.hs +++ b/servant-examples/tutorial/T4.hs @@ -60,4 +60,4 @@ server :: Server PersonAPI server = return persons app :: Application -app = serve personAPI EmptyConfig server +app = serve personAPI server diff --git a/servant-examples/tutorial/T5.hs b/servant-examples/tutorial/T5.hs index 81812d90..3b18aedb 100644 --- a/servant-examples/tutorial/T5.hs +++ b/servant-examples/tutorial/T5.hs @@ -34,4 +34,4 @@ server = do where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } app :: Application -app = serve ioAPI EmptyConfig server +app = serve ioAPI server diff --git a/servant-examples/tutorial/T6.hs b/servant-examples/tutorial/T6.hs index 3e24647d..781bf703 100644 --- a/servant-examples/tutorial/T6.hs +++ b/servant-examples/tutorial/T6.hs @@ -15,4 +15,4 @@ server :: Server API server = serveDirectory "tutorial" app :: Application -app = serve api EmptyConfig server +app = serve api server diff --git a/servant-examples/tutorial/T7.hs b/servant-examples/tutorial/T7.hs index 010b66dd..e0145caf 100644 --- a/servant-examples/tutorial/T7.hs +++ b/servant-examples/tutorial/T7.hs @@ -30,4 +30,4 @@ readerServer = enter readerToEither readerServerT readerToEither = Nat $ \r -> return (runReader r "hi") app :: Application -app = serve readerAPI EmptyConfig readerServer +app = serve readerAPI readerServer diff --git a/servant-examples/tutorial/T9.hs b/servant-examples/tutorial/T9.hs index a9fd575b..75dd0630 100644 --- a/servant-examples/tutorial/T9.hs +++ b/servant-examples/tutorial/T9.hs @@ -102,4 +102,4 @@ writeJSFiles = do TIO.writeFile "tutorial/t9/jq.js" jq app :: Application -app = serve api' EmptyConfig server' +app = serve api' server' diff --git a/servant-examples/wai-middleware/wai-middleware.hs b/servant-examples/wai-middleware/wai-middleware.hs index 7ad34c3f..1d26da1a 100644 --- a/servant-examples/wai-middleware/wai-middleware.hs +++ b/servant-examples/wai-middleware/wai-middleware.hs @@ -45,7 +45,7 @@ server = return products -- so applying a middleware is really as simple as -- applying a function to the result of 'serve' app :: Application -app = logStdout (serve simpleAPI EmptyConfig server) +app = logStdout (serve simpleAPI server) main :: IO () main = run 8080 app diff --git a/servant-mock/example/main.hs b/servant-mock/example/main.hs index 7f08f352..4a457467 100644 --- a/servant-mock/example/main.hs +++ b/servant-mock/example/main.hs @@ -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) diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 2c447ca0..7e2261e5 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -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) diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs index cd369ee6..320a60ac 100644 --- a/servant-mock/test/Servant/MockSpec.hs +++ b/servant-mock/test/Servant/MockSpec.hs @@ -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{ diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index 37c3f674..3fda367d 100644 --- a/servant-server/example/greet.hs +++ b/servant-server/example/greet.hs @@ -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. -- diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index ea78a969..fd71efb5 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -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 ()) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 4aa3bda7..3be47123 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -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 = diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 5314f37e..3575e2ac 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -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") @@ -198,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 diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 06e8af9b..8b450377 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -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" diff --git a/servant-server/test/Servant/Server/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs index a6c7ae43..64d6f2cf 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec.hs +++ b/servant-server/test/Servant/Server/UsingConfigSpec.hs @@ -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 diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 04461566..efda259f 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -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\"" diff --git a/servant-server/test/Servant/Utils/StaticFilesSpec.hs b/servant-server/test/Servant/Utils/StaticFilesSpec.hs index e6430b5c..94c63f18 100644 --- a/servant-server/test/Servant/Utils/StaticFilesSpec.hs +++ b/servant-server/test/Servant/Utils/StaticFilesSpec.hs @@ -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 = From 2cdd6a5fea338d6c5eb2659701562bf1030c1112 Mon Sep 17 00:00:00 2001 From: Ondrej Palkovsky Date: Thu, 18 Feb 2016 22:45:05 +0100 Subject: [PATCH 12/12] Bump aeson version. --- servant-js/servant-js.cabal | 2 +- servant-server/servant-server.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index b8a52d64..792fda22 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -63,7 +63,7 @@ executable counter buildable: False build-depends: base >= 4.7 && < 5 - , aeson >= 0.7 && < 0.11 + , aeson >= 0.7 && < 0.12 , filepath >= 1 , lens >= 4 , servant == 0.5.* diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index f6ed6319..79f3c934 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -45,7 +45,7 @@ library Servant.Utils.StaticFiles build-depends: base >= 4.7 && < 5 - , aeson >= 0.7 && < 0.11 + , aeson >= 0.7 && < 0.12 , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6