From cec89c1cd08d0976a9bda747a387a40c0de5ff91 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Tue, 2 Dec 2014 17:42:06 +0100 Subject: [PATCH] Built from d9d94e6f4e9349f232d4e0e99888e99faa583a57 --- LICENSE | 30 --- Setup.hs | 2 - example/README.md | 2 - example/greet.hs | 72 ------- example/greet.md | 52 ------ servant.cabal | 97 ---------- src/Servant.hs | 24 --- src/Servant/API.hs | 51 ----- src/Servant/API/Alternative.hs | 39 ---- src/Servant/API/Capture.hs | 60 ------ src/Servant/API/Delete.hs | 48 ----- src/Servant/API/Get.hs | 47 ----- src/Servant/API/Post.hs | 53 ------ src/Servant/API/Put.hs | 52 ------ src/Servant/API/QueryParam.hs | 162 ---------------- src/Servant/API/Raw.hs | 32 ---- src/Servant/API/ReqBody.hs | 49 ----- src/Servant/API/Sub.hs | 36 ---- src/Servant/Common/Text.hs | 130 ------------- src/Servant/QQ.hs | 198 -------------------- src/Servant/Server.hs | 105 ----------- src/Servant/Utils/Links.hs | 110 ----------- src/Servant/Utils/StaticFiles.hs | 36 ---- test/Servant/QQSpec.hs | 177 ------------------ test/Servant/ServerSpec.hs | 258 -------------------------- test/Servant/Utils/LinksSpec.hs | 52 ------ test/Servant/Utils/StaticFilesSpec.hs | 64 ------- test/Spec.hs | 1 - 28 files changed, 2039 deletions(-) delete mode 100644 LICENSE delete mode 100644 Setup.hs delete mode 100644 example/README.md delete mode 100644 example/greet.hs delete mode 100644 example/greet.md delete mode 100644 servant.cabal delete mode 100644 src/Servant.hs delete mode 100644 src/Servant/API.hs delete mode 100644 src/Servant/API/Alternative.hs delete mode 100644 src/Servant/API/Capture.hs delete mode 100644 src/Servant/API/Delete.hs delete mode 100644 src/Servant/API/Get.hs delete mode 100644 src/Servant/API/Post.hs delete mode 100644 src/Servant/API/Put.hs delete mode 100644 src/Servant/API/QueryParam.hs delete mode 100644 src/Servant/API/Raw.hs delete mode 100644 src/Servant/API/ReqBody.hs delete mode 100644 src/Servant/API/Sub.hs delete mode 100644 src/Servant/Common/Text.hs delete mode 100644 src/Servant/QQ.hs delete mode 100644 src/Servant/Server.hs delete mode 100644 src/Servant/Utils/Links.hs delete mode 100644 src/Servant/Utils/StaticFiles.hs delete mode 100644 test/Servant/QQSpec.hs delete mode 100644 test/Servant/ServerSpec.hs delete mode 100644 test/Servant/Utils/LinksSpec.hs delete mode 100644 test/Servant/Utils/StaticFilesSpec.hs delete mode 100644 test/Spec.hs diff --git a/LICENSE b/LICENSE deleted file mode 100644 index bfee8018..00000000 --- a/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -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/Setup.hs b/Setup.hs deleted file mode 100644 index 9a994af6..00000000 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/example/README.md b/example/README.md deleted file mode 100644 index a787d7c7..00000000 --- a/example/README.md +++ /dev/null @@ -1,2 +0,0 @@ -- `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 deleted file mode 100644 index 822559d6..00000000 --- a/example/greet.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# 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 deleted file mode 100644 index 149c3d59..00000000 --- a/example/greet.md +++ /dev/null @@ -1,52 +0,0 @@ -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.cabal b/servant.cabal deleted file mode 100644 index d163c6a8..00000000 --- a/servant.cabal +++ /dev/null @@ -1,97 +0,0 @@ -name: servant -version: 0.2 --- synopsis: --- description: -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 - -library - exposed-modules: - Servant - Servant.API - Servant.API.Alternative - Servant.API.Capture - Servant.API.Delete - Servant.API.Get - Servant.API.Post - Servant.API.Put - Servant.API.QueryParam - Servant.API.Raw - Servant.API.ReqBody - Servant.API.Sub - Servant.Common.Text - Servant.QQ - Servant.Server - Servant.Utils.Links - Servant.Utils.StaticFiles - build-depends: - base >=4.7 && <5 - , aeson - , attoparsec - , bytestring - , either - , http-types - , network-uri >= 2.6 - , parsec - , safe - , split - , string-conversions - , system-filepath - , template-haskell - , text - , transformers - , wai - , wai-app-static - , warp - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -O0 -Wall - -executable greet - main-is: greet.hs - hs-source-dirs: example - ghc-options: -O0 -Wall - default-language: Haskell2010 - build-depends: - base - , servant - , 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 deleted file mode 100644 index 0a92f8dd..00000000 --- a/src/Servant.hs +++ /dev/null @@ -1,24 +0,0 @@ -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/API.hs b/src/Servant/API.hs deleted file mode 100644 index c5a7a288..00000000 --- a/src/Servant/API.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Servant.API ( - - -- * Combinators - -- | Type-level combinator for expressing subrouting: @':>'@ - module Servant.API.Sub, - -- | Type-level combinator for alternative endpoints: @':<|>'@ - module Servant.API.Alternative, - - -- * Accessing information from the request - -- | Capturing parts of the url path as parsed values: @'Capture'@ - module Servant.API.Capture, - -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@ - module Servant.API.QueryParam, - -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@ - module Servant.API.ReqBody, - - -- * Actual endpoints, distinguished by HTTP method - -- | GET requests - module Servant.API.Get, - -- | POST requests - module Servant.API.Post, - -- | DELETE requests - module Servant.API.Delete, - -- | PUT requests - module Servant.API.Put, - - -- * Untyped endpoints - -- | Plugging in a wai 'Network.Wai.Application', serving directories - module Servant.API.Raw, - module Servant.Utils.StaticFiles, - - -- * Utilities - -- | QuasiQuotes for endpoints - module Servant.QQ, - -- | Type-safe internal URLs - module Servant.Utils.Links, - ) where - -import Servant.API.Alternative -import Servant.API.Capture -import Servant.API.Delete -import Servant.API.Get -import Servant.API.Post -import Servant.API.Put -import Servant.API.QueryParam -import Servant.API.Raw -import Servant.API.ReqBody -import Servant.API.Sub -import Servant.QQ (sitemap) -import Servant.Utils.Links (mkLink) -import Servant.Utils.StaticFiles diff --git a/src/Servant/API/Alternative.hs b/src/Servant/API/Alternative.hs deleted file mode 100644 index d8a73e59..00000000 --- a/src/Servant/API/Alternative.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Servant.API.Alternative where - -import Data.Monoid -import Data.Proxy -import Servant.Server - --- | Union of two APIs, first takes precedence in case of overlap. --- --- Example: --- --- > type MyApi = "books" :> Get [Book] -- GET /books --- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books -data a :<|> b = a :<|> b -infixr 8 :<|> - --- | 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 diff --git a/src/Servant/API/Capture.hs b/src/Servant/API/Capture.hs deleted file mode 100644 index fd92fd23..00000000 --- a/src/Servant/API/Capture.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Servant.API.Capture (Capture) where - -import Data.Proxy -import Data.Text -import GHC.TypeLits -import Network.Wai -import Servant.API.Sub -import Servant.Common.Text -import Servant.Server - --- | Capture a value from the request path under a certain type @a@. --- --- Example: --- --- > -- GET /books/:isbn --- > type MyApi = "books" :> Capture "isbn" Text :> Get Book -data Capture sym a - -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) diff --git a/src/Servant/API/Delete.hs b/src/Servant/API/Delete.hs deleted file mode 100644 index 8e6690be..00000000 --- a/src/Servant/API/Delete.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Servant.API.Delete where - -import Control.Monad.Trans.Either -import Data.Proxy -import Data.String.Conversions -import Data.Typeable -import Network.HTTP.Types -import Network.Wai -import Servant.Server - --- | Combinator for DELETE requests. --- --- Example: --- --- > -- DELETE /books/:isbn --- > type MyApi = "books" :> Capture "isbn" Text :> Delete -data Delete - deriving Typeable - --- | 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 diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs deleted file mode 100644 index d3d2f406..00000000 --- a/src/Servant/API/Get.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Servant.API.Get where - -import Control.Monad.Trans.Either -import Data.Aeson -import Data.Proxy -import Data.String.Conversions -import Data.Typeable -import Network.HTTP.Types -import Network.Wai -import Servant.Server - --- | Endpoint for simple GET requests. Serves the result as JSON. --- --- Example: --- --- > type MyApi = "books" :> Get [Book] -data Get a - deriving Typeable - --- | 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 diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs deleted file mode 100644 index a9600b29..00000000 --- a/src/Servant/API/Post.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Servant.API.Post where - -import Control.Monad.Trans.Either -import Data.Aeson -import Data.Proxy -import Data.String.Conversions -import Data.Typeable -import Network.HTTP.Types -import Network.Wai -import Servant.Server - --- | Endpoint for POST requests. The type variable represents the type of the --- response body (not the request body, use 'Servant.API.RQBody.RQBody' for --- that). --- --- Example: --- --- > -- POST /books --- > -- with a JSON encoded Book as the request body --- > -- returning the just-created Book --- > type MyApi = "books" :> ReqBody Book :> Post Book -data Post a - deriving Typeable - --- | 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 diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs deleted file mode 100644 index 527fc4e7..00000000 --- a/src/Servant/API/Put.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Servant.API.Put where - -import Control.Monad.Trans.Either -import Data.Aeson -import Data.Proxy -import Data.String.Conversions -import Data.Typeable -import Network.HTTP.Types -import Network.Wai -import Servant.Server - --- | Endpoint for PUT requests, usually used to update a ressource. --- The type @a@ is the type of the response body that's returned. --- --- Example: --- --- > -- PUT /books/:isbn --- > -- with a Book as request body, returning the updated Book --- > type MyApi = "books" :> Capture "isbn" Text :> ReqBody Book :> Put Book -data Put a - deriving Typeable - --- | 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 diff --git a/src/Servant/API/QueryParam.hs b/src/Servant/API/QueryParam.hs deleted file mode 100644 index 49978db3..00000000 --- a/src/Servant/API/QueryParam.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Servant.API.QueryParam where - -import Data.Maybe -import Data.Proxy -import Data.String.Conversions -import GHC.TypeLits -import Network.HTTP.Types -import Network.Wai -import Servant.API.Sub -import Servant.Common.Text -import Servant.Server - --- | Lookup the value associated to the @sym@ query string parameter --- and try to extract it as a value of type @a@. --- --- Example: --- --- > -- /books?author= --- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book] -data QueryParam sym a - --- | 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) - --- | Lookup the values associated to the @sym@ query string parameter --- and try to extract it as a value of type @[a]@. This is typically --- meant to support query string parameters of the form --- @param[]=val1¶m[]=val2@ and so on. Note that servant doesn't actually --- require the @[]@s and will fetch the values just fine with --- @param=val1¶m=val2@, too. --- --- Example: --- --- > -- /books?authors[]=&authors[]=&... --- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book] -data QueryParams sym a - --- | 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 - --- | Lookup a potentially value-less query string parameter --- with boolean semantics. If the param @sym@ is there without any value, --- or if it's there with value "true" or "1", it's interpreted as 'True'. --- Otherwise, it's interpreted as 'False'. --- --- Example: --- --- > -- /books?published --- > type MyApi = "books" :> QueryFlag "published" :> Get [Book] -data QueryFlag sym - --- | 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 diff --git a/src/Servant/API/Raw.hs b/src/Servant/API/Raw.hs deleted file mode 100644 index 2d8d175a..00000000 --- a/src/Servant/API/Raw.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -module Servant.API.Raw where - -import Data.Proxy -import Network.Wai -import Servant.Server - --- | Endpoint for plugging in your own Wai 'Application's. --- --- The given 'Application' will get the request as received by the server, potentially with --- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'. --- --- In addition to just letting you plug in your existing WAI 'Application's, --- this can also be used with 'Servant.Utils.StaticFiles.serveDirectory' to serve --- static files stored in a particular directory on your filesystem, or to serve --- your API's documentation with 'Servant.Utils.StaticFiles.serveDocumentation'. -data Raw - --- | 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) diff --git a/src/Servant/API/ReqBody.hs b/src/Servant/API/ReqBody.hs deleted file mode 100644 index 2e6aabb9..00000000 --- a/src/Servant/API/ReqBody.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Servant.API.ReqBody where - -import Control.Applicative -import Data.Aeson -import Data.Proxy -import Network.Wai -import Servant.API.Sub -import Servant.Server - --- | Extract the request body as a value of type @a@. --- --- Example: --- --- > -- POST /books --- > type MyApi = "books" :> ReqBody Book :> Post Book -data ReqBody a - --- | 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 diff --git a/src/Servant/API/Sub.hs b/src/Servant/API/Sub.hs deleted file mode 100644 index 06a3ff84..00000000 --- a/src/Servant/API/Sub.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Servant.API.Sub where - -import Data.Proxy -import Data.String.Conversions -import GHC.TypeLits -import Network.Wai -import Servant.Server - --- | The contained API (second argument) can be found under @("/" ++ path)@ --- (path being the first argument). --- --- Example: --- --- > -- GET /hello/world --- > -- returning a JSON encoded World value --- > type MyApi = "hello" :> "world" :> Get World -data (path :: k) :> a = Proxy path :> a -infixr 9 :> - --- | 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/Common/Text.hs b/src/Servant/Common/Text.hs deleted file mode 100644 index facac1ec..00000000 --- a/src/Servant/Common/Text.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} -module Servant.Common.Text - ( FromText(..) - , ToText(..) - ) where - -import Data.String.Conversions -import Data.Int -import Data.Text -import Data.Text.Read -import Data.Word - --- | For getting values from url captures and query string parameters -class FromText a where - fromText :: Text -> Maybe a - --- | For putting values in paths and query string parameters -class ToText a where - toText :: a -> Text - -instance FromText Text where - fromText = Just - -instance ToText Text where - toText = id - -instance FromText String where - fromText = Just . cs - -instance ToText String where - toText = cs - --- | --- > fromText "true" = Just True --- > fromText "false" = Just False --- > fromText _ = Nothing -instance FromText Bool where - fromText "true" = Just True - fromText "false" = Just False - fromText _ = Nothing - --- | --- > toText True = "true" --- > toText False = "false" -instance ToText Bool where - toText True = "true" - toText False = "false" - -instance FromText Int where - fromText = runReader (signed decimal) - -instance ToText Int where - toText = cs . show - -instance FromText Int8 where - fromText = runReader (signed decimal) - -instance ToText Int8 where - toText = cs . show - -instance FromText Int16 where - fromText = runReader (signed decimal) - -instance ToText Int16 where - toText = cs . show - -instance FromText Int32 where - fromText = runReader (signed decimal) - -instance ToText Int32 where - toText = cs . show - -instance FromText Int64 where - fromText = runReader (signed decimal) - -instance ToText Int64 where - toText = cs . show - -instance FromText Word where - fromText = runReader decimal - -instance ToText Word where - toText = cs . show - -instance FromText Word8 where - fromText = runReader decimal - -instance ToText Word8 where - toText = cs . show - -instance FromText Word16 where - fromText = runReader decimal - -instance ToText Word16 where - toText = cs . show - -instance FromText Word32 where - fromText = runReader decimal - -instance ToText Word32 where - toText = cs . show - -instance FromText Word64 where - fromText = runReader decimal - -instance ToText Word64 where - toText = cs . show - -instance FromText Integer where - fromText = runReader decimal - -instance ToText Integer where - toText = cs . show - -instance FromText Double where - fromText = runReader rational - -instance ToText Double where - toText = cs . show - -instance FromText Float where - fromText = runReader rational - -instance ToText Float where - toText = cs . show - -runReader :: Reader a -> Text -> Maybe a -runReader reader t = either (const Nothing) (Just . fst) $ reader t diff --git a/src/Servant/QQ.hs b/src/Servant/QQ.hs deleted file mode 100644 index a886c90f..00000000 --- a/src/Servant/QQ.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} --- | QuasiQuoting utilities for API types. --- --- 'sitemap' allows you to write your type in a very natural way: --- --- @ --- [sitemap| --- PUT hello String -> () --- POST hello/p:Int String -> () --- GET hello/?name:String Int --- |] --- @ --- --- Will generate: --- --- @ --- "hello" :> ReqBody String :> Put () --- :\<|> "hello" :> Capture "p" Int :> ReqBody String :> Post () --- :\<|> "hello" :> QueryParam "name" String :> Get Int --- @ --- --- Note the @/@ before a @QueryParam@! -module Servant.QQ where - -import Control.Monad (void) -import Control.Applicative hiding (many, (<|>), optional) -import Language.Haskell.TH.Quote -import Language.Haskell.TH -import Text.ParserCombinators.Parsec - -import Servant.API.Capture -import Servant.API.Get -import Servant.API.Post -import Servant.API.Put -import Servant.API.Delete -import Servant.API.QueryParam -import Servant.API.ReqBody -import Servant.API.Sub -import Servant.API.Alternative - --- | Finally-tagless encoding for our DSL. --- Keeping 'repr'' and 'repr' distinct when writing functions with an --- @ExpSYM@ context ensures certain invariants (for instance, that there is --- only one of 'get', 'post', 'put', and 'delete' in a value), but --- sometimes requires a little more work. -class ExpSYM repr' repr | repr -> repr', repr' -> repr where - lit :: String -> repr' -> repr - capture :: String -> String -> repr -> repr - reqBody :: String -> repr -> repr - queryParam :: String -> String -> repr -> repr - conj :: repr' -> repr -> repr - get :: String -> repr - post :: String -> repr - put :: String -> repr - delete :: String -> repr - - -infixr 6 >: - -(>:) :: Type -> Type -> Type -(>:) = conj - - -instance ExpSYM Type Type where - lit name r = LitT (StrTyLit name) >: r - capture name typ r = AppT (AppT (ConT ''Capture) (LitT (StrTyLit name))) - (ConT $ mkName typ) >: r - reqBody typ r = AppT (ConT ''ReqBody) (ConT $ mkName typ) >: r - queryParam name typ r = AppT (AppT (ConT ''QueryParam) (LitT (StrTyLit name))) - (ConT $ mkName typ) >: r - conj x = AppT (AppT (ConT ''(:>)) x) - get typ = AppT (ConT ''Get) (ConT $ mkName typ) - post typ = AppT (ConT ''Post) (ConT $ mkName typ) - put typ = AppT (ConT ''Put) (ConT $ mkName typ) - delete "()" = ConT ''Delete - delete _ = error "Delete does not return a request body" - -parseMethod :: ExpSYM repr' repr => Parser (String -> repr) -parseMethod = try (string "GET" >> return get) - <|> try (string "POST" >> return post) - <|> try (string "PUT" >> return put) - <|> try (string "DELETE" >> return delete) - -parseUrlSegment :: ExpSYM repr repr => Parser (repr -> repr) -parseUrlSegment = try parseCapture - <|> try parseQueryParam - <|> try parseLit - where - parseCapture = do - cname <- many (noneOf " ?/:") - char ':' - ctyp <- many (noneOf " ?/:") - return $ capture cname ctyp - parseQueryParam = do - char '?' - cname <- many (noneOf " ?/:") - char ':' - ctyp <- many (noneOf " ?/:") - return $ queryParam cname ctyp - parseLit = lit <$> many (noneOf " ?/:") - -parseUrl :: ExpSYM repr repr => Parser (repr -> repr) -parseUrl = do - optional $ char '/' - url <- parseUrlSegment `sepBy1` char '/' - return $ foldr1 (.) url - -data Typ = Val String - | ReqArgVal String String - -parseTyp :: Parser Typ -parseTyp = do - f <- many (noneOf "-{\n\r") - spaces - s <- optionMaybe (try parseRet) - try $ optional inlineComment - try $ optional blockComment - case s of - Nothing -> return $ Val (stripTr f) - Just s' -> return $ ReqArgVal (stripTr f) (stripTr s') - where - parseRet :: Parser String - parseRet = do - string "->" - spaces - many (noneOf "-{\n\r") - stripTr = reverse . dropWhile (== ' ') . reverse - - -parseEntry :: ExpSYM repr repr => Parser repr -parseEntry = do - met <- parseMethod - spaces - url <- parseUrl - spaces - typ <- parseTyp - case typ of - Val s -> return $ url (met s) - ReqArgVal i o -> return $ url $ reqBody i (met o) - -blockComment :: Parser () -blockComment = do - string "{-" - manyTill anyChar (try $ string "-}") - return () - -inlineComment :: Parser () -inlineComment = do - string "--" - manyTill anyChar (try $ lookAhead eol) - return () - -eol :: Parser String -eol = try (string "\n\r") - <|> try (string "\r\n") - <|> string "\n" - <|> string "\r" - "end of line" - -eols :: Parser () -eols = skipMany $ void eol <|> blockComment <|> inlineComment - -parseAll :: Parser Type -parseAll = do - eols - entries <- parseEntry `endBy` eols - return $ foldr1 union entries - where union :: Type -> Type -> Type - union a = AppT (AppT (ConT ''(:<|>)) a) - --- | The sitemap QuasiQuoter. --- --- * @.../:/...@ becomes a capture --- * @.../?:@ becomes a query parameter --- * @ ... @ becomes a method returning @@ --- * @ ... -> @ becomes a method with request --- body of @@ and returning @@ --- --- Comments are allowed, and have the standard Haskell format --- --- * @--@ for inline --- * @{- ... -}@ for block --- -sitemap :: QuasiQuoter -sitemap = QuasiQuoter { quoteExp = undefined - , quotePat = undefined - , quoteType = \x -> case parse parseAll "" x of - Left err -> error $ show err - Right st -> return st - , quoteDec = undefined - } - diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs deleted file mode 100644 index 3dc6f168..00000000 --- a/src/Servant/Server.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} - --- | This module lets you implement 'Server's for defined APIs. You'll --- most likely just need 'serve'. -module Servant.Server where - -import Data.Monoid -import Data.Proxy -import Network.HTTP.Types -import Network.Wai - --- * 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) - -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 diff --git a/src/Servant/Utils/Links.hs b/src/Servant/Utils/Links.hs deleted file mode 100644 index 547a3555..00000000 --- a/src/Servant/Utils/Links.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} --- | Type safe internal links. --- --- Provides the function 'mkLink': --- --- @ --- type API = Proxy ("hello" :> Get Int --- :<|> "bye" :> QueryParam "name" String :> Post Bool) --- --- api :: API --- api = proxy --- --- link1 :: Proxy ("hello" :> Get Int) --- link1 = proxy --- --- link2 :: Proxy ("hello" :> Delete) --- link2 = proxy --- --- mkLink link1 API -- typechecks, returns 'Link "/hello"' --- --- mkLink link2 API -- doesn't typecheck --- @ --- --- That is, 'mkLink' takes two arguments, a link proxy and a sitemap, and --- returns a 'Link', but only typechecks if the link proxy is a valid link, --- and part of the sitemap. --- --- __N.B.:__ 'mkLink' assumes a capture matches any string (without slashes). -module Servant.Utils.Links where - -import Data.Proxy -import GHC.TypeLits - -import Servant.API.Capture -import Servant.API.ReqBody -import Servant.API.QueryParam -import Servant.API.Get -import Servant.API.Post -import Servant.API.Put -import Servant.API.Delete -import Servant.API.Sub -import Servant.API.Alternative - - -type family Or a b where - Or 'False 'False = 'False - Or 'True b = 'True - Or a 'True = 'True - -type family And a b where - And 'True 'True = 'True - And a 'False = 'False - And 'False b = 'False - -type family IsElem a s where - IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb) - IsElem (e :> sa) (e :> sb) = IsElem sa sb - IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb - IsElem sa (ReqBody x :> sb) = IsElem sa sb - IsElem sa (QueryParam x y :> sb) = IsElem sa sb - IsElem e e = 'True - IsElem e a = 'False - -type family IsLink'' l where - IsLink'' (e :> Get x) = IsLink' e - IsLink'' (e :> Post x) = IsLink' e - IsLink'' (e :> Put x) = IsLink' e - IsLink'' (e :> Delete) = IsLink' e - IsLink'' a = 'False - -type family IsLink' e where - IsLink' (f :: Symbol) = 'True - -type family IsLink e where - IsLink (a :> b) = Or (And (IsLink' a) (IsLink'' b)) - (IsLink'' (a :> b)) - - --- | The 'ValidLinkIn f s' constraint holds when 's' is an API that --- contains 'f', and 'f' is a link. -class ValidLinkIn f s where - mkLink :: f -> s -> Link -- ^ This function will only typecheck if `f` - -- is an URI within `s` - -instance ( IsElem f s ~ 'True - , IsLink f ~ 'True - , VLinkHelper f) => ValidLinkIn f s where - mkLink _ _ = Link (vlh (Proxy :: Proxy f)) - -data Link = Link String deriving Show - -class VLinkHelper f where - vlh :: forall proxy. proxy f -> String - -instance (KnownSymbol s, VLinkHelper e) => VLinkHelper (s :> e) where - vlh _ = "/" ++ symbolVal (Proxy :: Proxy s) ++ vlh (Proxy :: Proxy e) - -instance VLinkHelper (Get x) where - vlh _ = "" - -instance VLinkHelper (Post x) where - vlh _ = "" - diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs deleted file mode 100644 index a8a05ed4..00000000 --- a/src/Servant/Utils/StaticFiles.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | 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 - --- | 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/QQSpec.hs b/test/Servant/QQSpec.hs deleted file mode 100644 index adf59611..00000000 --- a/test/Servant/QQSpec.hs +++ /dev/null @@ -1,177 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Servant.QQSpec where - -import Test.Hspec - -import Servant.API - --------------------------------------------------------------------------- --- Types for testing --------------------------------------------------------------------------- - --- Methods --------------------------------------------------------------- -type SimpleGet = [sitemap| -GET hello () -|] -type SimpleGet' = "hello" :> Get () -type SimpleGet'' = "hello" :> Get Bool - -type SimpleGet2 = [sitemap| -GET hello Bool -|] -type SimpleGet2' = "hello" :> Get Bool -type SimpleGet2'' = "hello" :> Get Int - -type SimplePost = [sitemap| -POST hello () -|] -type SimplePost' = "hello" :> Post () -type SimplePost'' = "hello" :> Post Bool - -type SimplePost2 = [sitemap| -POST hello Bool -|] -type SimplePost2' = "hello" :> Post Bool -type SimplePost2'' = "hello" :> Post () - -type SimplePut = [sitemap| -PUT hello () -|] -type SimplePut' = "hello" :> Put () -type SimplePut'' = "hello" :> Put Bool - -type SimplePut2 = [sitemap| -PUT hello Bool -|] -type SimplePut2' = "hello" :> Put Bool -type SimplePut2'' = "hello" :> Put () - --- Parameters ------------------------------------------------------------ - -type SimpleReqBody = [sitemap| -POST hello () -> Bool -|] -type SimpleReqBody' = "hello" :> ReqBody () :> Post Bool -type SimpleReqBody'' = "hello" :> ReqBody Bool :> Post () - -type SimpleCapture = [sitemap| -POST hello/p:Int Bool -|] -type SimpleCapture' = "hello" :> Capture "p" Int :> Post Bool -type SimpleCapture'' = "hello" :> Capture "r" Int :> Post Bool -type SimpleCapture''' = "hello" :> Capture "p" Bool :> Post Bool - -type SimpleQueryParam = [sitemap| -POST hello/?p:Int Bool -|] -type SimpleQueryParam' = "hello" :> QueryParam "p" Int :> Post Bool -type SimpleQueryParam'' = "hello" :> QueryParam "r" Int :> Post Bool -type SimpleQueryParam''' = "hello" :> QueryParam "p" Bool :> Post Bool - --- Combinations ---------------------------------------------------------- - -type TwoPaths = [sitemap| -POST hello Bool -GET hello Bool -|] -type TwoPaths' = ("hello" :> Post Bool) :<|> ("hello" :> Get Bool) - -type WithInlineComments = [sitemap| -GET hello Bool -- This is a comment -|] -type WithInlineComments' = "hello" :> Get Bool - -type WithInlineComments2 = [sitemap| -GET hello Bool --- This is a comment -|] -type WithInlineComments2' = "hello" :> Get Bool - - -type WithBlockComments = [sitemap| -GET hello Bool {- -POST hello Bool --} -|] -type WithBlockComments' = "hello" :> Get Bool - -type WithBlockComments2 = [sitemap| -GET hello Bool {- -POST hello Bool --} -POST hello Bool -|] -type WithBlockComments2' = ("hello" :> Get Bool) :<|> ("hello" :> Post Bool) - --------------------------------------------------------------------------- --- Spec --------------------------------------------------------------------------- - -spec :: Spec -spec = do - describe "'sitemap' QuasiQuoter" $ do - it "Handles simple GET types" $ do - (u::SimpleGet) ~= (u::SimpleGet' ) ~> True - (u::SimpleGet) ~= (u::SimpleGet'' ) ~> False - (u::SimpleGet2) ~= (u::SimpleGet2' ) ~> True - (u::SimpleGet2) ~= (u::SimpleGet2'') ~> False - it "Handles simple POST types" $ do - (u::SimplePost) ~= (u::SimplePost' ) ~> True - (u::SimplePost) ~= (u::SimplePost'' ) ~> False - (u::SimplePost2) ~= (u::SimplePost2' ) ~> True - (u::SimplePost2) ~= (u::SimplePost2'') ~> False - it "Handles simple PUT types" $ do - (u::SimplePut) ~= (u::SimplePut' ) ~> True - (u::SimplePut) ~= (u::SimplePut'' ) ~> False - (u::SimplePut2) ~= (u::SimplePut2' ) ~> True - (u::SimplePut2) ~= (u::SimplePut2'') ~> False - it "Handles simple request body types" $ do - (u::SimpleReqBody) ~= (u::SimpleReqBody' ) ~> True - (u::SimpleReqBody) ~= (u::SimpleReqBody'') ~> False - it "Handles simple captures" $ do - (u::SimpleCapture) ~= (u::SimpleCapture' ) ~> True - (u::SimpleCapture) ~= (u::SimpleCapture'') ~> False - (u::SimpleCapture) ~= (u::SimpleCapture''') ~> False - it "Handles simple querystring parameters" $ do - (u::SimpleQueryParam) ~= (u::SimpleQueryParam' ) ~> True - (u::SimpleQueryParam) ~= (u::SimpleQueryParam'') ~> False - (u::SimpleQueryParam) ~= (u::SimpleQueryParam''') ~> False - it "Handles multiples paths" $ do - (u::TwoPaths) ~= (u::TwoPaths') ~> True - it "Ignores inline comments" $ do - (u::WithInlineComments) ~= (u::WithInlineComments') ~> True - (u::WithInlineComments2) ~= (u::WithInlineComments2') ~> True - it "Ignores inline comments" $ do - (u::WithBlockComments) ~= (u::WithBlockComments') ~> True - (u::WithBlockComments2) ~= (u::WithBlockComments2') ~> True - - --------------------------------------------------------------------------- --- Utilities --------------------------------------------------------------------------- -data HTrue -data HFalse - --- Kiselyov's Type Equality predicate -class TypeEq x y b | x y -> b where { areEq :: x -> y -> Bool } -instance TypeEq x x HTrue where { areEq _ _ = True } -instance b ~ HFalse => TypeEq x y b where { areEq _ _ = False} - -infix 4 ~= -(~=) :: TypeEq x y b => x -> y -> Bool -(~=) = areEq - -u :: a -u = undefined - -infix 3 ~> -(~>) :: (Show a, Eq a) => a -> a -> Expectation -(~>) = shouldBe diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs deleted file mode 100644 index 38313136..00000000 --- a/test/Servant/ServerSpec.hs +++ /dev/null @@ -1,258 +0,0 @@ -{-# 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/LinksSpec.hs b/test/Servant/Utils/LinksSpec.hs deleted file mode 100644 index 3f16d71b..00000000 --- a/test/Servant/Utils/LinksSpec.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -module Servant.Utils.LinksSpec where - -import Test.Hspec - -import Servant.API -import Servant.QQSpec ( (~>) ) -import Servant.Utils.Links (IsElem, IsLink) - -type TestApi = - "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Get Bool - :<|> "greet" :> ReqBody 'True :> Post Bool - -type TestLink = "hello" :> "hi" :> Get Bool -type TestLink2 = "greet" :> Post Bool - -type BadTestLink = "hallo" :> "hi" :> Get Bool -type BadTestLink2 = "greet" :> Get Bool - -type NotALink = "hello" :> Capture "x" Bool :> Get Bool -type NotALink2 = "hello" :> ReqBody 'True :> Get Bool - -data Proxy x = Proxy -class ReflectT (x::Bool) where { reflected :: Proxy x -> Bool } -instance ReflectT 'True where { reflected _ = True } -instance ReflectT 'False where { reflected _ = False } - -spec :: Spec -spec = describe "Servant.API.Elem" $ do - isElem - isLink - -isElem :: Spec -isElem = describe "IsElem" $ do - it "is True when the first argument is an url within the second" $ do - reflected (Proxy::Proxy (IsElem TestLink TestApi)) ~> True - reflected (Proxy::Proxy (IsElem TestLink2 TestApi)) ~> True - it "is False when the first argument is not an url within the second" $ do - reflected (Proxy::Proxy (IsElem BadTestLink TestApi)) ~> False - reflected (Proxy::Proxy (IsElem BadTestLink2 TestApi)) ~> False - -isLink :: Spec -isLink = describe "IsLink" $ do - it "is True when all Subs are paths and the last is a method" $ do - reflected (Proxy::Proxy (IsLink TestLink)) ~> True - reflected (Proxy::Proxy (IsLink TestLink2)) ~> True - it "is False of anything with captures" $ do - reflected (Proxy::Proxy (IsLink NotALink)) ~> False - reflected (Proxy::Proxy (IsLink NotALink2)) ~> False - diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/test/Servant/Utils/StaticFilesSpec.hs deleted file mode 100644 index 8d34f90f..00000000 --- a/test/Servant/Utils/StaticFilesSpec.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# 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 deleted file mode 100644 index a824f8c3..00000000 --- a/test/Spec.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-}