diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -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 diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -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 diff --git a/src/Servant/Server/Internal/Router.hs b/src/Servant/Server/Internal/Router.hs --- a/src/Servant/Server/Internal/Router.hs +++ b/src/Servant/Server/Internal/Router.hs @@ -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 -> diff --git a/src/Servant/Server/Internal/RoutingApplication.hs b/src/Servant/Server/Internal/RoutingApplication.hs --- a/src/Servant/Server/Internal/RoutingApplication.hs +++ b/src/Servant/Server/Internal/RoutingApplication.hs @@ -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 diff --git a/test/Servant/ArbitraryMonadServerSpec.hs b/test/Servant/ArbitraryMonadServerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/ArbitraryMonadServerSpec.hs @@ -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" diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -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 -- }}}