servant-server 0.2.3 → 0.2.4
raw patch · 5 files changed
+210/−51 lines, 5 filesdep ~servantdep ~wai-app-static
Dependency ranges changed: servant, wai-app-static
Files
- CHANGELOG.md +5/−0
- servant-server.cabal +3/−4
- src/Servant/Server.hs +5/−4
- src/Servant/Server/Internal.hs +194/−40
- src/Servant/Utils/StaticFiles.hs +3/−3
CHANGELOG.md view
@@ -1,3 +1,8 @@+master+------++* Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html+ 0.2.3 -----
servant-server.cabal view
@@ -1,5 +1,5 @@ name: servant-server-version: 0.2.3+version: 0.2.4 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them@@ -26,7 +26,6 @@ type: git location: http://github.com/haskell-servant/servant-server.git - library exposed-modules: Servant@@ -42,14 +41,14 @@ , http-types , network-uri >= 2.6 , safe- , servant >= 0.2+ , servant >= 0.2.2 , split , string-conversions , system-filepath , text , transformers , wai- , wai-app-static+ , wai-app-static >= 3.0.0.6 , warp hs-source-dirs: src default-language: Haskell2010
src/Servant/Server.hs view
@@ -11,10 +11,12 @@ HasServer(..) ) where -import Data.Proxy-import Network.Wai+import Data.Proxy (Proxy)+import Network.Wai (Application)+ import Servant.Server.Internal + -- * Implementing Servers -- | 'serve' allows you to implement an API and produce a wai 'Application'.@@ -30,7 +32,7 @@ -- > postBook book = ... -- > -- > myApi :: Proxy MyApi--- > myApi = Proxy +-- > myApi = Proxy -- > -- > app :: Application -- > app = serve myApi server@@ -39,4 +41,3 @@ -- > main = Network.Wai.Handler.Warp.run 8080 app serve :: HasServer layout => Proxy layout -> Server layout -> Application serve p server = toApplication (route p server)-
src/Servant/Server/Internal.hs view
@@ -7,24 +7,28 @@ {-# LANGUAGE ScopedTypeVariables #-} module Servant.Server.Internal where -import Control.Applicative-import Control.Monad.Trans.Either-import Data.Aeson+import Control.Applicative ((<$>))+import Control.Monad.Trans.Either (EitherT, runEitherT)+import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode') import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import Data.IORef+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.List (unfoldr) import Data.Maybe (catMaybes)-import Data.Monoid-import Data.Proxy-import Data.String-import Data.String.Conversions-import Data.Text.Encoding (decodeUtf8)+import Data.Monoid (Monoid, mempty, mappend)+import Data.Proxy (Proxy(Proxy))+import Data.String (fromString)+import Data.String.Conversions (cs, (<>))+import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text (Text)-import GHC.TypeLits+import qualified Data.Text as T+import GHC.TypeLits (KnownSymbol, symbolVal) import Network.HTTP.Types hiding (Header)-import Network.Wai-import Servant.API-import Servant.Common.Text+import Network.Wai (Response, Request, ResponseReceived, Application, pathInfo, requestBody,+ strictRequestBody, lazyRequestBody, requestHeaders, requestMethod,+ rawQueryString, responseLBS)+import Servant.API (QueryParams, QueryParam, QueryFlag, MatrixParams, MatrixParam, MatrixFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Raw, (:>), (:<|>)(..))+import Servant.Common.Text (FromText, fromText) data ReqBodyState = Uncalled | Called !B.ByteString@@ -60,34 +64,34 @@ respond $ responseLBS notFound404 [] "not found" routingRespond (Left WrongMethod) = respond $ responseLBS methodNotAllowed405 [] "method not allowed"- routingRespond (Left InvalidBody) =- respond $ responseLBS badRequest400 [] "Invalid JSON in request body"+ routingRespond (Left (InvalidBody err)) =+ respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err routingRespond (Right response) = respond response -- * Route mismatch data RouteMismatch =- NotFound -- ^ the usual "not found" error- | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error- | InvalidBody -- ^ an even more informative "your json request body wasn't valid" error+ NotFound -- ^ the usual "not found" error+ | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error+ | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error deriving (Eq, Show) -- | -- @ -- > mempty = NotFound -- >--- > NotFound `mappend` x = x--- > WrongMethod `mappend` InvalidBody = InvalidBody--- > WrongMethod `mappend` _ = WrongMethod--- > InvalidBody `mappend` _ = InvalidBody+-- > NotFound `mappend` x = x+-- > WrongMethod `mappend` InvalidBody s = InvalidBody s+-- > WrongMethod `mappend` _ = WrongMethod+-- > InvalidBody s `mappend` _ = InvalidBody s -- @ instance Monoid RouteMismatch where mempty = NotFound - NotFound `mappend` x = x- WrongMethod `mappend` InvalidBody = InvalidBody- WrongMethod `mappend` _ = WrongMethod- InvalidBody `mappend` _ = InvalidBody+ NotFound `mappend` x = x+ WrongMethod `mappend` InvalidBody s = InvalidBody s+ WrongMethod `mappend` _ = WrongMethod+ InvalidBody s `mappend` _ = InvalidBody s -- | A wrapper around @'Either' 'RouteMismatch' a@. newtype RouteResult a =@@ -104,6 +108,14 @@ isMismatch (RR (Left _)) = True isMismatch _ = False +-- | Like `null . pathInfo`, but works with redundant trailing slashes.+pathIsEmpty :: Request -> Bool+pathIsEmpty = f . processedPathInfo+ where+ f [] = True+ f [""] = True+ f _ = False+ -- | If we get a `Right`, it has precedence over everything else. -- -- This in particular means that if we could get several 'Right's,@@ -119,13 +131,36 @@ Request -- ^ the request, the field 'pathInfo' may be modified by url routing -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived +splitMatrixParameters :: Text -> (Text, Text)+splitMatrixParameters = T.break (== ';')++parsePathInfo :: Request -> [Text]+parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo+ where mergePairs = concat . unfoldr pairToList+ pairToList [] = Nothing+ pairToList ((a, b):xs) = Just ([a, b], xs)++-- | Returns a processed pathInfo from the request.+--+-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be+-- processed, so routing works as intended. Therefor this function should be used to access+-- the pathInfo for routing purposes.+processedPathInfo :: Request -> [Text]+processedPathInfo r =+ case pinfo of+ (x:xs) | T.head x == ';' -> xs+ _ -> pinfo+ where pinfo = parsePathInfo r+ class HasServer layout where type Server layout :: * route :: Proxy layout -> Server layout -> RoutingApplication ++ -- * Instances --- | A server for @a ':<|>' b@ first tries to match the request again the route+-- | A server for @a ':<|>' b@ first tries to match the request against the route -- represented by @a@ and if it fails tries @b@. You must provide a request -- handler for each route. --@@ -173,7 +208,7 @@ type Server (Capture capture a :> sublayout) = a -> Server sublayout - route Proxy subserver request respond = case pathInfo request of+ route Proxy subserver request respond = case processedPathInfo request of (first : rest) -> case captured captureProxy first of Nothing -> respond $ failWith NotFound@@ -183,6 +218,7 @@ _ -> respond $ failWith NotFound where captureProxy = Proxy :: Proxy (Capture capture a)+ -- | If you have a 'Delete' endpoint in your API, -- the handler for this endpoint is meant to delete@@ -199,14 +235,14 @@ type Server Delete = EitherT (Int, String) IO () route Proxy action request respond- | null (pathInfo request) && requestMethod request == methodDelete = do+ | pathIsEmpty request && requestMethod request == methodDelete = do e <- runEitherT action respond $ succeedWith $ case e of Right () -> responseLBS status204 [] "" Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message)- | null (pathInfo request) && requestMethod request /= methodDelete =+ | pathIsEmpty request && requestMethod request /= methodDelete = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -224,14 +260,14 @@ instance ToJSON result => HasServer (Get result) where type Server (Get result) = EitherT (Int, String) IO result route Proxy action request respond- | null (pathInfo request) && requestMethod request == methodGet = do+ | pathIsEmpty request && requestMethod request == methodGet = do e <- runEitherT action respond . succeedWith $ case e of Right output -> responseLBS ok200 [("Content-Type", "application/json")] (encode output) Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message)- | null (pathInfo request) && requestMethod request /= methodGet =+ | pathIsEmpty request && requestMethod request /= methodGet = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -282,14 +318,14 @@ type Server (Post a) = EitherT (Int, String) IO a route Proxy action request respond- | null (pathInfo request) && requestMethod request == methodPost = do+ | pathIsEmpty request && requestMethod request == methodPost = do e <- runEitherT action respond . succeedWith $ case e of Right out -> responseLBS status201 [("Content-Type", "application/json")] (encode out) Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message)- | null (pathInfo request) && requestMethod request /= methodPost =+ | pathIsEmpty request && requestMethod request /= methodPost = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound @@ -308,14 +344,14 @@ type Server (Put a) = EitherT (Int, String) IO a route Proxy action request respond- | null (pathInfo request) && requestMethod request == methodPut = do+ | pathIsEmpty request && requestMethod request == methodPut = do e <- runEitherT action respond . succeedWith $ case e of Right out -> responseLBS ok200 [("Content-Type", "application/json")] (encode out) Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message)- | null (pathInfo request) && requestMethod request /= methodPut =+ | pathIsEmpty request && requestMethod request /= methodPut = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound@@ -431,6 +467,124 @@ examine v | v == "true" || v == "1" || v == "" = True | otherwise = False +parseMatrixText :: B.ByteString -> QueryText+parseMatrixText = parseQueryText++-- | If you use @'MatrixParam' "author" Text@ in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of type @'Maybe' 'Text'@.+--+-- This lets servant worry about looking it up in the query string+-- and turning it into a value of the type you specify, enclosed+-- in 'Maybe', because it may not be there and servant would then+-- hand you 'Nothing'.+--+-- You can control how it'll be converted from 'Text' to your type+-- by simply providing an instance of 'FromText' for your type.+--+-- Example:+--+-- > type MyApi = "books" :> MatrixParam "author" Text :> Get [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooksBy+-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]+-- > getBooksBy Nothing = ...return all books...+-- > getBooksBy (Just author) = ...return books by the given author...+instance (KnownSymbol sym, FromText a, HasServer sublayout)+ => HasServer (MatrixParam sym a :> sublayout) where++ type Server (MatrixParam sym a :> sublayout) =+ Maybe a -> Server sublayout++ route Proxy subserver request respond = case parsePathInfo request of+ (first : _)+ -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first+ param = case lookup paramname querytext of+ Nothing -> Nothing -- param absent from the query string+ Just Nothing -> Nothing -- param present with no value -> Nothing+ Just (Just v) -> fromText v -- if present, we try to convert to+ -- the right type+ route (Proxy :: Proxy sublayout) (subserver param) request respond+ _ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond++ where paramname = cs $ symbolVal (Proxy :: Proxy sym)++-- | If you use @'MatrixParams' "authors" Text@ in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of type @['Text']@.+--+-- This lets servant worry about looking up 0 or more values in the query string+-- associated to @authors@ and turning each of them into a value of+-- the type you specify.+--+-- You can control how the individual values are converted from 'Text' to your type+-- by simply providing an instance of 'FromText' for your type.+--+-- Example:+--+-- > type MyApi = "books" :> MatrixParams "authors" Text :> Get [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooksBy+-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]+-- > getBooksBy authors = ...return all books by these authors...+instance (KnownSymbol sym, FromText a, HasServer sublayout)+ => HasServer (MatrixParams sym a :> sublayout) where++ type Server (MatrixParams sym a :> sublayout) =+ [a] -> Server sublayout++ route Proxy subserver request respond = case parsePathInfo request of+ (first : _)+ -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first+ -- if sym is "foo", we look for matrix parameters+ -- named "foo" or "foo[]" and call fromText on the+ -- corresponding values+ parameters = filter looksLikeParam matrixtext+ values = catMaybes $ map (convert . snd) parameters+ route (Proxy :: Proxy sublayout) (subserver values) request respond+ _ -> route (Proxy :: Proxy sublayout) (subserver []) request respond++ where paramname = cs $ symbolVal (Proxy :: Proxy sym)+ looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")+ convert Nothing = Nothing+ convert (Just v) = fromText v++-- | If you use @'MatrixFlag' "published"@ in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of type 'Bool'.+--+-- Example:+--+-- > type MyApi = "books" :> MatrixFlag "published" :> Get [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooks+-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book]+-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...+instance (KnownSymbol sym, HasServer sublayout)+ => HasServer (MatrixFlag sym :> sublayout) where++ type Server (MatrixFlag sym :> sublayout) =+ Bool -> Server sublayout++ route Proxy subserver request respond = case parsePathInfo request of+ (first : _)+ -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first+ param = case lookup paramname matrixtext of+ Just Nothing -> True -- param is there, with no value+ Just (Just v) -> examine v -- param with a value+ Nothing -> False -- param not in the query string++ route (Proxy :: Proxy sublayout) (subserver param) request respond++ _ -> route (Proxy :: Proxy sublayout) (subserver False) request respond++ where paramname = cs $ symbolVal (Proxy :: Proxy sym)+ examine v | v == "true" || v == "1" || v == "" = True+ | otherwise = False+ -- | Just pass the request to the underlying application and serve its response. -- -- Example:@@ -467,16 +621,16 @@ a -> Server sublayout route Proxy subserver request respond = do- mrqbody <- decode' <$> lazyRequestBody request+ mrqbody <- eitherDecode' <$> lazyRequestBody request case mrqbody of- Nothing -> respond $ failWith InvalidBody- Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond+ Left e -> respond . failWith $ InvalidBody e+ Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@. instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where type Server (path :> sublayout) = Server sublayout- route Proxy subserver request respond = case pathInfo request of+ route Proxy subserver request respond = case processedPathInfo request of (first : rest) | first == cs (symbolVal proxyPath) -> route (Proxy :: Proxy sublayout) subserver request{
src/Servant/Utils/StaticFiles.hs view
@@ -7,9 +7,9 @@ ) where import Filesystem.Path.CurrentOS (decodeString)-import Network.Wai.Application.Static-import Servant.API.Raw-import Servant.Server.Internal+import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)+import Servant.API.Raw (Raw)+import Servant.Server.Internal (Server) -- | Serve anything under the specified directory as a 'Raw' endpoint. --