servant 0.1 → 0.2

raw patch · 26 files changed

+1540/−525 lines, 26 filesdep +QuickCheckdep +aesondep +attoparsecdep ~basenew-component:exe:greetPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, aeson, attoparsec, bytestring, directory, either, exceptions, hspec, hspec-wai, http-types, network, network-uri, parsec, safe, servant, split, string-conversions, system-filepath, template-haskell, temporary, text, transformers, wai, wai-app-static, wai-extra, warp

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• LICENSE +2/−2
• example/greet.hs +72/−0
• servant.cabal +172/−26
• src/Servant.hs +24/−0
• src/Servant/API.hs +54/−0
• src/Servant/API/Alternative.hs +39/−0
• src/Servant/API/Capture.hs +60/−0
• src/Servant/API/Delete.hs +48/−0
• src/Servant/API/Get.hs +47/−0
• src/Servant/API/Header.hs +58/−0
• src/Servant/API/Post.hs +53/−0
• src/Servant/API/Put.hs +52/−0
• src/Servant/API/QueryParam.hs +162/−0
• src/Servant/API/Raw.hs +32/−0
• src/Servant/API/ReqBody.hs +49/−0
• src/Servant/API/Sub.hs +36/−0
• src/Servant/Common/Text.hs +130/−0
• src/Servant/Context.hs +0/−47
• src/Servant/Error.hs +0/−94
• src/Servant/Prelude.hs +0/−163
• src/Servant/QQ.hs +198/−0
• src/Servant/Resource.hs +0/−193
• src/Servant/Server.hs +105/−0
• src/Servant/Utils/Links.hs +110/−0
• src/Servant/Utils/StaticFiles.hs +36/−0
• test/Spec.hs +1/−0

@@ -1,4 +1,4 @@-Copyright (c) 2014, Alp Mestanogullari+Copyright (c) 2014, Zalora South East Asia Pte Ltd  All rights reserved. @@ -13,7 +13,7 @@       disclaimer in the documentation and/or other materials provided       with the distribution. -    * Neither the name of Alp Mestanogullari nor the names of other+    * 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. 

@@ -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

@@ -1,37 +1,183 @@ name:                servant-version:             0.1-synopsis:            A library to generate REST-style webservices on top of scotty, handling all the boilerplate for you-description:         -  An abstraction for 'Resource's that can support any number-  of operations, which will be tagged at the type-level.+version:             0.2+synopsis:            A family of combinators for defining webservices APIs and serving them+description:+  A family of combinators for defining webservices APIs and serving them   .-  This package however does provide standard /REST-y/ operations-  ('Servant.Operation.Add', 'Servant.Operation.Delete', 'Servant.Operation.ListAll'-  , 'Servant.Operation.Update' and 'Servant.Operation.View') and lets you define your-  own.+  You can learn about the basics in <http://haskell-servant.github.io/getting-started/ the getting started> guide.   .-  You can then actually make a service out of a 'Servant.Resource.Resource' description-  using any backend you like (we currently only provide a-  <http://hackage.haskell.org/package/scotty scotty> backend in-  the /servant-scotty/ package).-homepage:            http://github.com/zalora/servant+  Here's a runnable example, with comments, that defines a dummy API and+  implements a webserver that serves this API. You can find it <https://github.com/haskell-servant/servant/blob/master/example/greet.hs here> too.+  .+  > {-# 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+homepage:            http://haskell-servant.github.io/+Bug-reports:         http://github.com/haskell-servant/servant/issues license:             BSD3 license-file:        LICENSE-author:              Alp Mestanogullari-maintainer:          alp@zalora.com-copyright:           2014 Zalora SEA-category:            Web, Database+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.git  library   exposed-modules:-      Servant.Context-    , Servant.Error-    , Servant.Prelude-    , Servant.Resource+    Servant+    Servant.API+    Servant.API.Alternative+    Servant.API.Capture+    Servant.API.Delete+    Servant.API.Get+    Servant.API.Header+    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 && <5-  hs-source-dirs:      src-  default-language:    Haskell2010-  ghc-options:         -Wall+      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: -Wall++executable greet+  main-is: greet.hs+  hs-source-dirs: example+  ghc-options: -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

@@ -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

@@ -0,0 +1,54 @@+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 specific headers from the request+  module Servant.API.Header,+  -- | 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.Header+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

