From e43532b71dd67a7c48f8ed69e66be031344e4ba4 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Wed, 10 Dec 2014 16:10:57 +0100 Subject: [PATCH] first shot at a server package --- LICENSE | 30 ++ README.md | 25 ++ Setup.hs | 2 + example/README.md | 2 + example/greet.hs | 72 ++++ example/greet.md | 52 +++ servant-server.cabal | 95 ++++++ src/Servant.hs | 24 ++ src/Servant/Server.hs | 39 +++ src/Servant/Server/Internal.hs | 459 ++++++++++++++++++++++++++ src/Servant/Utils/StaticFiles.hs | 36 ++ test/Servant/ServerSpec.hs | 258 +++++++++++++++ test/Servant/Utils/StaticFilesSpec.hs | 64 ++++ test/Spec.hs | 1 + 14 files changed, 1159 insertions(+) create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 example/README.md create mode 100644 example/greet.hs create mode 100644 example/greet.md create mode 100644 servant-server.cabal create mode 100644 src/Servant.hs create mode 100644 src/Servant/Server.hs create mode 100644 src/Servant/Server/Internal.hs create mode 100644 src/Servant/Utils/StaticFiles.hs create mode 100644 test/Servant/ServerSpec.hs create mode 100644 test/Servant/Utils/StaticFilesSpec.hs create mode 100644 test/Spec.hs diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..bfee8018 --- /dev/null +++ b/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. diff --git a/README.md b/README.md new file mode 100644 index 00000000..7d978b8a --- /dev/null +++ b/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/) diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/README.md b/example/README.md new file mode 100644 index 00000000..a787d7c7 --- /dev/null +++ b/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. \ No newline at end of file diff --git a/example/greet.hs b/example/greet.hs new file mode 100644 index 00000000..822559d6 --- /dev/null +++ b/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 diff --git a/example/greet.md b/example/greet.md new file mode 100644 index 00000000..149c3d59 --- /dev/null +++ b/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 diff --git a/servant-server.cabal b/servant-server.cabal new file mode 100644 index 00000000..03d62aa2 --- /dev/null +++ b/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 guide. + . + '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 diff --git a/src/Servant.hs b/src/Servant.hs new file mode 100644 index 00000000..0a92f8dd --- /dev/null +++ b/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 diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs new file mode 100644 index 00000000..d1d6e4c4 --- /dev/null +++ b/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) + diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs new file mode 100644 index 00000000..a706c211 --- /dev/null +++ b/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 diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs new file mode 100644 index 00000000..17146aa7 --- /dev/null +++ b/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\/\@ and look for +-- @\@ 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 ++ "/"))) diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs new file mode 100644 index 00000000..38313136 --- /dev/null +++ b/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 diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/test/Servant/Utils/StaticFilesSpec.hs new file mode 100644 index 00000000..8d34f90f --- /dev/null +++ b/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" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}