diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +0.7 +---- + +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Zalora South East Asia Pte Ltd + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Zalora South East Asia Pte Ltd nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,136 @@ +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +[![Build Status](https://travis-ci.org/haskell-servant/servant-snap.svg?branch=master)](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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/greet.hs b/example/greet.hs new file mode 100644 --- /dev/null +++ b/example/greet.hs @@ -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 + diff --git a/servant-snap.cabal b/servant-snap.cabal new file mode 100644 --- /dev/null +++ b/servant-snap.cabal @@ -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 , and about the basics of Snap at the Snaplets + . + + 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 snaplet, another delegates to . + . + +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 diff --git a/src/Servant.hs b/src/Servant.hs new file mode 100644 --- /dev/null +++ b/src/Servant.hs @@ -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 diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server.hs @@ -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 diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal.hs @@ -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 diff --git a/src/Servant/Server/Internal/PathInfo.hs b/src/Servant/Server/Internal/PathInfo.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/PathInfo.hs @@ -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 diff --git a/src/Servant/Server/Internal/Router.hs b/src/Servant/Server/Internal/Router.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/Router.hs @@ -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 "" (mkRouterLayout False r) + mkRouterLayout c RawRouterStructure = + if c then ["├─ "] else ["└─ "] + 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 = (<) diff --git a/src/Servant/Server/Internal/RoutingApplication.hs b/src/Servant/Server/Internal/RoutingApplication.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/RoutingApplication.hs @@ -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) diff --git a/src/Servant/Server/Internal/ServantErr.hs b/src/Servant/Server/Internal/ServantErr.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/ServantErr.hs @@ -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 = [] + } diff --git a/src/Servant/Server/Internal/SnapShims.hs b/src/Servant/Server/Internal/SnapShims.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/SnapShims.hs @@ -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} diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Utils/StaticFiles.hs @@ -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\/\@ and look for +-- @\@ under @\/var\/www@. +-- +-- It will do its best to guess the MIME type for that file, based on the extension, +-- and send an appropriate /Content-Type/ header if possible. +-- +-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API +-- as a webapp backend, you will most likely not want the static files to be hidden +-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectory' +-- handler in the last position, because /servant/ will try to match the handlers +-- in order. +serveDirectory :: MonadSnap m => FilePath -> Server Raw m +serveDirectory fp = liftSnap $ Snap.serveDirectory fp diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}