@@ -0,0 +1,39 @@+{-# 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

@@ -0,0 +1,60 @@+{-# 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)

@@ -0,0 +1,48 @@+{-# 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

@@ -0,0 +1,47 @@+{-# 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

@@ -0,0 +1,58 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Servant.API.Header where++import Data.Proxy+import Data.String+import Data.Text.Encoding (decodeUtf8)+import GHC.TypeLits+import Network.Wai+import Servant.API.Sub+import Servant.Common.Text+import Servant.Server++-- | Extract the given header's value as a value of type @a@.+--+-- Example:+--+-- > newtype Referer = Referer Text+-- >   deriving (Eq, Show, FromText, ToText)+-- >+-- >            -- GET /view-my-referer+-- > type MyApi = "view-my-referer" :> Header "from" Referer :> Get Referer+data Header sym a++-- | 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)

@@ -0,0 +1,53 @@+{-# 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

@@ -0,0 +1,52 @@+{-# 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

@@ -0,0 +1,162 @@+{-# 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=<author name>+-- > 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&param[]=val2@ and so on. Note that servant doesn't actually+-- require the @[]@s and will fetch the values just fine with+-- @param=val1&param=val2@, too.+--+-- Example:+--+-- > -- /books?authors[]=<author1>&authors[]=<author2>&...+-- > 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

@@ -0,0 +1,32 @@+{-# 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)

@@ -0,0 +1,49 @@+{-# 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

@@ -0,0 +1,36 @@+{-# 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

@@ -0,0 +1,130 @@+{-# 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

@@ -1,47 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{- |-Module      :  Servant.Context-Copyright   :  (c) Zalora SEA 2014-License     :  BSD3-Maintainer  :  Alp Mestanogullari <alp@zalora.com>-Stability   :  experimental--A 'Context' type for holding a function-that will use some /context/ to execute-something analoguous to a /database operation/.--This is equivalent to holding something like:--> withConnection someConnection--where you have previously set up @someConnection@ by specifying a-connection string or something like that. This lets us support-any kind of backend (even an in-memory Map in an /IORef/), and-most interestingly, we can use just raw connections or a connection-pool, this approach really covers a lot of situations while keeping-everything quite simple.---}-module Servant.Context-  ( Context-  , mkContext-  , withContext-  ) where---- | A 'Context' is just a wrapper around a function---   that can execute IO operations /given/---   this context.-newtype Context c-  = Context { withctx :: forall r. (c -> IO r) -> IO r }---- | Create a 'Context' from a suitable function-mkContext :: (forall r. (c -> IO r) -> IO r)-          -> Context c-mkContext = Context---- | Use the 'Context' to actually perform an 'IO'---   operation requiring it.-withContext :: Context c-            -> (c -> IO r)-            -> IO r-withContext = withctx

@@ -1,94 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{- |-Module      :  Servant.Error-Copyright   :  (c) Zalora SEA 2014-License     :  BSD3-Maintainer  :  Alp Mestanogullari <alp@zalora.com>-Stability   :  experimental--Everything you'll need when doing some kind of exception handling-around your \"database operations\".--}-module Servant.Error-  ( -- * Creating an combining 'ExceptionCatcher's-    ExceptionCatcher-  , noCatch-  , catchAnd-  , combineCatchers--  , -- * Running 'IO' actions against an 'ExceptionCatcher'-    handledWith-  ) where--import Control.Exception-import Data.Monoid---- | A container for zero or more "exception catchers".------   By exception catcher, we mean here a function that can convert---   some precise instance of 'Exception' to the error type used in---   your scotty app (the @e@ type in "Servant.Resource" "Servant.Service")-newtype ExceptionCatcher err =-	EC [Catcher err]---- a handy type for representing a single function that can catch--- some (specific) exception.--- The dictionary for the corresponding 'Exception' instance is packed--- along with the function in this data type.-data Catcher err = forall exc. Exception exc => Catcher (exc -> err)---- | Don't catch any exception.-noCatch :: ExceptionCatcher err-noCatch = EC []---- | Combine two 'ExceptionCatcher'.------   The resulting 'ExceptionCatcher' will be able to catch---   exceptions using the /catchers/ from both arguments.-combineCatchers :: ExceptionCatcher err-                -> ExceptionCatcher err-                -> ExceptionCatcher err-combineCatchers (EC c1s) (EC c2s) = EC (c1s ++ c2s)---- | If you're into 'Monoid's, enjoy our---   'mempty' ('noErrorHandling') and '<>' ('combineCatchers').-instance Monoid (ExceptionCatcher err) where-  mempty = noCatch--  mappend = combineCatchers---- | Run an 'IO' action by watching for all the exceptions---   supported by the 'ExceptionCatcher'.------   If an exception is thrown somewhere in the action and is caught---   by the catcher, it will call the function given to 'catchAnd'---   to convert the exception value to the error type of your scotty application.------   If an exception is thrown whose type isn't one for which there's a /catcher/---   in the 'ExceptionCatcher' argument, you'll have to catch it yourself or let it---   be sent to the default handler.------   Since 'Servant.Service.runService' sets up a 'defaultHandler', you'll most---   likely want to directly use 'raiseIfExc' which 'raise's the error value---   you got from the exception if some exception is thrown or just run some---   scotty action if everything went smoothly. This means writing a handler---   that'll set up a response with the proper HTTP status and send some JSON---   to the client with an informative error message, which... isn't a bad thing :-)-handledWith :: IO a -> ExceptionCatcher err -> IO (Either err a)-handledWith act (EC hs) = fmap Right act `catches` map runCatcher hs--  where runCatcher :: Catcher err -> Handler (Either err a)-        runCatcher (Catcher f) = Handler $ return . Left . f---- | Create an 'ExceptionCatcher' from a function.------   This will make the catcher aware of exceptions of type @except@---   so that when you'll run a catcher against an 'IO' action---   using 'raiseIfExc' or 'handledWith', if an exception of this type---   is thrown, it will be caught and converted to the error type of your---   web application using the provided function.-catchAnd :: Exception except-         => (except -> err) -         -> ExceptionCatcher err-catchAnd f = EC [catcher]-  where catcher = Catcher f

@@ -1,163 +0,0 @@-{-# LANGUAGE TypeOperators,-             ConstraintKinds,-             MultiParamTypeClasses,-             TypeFamilies,-             TypeSynonymInstances,-             DataKinds,-             FlexibleContexts,-             FlexibleInstances,-             ScopedTypeVariables #-}-{- |-Module      :  Servant.Prelude-Copyright   :  (c) Zalora SEA 2014-License     :  BSD3-Maintainer  :  Alp Mestanogullari <alp@zalora.com>-Stability   :  experimental--Some standard REST-y operations your 'Resource's can-support out of the box.--Your type will have to implement a couple of class instances-to be usable with a backend. For the scotty backend, this means-having 'FromJSON' or 'ToJSON' instances and the appropriate-'toResponse' implementations for the return types of your-database.--}-module Servant.Prelude- ( -- * Defining 'Resource's-   module Servant.Resource- , module Servant.Context- , module Servant.Error- - , -- * Standard operations-   Add- , addWith- , Delete- , deleteWith- , ListAll- , listAllWith- , Update- , updateWith- , View- , viewWith- ) where--import Servant.Context-import Servant.Error-import Servant.Resource---- | A dummy type representing an operation that adds an entry.-data Add-instance Show Add where show _ = "Add"---- | A dummy type representing an operation that deletes an entry.-data Delete-instance Show Delete where show _ = "Delete"---- | A dummy type representing an operation that lists all entries.-data ListAll-instance Show ListAll where show _ = "ListAll"---- | A dummy type representing an operation that updates an entry.-data Update-instance Show Update where show _ = "Update"---- | A dummy type representing an operation that looks up an entry.-data View-instance Show View where show _ = "View"---- | To 'Add' an entry, we require a function of type @c -> a -> IO r@.-type instance Operation Add c a i r     =      a -> c -> IO (r Add)--- | To 'Delete' an entry, we require a function of type @c -> i -> IO r@.-type instance Operation Delete c a i r  = i      -> c -> IO (r Delete)--- | To 'List' all entries, we require a function of type @c -> IO [a]@.-type instance Operation ListAll c a i r =           c -> IO [a]--- | To 'Update' an entry, we require a function of type @c -> i -> a -> IO r@.-type instance Operation Update c a i r  = i -> a -> c -> IO (r Update)--- | To 'View' an entry, we require a function of type @c -> i -> IO (Maybe a)@.-type instance Operation View c a i r    = i      -> c -> IO (Maybe a)---- | Make a 'Resource' support the 'Add'---   operation by using your function.------   Given:------   > addPerson :: PGSQL.Connection -> Person -> IO Bool------   you could do:------   > mkResource "persons" postgresContext noErrorHandling---   >   & addWith addPerson-addWith :: Contains Add ops ~ False-        => (a -> c -> IO (r Add))-        -> Resource c a i r e ops-        -> Resource c a i r e (Add ': ops)-addWith = addOperation---- | Make a 'Resource' support the 'Delete'---   operation by using your function.------   Given:------   > deletePerson :: PGSQL.Connection -> PersonId -> IO Bool------   you could do:------   > mkResource "persons" postgresContext noErrorHandling---   >   & deleteWith addPerson-deleteWith :: Contains Delete ops ~ False-           => (i -> c -> IO (r Delete))-           -> Resource c a i r e ops-           -> Resource c a i r e (Delete ': ops)-deleteWith = addOperation---- | Make a 'Resource' support the 'ListAll'---   operation by using your function.------   Given:------   > listAllPersons :: PGSQL.Connection -> IO [Person]------   you could do:------   > mkResource "persons" postgresContext noErrorHandling---   >   & listAllWith listAllPersons-listAllWith :: Contains ListAll ops ~ False-            => (c -> IO [a])-            -> Resource c a i r e ops-            -> Resource c a i r e (ListAll ': ops)-listAllWith = addOperation---- | Make a 'Resource' support the 'Update'---   operation by using your function.------   Given:------   > updatePerson :: PGSQL.Connection -> PersonId -> Person -> IO Bool------   you could do:------   > mkResource "persons" postgresContext noErrorHandling---   >   & updateWith updatePerson-updateWith :: Contains Update ops ~ False-           => (i -> a -> c -> IO (r Update))-           -> Resource c a i r e ops-           -> Resource c a i r e (Update ': ops)-updateWith = addOperation---- | Make a 'Resource' support the 'View'---   operation by using your function.------   Given:------   > viewPerson :: PGSQL.Connection -> PersonId -> IO (Maybe Person)------   you could do:------   > mkResource "persons" postgresContext noErrorHandling---   >   & viewWith viewPerson-viewWith :: Contains View ops ~ False-         => (i -> c -> IO (Maybe a))-         -> Resource c a i r e ops-         -> Resource c a i r e (View ': ops)-viewWith = addOperation

@@ -0,0 +1,198 @@+{-# 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.+--+--     * @.../<var>:<type>/...@ becomes a capture+--     * @.../?<var>:<type>@ becomes a query parameter+--     * @<method>   ...  <typ>@ becomes a method returning @<typ>@+--     * @<method>   ...  <typ1> -> <typ2>@ becomes a method with request+--       body of @<typ1>@ and returning @<typ2>@+--+-- 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+                      }+

@@ -1,193 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--{- |-Module      :  Servant.Resource-Copyright   :  (c) Zalora SEA 2014-License     :  BSD3-Maintainer  :  Alp Mestanogullari <alp@zalora.com>-Stability   :  experimental--Defining 'Resource's.--}-module Servant.Resource-  ( Resource-  , name-  , context-  , excCatcher-  , withHeadOperation-  , dropHeadOperation-  , mkResource-  , addOperation-  , Operation-  , (&)-  , Ops-  , Contains-  ) where--import Servant.Context-import Servant.Error---- | Heterogeneous list-data HList :: [*] -> * where-  Nil :: HList '[]-  Cons :: a -> HList as -> HList (a ': as)--hhead :: HList (a ': as) -> a-hhead (Cons h _) = h---- | Get the tail of an heterogeneous list-htail :: HList (a ': as) -> HList as-htail (Cons _ t) = t---- | Utility (closed) type family to detect whether a type---   is contained in a type-level list of types-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 781-type family Contains (elem :: *) (list :: [*]) :: Bool where-  Contains elem '[] = False-  Contains elem (elem ': xs) = True-  Contains elem (x ': xs) = Contains elem xs-#else-type Contains (elem :: *) (list :: [*]) = False-#endif---- | A resource that:------   * uses some context type @c@ (think database connection)---   * manages entries of type @a@---   * (optionally) supports indexing through the @i@ type (a dumb ID, or something like---     @data FooId = ByToken Token | ByID Integer@). That can be useful when trying to view,---     update or delete a particular entry, for example.---   * uses @r@ as the return type (tagged by the operation type) for /effectful/ database operations (e.g. adding, updating, deleting entries---     for example).---   * can catch exceptions, converting them to some error type---     @e@ of yours---   * supports the operations listed in the @ops@ type list. a corresponding---     (heterogeneous) list of "database functions" is held internally and we---     ask the compiler to make the types of these functions match with the ones---     expected for the operations listed at the type-level.-data Resource c a i (r :: * -> *) e (ops :: [*])-  = Resource { name       :: String    -- ^ Get the name of the 'Resource'-             , context    :: Context c -- ^ Gives the 'Context' attached to this 'Resource'-             , excCatcher :: ExceptionCatcher e -- ^ Hands you the 'ExceptionCatcher' you can-                                                --   'handledWith' with to make your \"database operations\"-                                                --   exception safe.-             , operations :: HList (Ops ops c a i r)-             }--instance Show (Resource c a i r e '[]) where-  show r = name r--instance (Show o, Show (Resource c a i r e ops)) -      => Show (Resource c a i r e (o ': ops)) where-  show r = -    show (dropHeadOperation r) ++-    opstring--    where opstring = "\n  - " ++ show (undefined :: o)---- | Typically, functions that will use our operations will need access---   to the resource's name and what not, so we need to provide them with---   the resource. But we obviously also need the \"database function\"---   associated to our operation. So we provide it too.------   Just give this function a 'Resource' and a function that uses it,---   most likely to run the handler for an operation,---   and it'll give your function the right arguments.-withHeadOperation :: Resource c a i r e (o ': ops)-                  -> (Resource c a i r e (o ': ops) -> Operation o c a i r -> b)-                  -> b-withHeadOperation res runop =-  runop res (hhead $ operations res)---- | Type-safely \"unconsider\" the first operation in the list------   Helpful when performing recursion on the type-level list---   and the internal list of \"database functions\"---   simultaneously.-dropHeadOperation :: Resource c a i r e (o ': ops) -> Resource c a i r e ops-dropHeadOperation r = r { operations = operations' }--  where operations' = htail (operations r)---- | Create an /empty/ resource that doesn't support any operation---   and catches exceptions using the given 'ExceptionCatcher'.---   Any operation supported later on can make use of the provided---   'Context', by simply doing:------   > withContext (context resource) $ \c -> ...------   where @c@ could be a PostgreSQL connection, for example.-mkResource :: String-           -> Context c-           -> ExceptionCatcher e-           -> Resource c a i r e '[]-mkResource n ctx catcher = Resource n ctx catcher Nil---- | Add an operation to a resource by specifying the \"database function\"---   that'll actually perform the lookup, update, listing, search and what not.------   We statically enforce that the operation we're adding isn't---   already supported by the 'Resource', when built with @ghc >= 7.8@.-addOperation :: Contains o ops ~ False-             => Operation o c a i r -             -> Resource c a i r e ops -             -> Resource c a i r e (o ': ops)-addOperation opfunc resource =-  resource { operations = Cons opfunc (operations resource) }---- | Type level 'map'-like function that replaces an operation's tag---   by the type of the associated \"database function\"------   For example:------   > Ops [Add, List] c a i r------   will result in:------   > [ a -> c -> IO r -- what 'Add' is replaced by---   > , c -> IO [a]    -- what 'List' is replaced by---   > ]------   This is useful as we can exactly determine the type of the heterogeneous---   list that holds the actual \"dtabase functions\" that will perform the---   operations, using 'Ops'. This among other things enforces a strong---   correspondance between the type-level list of operations and the---   (heterogeneous) list of functions held in the 'Resource' we're interested in.------   That means we can't magically convert a 'Resource' into one that supports one more---   operations without registering a function for it (which /must have/ the right type,---   or your code won't compile.-type family Ops (ops :: [*]) c a i (r :: * -> *) :: [*]-type instance Ops (o ': ops) c a i r = Operation o c a i r ': Ops ops c a i r-type instance Ops '[] c a i r = '[]---- | Map an operation tag @o@ to some combination of the other type---   parameters.------   For instance, if we look at 'Add', we know that we'll need our---   \"connection type\" @c@ and a value to add, of type @a@. The result will---   be of type @IO (r Add)@. If we put this all together, we get:------   > type instance Operation Add c a i r = a -> c -> IO (r Add)------   Whereas for listing all entries ('ListAll'), we just want some kind---   of connection @c@ and we get back @[a]@.------   > type instance Operation ListAll c a i r = c -> IO [a]-type family Operation o c a i (r :: * -> *) :: *---- | Reversed function application.------   > x & f = f x-(&) :: a -> (a -> b) -> b-x & f = f x-{-# INLINE (&) #-}

@@ -0,0 +1,105 @@+{-# 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

@@ -0,0 +1,110 @@+{-# 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 _ = ""+

@@ -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++-- | Serve anything under the specified directory as a 'Raw' endpoint.+--+-- @+-- type MyApi = "static" :> Raw+--+-- server :: Server MyApi+-- server = serveDirectory "\/var\/www"+-- @+--+-- would capture any request to @\/static\/\<something>@ and look for+-- @\<something>@ under @\/var\/www@.+--+-- It will do its best to guess the MIME type for that file, based on the extension,+-- and send an appropriate /Content-Type/ header if possible.+--+-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API+-- as a webapp backend, you will most likely not want the static files to be hidden+-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectory'+-- handler in the last position, because /servant/ will try to match the handlers+-- in order.+serveDirectory :: FilePath -> Server Raw+serveDirectory documentRoot =+  staticApp (defaultFileServerSettings (decodeString (documentRoot ++ "/")))

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