servant-server 0.8 → 0.8.1
raw patch · 6 files changed
+170/−12 lines, 6 filesdep ~aeson
Dependency ranges changed: aeson
Files
- servant-server.cabal +3/−2
- src/Servant/Server/Internal.hs +41/−6
- src/Servant/Server/Internal/Router.hs +10/−0
- src/Servant/Server/Internal/RoutingApplication.hs +2/−3
- test/Servant/ArbitraryMonadServerSpec.hs +58/−0
- test/Servant/ServerSpec.hs +56/−1
servant-server.cabal view
@@ -1,5 +1,5 @@ name: servant-server-version: 0.8+version: 0.8.1 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them@@ -47,7 +47,7 @@ build-depends: base >= 4.7 && < 4.10 , base-compat >= 0.9 && < 0.10- , aeson >= 0.7 && < 0.12+ , aeson >= 0.7 && < 1.1 , attoparsec >= 0.12 && < 0.14 , base64-bytestring >= 1.0 && < 1.1 , bytestring >= 0.10 && < 0.11@@ -99,6 +99,7 @@ hs-source-dirs: test main-is: Spec.hs other-modules:+ Servant.ArbitraryMonadServerSpec Servant.Server.ErrorSpec Servant.Server.Internal.ContextSpec Servant.Server.RouterSpec
src/Servant/Server/Internal.hs view
@@ -45,13 +45,15 @@ import Web.HttpApiData (FromHttpApiData) import Web.HttpApiData.Internal (parseHeaderMaybe, parseQueryParamMaybe,- parseUrlPieceMaybe)+ parseUrlPieceMaybe,+ parseUrlPieces) import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,- Verb, ReflectMethod(reflectMethod),- IsSecure(..), Header,- QueryFlag, QueryParam, QueryParams,- Raw, RemoteHost, ReqBody, Vault,+ CaptureAll, Verb,+ ReflectMethod(reflectMethod),+ IsSecure(..), Header, QueryFlag,+ QueryParam, QueryParams, Raw,+ RemoteHost, ReqBody, Vault, WithNamedContext) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..),@@ -128,10 +130,43 @@ CaptureRouter $ route (Proxy :: Proxy api) context- (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of+ (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of Nothing -> delayedFail err400 Just v -> return v )++-- | If you use 'CaptureAll' in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a+-- function that takes an argument of a list of the type specified by+-- the 'CaptureAll'. This lets servant worry about getting values from+-- the URL and turning them into values of the type you specify.+--+-- You can control how they'll be converted from 'Text' to your type+-- by simply providing an instance of 'FromHttpApiData' for your type.+--+-- Example:+--+-- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile+-- >+-- > server :: Server MyApi+-- > server = getSourceFile+-- > where getSourceFile :: [Text] -> Handler Book+-- > getSourceFile pathSegments = ...+instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)+ => HasServer (CaptureAll capture a :> sublayout) context where++ type ServerT (CaptureAll capture a :> sublayout) m =+ [a] -> ServerT sublayout m++ route Proxy context d =+ CaptureAllRouter $+ route (Proxy :: Proxy sublayout)+ context+ (addCapture d $ \ txts -> case parseUrlPieces txts of+ Left _ -> delayedFail err400+ Right v -> return v+ )+ allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
src/Servant/Server/Internal/Router.hs view
@@ -31,6 +31,9 @@ | CaptureRouter (Router' (Text, env) a) -- ^ first path component is passed to the child router in its -- environment and removed afterwards+ | CaptureAllRouter (Router' ([Text], env) a)+ -- ^ all path components are passed to the child router in its+ -- environment and are removed afterwards | RawRouter (env -> a) -- ^ to be used for routes we do not know anything about | Choice (Router' env a) (Router' env a)@@ -90,6 +93,9 @@ routerStructure (CaptureRouter router) = CaptureRouterStructure $ routerStructure router+routerStructure (CaptureAllRouter router) =+ CaptureRouterStructure $+ routerStructure router routerStructure (RawRouter _) = RawRouterStructure routerStructure (Choice r1 r2) =@@ -163,6 +169,10 @@ first : rest -> let request' = request { pathInfo = rest } in runRouterEnv router' (first, env) request' respond+ CaptureAllRouter router' ->+ let segments = pathInfo request+ request' = request { pathInfo = [] }+ in runRouterEnv router' (segments, env) request' respond RawRouter app -> app env request respond Choice r1 r2 ->
src/Servant/Server/Internal/RoutingApplication.hs view
@@ -11,7 +11,6 @@ import Control.Monad (ap, liftM) import Control.Monad.Trans (MonadIO(..)) import Control.Monad.Trans.Except (runExceptT)-import Data.Text (Text) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude ()@@ -161,8 +160,8 @@ -- | Add a capture to the end of the capture block. addCapture :: Delayed env (a -> b)- -> (Text -> DelayedIO a)- -> Delayed (Text, env) b+ -> (captured -> DelayedIO a)+ -> Delayed (captured, env) b addCapture Delayed{..} new = Delayed { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
+ test/Servant/ArbitraryMonadServerSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+module Servant.ArbitraryMonadServerSpec where++import qualified Control.Category as C+import Control.Monad.Reader+import Data.Proxy+import Servant.API+import Servant.Server++import Test.Hspec (Spec, describe, it)+import Test.Hspec.Wai (get, matchStatus, post,+ shouldRespondWith, with)++spec :: Spec+spec = describe "Arbitrary monad server" $ do+ enterSpec++type ReaderAPI = "int" :> Get '[JSON] Int+ :<|> "string" :> Post '[JSON] String++type IdentityAPI = "bool" :> Get '[JSON] Bool++type CombinedAPI = ReaderAPI :<|> IdentityAPI++readerAPI :: Proxy ReaderAPI+readerAPI = Proxy++combinedAPI :: Proxy CombinedAPI+combinedAPI = Proxy++readerServer' :: ServerT ReaderAPI (Reader String)+readerServer' = return 1797 :<|> ask++fReader :: Reader String :~> Handler+fReader = generalizeNat C.. (runReaderTNat "hi")++readerServer :: Server ReaderAPI+readerServer = enter fReader readerServer'++combinedReaderServer' :: ServerT CombinedAPI (Reader String)+combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True)++combinedReaderServer :: Server CombinedAPI+combinedReaderServer = enter fReader combinedReaderServer'++enterSpec :: Spec+enterSpec = describe "Enter" $ 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 combinedReaderServer)) $ do+ it "allows combnation of enters" $ do+ get "bool" `shouldRespondWith` "true"
test/Servant/ServerSpec.hs view
@@ -39,7 +39,7 @@ simpleHeaders, simpleStatus) import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData(BasicAuthData),- Capture, Delete, Get, Header (..),+ Capture, CaptureAll, Delete, Get, Header (..), Headers, HttpVersion, IsSecure (..), JSON, NoContent (..), Patch, PlainText,@@ -218,6 +218,58 @@ -- }}} ------------------------------------------------------------------------------+-- * captureAllSpec {{{+------------------------------------------------------------------------------++type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal+captureAllApi :: Proxy CaptureAllApi+captureAllApi = Proxy+captureAllServer :: [Integer] -> Handler Animal+captureAllServer legs = case sum legs of+ 4 -> return jerry+ 2 -> return tweety+ 0 -> return beholder+ _ -> throwE err404++captureAllSpec :: Spec+captureAllSpec = do+ describe "Servant.API.CaptureAll" $ do+ with (return (serve captureAllApi captureAllServer)) $ do++ it "can capture a single element of the 'pathInfo'" $ do+ response <- get "/2"+ liftIO $ decode' (simpleBody response) `shouldBe` Just tweety++ it "can capture multiple elements of the 'pathInfo'" $ do+ response <- get "/2/2"+ liftIO $ decode' (simpleBody response) `shouldBe` Just jerry++ it "can capture arbitrarily many elements of the 'pathInfo'" $ do+ response <- get "/1/1/0/1/0/1"+ liftIO $ decode' (simpleBody response) `shouldBe` Just jerry++ it "can capture when there are no elements in 'pathInfo'" $ do+ response <- get "/"+ liftIO $ decode' (simpleBody response) `shouldBe` Just beholder++ it "returns 400 if the decoding fails" $ do+ get "/notAnInt" `shouldRespondWith` 400++ it "returns 400 if the decoding fails, regardless of which element" $ do+ get "/1/0/0/notAnInt/3/" `shouldRespondWith` 400++ it "returns 400 if the decoding fails, even when it's multiple elements" $ do+ get "/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400++ with (return (serve+ (Proxy :: Proxy (CaptureAll "segments" String :> Raw))+ (\ _captured request_ respond ->+ respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do+ it "consumes everything from pathInfo" $ do+ get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))++-- }}}+------------------------------------------------------------------------------ -- * queryParamSpec {{{ ------------------------------------------------------------------------------ @@ -644,4 +696,7 @@ tweety :: Animal tweety = Animal "Bird" 2++beholder :: Animal+beholder = Animal "Beholder" 0 -- }}}