first shot at a server package

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2014, Zalora South East Asia Pte Ltd
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Zalora South East Asia Pte Ltd nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

@@ -0,0 +1,25 @@
+# servant
+
+[![Build Status](https://secure.travis-ci.org/haskell-servant/servant.svg)](http://travis-ci.org/haskell-servant/servant)
+
+![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
+
+These libraries provides a family of combinators to define webservices and automatically generate the documentation and client-side querying functions for each endpoint.
+
+In order to minimize the dependencies depending on your needs, we provide these features under different packages.
+
+- `servant`, which contains everything you need to *declare* a webservice and *implement* an HTTP server with handlers for each endpoint.
+- `servant-client`, which lets you derive automatically Haskell functions that let you query each endpoint of a *servant* webservice.
+- `servant-docs`, which lets you generate API docs for your webservice.
+- `servant-jquery`, which lets you derive Javascript functions (based on jquery) to query your API's endpoints, in the same spirit as `servant-client`.
+
+## Getting started
+
+We've written a [Getting Started](http://haskell-servant.github.io/getting-started/) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.
+
+## Repositories and Haddocks
+
+- The core [servant](http://github.com/haskell-servant) package - [docs](http://haskell-servant.github.io/servant/)
+- (Haskell) client-side function generation with [servant-client](http://github.com/haskell-servant/servant-client) - [docs](http://haskell-servant.github.io/servant-client/)
+- (Javascript) client-side function generation with [servant-jquery](http://github.com/haskell-servant/servant-jquery) - [docs](http://haskell-servant.github.io/servant-jquery/)
+- API docs generation with [servant-docs](http://github.com/haskell-servant/servant-docs) - [docs](http://haskell-servant.github.io/servant-docs/)

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

example/README.md

@@ -0,0 +1,2 @@
+- `greet.hs` shows how to write a simple webservice, run it, query it with automatically-derived haskell functions and print the (generated) markdown documentation for the API.
+- `greet.md` contains the aforementionned generated documentation.

example/greet.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Aeson
+import Data.Monoid
+import Data.Proxy
+import Data.Text
+import GHC.Generics
+import Network.Wai
+import Network.Wai.Handler.Warp
+
+import Servant
+
+-- * Example
+
+-- | A greet message data type
+newtype Greet = Greet { msg :: Text }
+  deriving (Generic, Show)
+
+instance FromJSON Greet
+instance ToJSON Greet
+
+-- API specification
+type TestApi =
+       -- GET /hello/:name?capital={true, false}  returns a Greet as JSON
+       "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
+
+       -- POST /greet with a Greet as JSON in the request body,
+       --             returns a Greet as JSON
+  :<|> "greet" :> ReqBody Greet :> Post Greet
+
+       -- DELETE /greet/:greetid
+  :<|> "greet" :> Capture "greetid" Text :> Delete
+
+testApi :: Proxy TestApi
+testApi = Proxy
+
+-- Server-side handlers.
+--
+-- There's one handler per endpoint, which, just like in the type
+-- that represents the API, are glued together using :<|>.
+--
+-- Each handler runs in the 'EitherT (Int, String) IO' monad.
+server :: Server TestApi
+server = helloH :<|> postGreetH :<|> deleteGreetH
+
+  where helloH name Nothing = helloH name (Just False)
+        helloH name (Just False) = return . Greet $ "Hello, " <> name
+        helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
+
+        postGreetH greet = return greet
+
+        deleteGreetH _ = return ()
+
+-- Turn the server into a WAI app. 'serve' is provided by servant,
+-- more precisely by the Servant.Server module.
+test :: Application
+test = serve testApi server
+
+-- Run the server.
+--
+-- 'run' comes from Network.Wai.Handler.Warp
+runTestServer :: Port -> IO ()
+runTestServer port = run port test
+
+-- Put this all to work!
+main :: IO ()
+main = runTestServer 8001

example/greet.md

@@ -0,0 +1,52 @@
+POST /greet
+-----------
+
+**Request Body**: 
+
+``` javascript
+{"msg":"Hello, haskeller!"}
+```
+
+**Response**: 
+
+ - Status code 201
+ - Response body as below.
+
+``` javascript
+{"msg":"Hello, haskeller!"}
+```
+
+GET /hello/:name
+----------------
+
+**Captures**: 
+
+- *name*: name of the person to greet
+
+**GET Parameters**: 
+
+ - capital
+     - **Values**: *true, false*
+     - **Description**: Get the greeting message in uppercase (true) or not (false). Default is false.
+
+
+**Response**: 
+
+ - Status code 200
+ - Response body as below.
+
+``` javascript
+{"msg":"Hello, haskeller!"}
+```
+
+DELETE /greet/:greetid
+----------------------
+
+**Captures**: 
+
+- *greetid*: identifier of the greet msg to remove
+
+**Response**: 
+
+ - Status code 204
+ - No response body

servant-server.cabal

@@ -0,0 +1,95 @@
+name:                servant-server
+version:             0.2.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
+  .
+  You can learn about the basics in <http://haskell-servant.github.io/getting-started/ the getting started> guide.
+  .
+  <https://github.com/haskell-servant/servant-server/blob/master/example/greet.hs Here>'s a runnable example, with comments, that defines a dummy API and
+  implements a webserver that serves this API, using this package.
+homepage:            http://haskell-servant.github.io/
+Bug-reports:         http://github.com/haskell-servant/servant-server/issues
+license:             BSD3
+license-file:        LICENSE
+author:              Alp Mestanogullari, Sönke Hahn, Julian K. Arni
+maintainer:          alpmestan@gmail.com
+copyright:           2014 Zalora South East Asia Pte Ltd
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+tested-with:         GHC >= 7.8
+source-repository head
+  type: git
+  location: http://github.com/haskell-servant/servant-server.git
+
+library
+  exposed-modules:
+    Servant
+    Servant.Server
+    Servant.Utils.StaticFiles
+  other-modules: Servant.Server.Internal
+  build-depends:
+      base >=4.7 && <5
+    , aeson
+    , attoparsec
+    , bytestring
+    , either
+    , http-types
+    , network-uri >= 2.6
+    , safe
+    , servant >= 0.2
+    , split
+    , string-conversions
+    , system-filepath
+    , text
+    , transformers
+    , wai
+    , wai-app-static
+    , warp
+  hs-source-dirs: src
+  default-language: Haskell2010
+  ghc-options: -Wall
+
+executable greet
+  main-is: greet.hs
+  hs-source-dirs: example
+  ghc-options: -Wall
+  default-language: Haskell2010
+  build-depends:
+      base
+    , servant
+    , servant-server
+    , aeson
+    , warp
+    , wai
+    , text
+
+test-suite spec
+  type: exitcode-stdio-1.0
+  ghc-options:
+    -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
+  default-language: Haskell2010
+  hs-source-dirs: test
+  main-is: Spec.hs
+  build-depends:
+      base == 4.*
+    , aeson
+    , bytestring
+    , directory
+    , either
+    , exceptions
+    , hspec == 2.*
+    , hspec-wai
+    , http-types
+    , network >= 2.6
+    , QuickCheck
+    , parsec
+    , servant
+    , string-conversions
+    , temporary
+    , text
+    , transformers
+    , wai
+    , wai-extra
+    , warp

src/Servant.hs

@@ -0,0 +1,24 @@
+module Servant (
+  -- | This module and its submodules can be used to define servant APIs. Note
+  -- that these API definitions don't directly implement a server (or anything
+  -- else).
+  module Servant.API,
+  -- | For implementing servers for servant APIs.
+  module Servant.Server,
+  -- | Using your types in request paths and query string parameters
+  module Servant.Common.Text,
+  -- | Utilities on top of the servant core
+  module Servant.QQ,
+  module Servant.Utils.Links,
+  module Servant.Utils.StaticFiles,
+  -- | Useful re-exports
+  Proxy(..),
+  ) where
+
+import Data.Proxy
+import Servant.API
+import Servant.Common.Text
+import Servant.Server
+import Servant.QQ
+import Servant.Utils.Links
+import Servant.Utils.StaticFiles

src/Servant/Server.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module lets you implement 'Server's for defined APIs. You'll
+-- most likely just need 'serve'.
+module Servant.Server
+  ( -- * Implementing an API
+    serve
+
+  , -- * Handlers for all standard combinators
+    HasServer(..)
+  ) where
+
+import Data.Proxy
+import Network.Wai
+import Servant.Server.Internal
+
+-- * Implementing Servers
+
+-- | 'serve' allows you to implement an API and produce a wai 'Application'.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> Get [Book] -- GET /books
+-- >         :<|> "books" :> ReqBody Book :> Post Book -- POST /books
+-- >
+-- > server :: Server MyApi
+-- > server = listAllBooks :<|> postBook
+-- >   where listAllBooks = ...
+-- >         postBook book = ...
+-- >
+-- > app :: Application
+-- > app = serve myApi server
+-- >
+-- > main :: IO ()
+-- > 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

@@ -0,0 +1,459 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Servant.Server.Internal where
+
+import Control.Applicative
+import Control.Monad.Trans.Either
+import Data.Aeson
+import Data.Maybe (catMaybes)
+import Data.Monoid
+import Data.Proxy
+import Data.String
+import Data.String.Conversions
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import GHC.TypeLits
+import Network.HTTP.Types hiding (Header)
+import Network.Wai
+import Servant.API
+import Servant.Common.Text
+
+toApplication :: RoutingApplication -> Application
+toApplication ra request respond = do
+  ra request (routingRespond . routeResult)
+ where
+  routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
+  routingRespond (Left NotFound) =
+    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 (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
+  deriving (Eq, Show)
+
+-- | 
+-- @
+-- > mempty = NotFound
+-- >
+-- > NotFound    `mappend`           x = x
+-- > WrongMethod `mappend` InvalidBody = InvalidBody
+-- > WrongMethod `mappend`           _ = WrongMethod
+-- > InvalidBody `mappend`           _ = InvalidBody
+-- @
+instance Monoid RouteMismatch where
+  mempty = NotFound
+
+  NotFound    `mappend`           x = x
+  WrongMethod `mappend` InvalidBody = InvalidBody
+  WrongMethod `mappend`           _ = WrongMethod
+  InvalidBody `mappend`           _ = InvalidBody
+
+-- | A wrapper around @'Either' 'RouteMismatch' a@.
+newtype RouteResult a =
+  RR { routeResult :: Either RouteMismatch a }
+  deriving (Eq, Show)
+
+failWith :: RouteMismatch -> RouteResult a
+failWith = RR . Left
+
+succeedWith :: a -> RouteResult a
+succeedWith = RR . Right
+
+isMismatch :: RouteResult a -> Bool
+isMismatch (RR (Left _)) = True
+isMismatch _             = False
+
+-- | If we get a `Right`, it has precedence over everything else.
+--
+-- This in particular means that if we could get several 'Right's,
+-- only the first we encounter would be taken into account.
+instance Monoid (RouteResult a) where
+  mempty = RR $ Left mempty
+
+  RR (Left x)  `mappend` RR (Left y)  = RR $ Left (x <> y)
+  RR (Left _)  `mappend` RR (Right y) = RR $ Right y
+  r            `mappend` _            = r
+
+type RoutingApplication =
+     Request -- ^ the request, the field 'pathInfo' may be modified by url routing
+  -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
+
+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
+--   represented by @a@ and if it fails tries @b@. You must provide a request
+--   handler for each route.
+--
+-- > type MyApi = "books" :> Get [Book] -- GET /books
+-- >         :<|> "books" :> ReqBody Book :> Post Book -- POST /books
+-- >
+-- > server :: Server MyApi
+-- > server = listAllBooks :<|> postBook
+-- >   where listAllBooks = ...
+-- >         postBook book = ...
+instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
+  type Server (a :<|> b) = Server a :<|> Server b
+  route Proxy (a :<|> b) request respond =
+    route pa a request $ \ mResponse ->
+      if isMismatch mResponse
+        then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
+        else respond mResponse
+
+    where pa = Proxy :: Proxy a
+          pb = Proxy :: Proxy b
+
+captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
+captured _ = fromText
+
+-- | If you use 'Capture' in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a function
+-- that takes an argument of the type specified by the 'Capture'.
+-- This lets servant worry about getting it from the URL and turning
+-- it into a value of the type you specify.
+--
+-- 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" :> Capture "isbn" Text :> Get Book
+-- >
+-- > server :: Server MyApi
+-- > server = getBook
+-- >   where getBook :: Text -> EitherT (Int, String) IO Book
+-- >         getBook isbn = ...
+instance (KnownSymbol capture, FromText a, HasServer sublayout)
+      => HasServer (Capture capture a :> sublayout) where
+
+  type Server (Capture capture a :> sublayout) =
+     a -> Server sublayout
+
+  route Proxy subserver request respond = case pathInfo request of
+    (first : rest)
+      -> case captured captureProxy first of
+           Nothing  -> respond $ failWith NotFound
+           Just v   -> route (Proxy :: Proxy sublayout) (subserver v) request{
+                         pathInfo = rest
+                       } respond
+    _ -> 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
+-- a resource.
+--
+-- The code of the handler will, just like
+-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and
+-- 'Servant.API.Put.Put', run in @EitherT (Int, String) IO ()@.
+-- The 'Int' represents the status code and the 'String' a message
+-- to be returned. You can use 'Control.Monad.Trans.Either.left' to
+-- painlessly error out if the conditions for a successful deletion
+-- are not met.
+instance HasServer Delete where
+  type Server Delete = EitherT (Int, String) IO ()
+
+  route Proxy action request respond
+    | null (pathInfo 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 =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- | When implementing the handler for a 'Get' endpoint,
+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
+-- and 'Servant.API.Put.Put', the handler code runs in the
+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
+-- the status code and the 'String' a message, returned in case of
+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
+-- to quickly fail if some conditions are not met.
+--
+-- If successfully returning a value, we just require that its type has
+-- a 'ToJSON' instance and servant takes care of encoding it for you,
+-- yielding status code 200 along the way.
+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
+        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 =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- | If you use 'Header' in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a function
+-- that takes an argument of the type specified by 'Header'.
+-- This lets servant worry about extracting it from the request and turning
+-- it into a value of the type you specify.
+--
+-- All it asks is for a 'FromText' instance.
+--
+-- Example:
+--
+-- > newtype Referer = Referer Text
+-- >   deriving (Eq, Show, FromText, ToText)
+-- >
+-- >            -- GET /view-my-referer
+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer
+-- >
+-- > server :: Server MyApi
+-- > server = viewReferer
+-- >   where viewReferer :: Referer -> EitherT (Int, String) IO referer
+-- >         viewReferer referer = return referer
+instance (KnownSymbol sym, FromText a, HasServer sublayout)
+      => HasServer (Header sym a :> sublayout) where
+
+  type Server (Header sym a :> sublayout) =
+    Maybe a -> Server sublayout
+
+  route Proxy subserver request respond = do
+    let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
+    route (Proxy :: Proxy sublayout) (subserver mheader) request respond
+
+      where str = fromString $ symbolVal (Proxy :: Proxy sym)
+
+-- | When implementing the handler for a 'Post' endpoint,
+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
+-- and 'Servant.API.Put.Put', the handler code runs in the
+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
+-- the status code and the 'String' a message, returned in case of
+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
+-- to quickly fail if some conditions are not met.
+--
+-- If successfully returning a value, we just require that its type has
+-- a 'ToJSON' instance and servant takes care of encoding it for you,
+-- yielding status code 201 along the way.
+instance ToJSON a => HasServer (Post a) where
+  type Server (Post a) = EitherT (Int, String) IO a
+
+  route Proxy action request respond
+    | null (pathInfo 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 =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- | When implementing the handler for a 'Put' endpoint,
+-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
+-- and 'Servant.API.Post.Post', the handler code runs in the
+-- @EitherT (Int, String) IO@ monad, where the 'Int' represents
+-- the status code and the 'String' a message, returned in case of
+-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
+-- to quickly fail if some conditions are not met.
+--
+-- If successfully returning a value, we just require that its type has
+-- a 'ToJSON' instance and servant takes care of encoding it for you,
+-- yielding status code 200 along the way.
+instance ToJSON a => HasServer (Put a) where
+  type Server (Put a) = EitherT (Int, String) IO a
+
+  route Proxy action request respond
+    | null (pathInfo 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 =
+        respond $ failWith WrongMethod
+
+    | otherwise = respond $ failWith NotFound
+
+-- | If you use @'QueryParam' "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" :> QueryParam "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 (QueryParam sym a :> sublayout) where
+
+  type Server (QueryParam sym a :> sublayout) =
+    Maybe a -> Server sublayout
+
+  route Proxy subserver request respond = do
+    let querytext = parseQueryText $ rawQueryString request
+        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
+
+    where paramname = cs $ symbolVal (Proxy :: Proxy sym)
+
+-- | If you use @'QueryParams' "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" :> QueryParams "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 (QueryParams sym a :> sublayout) where
+
+  type Server (QueryParams sym a :> sublayout) =
+    [a] -> Server sublayout
+
+  route Proxy subserver request respond = do
+    let querytext = parseQueryText $ rawQueryString request
+        -- if sym is "foo", we look for query string parameters
+        -- named "foo" or "foo[]" and call fromText on the
+        -- corresponding values
+        parameters = filter looksLikeParam querytext
+        values = catMaybes $ map (convert . snd) parameters
+
+    route (Proxy :: Proxy sublayout) (subserver values) 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 @'QueryFlag' "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" :> QueryFlag "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 (QueryFlag sym :> sublayout) where
+
+  type Server (QueryFlag sym :> sublayout) =
+    Bool -> Server sublayout
+
+  route Proxy subserver request respond = do
+    let querytext = parseQueryText $ rawQueryString request
+        param = case lookup paramname querytext 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
+
+    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:
+--
+-- > type MyApi = "images" :> Raw
+-- >
+-- > server :: Server MyApi
+-- > server = serveDirectory "/var/www/images"
+instance HasServer Raw where
+  type Server Raw = Application
+  route Proxy rawApplication request respond =
+    rawApplication request (respond . succeedWith)
+
+-- | If you use 'ReqBody' in one of the endpoints for your API,
+-- this automatically requires your server-side handler to be a function
+-- that takes an argument of the type specified by 'ReqBody'.
+-- This lets servant worry about extracting it from the request and turning
+-- it into a value of the type you specify.
+--
+-- All it asks is for a 'FromJSON' instance.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> ReqBody Book :> Post Book
+-- >
+-- > server :: Server MyApi
+-- > server = postBook
+-- >   where postBook :: Book -> EitherT (Int, String) IO Book
+-- >         postBook book = ...insert into your db...
+instance (FromJSON a, HasServer sublayout)
+      => HasServer (ReqBody a :> sublayout) where
+
+  type Server (ReqBody a :> sublayout) =
+    a -> Server sublayout
+
+  route Proxy subserver request respond = do
+    mrqbody <- decode' <$> lazyRequestBody request
+    case mrqbody of
+      Nothing -> respond $ failWith InvalidBody
+      Just 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
+    (first : rest)
+      | first == cs (symbolVal proxyPath)
+      -> route (Proxy :: Proxy sublayout) subserver request{
+           pathInfo = rest
+         } respond
+    _ -> respond $ failWith NotFound
+
+    where proxyPath = Proxy :: Proxy path

src/Servant/Utils/StaticFiles.hs

@@ -0,0 +1,36 @@
+-- | This module defines a sever-side handler that lets you serve static files.
+--
+-- - 'serveDirectory' lets you serve anything that lives under a particular
+--   directory on your filesystem.
+module Servant.Utils.StaticFiles (
+  serveDirectory,
+ ) where
+
+import Filesystem.Path.CurrentOS (decodeString)
+import Network.Wai.Application.Static
+import Servant.API.Raw
+import Servant.Server.Internal
+
+-- | Serve anything under the specified directory as a 'Raw' endpoint.
+--
+-- @
+-- type MyApi = "static" :> Raw
+--
+-- server :: Server MyApi
+-- server = serveDirectory "\/var\/www"
+-- @
+--
+-- would capture any request to @\/static\/\<something>@ and look for
+-- @\<something>@ under @\/var\/www@.
+--
+-- It will do its best to guess the MIME type for that file, based on the extension,
+-- and send an appropriate /Content-Type/ header if possible.
+--
+-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API
+-- as a webapp backend, you will most likely not want the static files to be hidden
+-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectory'
+-- handler in the last position, because /servant/ will try to match the handlers
+-- in order.
+serveDirectory :: FilePath -> Server Raw
+serveDirectory documentRoot =
+  staticApp (defaultFileServerSettings (decodeString (documentRoot ++ "/")))

test/Servant/ServerSpec.hs

@@ -0,0 +1,258 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Servant.ServerSpec where
+
+
+import Control.Monad.Trans.Either
+import Data.Aeson
+import Data.Char
+import Data.Proxy
+import Data.String
+import Data.String.Conversions
+import GHC.Generics
+import Network.HTTP.Types
+import Network.Wai
+import Network.Wai.Test
+import Test.Hspec
+import Test.Hspec.Wai
+
+import Servant.API.Capture
+import Servant.API.Get
+import Servant.API.ReqBody
+import Servant.API.Post
+import Servant.API.QueryParam
+import Servant.API.Raw
+import Servant.API.Sub
+import Servant.API.Alternative
+import Servant.Server
+
+
+-- * test data types
+
+data Person = Person {
+  name :: String,
+  age :: Integer
+ }
+  deriving (Eq, Show, Generic)
+
+instance ToJSON Person
+instance FromJSON Person
+
+alice :: Person
+alice = Person "Alice" 42
+
+data Animal = Animal {
+  species :: String,
+  numberOfLegs :: Integer
+ }
+  deriving (Eq, Show, Generic)
+
+instance ToJSON Animal
+instance FromJSON Animal
+
+jerry :: Animal
+jerry = Animal "Mouse" 4
+
+tweety :: Animal
+tweety = Animal "Bird" 2
+
+
+-- * specs
+
+spec :: Spec
+spec = do
+  captureSpec
+  getSpec
+  queryParamSpec
+  postSpec
+  rawSpec
+  unionSpec
+
+
+type CaptureApi = Capture "legs" Integer :> Get Animal
+captureApi :: Proxy CaptureApi
+captureApi = Proxy
+captureServer :: Integer -> EitherT (Int, String) IO Animal
+captureServer legs = case legs of
+  4 -> return jerry
+  2 -> return tweety
+  _ -> left (404, "not found")
+
+captureSpec :: Spec
+captureSpec = do
+  describe "Servant.API.Capture" $ do
+    with (return (serve captureApi captureServer)) $ do
+      it "can capture parts of the 'pathInfo'" $ do
+        response <- get "/2"
+        liftIO $ do
+          decode' (simpleBody response) `shouldBe` Just tweety
+
+    with (return (serve
+        (Proxy :: Proxy (Capture "captured" String :> Raw))
+        (\ "captured" request respond ->
+            respond $ responseLBS ok200 [] (cs $ show $ pathInfo request)))) $ do
+      it "strips the captured path snippet from pathInfo" $ do
+        get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
+
+
+type GetApi = Get Person
+getApi :: Proxy GetApi
+getApi = Proxy
+
+getSpec :: Spec
+getSpec = do
+  describe "Servant.API.Get" $ do
+    with (return (serve getApi (return alice))) $ do
+      it "allows to GET a Person" $ do
+        response <- get "/"
+        return response `shouldRespondWith` 200
+        liftIO $ do
+          decode' (simpleBody response) `shouldBe` Just alice
+
+      it "throws 405 (wrong method) on POSTs" $ do
+        post "/" "" `shouldRespondWith` 405
+
+
+type QueryParamApi = QueryParam "name" String :> Get Person
+                :<|> "a" :> QueryParams "names" String :> Get Person
+                :<|> "b" :> QueryFlag "capitalize" :> Get Person
+
+queryParamApi :: Proxy QueryParamApi
+queryParamApi = Proxy
+
+qpServer :: Server QueryParamApi
+qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize
+
+  where qpNames (_:name2:_) = return alice { name = name2 }
+        qpNames _           = return alice
+
+        qpCapitalize False = return alice
+        qpCapitalize True  = return alice { name = map toUpper (name alice) }
+
+        queryParamServer (Just name) = return alice{name = name}
+        queryParamServer Nothing = return alice
+
+queryParamSpec :: Spec
+queryParamSpec = do
+  describe "Servant.API.QueryParam" $ do
+      it "allows to retrieve simple GET parameters" $
+        (flip runSession) (serve queryParamApi qpServer) $ do
+          let params1 = "?name=bob"
+          response1 <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params1,
+            queryString = parseQuery params1
+           }
+          liftIO $ do
+            decode' (simpleBody response1) `shouldBe` Just alice{
+              name = "bob"
+             }
+
+      it "allows to retrieve lists in GET parameters" $
+        (flip runSession) (serve queryParamApi qpServer) $ do
+          let params2 = "?names[]=bob&names[]=john"
+          response2 <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params2,
+            queryString = parseQuery params2,
+            pathInfo = ["a"]
+           }
+          liftIO $
+            decode' (simpleBody response2) `shouldBe` Just alice{
+              name = "john"
+             }
+
+      it "allows to retrieve value-less GET parameters" $
+        (flip runSession) (serve queryParamApi qpServer) $ do
+          let params3 = "?capitalize"
+          response3 <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params3,
+            queryString = parseQuery params3,
+            pathInfo = ["b"]
+           }
+          liftIO $
+            decode' (simpleBody response3) `shouldBe` Just alice{
+              name = "ALICE"
+             }
+
+          let params3' = "?capitalize="
+          response3' <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params3',
+            queryString = parseQuery params3',
+            pathInfo = ["b"]
+           }
+          liftIO $
+            decode' (simpleBody response3') `shouldBe` Just alice{
+              name = "ALICE"
+             }
+
+type PostApi = ReqBody Person :> Post Integer
+postApi :: Proxy PostApi
+postApi = Proxy
+
+postSpec :: Spec
+postSpec = do
+  describe "Servant.API.Post and .ReqBody" $ do
+    with (return (serve postApi (return . age))) $ do
+      it "allows to POST a Person" $ do
+        post "/" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 201
+         }
+
+      it "correctly rejects invalid request bodies with status 400" $ do
+        post "/" "some invalid body" `shouldRespondWith` 400
+
+
+type RawApi = "foo" :> Raw
+rawApi :: Proxy RawApi
+rawApi = Proxy
+rawApplication :: Show a => (Request -> a) -> Application
+rawApplication f request respond = respond $ responseLBS ok200 [] (cs $ show $ f request)
+
+rawSpec :: Spec
+rawSpec = do
+  describe "Servant.API.Raw" $ do
+    it "runs applications" $ do
+      (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
+        response <- Network.Wai.Test.request defaultRequest{
+          pathInfo = ["foo"]
+         }
+        liftIO $ do
+          simpleBody response `shouldBe` "42"
+
+    it "gets the pathInfo modified" $ do
+      (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
+        response <- Network.Wai.Test.request defaultRequest{
+          pathInfo = ["foo", "bar"]
+         }
+        liftIO $ do
+          simpleBody response `shouldBe` cs (show ["bar" :: String])
+
+
+type AlternativeApi =
+       "foo" :> Get Person
+  :<|> "bar" :> Get Animal
+unionApi :: Proxy AlternativeApi
+unionApi = Proxy
+
+unionServer :: Server AlternativeApi
+unionServer =
+       return alice
+  :<|> return jerry
+
+unionSpec :: Spec
+unionSpec = do
+  describe "Servant.API.Alternative" $ do
+    with (return $ serve unionApi unionServer) $ do
+      it "unions endpoints" $ do
+        response <- get "/foo"
+        liftIO $ do
+          decode' (simpleBody response) `shouldBe`
+            Just alice
+        response <- get "/bar"
+        liftIO $ do
+          decode' (simpleBody response) `shouldBe`
+            Just jerry

test/Servant/Utils/StaticFilesSpec.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Servant.Utils.StaticFilesSpec where
+
+import Control.Exception
+import Data.Proxy
+import Network.Wai
+import System.Directory
+import System.IO.Temp
+import Test.Hspec hiding (pending)
+import Test.Hspec.Wai
+
+import Servant.API.Alternative
+import Servant.API.Capture
+import Servant.API.Get
+import Servant.API.Raw
+import Servant.API.Sub
+import Servant.Server
+import Servant.ServerSpec
+import Servant.Utils.StaticFiles
+
+type Api =
+       "dummy_api" :> Capture "person_name" String :> Get Person
+  :<|> "static" :> Raw
+
+
+api :: Proxy Api
+api = Proxy
+
+app :: Application
+app = serve api server
+
+server :: Server Api
+server =
+       (\ name -> return (Person name 42))
+  :<|> serveDirectory "static"
+
+withStaticFiles :: IO () -> IO ()
+withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->
+  bracket (setup tmpDir) teardown (const action)
+ where
+  setup tmpDir = do
+    outer <- getCurrentDirectory
+    setCurrentDirectory tmpDir
+    createDirectory "static"
+    writeFile "static/foo.txt" "bar"
+    writeFile "static/index.html" "index"
+    return outer
+
+  teardown outer = do
+    setCurrentDirectory outer
+
+spec :: Spec
+spec = do
+  around_ withStaticFiles $ with (return app) $ do
+    describe "serveDirectory" $ do
+      it "successfully serves files" $ do
+        get "/static/foo.txt" `shouldRespondWith` "bar"
+
+      it "serves the contents of index.html when requesting the root of a directory" $ do
+        get "/static" `shouldRespondWith` "index"

test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}