servant-snap (empty) → 0.7
raw patch · 16 files changed
+1864/−0 lines, 16 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, attoparsec, base, base64-bytestring, bytestring, case-insensitive, containers, digestive-functors, directory, either, errors, exceptions, filepath, heist, hspec, hspec-core, hspec-snap, http-api-data, http-types, io-streams, lens, map-syntax, mmorph, mtl, network, network-uri, parsec, process, servant, servant-snap, snap, snap-core, snap-server, string-conversions, temporary, text, time, transformers
Files
- CHANGELOG.md +4/−0
- LICENSE +30/−0
- README.md +136/−0
- Setup.hs +2/−0
- example/greet.hs +123/−0
- servant-snap.cabal +130/−0
- src/Servant.hs +19/−0
- src/Servant/Server.hs +100/−0
- src/Servant/Server/Internal.hs +471/−0
- src/Servant/Server/Internal/PathInfo.hs +64/−0
- src/Servant/Server/Internal/Router.hs +180/−0
- src/Servant/Server/Internal/RoutingApplication.hs +251/−0
- src/Servant/Server/Internal/ServantErr.hs +243/−0
- src/Servant/Server/Internal/SnapShims.hs +72/−0
- src/Servant/Utils/StaticFiles.hs +38/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.7+----++Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Zalora South East Asia Pte Ltd++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Zalora South East Asia Pte Ltd nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,136 @@+++[](https://travis-ci.org/haskell-servant/servant-snap)++A library for running [servant](https://haskell-servant.github.io) APIs under any [MonadSnap](http://snapframework.com) monad. For example, we can build a `Servant` server from `Snap` handlers:++++```+> :set -XTypeOperators -XDataKinds -XOverloadedStrings+> import Data.Proxy (Proxy(..))+> import Data.Text (Text, append)+> import Servant+> import Servant.Server (serveSnap)+> import Snap.Http.Server (quickHttpServe)+> type Api = "number" :> Get '[JSON] Int :<|> "hello" :> Capture "name" String :> Get '[JSON] String)+> let api = Proxy :: Proxy Api+> quickHttpServe $ serveSnap api (return 5 :<|> \name -> return (append "Hello, " name))++curl localhost:8000/hello/world+"Hello, world"+```++Or we can integrate a `Servant` API into a more complex application with [`Snaplets`](https://hackage.haskell.org/package/snap-1.0.0.0/docs/Snap-Snaplet.html) and your own `Handler b v` monad.++There is a longer example demonstrating this below, and one you can compile at [example/greet.hs](https://github.com/haskell-servant/servant-snap/blob/master/example/greet.hs).++For more information about getting started servant itself, please see the [servant documentation](https://haskell-servant.readthedocs.io/en/stable/). To learn about Snap, see the [snap-core](https://hackage.haskell.org/package/snap-core-1.0.0.0/docs/Snap-Core.html) and [snaplet](https://hackage.haskell.org/package/snap-1.0.0.0/docs/Snap-Snaplet.html) haddocks.+++## Comparison with `servant-server`++**servant-snap** is very similar to `servant-server`, providing a number of `HasServer` instances for various `servant` API combinators and the function `serveSnap` for turning your API spec into a runnable server.++**servant-snap** hosts `MonadSnap m` handlers (for example `Snap`, `Handler b v`). **servant-server** hosts `EitherT ServantErr IO` handlers and other monads that can be naturally transformed via `[enter](http://haskell-servant.readthedocs.io/en/stable/tutorial/Server.html#using-another-monad-for-your-handlers)`.+This makes **servant-snap** both a bit more flexible and a bit less type-safe, because **servant-snap** handlers can access data from the HTTP request. **servant-server** on the other hand hides the raw request from the handlers so that all routing decisions are determined strictly by the API type.++Snap's `Handler b v` handlers use lenses and snaplets to control which effects and state the handler can access.+In **servant-server**, you use `[vault](https://hackage.haskell.org/package/servant-0.8.1/docs/Servant-API-Vault.html)` to hold these needed bits of state (for example, database connections).++**servant-server** provides combinators for controlling access to sub-api's. **servant-snap** still does authentication through the `[auth snaplet](https://hackage.haskell.org/package/snap-1.0.0.0/docs/Snap-Snaplet-Auth.html)`, without signalling this in the API type.+We are still thinking about how to support type-level signalling of auth requirements for **servant-snap**.+It would be possible to provide `snap`-specific auth combinators, but using them would force a `snap` dependency on the API itself, which we want to avoid (it is common to compile a `servant` API with `ghcjs`, so we want the API to be packaged without any system dependencies).+++## FAQ+++### Can `servant-snap` serve Heist templates?++You can call `renderTemplate` in a handler for a `Raw` endpoint. We don't offer a `Heist` combinator, but in the future this may be nice to have in another package.+++### What does Snap offer beyond a regular **servant-server** application?++Snap has a very simple core, a nice monad for request/response handling, and a large number of stable units of added functionality ("Snaplets") for handling auth, persistence, templating, etc. One of the biggest pain-points of Snap use is manually digging data out of requests, validating it, and building responses. Servant fills this gap for snap perfectly. Read more about the [Snap Framework](http://www.snapframework.com)!+++### If this package is called **servant-snap**, shouldn't **servant-server** be named **servant-wai**? The current naming is confusing.++At some point, we hope to split **servant-server** into a generic base part and **servant-wai**, **servant-snap**, backends. This would make writing other backends easier and drastically reduce code duplication.++++## More detailed Snap example++Note: *It's recommended to use `snap init` to build a site template for new projects, rather than packing everything into a single file like this.*+++```+-- Top-level Application State+data App = App+ { _heist :: Snaplet (Heist App)+ , _sess :: Snaplet SessionManager+ , _db :: Snaplet Postgres+ , _auth :: Snaplet (AuthManager App)+ }++makeLenses'' App++instance HasHeist App where+ heistLens = subSnaplet heist+++-- Our app's base monad+type AppHandler = Handler App App+++-- Our Servant API+type Api = "users" :> Get '[JSON] [User]+ :<|>+ "user" :> Capture "name" Text :> Get '[JSON] User+ :<|>+ "reset_db" :> Post '[JSON] NoContent+++-- Servant API implementation using DB and Auth Snaplets+apiServer :: ServerT Api AppHandler+apiServer = getAllUsers :<|> getUserByName :<|> resetDB+ where+ getAllUsers =+ with db $ query_ "SELECT * FROM users"++ getUserByName name =+ with db $ query "SELECT * FROM users WHERE name=(?)" [(Only name)]++ resetDB = do+ isAdmin <- with auth $ do+ u <- getCurrentUser+ return ((userLogin <$> u) == Just "admin")+ if isAdmin+ then with db $ query_ "DELETE FROM users"+ else throwError err403+ ++-- Snap initializer action+-- (Notice that we mix servant and non-servant routes)+app :: SnapletInit App App+app = makeSnaplet "app" "standard example app" Nothing $ do+ h <- nestSnaplet "" heist $ heistInit "templates"+ s <- nestSnaplet "sess" sess $+ initCookieSessionManager "site_key.txt" "sess" Nothing (Just 3600)+ d <- nestSnaplet "db" db pgsInit+ a <- nestSnaplet "auth" auth $ initPostgresAuth sess d+ addRoutes [ ("login", with auth handleLoginSubmit) -- Regular snap handler+ , ("logout", with auth handleLogout) -- for non-API routes+ , ("new_user", with auth handleNewUser)+ , ("api", serveSnap api apiServer -- servant-snap handler+ , ("", serveDirectory "static")+ ]+ addAuthSplices h auth+ return $ App h s d a++main :: IO ()+main = httpServe defaultConfig app+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/greet.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}++import Control.Lens+import Data.Aeson+import Data.Map.Syntax ((##))+import Data.Monoid+import Data.Proxy+import Data.Text+import GHC.Generics+import qualified Heist.Interpreted as I+import Snap.Snaplet+import Snap.Snaplet.Auth+import Snap.Snaplet.Session+import Snap.Snaplet.Session.Backends.CookieSession+import Snap.Snaplet.Auth.Backends.JsonFile+import Snap.Snaplet.Heist+import Snap.Http.Server (defaultConfig)++import Servant.API+import Servant (serveSnap, Server, serveDirectory)++-- * Example++-- | A greet message data type+newtype Greet = Greet { _msg :: Text }+ deriving (Generic, Show)++instance FromJSON Greet+instance ToJSON Greet++-- API specification+type TestApi m =++ -- GET /hello/:name?capital={true, false} returns a Greet as JSON+ "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet+++ :<|> "hellosnap" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet++ -- POST /greet with a Greet as JSON in the request body,+ -- returns a Greet as JSON+ :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet++ -- DELETE /greet/:greetid+ :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] ()++ :<|> "files" :> Raw+ :<|> "doraw" :> Raw+++-- Our application has some of the usual Snaplets+data App = App {+ _heist :: Snaplet (Heist App)+ , _sess :: Snaplet SessionManager+ , _auth :: Snaplet (AuthManager App)+ }+makeLenses ''App++instance HasHeist App where+ heistLens = subSnaplet heist++type AppHandler = Handler App App++testApi :: Proxy (TestApi AppHandler)+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 'AppHandler' monad.++server :: Server (TestApi AppHandler) AppHandler+server = helloH+ :<|> helloH'+ :<|> postGreetH+ :<|> deleteGreetH+ :<|> serveDirectory "static"+ :<|> doRaw++ where helloH :: Text -> Maybe Bool -> AppHandler Greet+ helloH name Nothing = helloH name (Just False)+ helloH name (Just False) = return . Greet $ "Hello, " <> name+ helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name++ helloH' :: Text -> Maybe Bool -> (Handler App App) Greet+ helloH' name _ = with auth $ do+ cu <- currentUser+ return (Greet $ "Hi from snaplet, " <> name+ <> ". Login is " <> maybe "No login" (pack . show) cu)++ postGreetH :: Greet -> (Handler App App) Greet+ postGreetH greet = return greet++ deleteGreetH _ = return ()++ doRaw = with auth $ do+ u <- currentUser+ let spl = "tName" ## I.textSplice (maybe "NoLogin" (pack . show) u)+ renderWithSplices "test" spl+++initApp :: SnapletInit App App+initApp = makeSnaplet "myapp" "An example app in servant" Nothing $ do+ h <- nestSnaplet "" heist $ heistInit "templates"+ s <- nestSnaplet "sess" sess $ initCookieSessionManager "site_key.txt" "sess" Nothing (Just 3600)+ a <- nestSnaplet "" auth $ initJsonFileAuthManager defAuthSettings sess "users.json"+ addRoutes [("api", serveSnap testApi server)]+ return $ App h s a+++-- Run the server.+main :: IO ()+main = serveSnaplet defaultConfig initApp+
+ servant-snap.cabal view
@@ -0,0 +1,130 @@+name: servant-snap+version: 0.7+synopsis: A family of combinators for defining webservices APIs and serving them+description:+ Interpret a Servant API as a Snap server, using any Snaplets you like.+ .+ You can learn about the basics of servant in the Servant <https://haskell-servant.readthedocs.io tutorial>, and about the basics of Snap at the Snaplets <http://snapframework.com/docs/tutorials/snaplets-tutorial tutorial>+ .+ <https://github.com/haskell-servant/servant-snap/blob/master/example/greet.hs Here>+ is a runnable example, with comments, that defines a dummy API and implements+ a webserver that serves this API, using this package. One route delegates to the <https://hackage.haskell.org/package/snap/docs/Snap-Snaplet-Auth.html Auth> snaplet, another delegates to <https://hackage.haskell.org/package/snap/docs/Snap-Snaplet-Heist.html Heist>.+ .+ <https://github.com/haskell-servant/servant-snap/blob/master/CHANGELOG.md CHANGELOG>+homepage: http://haskell-servant.github.io/+Bug-reports: http://github.com/haskell-servant/servant/issues+license: BSD3+license-file: LICENSE+author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni, Greg Hale+maintainer: alpmestan@gmail.com imalsogreg@gmail.com+copyright: 2014 Zalora South East Asia Pte Ltd+category: Web+build-type: Simple+cabal-version: >=1.10+tested-with: GHC == 7.10.2, GHC == 8.0.1+extra-source-files:+ CHANGELOG.md+ README.md+source-repository head+ type: git+ location: http://github.com/haskell-servant/servant-snap.git+++library+ exposed-modules:+ Servant+ Servant.Server+ Servant.Server.Internal+ Servant.Server.Internal.PathInfo+ Servant.Server.Internal.Router+ Servant.Server.Internal.RoutingApplication+ Servant.Server.Internal.ServantErr+ Servant.Server.Internal.SnapShims+ Servant.Utils.StaticFiles+ build-depends:+ base >= 4.7 && < 4.10+ , aeson >= 0.7 && < 1.1+ , attoparsec >= 0.12 && < 0.14+ , bytestring >= 0.10 && < 0.11+ , case-insensitive >= 1.2 && < 1.3+ , containers >= 0.5 && < 0.6+ , either >= 4.3 && < 4.5+ , filepath >= 1 && < 1.5+ , http-types >= 0.8 && < 0.10+ , http-api-data >= 0.2 && < 0.4+ , io-streams >= 1.3 && < 1.4+ , network-uri >= 2.6 && < 2.7+ , mtl >= 2.0 && < 2.3+ , mmorph >= 1 && < 1.1+ , servant >= 0.8 && < 0.9+ , string-conversions >= 0.3 && < 0.5+ , text >= 1.2 && < 1.3+ , snap >= 1.0 && < 1.1+ , snap-core >= 1.0 && < 1.1+ , snap-server >= 1.0 && < 1.1+ , transformers >= 0.3 && < 0.6+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++executable snap-greet+ main-is: greet.hs+ hs-source-dirs: example+ ghc-options: -Wall+ default-language: Haskell2010+ build-depends:+ aeson+ , base+ , bytestring+ , either+ , errors+ , heist+ , lens+ , servant >= 0.6+ , servant-snap+ , map-syntax+ , snap+ , snap-core+ , snap-server+ , text+ , transformers++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+ , base64-bytestring+ , bytestring+ , case-insensitive+ , containers+ , directory+ , either+ , exceptions+ , hspec >= 2.2.3 && < 2.4+ , process+ , digestive-functors == 0.8.1.0+ , time+ , hspec-snap >= 1.0 && < 1.1+ , hspec-core == 2.2.3+ , http-types+ , HUnit+ , digestive-functors == 0.8.1.0+ , mtl+ , network >= 2.6+ , QuickCheck+ , parsec+ , servant+ , servant-snap+ , snap+ , snap-core+ , snap-server+ , string-conversions+ , temporary+ , text+ , transformers
+ src/Servant.hs view
@@ -0,0 +1,19 @@+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,+ -- | Utilities on top of the servant core+ module Servant.Utils.Links,+ module Servant.Utils.StaticFiles,+ -- | Useful re-exports+ Proxy(..),+ ) where++import Data.Proxy+import Servant.API+import Servant.Server+import Servant.Utils.Links+import Servant.Utils.StaticFiles
+ src/Servant/Server.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module lets you implement 'Server's for defined APIs. You'll+-- most likely just need 'serve'.+module Servant.Server+ ( -- * Run a snap handler from an API+ serveSnap++ , -- * Handlers for all standard combinators+ HasServer(..)+ , Server++ -- ** Basic functions and datatypes++ -- * Default error type+ , ServantErr(..)+ , throwError+ -- ** 3XX+ , err300+ , err301+ , err302+ , err303+ , err304+ , err305+ , err307+ -- ** 4XX+ , err400+ , err401+ , err402+ , err403+ , err404+ , err405+ , err406+ , err407+ , err409+ , err410+ , err411+ , err412+ , err413+ , err414+ , err415+ , err416+ , err417+ -- * 5XX+ , err500+ , err501+ , err502+ , err503+ , err504+ , err505++ ) where++import Data.Proxy (Proxy(..))+import Servant.Server.Internal+import Servant.Server.Internal.SnapShims+import Snap.Core hiding (route)+++-- * Implementing Servers++-- | 'serve' allows you to implement an API and produce a wai 'Application'.+--+-- Example:+--+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books+-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books+-- >+-- > server :: Server MyApi+-- > server = listAllBooks :<|> postBook+-- > where listAllBooks = ...+-- > postBook book = ...+-- >+-- > myApi :: Proxy MyApi+-- > myApi = Proxy+-- >+-- > app :: Application+-- > app = serve myApi server+-- >+-- > main :: IO ()+-- > main = Network.Wai.Handler.Warp.run 8080 app+--++serveApplication+ :: forall layout m.(HasServer layout, MonadSnap m)+ => Proxy layout+ -> Server layout m+ -> Application m+serveApplication p server = toApplication (runRouter (route p (emptyDelayed (Proxy :: Proxy (m :: * -> *)) ((Route server)))))++serveSnap+ :: forall layout m.(HasServer layout, MonadSnap m)+ => Proxy layout+ -> Server layout m+ -> m ()+serveSnap p server = applicationToSnap $ serveApplication p server
+ src/Servant/Server/Internal.hs view
@@ -0,0 +1,471 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Servant.Server.Internal+ ( module Servant.Server.Internal+ , module Servant.Server.Internal.PathInfo+ , module Servant.Server.Internal.Router+ , module Servant.Server.Internal.RoutingApplication+ , module Servant.Server.Internal.ServantErr+ ) where++-------------------------------------------------------------------------------+import Control.Applicative ((<$>))+import Control.Monad.Trans.Class (lift)+import Data.Bool (bool)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as BL+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Proxy+import Data.String (fromString)+import Data.String.Conversions (cs, (<>))+import Data.Text (Text)+import GHC.TypeLits (KnownNat, KnownSymbol, natVal,+ symbolVal)+import Network.HTTP.Types (HeaderName, Method,+ Status(..), parseQueryText,+ methodGet, methodHead,+ hContentType, hAccept)+import Web.HttpApiData (FromHttpApiData,+ parseHeaderMaybe,+ parseQueryParamMaybe,+ parseUrlPieceMaybe,+ parseUrlPieces)+import Snap.Core hiding (Headers, Method,+ getResponse, headers, route,+ method, withRequest)+import Servant.API ((:<|>) (..), (:>), Capture,+ CaptureAll, Header,+ IsSecure(..), QueryFlag,+ QueryParam, QueryParams, Raw,+ RemoteHost, ReqBody,+ ReflectMethod(..), Verb)+import Servant.API.ContentTypes (AcceptHeader (..),+ AllCTRender (..),+ AllCTUnrender (..), AllMime(..), canHandleAcceptH)+import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,+ getHeaders)+-- import Servant.Common.Text (FromText, fromText)++import Servant.Server.Internal.PathInfo+import Servant.Server.Internal.Router+import Servant.Server.Internal.RoutingApplication+import Servant.Server.Internal.ServantErr+import Servant.Server.Internal.SnapShims++class HasServer api where+ type ServerT api (m :: * -> *) :: *++ route :: MonadSnap m+ => Proxy api+ -> Delayed m env (Server api m)+ -> Router m env++type Server api m = ServerT api m++-- * Instances++-- | A server for @a ':<|>' b@ first tries to match the request against the route+-- represented by @a@ and if it fails tries @b@. You must provide a request+-- handler for each route.+--+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books+-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books+-- >+-- > server :: Server MyApi+-- > server = listAllBooks :<|> postBook+-- > where listAllBooks = ...+-- > postBook book = ...+instance (HasServer a, HasServer b) => HasServer (a :<|> b) where++ type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m++ route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server))+ (route pb ((\ (_ :<|> b) -> b) <$> server))+ where pa = Proxy :: Proxy a+ pb = Proxy :: Proxy b++captured :: FromHttpApiData a => proxy (Capture sym a) -> Text -> Maybe a+captured _ = parseUrlPieceMaybe++-- | 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 '[JSON] Book+-- >+-- > server :: Server MyApi+-- > server = getBook+-- > where getBook :: Text -> EitherT ServantErr IO Book+-- > getBook isbn = ...+instance (FromHttpApiData a, HasServer sublayout)+ => HasServer (Capture capture a :> sublayout) where++ type ServerT (Capture capture a :> sublayout) m =+ a -> ServerT sublayout m++ route Proxy d =+ CaptureRouter $+ route (Proxy :: Proxy sublayout)+ (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of+ Nothing -> delayedFail err400+ Just v -> return v+ )+++instance (FromHttpApiData a, HasServer sublayout)+ => HasServer (CaptureAll capture a :> sublayout) where++ type ServerT (CaptureAll capture a :> sublayout) m =+ [a] -> ServerT sublayout m++ route Proxy d =+ CaptureAllRouter $+ route (Proxy :: Proxy sublayout)+ (addCapture d $ \ txts -> case parseUrlPieces txts of+ Left _ -> delayedFail err400+ Right v -> return v+ )+++allowedMethodHead :: Method -> Request -> Bool+allowedMethodHead method request =+ method == methodGet && unSnapMethod (rqMethod request) == methodHead++allowedMethod :: Method -> Request -> Bool+allowedMethod method request =+ allowedMethodHead method request || unSnapMethod (rqMethod request) == method++processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method+ -> Maybe [(HeaderName, B.ByteString)]+ -> Request -> RouteResult Response+processMethodRouter handleA status method headers request = case handleA of+ Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does+ Just (contentT, body) -> Route $ responseLBS status hdrs bdy+ where+ bdy = if allowedMethodHead method request then "" else body+ hdrs = (hContentType, cs contentT) : fromMaybe [] headers++methodCheck :: MonadSnap m => Method -> Request -> DelayedM m ()+methodCheck method request+ | allowedMethod method request = return ()+ | otherwise = delayedFail err405++-- This has switched between using 'Fail' and 'FailFatal' a number of+-- times. If the 'acceptCheck' is run after the body check (which would+-- be morally right), then we have to set this to 'FailFatal', because+-- the body check is not reversible, and therefore backtracking after the+-- body check is no longer an option. However, we now run the accept+-- check before the body check and can therefore afford to make it+-- recoverable.+acceptCheck :: (AllMime list, MonadSnap m) => Proxy list -> B.ByteString -> DelayedM m ()+acceptCheck proxy accH+ | canHandleAcceptH proxy (AcceptHeader accH) = return ()+ | otherwise = delayedFail err406++++methodRouter :: (AllCTRender ctypes a, MonadSnap m)+ => Method -> Proxy ctypes -> Status+ -> Delayed m env (m a)+ -> Router m env -- Request (RoutingApplication m) m+methodRouter method proxy status action = leafRouter route'+ where+ route' env request respond =+ let accH = fromMaybe ct_wildcard $ getHeader hAccept request -- lookup hAccept $ requestHeaders request+ in runAction (action `addMethodCheck` methodCheck method request+ `addAcceptCheck` acceptCheck proxy accH+ ) env request respond $ \ output -> do+ let handleA = handleAcceptH proxy (AcceptHeader accH) output+ processMethodRouter handleA status method Nothing request+++methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v, MonadSnap m)+ => Method -> Proxy ctypes -> Status+ -> Delayed m env (m (Headers h v))+ -> Router m env -- Request (RoutingApplication m) m+methodRouterHeaders method proxy status action = leafRouter route'+ where+ route' env request respond =+ let accH = fromMaybe ct_wildcard $ getHeader hAccept request -- lookup hAccept $ requestHeaders request+ in runAction (action `addMethodCheck` methodCheck method request+ `addAcceptCheck` acceptCheck proxy accH+ ) env request respond $ \ output -> do+ let headers = getHeaders output+ handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)+ processMethodRouter handleA status method (Just headers) request+++instance {-# OVERLAPPABLE #-} (AllCTRender ctypes a,+ ReflectMethod method,+ KnownNat status)+ => HasServer (Verb method status ctypes a) where+ type ServerT (Verb method status ctypes a) m = m a+ route Proxy = methodRouter method (Proxy :: Proxy ctypes) status+ where method = reflectMethod (Proxy :: Proxy method)+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)++instance {-# OVERLAPPABLE #-} (AllCTRender ctypes a,+ ReflectMethod method,+ KnownNat status,+ GetHeaders (Headers h a))+ => HasServer (Verb method status ctypes (Headers h a)) where++ type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)+ route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status+ where method = reflectMethod (Proxy :: Proxy method)+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)++++-- | 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 '[JSON] Referer+-- >+-- > server :: Server MyApi+-- > server = viewReferer+-- > where viewReferer :: Referer -> EitherT ServantErr IO referer+-- > viewReferer referer = return referer+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)+ => HasServer (Header sym a :> sublayout) where++ type ServerT (Header sym a :> sublayout) m =+ Maybe a -> ServerT sublayout m++ route Proxy subserver =+ let mheader req = parseHeaderMaybe =<< getHeader str req+ in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)+ where str = fromString $ symbolVal (Proxy :: Proxy sym)+++-- | 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 '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooksBy+-- > where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book]+-- > getBooksBy Nothing = ...return all books...+-- > getBooksBy (Just author) = ...return books by the given author...+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)+ => HasServer (QueryParam sym a :> sublayout) where++ type ServerT (QueryParam sym a :> sublayout) m =+ Maybe a -> ServerT sublayout m++ route Proxy subserver =+ let querytext r = parseQueryText $ rqQueryString r+ param r =+ case lookup paramname (querytext r) of+ Nothing -> Nothing -- param absent from the query string+ Just Nothing -> Nothing -- param present with no value -> Nothing+ Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to+ -- the right type+ in route (Proxy :: Proxy sublayout) (passToServer subserver param)+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)+++-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of type @['Text']@.+--+-- This lets servant worry about looking up 0 or more values in the query string+-- associated to @authors@ and turning each of them into a value of+-- the type you specify.+--+-- You can control how the individual values are converted from 'Text' to your type+-- by simply providing an instance of 'FromText' for your type.+--+-- Example:+--+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooksBy+-- > where getBooksBy :: [Text] -> EitherT ServantErr IO [Book]+-- > getBooksBy authors = ...return all books by these authors...+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)+ => HasServer (QueryParams sym a :> sublayout) where++ type ServerT (QueryParams sym a :> sublayout) m =+ [a] -> ServerT sublayout m++ route Proxy subserver =+ let querytext r = parseQueryText $ rqQueryString r+ -- if sym is "foo", we look for query string parameters+ -- named "foo" or "foo[]" and call parseQueryParam on the+ -- corresponding values+ parameters r = filter looksLikeParam (querytext r)+ values r = mapMaybe (convert . snd) (parameters r)+ in route (Proxy :: Proxy sublayout) (passToServer subserver values)+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)+ looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")+ convert Nothing = Nothing+ convert (Just v) = parseQueryParamMaybe v+++-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,+-- this automatically requires your server-side handler to be a function+-- that takes an argument of type 'Bool'.+--+-- Example:+--+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]+-- >+-- > server :: Server MyApi+-- > server = getBooks+-- > where getBooks :: Bool -> EitherT ServantErr 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 ServerT (QueryFlag sym :> sublayout) m =+ Bool -> ServerT sublayout m++ route Proxy subserver =+ let querytext r = parseQueryText $ rqQueryString r+ param r = case lookup paramname (querytext r) 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+ in route (Proxy :: Proxy sublayout) (passToServer subserver param)+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)+ examine v | v == "true" || v == "1" || v == "" = True+ | otherwise = False+++-- | Just pass the request to the underlying application and serve its response.+--+-- Example:+--+-- > type MyApi = "images" :> Raw+-- >+-- > server :: Server MyApi+-- > server = serveDirectory "/var/www/images"+instance HasServer Raw where++ type ServerT Raw m = m ()++ route Proxy rawApplication = RawRouter $ \ env request respond -> do+ r <- runDelayed rawApplication env request+ case r of+ Route app -> (snapToApplication' app) request (respond . Route)+ Fail a -> respond $ Fail a+ FailFatal e -> respond $ FailFatal e+++-- | 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'.+-- The @Content-Type@ header is inspected, and the list provided is used to+-- attempt deserialization. If the request does not have a @Content-Type@+-- header, it is treated as @application/octet-stream@.+-- 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 '[JSON] Book :> Post '[JSON] Book+-- >+-- > server :: Server MyApi+-- > server = postBook+-- > where postBook :: Book -> EitherT ServantErr IO Book+-- > postBook book = ...insert into your db...+instance ( AllCTUnrender list a, HasServer sublayout+ ) => HasServer (ReqBody list a :> sublayout) where++ type ServerT (ReqBody list a :> sublayout) m =+ a -> ServerT sublayout m++ route Proxy subserver =+ route (Proxy :: Proxy sublayout) (addBodyCheck (subserver ) bodyCheck')+ where+ -- bodyCheck' :: DelayedM m a+ bodyCheck' = do+ req <- lift getRequest+ let contentTypeH = fromMaybe "application/octet-stream" $ getHeader hContentType req+ mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) <$>+ lift (readRequestBody 2147483647) -- Maximum size: 2GB+ case mrqbody of+ Nothing -> delayedFailFatal err415+ Just (Left e) -> delayedFailFatal err400 { errBody = cs e }+ Just (Right v) -> return v+++-- | 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 ServerT (path :> sublayout) m = ServerT sublayout m++ route Proxy subserver =+ pathRouter+ (cs (symbolVal proxyPath))+ (route (Proxy :: Proxy sublayout) subserver)+ where proxyPath = Proxy :: Proxy path+++instance HasServer api => HasServer (HttpVersion :> api) where+ type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m++ route Proxy subserver =+ route (Proxy :: Proxy api) (passToServer subserver rqVersion)+++instance HasServer api => HasServer (IsSecure :> api) where+ type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m++ route Proxy subserver =+ route (Proxy :: Proxy api) (passToServer subserver (bool NotSecure Secure . rqIsSecure))++instance HasServer api => HasServer (RemoteHost :> api) where+ type ServerT (RemoteHost :> api) m = B.ByteString -> ServerT api m++ route Proxy subserver =+ route (Proxy :: Proxy api) (passToServer subserver rqHostName)++ct_wildcard :: B.ByteString+ct_wildcard = "*" <> "/" <> "*" -- Because CPP
+ src/Servant/Server/Internal/PathInfo.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+module Servant.Server.Internal.PathInfo where++import qualified Data.ByteString.Char8 as B+import Data.List (unfoldr)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Snap.Core+++rqPath :: Request -> B.ByteString+rqPath r = B.append (rqContextPath r) (rqPathInfo r)++pathInfo :: Request -> [Text]+pathInfo = T.splitOn "/" . T.decodeUtf8 . rqPathInfo+++pathSafeTail :: Request -> ([B.ByteString], [B.ByteString])+pathSafeTail r =+ let contextParts = B.split '/' (rqContextPath r)+ restParts = B.split '/' (rqPathInfo r)+ in (contextParts, drop 1 restParts)+++-- TODO: Is this right? Does it drop leading/trailing slashes?+reqSafeTail :: Request -> Request+reqSafeTail r = let (ctx,inf) = pathSafeTail r+ in r { rqContextPath = B.intercalate "/" ctx+ , rqPathInfo = B.intercalate "/" inf+ }++reqNoPath :: Request -> Request+reqNoPath r = r {rqPathInfo = ""}++-- | Like `null . pathInfo`, but works with redundant trailing slashes.+pathIsEmpty :: Request -> Bool+pathIsEmpty = f . processedPathInfo+ where+ f [] = True+ f [""] = True+ f _ = False+++splitMatrixParameters :: Text -> (Text, Text)+splitMatrixParameters = T.break (== ';')++parsePathInfo :: Request -> [Text]+parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo+ where mergePairs = concat . unfoldr pairToList+ pairToList [] = Nothing+ pairToList ((a, b):xs) = Just ([a, b], xs)++-- | Returns a processed pathInfo from the request.+--+-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be+-- processed, so routing works as intended. Therefor this function should be used to access+-- the pathInfo for routing purposes.+processedPathInfo :: Request -> [Text]+processedPathInfo r =+ case pinfo of+ (x:xs) | T.head x == ';' -> xs+ _ -> pinfo+ where pinfo = parsePathInfo r
+ src/Servant/Server/Internal/Router.hs view
@@ -0,0 +1,180 @@+{-# language DeriveFunctor #-}+{-# language KindSignatures #-}+{-# language OverloadedStrings #-}++module Servant.Server.Internal.Router where++import Data.Map (Map)+import qualified Data.Map as M+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Servant.Server.Internal.PathInfo+import Servant.Server.Internal.RoutingApplication+import Servant.Server.Internal.ServantErr+import Snap.Core++type Router (m :: * -> *) env = Router' m env (RoutingApplication m)++-- | Internal representation of a router.+data Router' (m :: * -> *) env a = -- req app m =+ -- WithRequest (req -> Router req app m)+ -- -- ^ current request is passed to the router+ StaticRouter (Map Text (Router' m env a)) [env -> a]+ | CaptureRouter (Router' m (Text, env) a)+ | CaptureAllRouter (Router' m ([Text], env) a)+ | RawRouter (env -> a)+ | Choice (Router' m env a) (Router' m env a)+ deriving (Functor)++pathRouter :: Text -> Router' m env a -> Router' m env a+pathRouter t r = StaticRouter (M.singleton t r) []++leafRouter :: (env -> a) -> Router' m env a+leafRouter l = StaticRouter M.empty [l]+++-- | Smart constructor for the choice between routers.+-- We currently optimize the following cases:+--+-- * Two static routers can be joined by joining their maps.+-- * Two dynamic routers can be joined by joining their codomains.+-- * Two 'WithRequest' routers can be joined by passing them+-- the same request and joining their codomains.+-- * A 'WithRequest' router can be joined with anything else by+-- passing the same request to both but ignoring it in the+-- component that does not need it.+--+choice :: MonadSnap m => Router' m env a -> Router' m env a -> Router' m env a+choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =+ StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)+choice (CaptureRouter router1) (CaptureRouter router2) =+ CaptureRouter (choice router1 router2)+choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3+choice router1 router2 = Choice router1 router2++data RouterStructure =+ StaticRouterStructure (Map Text RouterStructure) Int+ | CaptureRouterStructure RouterStructure+ | RawRouterStructure+ | ChoiceStructure RouterStructure RouterStructure+ deriving (Eq, Show)++routerStructure :: Router' m env a -> RouterStructure+routerStructure (StaticRouter m ls) =+ StaticRouterStructure (fmap routerStructure m) (length ls)+routerStructure (CaptureRouter router) =+ CaptureRouterStructure $+ routerStructure router+routerStructure (CaptureAllRouter router) =+ CaptureRouterStructure $+ routerStructure router+routerStructure (RawRouter _) =+ RawRouterStructure+routerStructure (Choice r1 r2) =+ ChoiceStructure+ (routerStructure r1)+ (routerStructure r2)++-- | Compare the structure of two routers.+--+sameStructure :: Router' m env a -> Router' m env b -> Bool+sameStructure r1 r2 =+ routerStructure r1 == routerStructure r2++-- | Provide a textual representation of the+-- structure of a router.+--+routerLayout :: Router' m env a -> Text+routerLayout router =+ T.unlines (["/"] ++ mkRouterLayout False (routerStructure router))+ where+ mkRouterLayout :: Bool -> RouterStructure -> [Text]+ mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n+ mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)+ mkRouterLayout c RawRouterStructure =+ if c then ["├─ <raw>"] else ["└─ <raw>"]+ mkRouterLayout c (ChoiceStructure r1 r2) =+ mkRouterLayout True r1 ++ ["┆"] ++ mkRouterLayout c r2++ mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text]+ mkSubTrees _ [] 0 = []+ mkSubTrees c [] n =+ concat (replicate (n - 1) (mkLeaf True) ++ [mkLeaf c])+ mkSubTrees c [(t, r)] 0 =+ mkSubTree c t (mkRouterLayout False r)+ mkSubTrees c ((t, r) : trs) n =+ mkSubTree True t (mkRouterLayout False r) ++ mkSubTrees c trs n++ mkLeaf :: Bool -> [Text]+ mkLeaf True = ["├─•","┆"]+ mkLeaf False = ["└─•"]++ mkSubTree :: Bool -> Text -> [Text] -> [Text]+ mkSubTree True pth children = ("├─ " <> pth <> "/") : map ("│ " <>) children+ mkSubTree False pth children = ("└─ " <> pth <> "/") : map (" " <>) children++-- | Apply a transformation to the response of a `Router`.+tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router m env -> Router m env+tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))++runRouter :: MonadSnap m => Router m () -> RoutingApplication m+runRouter r = runRouterEnv r ()++-- | Interpret a router as an application.+runRouterEnv :: MonadSnap m+ => Router m env+ -> env+ -> RoutingApplication m+runRouterEnv router env request respond = case router of+ StaticRouter table ls -> case processedPathInfo request of+ [] -> runChoice ls env request respond+ [""] -> runChoice ls env request respond+ first : _ | Just router' <- M.lookup first table+ -> let request' = reqSafeTail request+ in runRouterEnv router' env request' respond+ _ -> respond $ Fail err404+ CaptureRouter router' ->+ case processedPathInfo request of+ [] -> respond $ Fail err404+ -- This case is to handle trailing slashes.+ [""] -> respond $ Fail err404+ first : _+ -> let request' = reqSafeTail request+ in runRouterEnv router' (first,env) request' respond+ CaptureAllRouter router' ->+ let segments = processedPathInfo request+ request'= reqNoPath request+ in runRouterEnv router' (segments, env) request' respond+ RawRouter app ->+ app env request respond+ Choice r1 r2 ->+ runChoice [runRouterEnv r1, runRouterEnv r2] env request respond+++runChoice :: [env -> RoutingApplication m] -> env -> RoutingApplication m+runChoice ls =+ case ls of+ [] -> \ _ _ respond -> respond (Fail err404)+ [r] -> r+ (r : rs) ->+ \ env request respond ->+ r env request $ \ response1 ->+ case response1 of+ Fail _ -> runChoice rs env request $ \ response2 ->+ respond $ highestPri response1 response2+ _ -> respond response1+ where+ highestPri (Fail e1) (Fail e2) =+ if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)+ then Fail e2+ else Fail e1+ highestPri (Fail _) y = y+ highestPri x _ = x++-- Priority on HTTP codes.+--+-- It just so happens that 404 < 405 < 406 as far as+-- we are concerned here, so we can use (<).+worseHTTPCode :: Int -> Int -> Bool+worseHTTPCode = (<)
+ src/Servant/Server/Internal/RoutingApplication.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Servant.Server.Internal.RoutingApplication where++import Control.Applicative (Applicative, Alternative(..), (<$>))+import Control.Monad (ap, liftM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Lazy as BL+import Data.CaseInsensitive (CI)+import qualified Data.List as L+import Data.Proxy (Proxy(..))+import Network.HTTP.Types (Status(..))+import qualified System.IO.Streams as Streams+import Servant.Server.Internal.SnapShims+import Servant.Server.Internal.ServantErr+import Snap.Core+import Snap.Internal.Http.Types (setResponseBody)+++type RoutingApplication m =+ Request -- ^ the request, the field 'pathInfo' may be modified by url routing+ -> (RouteResult Response -> m Response) -> m Response+++-- | The result of matching against a path in the route tree.+data RouteResult a =+ Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@+ -- should only be 404, 405 or 406.+ | FailFatal !ServantErr -- ^ Don't try other paths.+ | Route !a+ deriving (Eq, Show, Read, Functor)+++toApplication :: forall m. MonadSnap m => RoutingApplication m -> Application m+toApplication ra request respond = do+ r <- ra request routingRespond+ respond r+ where+ routingRespond (Fail err) = respond $ responseServantErr err+ routingRespond (FailFatal err) = respond $ responseServantErr err+ routingRespond (Route v) = respond v++responseLBS :: Status -> [(CI B.ByteString, B.ByteString)] -> BL.ByteString -> Response+responseLBS (Status code msg) hs body =+ setResponseStatus code msg+ . (\r -> L.foldl' (\r' (h,h') -> addHeader h h' r') r hs)+ . setResponseBody (\out -> do+ Streams.write (Just $ Builder.lazyByteString body) out+ return out)+ $ emptyResponse++runAction :: MonadSnap m+ => Delayed m env (m a)+ -> env+ -> Request+ -> (RouteResult Response -> m r)+ -> (a -> RouteResult Response)+ -> m r+runAction action env req respond k = do+ runDelayed action env req >>= go >>= respond+ where+ go (Fail e) = return $ Fail e+ go (FailFatal e) = return $ FailFatal e+ go (Route a) = do+ e <- a+ return $ k e+++data Delayed m env c where+ Delayed :: { capturesD :: env -> DelayedM m captures+ , methodD :: DelayedM m ()+ , authD :: DelayedM m auth+ , bodyD :: DelayedM m body+ , serverD :: captures -> auth -> body -> Request -> RouteResult c+ } -> Delayed m env c++instance Functor (Delayed m env) where+ fmap f Delayed{..} =+ Delayed+ { serverD = \ c a b req -> f <$> serverD c a b req+ , ..+ }++newtype DelayedM m a = DelayedM { runDelayedM :: Request -> m (RouteResult a) }++instance Monad m => Functor (DelayedM m) where+ fmap = liftM++instance Monad m => Applicative (DelayedM m) where+ pure = return+ (<*>) = ap++instance Monad m => Monad (DelayedM m) where+ return x = DelayedM (const $ return (Route x))+ DelayedM m >>= f =+ DelayedM $ \ req -> do+ r <- m req+ case r of+ Fail e -> return $ Fail e+ FailFatal e -> return $ FailFatal e+ Route a -> runDelayedM (f a) req++instance MonadIO m => MonadIO (DelayedM m) where+ liftIO m = DelayedM (const . liftIO $ Route <$> m)++instance Monad m => Alternative (DelayedM m) where+ empty = DelayedM $ \_ -> return (Fail err404)+ a <|> b = DelayedM $ \req -> do+ respA <- runDelayedM a req+ case respA of+ Route a' -> return $ Route a'+ _ -> runDelayedM b req+++instance MonadTrans DelayedM where+ lift f = DelayedM $ \_ -> do+ a <- f+ return $ Route a+++-- | A 'Delayed' without any stored checks.+emptyDelayed :: Monad m => Proxy (m :: * -> *) -> RouteResult a -> Delayed m env a+emptyDelayed (Proxy :: Proxy m) result =+ Delayed (const r) r r r (\ _ _ _ _ -> result)+ where+ r :: DelayedM m ()+ r = return ()++-- | Fail with the option to recover.+delayedFail :: Monad m => ServantErr -> DelayedM m a+delayedFail err = DelayedM (const $ return $ Fail err)++-- | Fail fatally, i.e., without any option to recover.+delayedFailFatal :: Monad m => ServantErr -> DelayedM m a+delayedFailFatal err = DelayedM (const $ return $ FailFatal err)++-- | Gain access to the incoming request.+withRequest :: (Request -> DelayedM m a) -> DelayedM m a+withRequest f = DelayedM (\ req -> runDelayedM (f req) req)++-- | Add a capture to the end of the capture block.+addCapture :: forall env a b captured m. Monad m => Delayed m env (a -> b)+ -> (captured -> DelayedM m a)+ -> Delayed m (captured, env) b+addCapture Delayed{..} new =+ Delayed+ { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt+ , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req+ , ..+ } -- Note [Existential Record Update]++-- | Add a method check to the end of the method block.+addMethodCheck :: Monad m+ => Delayed m env a+ -> DelayedM m ()+ -> Delayed m env a+addMethodCheck Delayed{..} new =+ Delayed+ { methodD = methodD <* new+ , ..+ } -- Note [Existential Record Update]++-- | Add an auth check to the end of the auth block.+addAuthCheck :: Monad m+ => Delayed m env (a -> b)+ -> DelayedM m a+ -> Delayed m env b+addAuthCheck Delayed{..} new =+ Delayed+ { authD = (,) <$> authD <*> new+ , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req+ , ..+ } -- Note [Existential Record Update]++-- | Add a body check to the end of the body block.+addBodyCheck :: Monad m+ => Delayed m env (a -> b)+ -> DelayedM m a+ -> Delayed m env b+addBodyCheck Delayed{..} new =+ Delayed+ { bodyD = (,) <$> bodyD <*> new+ , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req+ , ..+ } -- Note [Existential Record Update]+++-- | Add an accept header check to the beginning of the body+-- block. There is a tradeoff here. In principle, we'd like+-- to take a bad body (400) response take precedence over a+-- failed accept check (406). BUT to allow streaming the body,+-- we cannot run the body check and then still backtrack.+-- We therefore do the accept check before the body check,+-- when we can still backtrack. There are other solutions to+-- this, but they'd be more complicated (such as delaying the+-- body check further so that it can still be run in a situation+-- where we'd otherwise report 406).+addAcceptCheck :: Monad m+ => Delayed m env a+ -> DelayedM m ()+ -> Delayed m env a+addAcceptCheck Delayed{..} new =+ Delayed+ { bodyD = new *> bodyD+ , ..+ } -- Note [Existential Record Update]++-- | Many combinators extract information that is passed to+-- the handler without the possibility of failure. In such a+-- case, 'passToServer' can be used.+passToServer :: Delayed m env (a -> b) -> (Request -> a) -> Delayed m env b+passToServer Delayed{..} x =+ Delayed+ { serverD = \ c a b req -> ($ x req) <$> serverD c a b req+ , ..+ } -- Note [Existential Record Update]+++-- | Run a delayed server. Performs all scheduled operations+-- in order, and passes the results from the capture and body+-- blocks on to the actual handler.+--+-- This should only be called once per request; otherwise the guarantees about+-- effect and HTTP error ordering break down.+runDelayed :: Monad m+ => Delayed m env a+ -> env+ -> Request+ -> m (RouteResult a)+runDelayed Delayed{..} env = runDelayedM $ do+ c <- capturesD env+ methodD+ a <- authD+ b <- bodyD+ DelayedM (\ req -> return $ serverD c a b req)
+ src/Servant/Server/Internal/ServantErr.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Servant.Server.Internal.ServantErr where++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List as L+import qualified Network.HTTP.Types as HTTP+import Snap.Core++data ServantErr = ServantErr { errHTTPCode :: Int+ , errReasonPhrase :: String+ , errBody :: LBS.ByteString+ , errHeaders :: [HTTP.Header]+ } deriving (Show, Eq, Read)++setHeaders :: [HTTP.Header] -> Response -> Response+setHeaders hs r =+ L.foldl' (\r' (h, h') -> addHeader h h' r') r hs++responseServantErr :: ServantErr -> Response+responseServantErr ServantErr{..} =+ setHeaders errHeaders+ . setResponseStatus errHTTPCode (BS.pack errReasonPhrase)+ $ emptyResponse -- responseLBS status errHeaders errBody++-- | Terminate request handling with a @ServantErr@ via @finishWith@+throwError :: MonadSnap m => ServantErr -> m a+throwError ServantErr{..} = do+ modifyResponse $ setResponseStatus errHTTPCode (BS.pack errReasonPhrase)+ modifyResponse $ setHeader "Content-Type" "application/json"+ writeBS "null"+ getResponse >>= finishWith++err300 :: ServantErr+err300 = ServantErr { errHTTPCode = 300+ , errReasonPhrase = "Multiple Choices"+ , errBody = ""+ , errHeaders = []+ }++err301 :: ServantErr+err301 = ServantErr { errHTTPCode = 301+ , errReasonPhrase = "Moved Permanently"+ , errBody = ""+ , errHeaders = []+ }++err302 :: ServantErr+err302 = ServantErr { errHTTPCode = 302+ , errReasonPhrase = "Found"+ , errBody = ""+ , errHeaders = []+ }++err303 :: ServantErr+err303 = ServantErr { errHTTPCode = 303+ , errReasonPhrase = "See Other"+ , errBody = ""+ , errHeaders = []+ }++err304 :: ServantErr+err304 = ServantErr { errHTTPCode = 304+ , errReasonPhrase = "Not Modified"+ , errBody = ""+ , errHeaders = []+ }++err305 :: ServantErr+err305 = ServantErr { errHTTPCode = 305+ , errReasonPhrase = "Use Proxy"+ , errBody = ""+ , errHeaders = []+ }++err307 :: ServantErr+err307 = ServantErr { errHTTPCode = 307+ , errReasonPhrase = "Temporary Redirect"+ , errBody = ""+ , errHeaders = []+ }++err400 :: ServantErr+err400 = ServantErr { errHTTPCode = 400+ , errReasonPhrase = "Bad Request"+ , errBody = ""+ , errHeaders = []+ }++err401 :: ServantErr+err401 = ServantErr { errHTTPCode = 401+ , errReasonPhrase = "Unauthorized"+ , errBody = ""+ , errHeaders = []+ }++err402 :: ServantErr+err402 = ServantErr { errHTTPCode = 402+ , errReasonPhrase = "Payment Required"+ , errBody = ""+ , errHeaders = []+ }++err403 :: ServantErr+err403 = ServantErr { errHTTPCode = 403+ , errReasonPhrase = "Forbidden"+ , errBody = ""+ , errHeaders = []+ }++err404 :: ServantErr+err404 = ServantErr { errHTTPCode = 404+ , errReasonPhrase = "Not Found"+ , errBody = ""+ , errHeaders = []+ }++err405 :: ServantErr+err405 = ServantErr { errHTTPCode = 405+ , errReasonPhrase = "Method Not Allowed"+ , errBody = ""+ , errHeaders = []+ }++err406 :: ServantErr+err406 = ServantErr { errHTTPCode = 406+ , errReasonPhrase = "Not Acceptable"+ , errBody = ""+ , errHeaders = []+ }++err407 :: ServantErr+err407 = ServantErr { errHTTPCode = 407+ , errReasonPhrase = "Proxy Authentication Required"+ , errBody = ""+ , errHeaders = []+ }++err409 :: ServantErr+err409 = ServantErr { errHTTPCode = 409+ , errReasonPhrase = "Conflict"+ , errBody = ""+ , errHeaders = []+ }++err410 :: ServantErr+err410 = ServantErr { errHTTPCode = 410+ , errReasonPhrase = "Gone"+ , errBody = ""+ , errHeaders = []+ }++err411 :: ServantErr+err411 = ServantErr { errHTTPCode = 411+ , errReasonPhrase = "Length Required"+ , errBody = ""+ , errHeaders = []+ }++err412 :: ServantErr+err412 = ServantErr { errHTTPCode = 412+ , errReasonPhrase = "Precondition Failed"+ , errBody = ""+ , errHeaders = []+ }++err413 :: ServantErr+err413 = ServantErr { errHTTPCode = 413+ , errReasonPhrase = "Request Entity Too Large"+ , errBody = ""+ , errHeaders = []+ }++err414 :: ServantErr+err414 = ServantErr { errHTTPCode = 414+ , errReasonPhrase = "Request-URI Too Large"+ , errBody = ""+ , errHeaders = []+ }++err415 :: ServantErr+err415 = ServantErr { errHTTPCode = 415+ , errReasonPhrase = "Unsupported Media Type"+ , errBody = ""+ , errHeaders = []+ }++err416 :: ServantErr+err416 = ServantErr { errHTTPCode = 416+ , errReasonPhrase = "Request range not satisfiable"+ , errBody = ""+ , errHeaders = []+ }++err417 :: ServantErr+err417 = ServantErr { errHTTPCode = 417+ , errReasonPhrase = "Expectation Failed"+ , errBody = ""+ , errHeaders = []+ }++err500 :: ServantErr+err500 = ServantErr { errHTTPCode = 500+ , errReasonPhrase = "Internal Server Error"+ , errBody = ""+ , errHeaders = []+ }++err501 :: ServantErr+err501 = ServantErr { errHTTPCode = 501+ , errReasonPhrase = "Not Implemented"+ , errBody = ""+ , errHeaders = []+ }++err502 :: ServantErr+err502 = ServantErr { errHTTPCode = 502+ , errReasonPhrase = "Bad Gateway"+ , errBody = ""+ , errHeaders = []+ }++err503 :: ServantErr+err503 = ServantErr { errHTTPCode = 503+ , errReasonPhrase = "Service Unavailable"+ , errBody = ""+ , errHeaders = []+ }++err504 :: ServantErr+err504 = ServantErr { errHTTPCode = 504+ , errReasonPhrase = "Gateway Time-out"+ , errBody = ""+ , errHeaders = []+ }++err505 :: ServantErr+err505 = ServantErr { errHTTPCode = 505+ , errReasonPhrase = "HTTP Version not supported"+ , errBody = ""+ , errHeaders = []+ }
+ src/Servant/Server/Internal/SnapShims.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}++module Servant.Server.Internal.SnapShims where++import qualified Data.ByteString.Char8 as B+import Network.HTTP.Types (Status(..))+import Data.IORef+import Snap.Core+++type Application m = Request -> (Response -> m Response) -> m Response++snapToApplication :: MonadSnap m => m () -> Application m+snapToApplication snapAction req respond = do+ putRequest req+ snapAction >> getResponse >>= respond++snapToApplication' :: MonadSnap m => m a -> Application m+snapToApplication' snapAction req respond = do+ putRequest req+ snapAction >> getResponse >>= respond++applicationToSnap :: MonadSnap m => Application m -> m ()+applicationToSnap app = do+ req <- getRequest+ r <- app req return+ putResponse r++unSnapMethod :: Method -> B.ByteString+unSnapMethod = B.pack . show++-- data Status = Status {+-- statusCode :: Int+-- , statusMessage :: B.ByteString+-- } deriving (Eq, Show, Ord)++ok200 :: Status+ok200 = Status 200 "OK"++noContent204 :: Status+noContent204 = Status 204 "No Content"++created201 :: Status+created201 = Status 201 "Created"++badRequest400 :: Status+badRequest400 = Status 400 "Bad Request"++notFound404 :: Status+notFound404 = Status 404 "Not Found"++methodNotAllowed405 :: Status+methodNotAllowed405 = Status 405 "Method Not Allowed"++unsupportedMediaType415 :: Status+unsupportedMediaType415 = Status 415 "Not Found"++++-- Emulate a thunk for memoizing the result of an IO action+-- may be useful for dealing with the multiple body reads [issue](https://github.com/haskell-servant/servant/issues/3)+initThunk :: IO a -> IO (IO a)+initThunk act = do+ r <- newIORef Nothing+ return (fromThunk act r)++ where+ fromThunk :: IO a -> IORef (Maybe a) -> IO a+ fromThunk action r = do+ ma <- readIORef r+ maybe forceIt return ma+ where forceIt = do {a <- action; writeIORef r (Just a); return a}
+ src/Servant/Utils/StaticFiles.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- | 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 Servant.API.Raw (Raw)+import Servant.Server (Server)+import Snap.Core+import qualified Snap.Util.FileServe as Snap++-- | 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 :: MonadSnap m => FilePath -> Server Raw m+serveDirectory fp = liftSnap $ Snap.serveDirectory fp
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}