respond (empty) → 0.2.0.0

raw patch · 20 files changed

+2101/−0 lines, 20 filesdep +HListdep +aesondep +basesetup-changed

Dependencies added: HList, aeson, base, bifunctors, bytestring, containers, data-default-class, exceptions, fast-logger, formatting, http-media, http-types, lens, monad-control, monad-logger, mtl, path-pieces, respond, safe, scientific, template-haskell, text, transformers, transformers-base, unordered-containers, vector, wai, wai-extra, warp

Files

• LICENSE +30/−0
• README.md +415/−0
• Setup.hs +2/−0
• example/Main.hs +78/−0
• respond.cabal +108/−0
• src/Web/Respond.hs +69/−0
• src/Web/Respond/DefaultHandlers.hs +62/−0
• src/Web/Respond/DefaultServer.hs +39/−0
• src/Web/Respond/HListUtils.hs +40/−0
• src/Web/Respond/Method.hs +87/−0
• src/Web/Respond/Monad.hs +171/−0
• src/Web/Respond/Path.hs +248/−0
• src/Web/Respond/Request.hs +101/−0
• src/Web/Respond/Response.hs +136/−0
• src/Web/Respond/Run.hs +60/−0
• src/Web/Respond/Types.hs +35/−0
• src/Web/Respond/Types/Errors.hs +172/−0
• src/Web/Respond/Types/Path.hs +47/−0
• src/Web/Respond/Types/Request.hs +71/−0
• src/Web/Respond/Types/Response.hs +130/−0

@@ -0,0 +1,30 @@+Copyright (c) 2014, aidan coyne++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 aidan coyne 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.

@@ -0,0 +1,415 @@+# respond+a Haskell library built on top of WAI for processing and routing HTTP requests+and generating responses.++## motivation+you might wonder why I went to the trouble of building respond when there are,+at this point, plenty of libraries etc for HTTP routing in Haskell. (i could say+that when I started, there weren't as many, but no one's going to believe that!)+I have three justifications for developing this library.++* some HTTP APIs will be best represented using a nested routing structure. this+  is, in fact, the primary reason i wrote respond - while working on a different+  project, i found that the nested routes in the API specification for that+  project were not well served by other libraries. respond should serve in those+  situations, where groups of routes repeatedly need the same shared routing+  filters.+* type-safe path matching and parameter extraction is useful, and respond has+  it.+* it's fairly simple - the core of it is a newtype wrapper for a ReaderT, and+  the rest of the library contains convenience functions that interact with the+  monadic interface that RespondT implements. if you want to interact directly+  with the request, or build and send your own responses, the core interface+  will let you do that.++## using respond+you'll probably want to look at the haddock documentation (link to come after +release) while you're reading this guide.+let's get started with a brief overview of how to use this library.++### a brief overview+building an app using respond should hopefully be straightforward, and familiar +to anyone who has used other WAI-based web service libraries (e.g. scotty).+* first, you integrate the `RespondT` monad transformer into your monad stack. you +  can also use `RespondM` if you don't need a more involved stack.+* use various routing tools (defined in terms of `MonadRespond`) to match various +  aspects of the request+* produce responses from inside your routing, either by building them directly, +  or by using one of the tools for building responses+* convert your routing stack into a WAI app and run it in a WAI compatible +  server; this library provides a default warp setup you can use.++### the monad transformer and monadic interface+MonadRespond is the monadic interface that most of the tools this library +provides build on top of. it defines a core set of actions:+* `respond` is the WAI 3.0 `Application` continuation lifted into `MonadRespond`. +  whenever you see the type `ResponseReceived`, a call to respond is involved.+* `getRequest` gets the request that's currently being handled. if you ever +  find yourself using this directly, get in touch; there's probably an +  opportunity to add a new tool to the library or improve the existing ones!+* `getHandlers` gets out the `FailureHandlers`. these define the responding+  action to use when request matching or processing fails.+* `withHandlers` runs the inner `MonadRespond` action with a modified set of+  handlers; you can use this to add code to be run after the actual response is+  sent, or to change the response entirely.+* `getPath` gets the current `PathConsumer`.+* `withPath` runs the passed `MonadRespond` action with a modified `PathConsumer`+  value. this and the previous function will be explained further in the+  discussion of path routing.++the WAI `Application` type specifies that both the passed continuation and the+returned value are in `IO`; because MonadRespond specifies a wrapping of that+continuation, any instance of `MonadRespond` must be an instance of `MonadIO`.++`RespondT` is the monad transformer that implements the `MonadRespond` class (as+long as it is stacked on top of a `MonadIO`); it's basically a newtype for a+`ReaderT` that contains a record type containing the relevant components. there is+a simple `RespondM` type alias defined in the `Web.Respond.Run` module; this+alias stacks `RespondT` directly on `IO`, i.e.++```haskell+type RespondM a = RespondT IO a +```+++### running the app+there are several functions in `Web.Respond.Run` that you can use. the key ones+build a WAI application from a `RespondT` route (i.e. a value of type `RespondT m+ResponseReceived`); note that these functions (`respondApp` and `respondAppDefault`)+require a function to run the rest of the monadic stack to an `IO` value.+(the `RespondM` functions, of course, do not require this run function - running+the `RespondT` already produces the necessary `IO` value.)++the default handlers used by the \*Default functions are contained in+`Web.Respond.DefaultHandlers`; the default warp server setup used by the serve\*+functions are contained in `Web.Respond.DefaultServer`.++### request processing and routing+a number of tools are provided for (hopefully) convenient request processing and+routing.++#### matching methods+`Web.Respond.Method` defines the type `MethodMatcher`, which is just a newtype+around a Map from `StandardMethod` to some value. the module provides an+`onMethod` function that takes a `StandardMethod` and a value and provide a+`MethodMatcher` for just that method. functions are provided that apply+`onMethod` to each `StandardMethod`. using the monoid instance of+`MethodMatcher`, you can combine matchers to map different methods to different+actions. for example:++```haskell+-- | do something+act1 :: MonadRespond m => m ResponseReceived+act1 = ...++-- | do something else+act2 :: MonadRespond m => m ResponseReceived+act2 = ...++getOrPutActions ::  MonadRespond m => MethodMatcher (m ResponseReceived)+getOrPutActions = onGET act1 <> onPOST act2+```++`matchMethod` takes a `MethodMatcher` that will produce an appropriate responding+action for each mapped HTTP method, and chooses the action that handles the+current request's method. ++```haskell+-- continuing from before ...+route :: MonadRespond m => m ResponseReceived+route = matchMethod $ +    onGET act1 <>+    onPOST act2+```++in this example, route will use act1 if the request method is GET, act2 if the+method is POST, and will call `handleUnsupportedMethod` for any other method+(including ones that are not in `StandardMethod`). +what  `handleUnsupportedMethod` does from there will be explained in the section+on error handling below.++#### matching paths+`PathMatcher a` is a newtype for functions that take `PathConsumer`s and produce+`Maybe a`s. the `matchPath` function uses these to choose the responding action+based on the current path state.++`PathMatcher` is a functor, which lets you do things like wrap inner actions+with other routing logic;+```haskell+-- this is provided in the module, though with a simpler definition+-- whatever action the original matcher would perform is now only performed if+-- the method matches.+matchPathWithMethod :: MonadRespond m => StdMethod -> PathMatcher (m ResponseReceived) -> PathMatcher (m ResponseReceived)+matchPathWithMethod method matcher = (matchMethod . onMethod method) <$> matcher+```++`PathMatcher` is also an instance of Applicative and, more importantly,+Alternative. the Alternative instance is what allows you to choose different+actions for different request paths, for instance++```haskell+-- for now, suppose this is at the top level of the API+pathExample0 :: RespondM ResponseReceived+pathExample0 = matchPath $+    -- if the request is to e.g. http://localhost:3000/, rootAction will produce the response+    pathEndOrSlash rootAction <|>+    -- however, if the request is to e.g. http://localhost:3000/one/ or http://localhost:3000/one, actionOne will get to respond+    pathLastSeg "one" actionOne+```++if the request is to none of those paths, then `handleUnmatchedPath` will get+called (see further on).++##### path extraction+obviously, we want to do more advanced matching on paths, and often we want to+get parameters out of paths. this is supported by the use of `PathExtractor`,+which is newtype wrapper around a somewhat fearsome-looking stack of monads. you+should look at the definition, but to summarize, it is meant to track+`PathConsumer` state , and possibly produce a value.++a `PathConsumer`, defined in `Web.Respond.Types.Path`, can be thought of as a+pair of the path segments that have been consumed and the path segments that+have not been consumed.+each field within the consumer keeps the segments in order, so it is possible to+rebuild the original request path using `getFullPath`. +`pcConsumeNext` produces a new consumer with the first segment in the previous+unconsumed segment list appended to the consumed sequence (if there is no next+segment, i.e. `pcGetNext` produces nothing, `pcConsumeNext` should produce an+identical consumer).++the path extractor produced by `seg "whatever"` does the following when run+against a `PathMatcher` (e.g. by using the function `pathExtract`)+* it pulls out the current `PathConsumer` state+* if there is a next segment, and it matches the string "whatever", then it+  produces an empty value (`HList0`)+* it then updates the state with the result of applying `pcConsumeNext` to the+  old state.++these extractors can then be sequenced using the `(</>)` combinator, which takes+advantage of the Applicative instance of `PathExtractor` to put them together.+(now, if you happen to be looking at the documentation for this function, you+might be wondering what all this HList stuff is about. we'll get to that soon.)++now you can use the `path` function to combine extractors and inner actions to+produce path matchers to use with `matchPath`. for example++```haskell+pathExample1 :: RespondM ResponseReceived+pathExample1 = matchPath $+    path (seg "one" </> seg "two" </> endOrSlash) someAction+```++and someAction will only get run if the request is to e.g.+`http://localhost:3000/one/two/`++it wouldn't make sense to call it `PathExtractor` if it couldn't extract values;+this is where HLists come in. a simple example is the `value` PathExtractor; it+produces a single value from a single segment if it can successfully be+extracted using the `PathPiece` instance. +when multiple value extractors are chained, they build an HList of those types+(since `(</>)` appends each side's HList).+the `path` function's second parameter expects a function that takes the types+of the constructed HList and produces a MonadRespond action.+in fact, that is all that `HListElim` is; a function that has a type signature+that matches up with the types of an HList - the function `hListUncurry`+uncurries such a function against a conforming HList. putting this all together,+you can do something like++```haskell+pathInnerAction1 :: Integer -> Text -> Text -> RespondM ResponseReceived+pathInnerAction1 num t1 t2 = ... -- does whatever++pathExample2 :: RespondM ResponseReceived+pathExample2 = matchPath $+    path (seg "id" </> value </> seg "params" </> value </> value) pathInnerAction1+```++and e.g. a GET against `http://localhost:3000/id/42/params/one/two` would lead+to whatever response the action `pathInnerAction1 42 "one" "two"` produces.++##### path route nesting+an important point about the `path` function is that it runs the inner action+with a modified `PathConsumer` - specifically, the consumer produced by running+the `PathExtractor`. this is accomplished by building on the `withPath` function+specified by the the `MonadRespond` class. this lets you nest routing in a+sensible and hopefully pleasant way:++```haskell+idAction :: Text -> Integer -> RespondM ResponseReceived+idAction t i = --whatever++pathInnerRouting1 :: Text -> RespondM ResponseReceived+pathInnerRouting1 text = matchPath $+    pathEndOrSlash (innerRootAction text) <|>+    path (seg "id" </> value </> endOrSlash) (\v -> idAction text v)++pathExample3 :: RespondM ResponseReceived+pathExample3 = matchPath $+    pathEndOrSlash outerRootAction <|>+    path (seg "loc" </> value) pathInnerRouting1+```++which handles requests to e.g.+* `http://localhost:3000/` with `outerRootAction`+* `http://localhost:3000/seg/loc` with `handleUnmatchedPath`+* `http://localhost:3000/seg/loc/here` with `pathInnerRouting1 "here"`, which in+  turn uses `innerRootAction "here"`.+* `http://localhost:3000/seg/loc/here/id/55` with `pathInnerRouting1 "here"`, which in+  turn uses `idAction "here" 55`.++#### extracting request body values+respond defines the `FromBody` typeclass; instances of this class implement a+function that either extracts a value of the instance type out of a lazy+bytestring or produces an error value (see below for ReportableError).++##### provided instances+several newtype wrappers with FromBody instances have been provided for+convenience.+* `TextBody` is a wrapper around a lazy Text value. it decodes the bytestring+  body as utf-8. it fails with a UnicodeException.+* `TextBodyS` is like TextBody except that it converts lazy Text into strict Text+  after decoding.+* `Json` is a wrapper around a JSON Value. it uses Aeson's `eitherDecode` for+  lazy conversion and wraps up a failure message with `JsonParseError`.+* `JsonS` is also a wrapper around a JSON Value - it works much the same way as+  the previous wrapper except that it uses `eitherDecode'` to perform immediate+  conversion.++##### getting the request body - lazy vs strict IO+in `Web.Respond.Request`, there are 6 functions for extracting the request body+as a `MonadRespond` action.+* `getBodyLazy` uses Wai's `lazyRequestBody` function to lazily load the request+  body. this may or may not be safe for your purposes.+* `getBodyStrict` uses Wai's `strictRequestBody` function instead.+* `extractBodyLazy` and `extractBodyStrict` build on `getBodyLazy` and+  `getBodyStrict`, and apply the `getBody` method for the desired instance of+  `FromBody`.+* `withRequiredBody` and `withRequiredBody'` use `extractBodyLazy` and+  `extractBodyStrict` and then run the passed continuation if a value was+  successfully extracted. otherwise, they run `handleBodyParseFailure` to report+  the error (see section on error reporting).++#### authentication and authorization tools+there are several functions that run inner actions based on passed values - the+main difference between the authenticate and authorize functions is that when+a failure is indicated, the former call `handleAuthFailed` and the latter call+`handleAccessDenied`.++### generating responses+the `ToResponseBody` typeclass is defined to allow you to choose how a type+being used a response value should be rendered based on content negotiation.+this is accomplished by having the Accept header of the request be passed into+the `toResponseBody` function. various utilities for matching on this header are+provided, built on top of the http-media library.++as an example, let's say you have a type `ExDocument` that you want to use as a+response body, and various ways of rendering it.++```haskell+import qualified Data.Text as T+import Network.HTTP.Media++data ExDocument = ...++-- you have the following ways of rendering it defined appropriately ...++instance ToJSON ExDocument where+    toJSON doc = undefined ++renderDocPlaintext :: ExDocument -> T.Text+renderDocPlaintext doc = undefined ++renderDocHTML :: ExDocument -> T.Text+renderDocHTML doc = undefined++-- you can then use these rendering tools based on the Accept header+-- by defining a ToResponseBody instance.+instance ToResponseBody ExDocument where+    toResponseBody = matchToContentTypes [+        textUtf8 "text/html" renderDocHTML,+        jsonMatcher,+        textUtf8 "text/plain" renderDocPlaintext+    ]+```++as this example hopefully illustrates, you do not have to handle the+interpretation of the Accept header value yourself - you can rely on the+http-media library and the provided convenience functions to select the+appropriate encoding function. let's break down what they do:+* `matchToContentTypes` takes a list of `MediaTypeMatcher`s, "prepares" them,+  and uses the first one that matches (if any) to produce a ResponseBody. it is+  defined so that it can be easily used to implement `toResponseBody` - you give+  it the matcher list and it gives you the implementation.+* `ResponseBody` is a pair of the value to use as the content type header and+  the bytestring to use as the body.+* a `MediaTypeMatcher` is a pair of a media type value and a function that+  produces a bytestring for a value.+* `prepareMediaTypeMatcher` is a function that `matchToContentTypes` uses to+  construct a pair of media type and response body out of a value and a media+  type matcher.+* `textUtf8` takes a media type and a Text based renderer, and produces a+  `MediaTypeMatcher` that will render the value to Text and then encode it as+  utf-8; it will also add the parameter specifying the encoding to the media+  type you pass in.+* jsonMatcher is a MediaTypeMatcher for any instance of `ToJSON`;+  unsurprisingly, it matches the media type `application/json`.++once you have an instance of `ToResponseBody` for a type, you can use the functions in+`Web.Respond.Response` to send responses for that type. for instance, let's say+your app monad has a way to fetch a document from the database ...++```haskell+lookupDocument :: ExampleAppMonad m => DocId -> m ExDocument+lookupDocument id = undefined++docLookupRoute  :: (MonadRespond m, ExampleAppMonad m) -> DocId -> m ResponseReceived+docLookupRoute id = do+    doc <- lookupDocument id+    respondOk doc+```++now, you may be wondering what happens if the request's Accept header can't be+matched; e.g. someone made a request into docLookupRoute but specified the+header `Accept: text/xml` but ExDocument doesn't render to XML. all of the+functions built on `respondWith` use `respondUnacceptable` if `toResponseBody`+produces `Nothing`; this sends back a `406 Unacceptable` response with an empty+body and no content type.++if you know that a set of inner routes will only produce certain content types,+you can handle those early on using the `checkAccepts` function, which takes a+list of media types that the inner route can produce, and uses+`respondUnacceptable` if the request's Accept header doesn't match any of them.++also, it is worth keeping in mind that the respond library will default to `*/*`+if the request does not set an Accept header explicitly.++#### ErrorReport and ReportableError+An ErrorReport is a container for information about errors that occur during+request processing. it has a ReportableError instance that defaults to rendering+the error report as HTML with the status code as a header, and also renders to+plain text and JSON.++ReportableError is similar to ToResponseBody except that it must choose a+default rendering if it can't match the Accept header. it is also given the+status code that will be sent in the response so it may render the status in the+body.++if you want to make other errors into ReportableErrors, you may find it+convenient to define a function to convert values of your error type into an+appropriate ErrorReport value and then define the ReportableError instance using+`reportAsErrorReport`.++#### handling failures and errors during request processing+various routing failures are handled by using the appropriate handle\* function.+these functions get the appropriate function from the current+`FailureHandlers` value and run it against the arguments.++it should be possible to modify these functions at any point during routing -+installing a new function for a particular handler can allow you to modify how+the inner route will respond if it fails in a way that uses the modified+handler, and it should allow you to perform other actions, such as any sort of+cleanup you might need. ++currently, exception handling is a particularly weak part of the respond+library - `catchRespond` only works on specific exception types, so there is no+top level exception handling.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,78 @@+module Main where++import Data.Monoid ((<>))+import Control.Applicative ((<|>))+import Network.Wai+import Data.Aeson+import Network.HTTP.Types.Status+import Network.HTTP.Types.Method+import qualified Data.Text as T+import Web.Respond+import System.Log.FastLogger+import Control.Exception+++main :: IO ()+main = do+    logger <- newStdoutLoggerSet defaultBufSize +    serveRespondDefault 3000 logger id exampleApi++type Example = RespondT IO++exampleApi :: Example ResponseReceived+exampleApi = matchPath $+    path endOrSlash apiRoot <|> +    path (seg "assemble" ) assembleHandler <|>+    path (seg "number" </> value </> seg "string" </> value </> endOrSlash) numHandler <|>+    path (seg "error" </> endOrSlash) errorExample <|>+    path (seg "methoding") methodingExample+    where+    numHandler :: Integer -> T.Text -> Example ResponseReceived+    numHandler num t = respondOk $ object ["text" .= t, "num" .= num]++assembleHandler :: Example ResponseReceived+assembleHandler = matchPath $+    path endOrSlash (respondStdHeaders notImplemented501 (object ["awaiting" .= ("stray kitten" :: T.Text)])) <|>+    path value firstHandler++apiRoot :: Example ResponseReceived+apiRoot = matchMethod $+    onGET (respondOk (object ["location" .= ("here" :: T.Text)])) <>+    onPUT (respondOk (object ["location" .= ("there" :: T.Text)])) <>+    onPOST (withRequiredBody $ showPostedValue . getJson)+    where+    showPostedValue :: Value -> Example ResponseReceived+    showPostedValue v = respondOk (object ["location" .= ("cold" :: T.Text), "recvd" .= v])++firstHandler :: T.Text -> Example ResponseReceived+firstHandler p = do +    ps <- getUnconsumedPath+    respondStdHeaders notImplemented501 (object ["head" .= p, "tail" .= ps])++errorExample :: Example ResponseReceived+errorExample = catchRespond displayError $ matchMethod $+    onGET $ error "hey what's going on"+    where+    displayError (ErrorCall s) = errorReportWithMessage "error_thrown" (T.pack s)++textGET :: T.Text+textGET = "get"++textPOST :: T.Text+textPOST = "post"++textOne :: T.Text+textOne = "one"++textTwo :: T.Text+textTwo = "two"++methodingExample :: Example ResponseReceived+methodingExample = matchPath $+    pathEndOrSlash (matchMethod $+        onGET (respondOk $ object ["method" .= textGET]) <>+        onPOST (respondOk $ object ["method" .= textPOST])) <|>+    matchPathWithMethod GET (+        pathLastSeg "one" (respondOk $ object ["got" .= textOne]) <|>+        path (seg "two" </> (value :: PathExtractor1 Int)) (\i -> respondOk $ object ["got" .= textTwo, "v" .= i]))+

@@ -0,0 +1,108 @@+name:+    respond+version:+    0.2.0.0+homepage:+    http://github.com/raptros/respond+license:+    BSD3+license-file:+    LICENSE+author:+    aidan coyne+maintainer:+    coynea90@gmail.com+copyright:+    2014, aidan coyne+category:+    Web+build-type:+    Simple+extra-source-files:+    README.md+cabal-version:+    >=1.10+synopsis:+    process and route HTTP requests and generate responses on top of WAI+description:+    a Haskell library built on top of WAI for processing and routing HTTP requests and generating responses. +    see the source repository for a simple example application.++source-repository head+    type: git+    location: https://github.com/raptros/respond.git++library+    ghc-options:+        -Wall+    default-extensions:+        OverloadedStrings+    default-language:+        Haskell2010+    hs-source-dirs:+        src+    exposed-modules:+        Web.Respond+        Web.Respond.Types+        Web.Respond.Types.Path+        Web.Respond.Types.Response+        Web.Respond.Types.Request+        Web.Respond.Types.Errors+        Web.Respond.Monad+        Web.Respond.Response+        Web.Respond.DefaultHandlers+        Web.Respond.Request+        Web.Respond.Method+        Web.Respond.HListUtils+        Web.Respond.Path+        Web.Respond.DefaultServer+        Web.Respond.Run+    build-depends:+        base >=4.7 && <4.8,+        transformers-base == 0.4.*,+        monad-control == 0.3.*,+        data-default-class,+        exceptions >= 0.6 && < 0.7,+        bifunctors >= 4.1 && <= 4.3,+        scientific >= 0.3.1 && < 0.4,+        vector >= 0.10 && < 0.11,+        fast-logger == 2.*,+        transformers == 0.4.*,+        http-media == 0.4.*,+        safe >= 0.3 && < 0.4,+        containers == 0.5.5.*,+        text >= 1.2 && < 1.3,+        formatting >= 5.0 && < 6.0,+        bytestring >= 0.10 && < 0.11,+        monad-logger >= 0.3.8 && < 0.4,+        wai >= 3.0 && < 4.0,+        wai-extra >= 3.0 && < 4.0,+        warp >= 3.0 && < 4.0,+        HList >= 0.3 && < 0.4,+        http-types >= 0.8 && < 0.9,+        path-pieces >= 0.1 && <= 0.2,+        unordered-containers >= 0.2 && < 0.3,+        template-haskell == 2.9.*,    +        mtl >= 2.2 && < 2.3, +        aeson == 0.8.*,+        lens >= 4.6 && < 4.7++executable example+    ghc-options:+        -Wall+    default-extensions:+        OverloadedStrings+    default-language:+        Haskell2010+    hs-source-dirs:+        example+    main-is:+        Main.hs+    build-depends:+        base,+        respond,+        wai,+        aeson,+        http-types,+        text,+        fast-logger

@@ -0,0 +1,69 @@+{-|+Description: main module for library. exports everything.++= how to navigate the modules+this module re-exports all of the modules that make up this library, so+hopefully this can tell you where to find what you're looking for.++== fundamental modules++=== "Web.Respond.Types"+various types and classes are exported in this module++=== "Web.Respond.Monad"+the monad transformer and monadic interface for building a routing structure++== running a router++=== "Web.Respond.Run" +contains functions that build WAI appliciations and run them in warp servers++=== "Web.Respond.DefaultServer"+defines the default setup for the Warp server ++== sending responses++=== "Web.Respond.Response"+functions for building responses using classes in "Web.Respond.Types" and sending them as 'MonadRespond' actions++=== "Web.Respond.DefaultHandlers"+defines the default set of 'RequestErrorHandlers' used by "Web.Respond.Run"++== processing and routing++=== "Web.Respond.Request"+contains request body processing tools and authentication/authorization tools++=== "Web.Respond.Method"+contains request method matching tools++=== "Web.Respond.Path"+contains path matching tools++=== "Web.Respond.HListUtils"+you'll want to use these with the path matching tools++-}+module Web.Respond (+                   module Web.Respond.Monad,+                   module Web.Respond.Types,+                   module Web.Respond.Run,+                   module Web.Respond.DefaultServer,+                   module Web.Respond.Response,+                   module Web.Respond.DefaultHandlers,+                   module Web.Respond.Request,+                   module Web.Respond.Method,+                   module Web.Respond.Path,+                   module Web.Respond.HListUtils+                   ) where++import Web.Respond.Types+import Web.Respond.Monad+import Web.Respond.Response+import Web.Respond.DefaultHandlers+import Web.Respond.Request+import Web.Respond.Method+import Web.Respond.Path+import Web.Respond.DefaultServer+import Web.Respond.Run+import Web.Respond.HListUtils 

@@ -0,0 +1,62 @@+{-|+Description: response utilities++utilities and defaults for sending responses.+-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+module Web.Respond.DefaultHandlers where++import Control.Applicative ((<$>))+import Network.Wai+import qualified Data.ByteString as BS+import Network.HTTP.Types.Status+--import Network.HTTP.Types.Header+import Network.HTTP.Types.Method+--import Control.Lens (view)++import Web.Respond.Types+import Web.Respond.Monad+import Web.Respond.Response++-- | default failure handlers. uses the defaultXHandler for each field+defaultHandlers :: FailureHandlers+defaultHandlers = FailureHandlers {+    _unsupportedMethod = defaultUnsupportedMethodHandler,+    _unmatchedPath = defaultUnmatchedPathHandler,+    _bodyParseFailed = defaultBodyParseFailureHandler,+    _authFailed = defaultAuthFailedHandler,+    _accessDenied = defaultAccessDeniedHandler,+    _caughtException = defaultCaughtExceptionHandler,+    _unacceptableResponse = defaultUnacceptableResponseHandler+}++-- | default unsupported method handler sends back an EmptyBody with status+-- 405 and an Allowed header listing the allowed methods in the first path+defaultUnsupportedMethodHandler :: MonadRespond m => [StdMethod] -> Method -> m ResponseReceived+defaultUnsupportedMethodHandler allowed = const $ respondEmptyBody methodNotAllowed405 [("Allowed", allowedStr allowed)]+    where allowedStr mths = BS.intercalate ", " (renderStdMethod <$> mths)++-- | respond with status404 and nothing else+defaultUnmatchedPathHandler :: MonadRespond m => m ResponseReceived+defaultUnmatchedPathHandler = respondEmptyBody notFound404 []++-- | respond with status 400 and a message about the body parse failure+defaultBodyParseFailureHandler :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived+defaultBodyParseFailureHandler = respondReportError badRequest400 []++-- | respond with 401+defaultAuthFailedHandler :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived+defaultAuthFailedHandler = respondReportError unauthorized401 []++-- | respond with 403+defaultAccessDeniedHandler :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived+defaultAccessDeniedHandler = respondReportError forbidden403 []++-- | respond with 500+defaultCaughtExceptionHandler :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived+defaultCaughtExceptionHandler = respondReportError internalServerError500 []++-- | respond with 406+defaultUnacceptableResponseHandler :: MonadRespond m => m ResponseReceived+defaultUnacceptableResponseHandler = respondEmptyBody notAcceptable406 []

@@ -0,0 +1,39 @@+{-|+Description: default warp server setup++Provides a runner for a Warp server to run an app with some hopefully sensible middleware (such as request logging).+-}+module Web.Respond.DefaultServer where++import Control.Applicative ((<$>))+import Network.Wai+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Middleware.Gzip as Gzip+import qualified Network.Wai.Middleware.RequestLogger as RequestLogger+import qualified Data.Default.Class as Def+import System.Log.FastLogger++-- | sets up the app using 'prepApp' then uses 'Warp.run' to run it.+runWaiApp :: Warp.Port -> LoggerSet -> Application -> IO ()+runWaiApp port logger app = prepApp logger app >>= Warp.run port++-- | combines the application with the middleware created by+-- 'mkMiddleware'+prepApp :: LoggerSet -> Application -> IO Application+prepApp logger app = ($ app) <$> mkMiddleware logger++-- | combines gzip middleware and request logging middleware+--+-- see 'Gzip.gzip'; uses the default values for it.+--+-- the request logger is set up with the format 'RequestLogger.Apache'+-- 'RequestLogger.FromSocket', and uses the 'LoggerSet' as the destination.+-- see 'RequestLogger.mkRequestLogger'.+mkMiddleware :: LoggerSet -> IO Middleware+mkMiddleware logger = (. middlewares) <$> logMiddleware+    where+    middlewares = Gzip.gzip Def.def+    logMiddleware = RequestLogger.mkRequestLogger $ Def.def {+        RequestLogger.outputFormat = RequestLogger.Apache RequestLogger.FromSocket,+        RequestLogger.destination = RequestLogger.Logger logger+    }

@@ -0,0 +1,40 @@+{-|+Description: simple utilities for working with HLists.++These are some tools for working with HLists; this is relevant when you are using path extractors.+-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Web.Respond.HListUtils where++import Data.HList++-- | this type family represents functions that can take all of the+-- elements of an HList.+type family HListElim (ts :: [*]) (a :: *) :: *+type instance HListElim '[] a = a+type instance HListElim (t ': ts) a = t -> HListElim ts a++-- | empty HList (useful for keeping other modules from needing to add+-- several language extensions).+type HList0 = HList '[]++-- | HList with one element.+type HList1 a = HList '[a]++-- | uncurrys a function by applying it to the elements of the HList.+hListUncurry :: HListElim ts a -> HList ts -> a+hListUncurry f HNil = f+hListUncurry f (HCons x xs) = hListUncurry (f x) xs++-- | uncurrys the function by applying it to the HList, then returns the+-- result of that uncurrying as a single-element HList. useful for+-- transforming PathExtractors.+hListMapTo1 :: HListElim ts a -> HList ts -> HList1 a+hListMapTo1 f hl = hListUncurry f hl .*. HNil

@@ -0,0 +1,87 @@+{-|+Description: utilties for matching HTTP request methods++contains MethodMatcher and associated tools for routing based on the HTTP request method.+-}++module Web.Respond.Method where++import Network.Wai+import Network.HTTP.Types.Method+import qualified Data.Map.Lazy as Map+import Control.Lens (at, (^.), (<&>), to)+import Data.Maybe (fromMaybe)++import Data.Monoid+import Data.Function (on)++import Web.Respond.Monad+import Web.Respond.Response++-- | Map from method to thing. use it as a monoid.+--+-- > onGET action1 <> onPUT action2+newtype MethodMatcher a = MethodMatcher { +    getMethodMatcher :: Map.Map StdMethod a +}++instance Monoid (MethodMatcher a) where+    mempty = MethodMatcher mempty+    mappend = (MethodMatcher .) . on mappend getMethodMatcher ++-- * using the method matcher++-- | look up the request method in the MethodMatcher map and run the+-- action; fall back on 'handleUnsupportedMethod' if the method cannot be+-- parsed or is not in the map.+matchMethod :: MonadRespond m => MethodMatcher (m ResponseReceived) -> m ResponseReceived+matchMethod dispatcher = getRequest <&> (parseMethod . requestMethod) >>= either (handleUnsupportedMethod supported) selectMethod+    where+    supported = Map.keys (getMethodMatcher dispatcher)+    selectMethod mth = fromMaybe (handleUnsupportedMethod supported (renderStdMethod mth)) $ dispatcher ^. to getMethodMatcher . at mth++-- * prebuilt method matchers++-- | map a StdMethod to a thing.+onMethod :: StdMethod -> a -> MethodMatcher a+onMethod = (MethodMatcher .) . Map.singleton++onGET :: a -> MethodMatcher a+onGET = onMethod GET++onPOST :: a -> MethodMatcher a+onPOST = onMethod POST++onHEAD :: a -> MethodMatcher a+onHEAD = onMethod HEAD++onPUT :: a -> MethodMatcher a+onPUT = onMethod PUT++onDELETE :: a -> MethodMatcher a+onDELETE = onMethod DELETE++onTRACE :: a -> MethodMatcher a+onTRACE = onMethod TRACE++onCONNECT :: a -> MethodMatcher a+onCONNECT = onMethod CONNECT++onOPTIONS :: a -> MethodMatcher a+onOPTIONS = onMethod OPTIONS++onPATCH :: a -> MethodMatcher a+onPATCH = onMethod PATCH++-- * method matching shortcuts++-- | shortcut for when you want to run an inner action for just one http method+--+-- > matchOnlyMethod m = matchMethod . onMethod m+matchOnlyMethod :: MonadRespond m => StdMethod -> m ResponseReceived -> m ResponseReceived+matchOnlyMethod m = matchMethod . onMethod m++-- | shortcut for 'matchOnlyMethod' GET+matchGET :: MonadRespond m => m ResponseReceived -> m ResponseReceived+matchGET = matchOnlyMethod GET+

@@ -0,0 +1,171 @@+{-|+Description: the monad and all of its support++you build your api using this stuff.+-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Web.Respond.Monad (+                         -- * the monad interface+                         MonadRespond(..),+                         -- ** an implementation+                         RespondT,+                         runRespondT,+                         mapRespondT,+                         -- * handling errors+                         FailureHandlers(..),+                         -- ** Getters for each handler+                         unsupportedMethod, +                         unmatchedPath, +                         bodyParseFailed,+                         authFailed,+                         accessDenied,+                         caughtException,+                         unacceptableResponse+                         ) where++import Control.Applicative+import Network.Wai+import Network.HTTP.Types.Method+import Control.Monad.Trans.Reader (ReaderT, runReaderT, mapReaderT)+import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)+import Control.Monad.Trans.Except (ExceptT, mapExceptT)+import Control.Monad.Reader.Class+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Base (MonadBase, liftBase, liftBaseDefault)+import Control.Monad.Trans.Control (MonadTransControl, StT, liftWith, restoreT, defaultLiftWith, defaultRestoreT, MonadBaseControl, StM, liftBaseWith, defaultLiftBaseWith, restoreM, defaultRestoreM, ComposeSt)+import Control.Monad.Trans.Class+import Control.Monad.Logger+import Control.Monad.Catch++import Control.Lens ((%~), makeLenses, view)+import Web.Respond.Types+    +-- | this class is the api for building your handler.+class (Functor m, MonadIO m) => MonadRespond m where+    -- | perform the WAI application respond action (after converting the+    -- value to a response)+    respond :: Response -> m ResponseReceived+    -- | get out the request.+    getRequest :: m Request+    -- | get the 'FailureHandlers'.+    getHandlers :: m FailureHandlers+    -- | run an inner action that will see an updates set of error+    -- handlers. this is useful when you know that inner actions will need+    -- to do resource cleanup or something.+    withHandlers :: (FailureHandlers -> FailureHandlers) -> m a -> m a+    -- | get the path as it's been consumed so far.+    getPath :: m PathConsumer+    -- | run the inner action with an updated path state.+    withPath :: (PathConsumer -> PathConsumer) -> m a -> m a++instance MonadRespond m => MonadRespond (ExceptT e m) where+    respond = lift . respond+    getRequest = lift getRequest+    getHandlers = lift getHandlers+    withHandlers = mapExceptT . withHandlers+    getPath = lift getPath+    withPath = mapExceptT . withPath++instance MonadRespond m => MonadRespond (MaybeT m) where+    respond = lift . respond+    getRequest = lift getRequest+    getHandlers = lift getHandlers+    withHandlers = mapMaybeT . withHandlers+    getPath = lift getPath+    withPath = mapMaybeT . withPath++-- | record containing responders that request matching tools can use when+-- failures occur.+data FailureHandlers = FailureHandlers {+    -- | what to do if the request method is not supported+    _unsupportedMethod :: MonadRespond m => [StdMethod] -> Method -> m ResponseReceived,+    -- | what to do if the request path has no matches+    _unmatchedPath :: MonadRespond m => m ResponseReceived,+    -- | what to do if the body failed to parse+    _bodyParseFailed :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived,+    -- | what to do when authentication fails+    _authFailed :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived,+    -- | what to do when authorization fails+    _accessDenied :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived,+    -- | what to do when an exception has been caught+    _caughtException :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived,+    -- | what to do when no media type is acceptable+    _unacceptableResponse :: (MonadRespond m) => m ResponseReceived+}++makeLenses ''FailureHandlers++-- | this is the environment data used by RespondT. you probably don't want+-- to mess with this.+data RespondData = RespondData {+    _handlers :: FailureHandlers,+    _request :: Request,+    _responder :: Responder,+    _pathConsumer :: PathConsumer+}++makeLenses ''RespondData++-- | RespondT is a monad transformer that provides an implementation of+-- MonadRespond. you build your application using this.+newtype RespondT m a = RespondT { +    unRespondT :: ReaderT RespondData m a +} deriving (Functor, Applicative, Monad, MonadReader RespondData)++instance (Functor m, MonadIO m) => MonadRespond (RespondT m) where+    respond v = view responder >>= \r -> liftIO . r $ v+    getRequest = view request+    getHandlers = view handlers+    withHandlers h = local (handlers %~ h)+    getPath = view pathConsumer+    withPath f = local (pathConsumer %~ f) ++-- | run the RespondT action with failure handlers and request information.+runRespondT :: RespondT m a -> FailureHandlers -> Request -> Responder -> m a+runRespondT (RespondT act) h req res = runReaderT act $ RespondData h req res (mkPathConsumer $ pathInfo req)++mapRespondT :: (m a -> n b) -> RespondT m a -> RespondT n b+mapRespondT f = RespondT . mapReaderT f . unRespondT++instance MonadTrans RespondT where+    lift act = RespondT $ lift act++instance MonadIO m => MonadIO (RespondT m) where+    liftIO act = RespondT $ liftIO act++instance MonadThrow m => MonadThrow (RespondT m) where+    throwM = lift . throwM++instance MonadCatch m => MonadCatch (RespondT m) where+    catch act h = RespondT $ catch (unRespondT act) (\e -> unRespondT (h e))++--these next three son of a gun all need UndecidableInstances++instance MonadBase b m => MonadBase b (RespondT m) where+    liftBase = liftBaseDefault++-- and these two demand TypeFamilies++instance MonadTransControl RespondT where+    newtype StT RespondT a = StRespond { unStRespond :: StT (ReaderT RespondData) a }+    liftWith = defaultLiftWith RespondT unRespondT StRespond+    restoreT = defaultRestoreT RespondT unStRespond++instance MonadBaseControl b m => MonadBaseControl b (RespondT m) where+    newtype StM (RespondT m) a = StMT { unStMT :: ComposeSt RespondT m a}+    liftBaseWith = defaultLiftBaseWith StMT+    restoreM     = defaultRestoreM   unStMT++instance MonadLogger m => MonadLogger (RespondT m) where+    monadLoggerLog loc src level msg = lift $ monadLoggerLog loc src level msg+

@@ -0,0 +1,248 @@+{-|+Description: path matching utility++This module provides the tools you need to match the path of a request, extract data+from it, and connect matches to Respond actions.+-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Web.Respond.Path where++import Control.Applicative+import Network.Wai+import qualified Data.Text as T+import qualified Data.Sequence as S+import Safe (headMay)+import Data.Maybe (fromMaybe)+import qualified Control.Monad.State.Class as MState+import qualified Control.Monad.State as StateT+import qualified Control.Monad.Trans.Maybe as MaybeT+import Data.HList+import Web.PathPieces+import Network.HTTP.Types.Method++import Web.Respond.Types+import Web.Respond.Monad+import Web.Respond.Response+import Web.Respond.Method+import Web.Respond.HListUtils++-- * matching paths to actions++-- | the PathMatcher makes it easy to provide actions for different paths.+-- you use 'matchPath' to run it.+--+-- you can use this as a monad, but tbh you probably just want to use the+-- 'Applicative' and especially 'Alternative' instances.+newtype PathMatcher a = PathMatcher {+    runPathMatcher :: PathConsumer -> Maybe a+} ++instance Functor PathMatcher where+    fmap f pm = PathMatcher $ fmap f . runPathMatcher pm++instance Applicative PathMatcher where+    pure v = PathMatcher $ pure $ pure v+    f <*> r = PathMatcher $ (<*>) <$> runPathMatcher f <*> runPathMatcher r++instance Alternative PathMatcher where+    empty = PathMatcher $ const Nothing+    l <|> r = PathMatcher $ (<|>) <$> runPathMatcher l <*> runPathMatcher r++instance Monad PathMatcher where+    return = pure+    a >>= f = PathMatcher $ (>>=) <$> runPathMatcher a  <*> flip (runPathMatcher . f)++-- | run a path matcher containing a respond action against the current+-- path. uses the currently installed unmatched path handler if the match+-- fails.+--+-- see 'handleUnmatchedPath'+matchPath :: MonadRespond m => PathMatcher (m ResponseReceived) -> m ResponseReceived+matchPath pm = getPath >>= (fromMaybe handleUnmatchedPath . runPathMatcher pm)++-- ** transforming path matchers++-- | wrap the action within a path matcher with 'matchOnlyMethod'; this way+-- all paths below this can be restricted to a single method properly. +matchPathWithMethod :: MonadRespond m => StdMethod -> PathMatcher (m ResponseReceived) -> PathMatcher (m ResponseReceived)+matchPathWithMethod = fmap . matchOnlyMethod++-- | 'pathWithMethod' GET+matchPathWithGET :: MonadRespond m => PathMatcher (m ResponseReceived) -> PathMatcher (m ResponseReceived)+matchPathWithGET = matchPathWithMethod GET++-- * extracting path elements++-- | the path extractor matches the path and extracts values; it is useful+-- for building PathMatchers. it is built on both MState and Maybe - if it+-- succeeds, it can modify the state to represent the path it has consumed.+newtype PathExtractor l = PathExtractor {+    runPathExtractor :: MaybeT.MaybeT (StateT.State PathConsumer) l+} deriving (Functor, Applicative, Monad, Alternative, MState.MonadState PathConsumer, MonadPlus)++-- | takes a Maybe and makes it into a path extractor+asPathExtractor :: Maybe a -> PathExtractor a+asPathExtractor = maybe empty return++-- | a path extractor that extracts nothing, just matches+type PathExtractor0 = PathExtractor HList0++-- | a path extractor that extracts a single value from the path+type PathExtractor1 a = PathExtractor (HList1 a)++-- ** using path extractors++-- | runs a 'PathExtractor' against a 'PathConsumer'.+pathExtract :: PathExtractor a -> PathConsumer -> (Maybe a, PathConsumer)+pathExtract = StateT.runState . MaybeT.runMaybeT . runPathExtractor++-- | create a 'PathMatcher' by providing a path extractor and an action that+-- consumes the extracted elements.+--+-- note that 'HListElim' is just a function from the types extracted to+-- something else+--+-- > path ((value :: PathExtractor1 String) </> seg "whatever" </> (value :: PathExtractor1 Integer)) $ \string integer -> -- some action+path :: MonadRespond m => PathExtractor (HList l) -> HListElim l (m a) -> PathMatcher (m a)+path extractor f = PathMatcher $ uncurry (useNextPathState f) . pathExtract extractor++-- | an action that runs the action (HListElim l (m a)) with the new path+-- consumer state if an extracted value is provided. +--+-- this mainly exists for the use of 'path'.+useNextPathState :: MonadRespond m => HListElim l (m a) -> Maybe (HList l) -> PathConsumer -> Maybe (m a)+useNextPathState elim maybeExtraction nextPath = (usePath nextPath . hListUncurry elim) <$> maybeExtraction++-- | a simple matcher for being at the end of the path.+-- +-- > pathEndOrSlash = path endOrSlash+pathEndOrSlash :: MonadRespond m => m a -> PathMatcher (m a)+pathEndOrSlash = path endOrSlash++-- | a simple matcher for the last segment of a path+--+-- > pathLastSeg s = path (seg s </> endOrSlash)+pathLastSeg :: MonadRespond m => T.Text -> m a -> PathMatcher (m a)+pathLastSeg s = path (seg s </> endOrSlash)++-- | combine two path extractors in sequence.+(</>) :: PathExtractor (HList l) -> PathExtractor (HList r) -> PathExtractor (HList (HAppendList l r))+(</>) = liftA2 hAppendList++-- ** useful path extractors++-- | match only when the PathConsumer in the path state has no unconsumed+-- elements.+pathEnd :: PathExtractor0+pathEnd = MState.get >>= maybe (return HNil) (const empty) . pcGetNext++-- | build a path matcher that runs an extractor function on a single+-- element and then advances the path state if it matched. +singleSegExtractor :: (T.Text -> Maybe (HList a)) -> PathExtractor (HList a)+singleSegExtractor extractor = do+    res <- MState.get >>= asPathExtractor . (pcGetNext >=> extractor)+    MState.modify pcConsumeNext +    return res++-- | build an extractor from a function that does not produce any real+-- value+unitExtractor :: (T.Text -> Maybe ()) -> PathExtractor0+unitExtractor = singleSegExtractor . (fmap (const HNil) .)++-- | convert a predicate into a 'PathExtractor0'+predicateExtractor :: (T.Text -> Bool) -> PathExtractor0+predicateExtractor = unitExtractor . (mayWhen () .)++-- | WAI represents a trailing slash by having a null text as the last+-- element in the list. this matches it. it's just+--+-- @+-- slashEnd = 'predicateExtractor' 'Data.Text.null'+-- @+slashEnd :: PathExtractor0+slashEnd = predicateExtractor T.null++-- | best way to match the path end. it's just+--+-- @ +-- endOrSlash = 'pathEnd' 'Control.Applicative.<|>' 'slashEnd'+-- @+endOrSlash :: PathExtractor0+endOrSlash = pathEnd <|> slashEnd++-- | require that a segment be a certain string.+seg :: T.Text -> PathExtractor0+seg = predicateExtractor . (==)++-- | an extractor that takes a single path element and produces a single+-- value+singleItemExtractor :: (T.Text -> Maybe a) -> PathExtractor1 a+singleItemExtractor = singleSegExtractor . (fmap (hEnd . hBuild) .)++-- | if you have a 'PathPiece' instance for some type, you can extract it+-- from the path.+value :: PathPiece a => PathExtractor1 a+value = singleItemExtractor fromPathPiece++-- *** extract while matching methods++-- | path extraction matcher transformed with 'matchPath'+pathMethod :: MonadRespond m => StdMethod -> PathExtractor (HList l) -> HListElim l (m ResponseReceived) -> PathMatcher (m ResponseReceived)+pathMethod m extractor = matchPathWithMethod m . path extractor++-- | path extraction matcher with action wrapped so that it only matches+-- GET method+pathGET :: MonadRespond m => PathExtractor (HList l) -> HListElim l (m ResponseReceived) -> PathMatcher (m ResponseReceived)+pathGET = pathMethod GET+++-- * utilities++-- | utility method for conditionally providing a value+mayWhen :: a -> Bool -> Maybe a+mayWhen v True = Just v+mayWhen _ False = Nothing++-- | run the inner action with a set path state.+--+-- > usePath = withPath . const+usePath :: MonadRespond m => PathConsumer -> m a -> m a+usePath = withPath . const++-- | get the part of the path that's been consumed so far.+--+-- > getConsumedPath = _pcConsumed <$> getPath+getConsumedPath :: MonadRespond m => m (S.Seq T.Text)+getConsumedPath = _pcConsumed <$> getPath++-- | get the part of the path that has yet to be consumed.+--+-- > getUnconsumedPath = _pcUnconsumed <$> getPath+getUnconsumedPath :: MonadRespond m => m [T.Text]+getUnconsumedPath = _pcUnconsumed <$> getPath++-- | get the next unconsumed path segment if there is one+--+-- > getNextSegment = headMay <$> getUnconsumedPath+getNextSegment :: MonadRespond m => m (Maybe T.Text)+getNextSegment = headMay <$> getUnconsumedPath++-- | run the inner action with the next path segment consumed.+--+-- > withNextSegmentConsumed = withPath pcConsumeNext+withNextSegmentConsumed :: MonadRespond m => m a -> m a+withNextSegmentConsumed = withPath pcConsumeNext++-- ** things you can get out of paths++-- | natural numbers starting with 1. you can get this out of a path.+newtype Natural = Natural Integer deriving (Eq, Show)++instance PathPiece Natural where+    toPathPiece (Natural i) = T.pack $ show i +    fromPathPiece s = fromPathPiece s >>= \i -> mayWhen (Natural i) (i >= 1)+

@@ -0,0 +1,101 @@+{-|+Description: helpers for matching requests++contains various matching utilities+-}+{-# LANGUAGE TupleSections #-}+module Web.Respond.Request where++import Network.Wai+import qualified Data.ByteString.Lazy as LBS+import Control.Applicative ((<$>))++import Control.Monad.IO.Class (liftIO)+import qualified Network.HTTP.Media as Media+import Data.Maybe (fromMaybe)++import Web.Respond.Types+import Web.Respond.Monad+import Web.Respond.Response++-- * extracting the request body++-- | gets the body as a lazy ByteString using lazy IO (see 'lazyRequestBody')+getBodyLazy :: MonadRespond m => m LBS.ByteString+getBodyLazy = getRequest >>= liftIO . lazyRequestBody++-- | gets the body as a lazy ByteString using /strict/ IO (see 'strictRequestBody')+getBodyStrict :: MonadRespond m => m LBS.ByteString+getBodyStrict = getRequest >>= liftIO . strictRequestBody++-- ** extraction using FromBody++-- | use a FromBody instance to parse the body. uses 'getBodyLazy' to+-- lazily load the body data.+extractBodyLazy :: (ReportableError e, FromBody e a, MonadRespond m) => m (Either e a)+extractBodyLazy = fromBody <$> getBodyLazy++-- | uses a FromBody instance to parse the body. uses 'getBodyStrict' to+-- load the body strictly.+extractBodyStrict :: (ReportableError e, FromBody e a, MonadRespond m) => m (Either e a)+extractBodyStrict = fromBody <$> getBodyStrict++-- | extracts the body using 'extractBodyLazy'. runs the inner action only+-- if the body could be loaded and parseda using the FromBody instance;+-- otherwise responds with the reportable error by calling+-- 'handleBodyParseFailure'.+withRequiredBody :: (ReportableError e, FromBody e a, MonadRespond m) => (a -> m ResponseReceived) -> m ResponseReceived+withRequiredBody action = extractBodyLazy >>= either handleBodyParseFailure action++-- | extracts the body using 'extractBodyStrict'. runs the inner action only+-- if the body could be loaded and parseda using the FromBody instance;+-- otherwise responds with the reportable error by calling+-- 'handleBodyParseFailure'.+withRequiredBody' :: (ReportableError e, FromBody e a, MonadRespond m) => (a -> m ResponseReceived) -> m ResponseReceived+withRequiredBody' action = extractBodyStrict >>= either handleBodyParseFailure action++-- * authentication and authorization++-- | authenticate uses the result of the authentication action (if it+-- succssfully produced a result) to run the inner action function.+-- otherwise, it uses 'handleAuthFailed'.+authenticate :: (MonadRespond m, ReportableError e) => m (Either e a) -> (a -> m ResponseReceived) -> m ResponseReceived+authenticate auth inner = auth >>= either handleAuthFailed inner++-- | reauthenticate tries to use a prior authentication value to run the+-- inner action; if it's not availalble, it falls back to 'authenticate' to+-- apply the auth action and run the inner action.+reauthenticate :: (MonadRespond m, ReportableError e) => Maybe a -> m (Either e a) -> (a -> m ResponseReceived) -> m ResponseReceived+reauthenticate prior auth inner = maybe (authenticate auth inner) inner prior ++-- | if given an error report value , respond immediately using +-- 'handleDenied'. otherwise, run the inner route.+authorize :: (ReportableError e, MonadRespond m) => Maybe e -> m ResponseReceived -> m ResponseReceived+authorize check inner = maybe inner handleAccessDenied check++-- | if the bool is true, run the inner. otherwise, handleDenied the+-- report.+authorizeBool :: (ReportableError e, MonadRespond m) => e -> Bool -> m ResponseReceived -> m ResponseReceived+authorizeBool report allowed inner+    | allowed = inner+    | otherwise = handleAccessDenied report++-- | authorize using an Either; if it's Left, fail using 'handleDenied' on+-- the contained ReportableError. if it's right, run the inner action using+-- the contained value,+authorizeE :: (ReportableError e, MonadRespond m) => Either e a -> (a -> m ResponseReceived) -> m ResponseReceived+authorizeE check inner = either handleAccessDenied inner check++-- * content negotiation++-- | selects action by accept header+routeAccept :: MonadRespond m +            => m a -- ^ default action - do this if nothing matches+            -> [(Media.MediaType, m a)] -- ^ actions to perform for each accepted media type+            -> m a -- ^ chosen action+routeAccept def mapped = getAcceptHeader >>= fromMaybe def . Media.mapAcceptMedia mapped++-- | defends the inner routes by first checking the Accept header and+-- failing if it cannot accept any media type in the list+checkAccepts :: MonadRespond m => [Media.MediaType] -> m ResponseReceived -> m ResponseReceived+checkAccepts list action = getAcceptHeader >>= maybe handleUnacceptableResponse (const action) . Media.matchAccept list

@@ -0,0 +1,136 @@+{-|+Description: response utilities++utilities and defaults for sending responses.+-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+module Web.Respond.Response where++import Control.Applicative ((<$>))+import Network.Wai+import qualified Data.ByteString as BS+import Network.HTTP.Types.Status+import Network.HTTP.Types.Header+import Network.HTTP.Types.Method+--import qualified Data.Text as T+import Control.Lens (view)+import Control.Monad (join)+import Control.Monad.Catch+import Data.Maybe (fromMaybe)++import Web.Respond.Types+import Web.Respond.Monad+++-- * headers+findHeader :: MonadRespond m => HeaderName -> m (Maybe BS.ByteString)+findHeader header = lookup header . requestHeaders <$> getRequest++findHeaderDefault :: MonadRespond m => HeaderName -> BS.ByteString -> m BS.ByteString+findHeaderDefault header defValue = fromMaybe defValue <$> findHeader header++-- | get the value of the Accept header, falling back to "*/*" if it was+-- not sent in the request+getAcceptHeader :: MonadRespond m => m BS.ByteString+getAcceptHeader = findHeaderDefault hAccept "*/*"++-- * constructing responses++-- | responding with an empty body means not having to worry about the+-- Accept header.+respondEmptyBody :: MonadRespond m => Status -> ResponseHeaders -> m ResponseReceived+respondEmptyBody status headers = respond $ responseLBS status headers ""++-- | respond by getting the information from a 'ResponseBody'+respondUsingBody :: MonadRespond m => Status -> ResponseHeaders -> ResponseBody -> m ResponseReceived+respondUsingBody status headers body = respond $ mkResponseForBody status headers body++-- | respond by using the ToResponseBody instance for the value and+-- determining if it can be converted into an acceptable response body.+--+-- calls 'handleUnacceptableResponse' if an acceptable content type cannot+-- be produced..+respondWith :: (MonadRespond m, ToResponseBody a) => Status -> ResponseHeaders -> a -> m ResponseReceived+respondWith status headers body = getAcceptHeader >>= maybe handleUnacceptableResponse respond . mkResponse status headers body++--mkResponse :: ToResponseBody a => Status -> ResponseHeaders -> a -> BS.ByteString -> Maybe Response++-- | respond with no additional headers+respondStdHeaders :: (MonadRespond m, ToResponseBody a) => Status -> a -> m ResponseReceived+respondStdHeaders = flip respondWith []++-- | respond with 200 Ok+respondOk :: (MonadRespond m, ToResponseBody a) => a -> m ResponseReceived+respondOk = respondStdHeaders ok200++-- | respond using a ReportableError to generate the response body.+respondReportError :: (MonadRespond m, ReportableError e) => Status -> ResponseHeaders -> e -> m ResponseReceived+respondReportError status headers err = getAcceptHeader >>= respondUsingBody status headers . reportError status err++-- | respond that something was not found+respondNotFound :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived+respondNotFound = respondReportError notFound404 []++-- * use the RequestErrorHandlers++-- | an action that gets the currently installed unsupported method handler+-- and applies it to the arguments+handleUnsupportedMethod :: MonadRespond m => [StdMethod] -> Method -> m ResponseReceived+handleUnsupportedMethod supported unsupported = do+    handler <- getHandler (view unsupportedMethod)+    handler supported unsupported++-- | an action that gets the installed unmatched path handler and uses it+handleUnmatchedPath :: MonadRespond m => m ResponseReceived+handleUnmatchedPath = join (getHandler (view unmatchedPath))++-- | get and use handler for unacceptable response types+handleUnacceptableResponse :: MonadRespond m => m ResponseReceived+handleUnacceptableResponse = join (getHandler (view unacceptableResponse))++-- | generic handler-getter for things that use ErrorReports+useHandlerForReport :: (MonadRespond m, ReportableError e) +                    => (FailureHandlers -> e -> m ResponseReceived) +                    -- ^ a handler-getter that gets a handler that takes+                    -- an error report+                    -> e +                    -- ^ the error+                    -> m ResponseReceived+useHandlerForReport getter e = do+    h <- getHandler getter +    h e++-- | an action that gets the installed body parse failure handler and+-- applies it+handleBodyParseFailure :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived+handleBodyParseFailure = useHandlerForReport (view bodyParseFailed)++-- | get and use installed auth failed handler+handleAuthFailed :: (MonadRespond m, ReportableError e) => e -> m ResponseReceived+handleAuthFailed = useHandlerForReport (view authFailed)++-- | get and use access denied handler+handleAccessDenied :: (ReportableError e, MonadRespond m) => e -> m ResponseReceived+handleAccessDenied = useHandlerForReport (view accessDenied)++-- | get and use handler for caught exceptions.+handleCaughtException :: (ReportableError e, MonadRespond m) => e -> m ResponseReceived+handleCaughtException = useHandlerForReport (view caughtException)++-- | get a specific handler.+--+-- > getHandler = (<$> getHandlers)+getHandler :: MonadRespond m => (FailureHandlers -> a) -> m a+getHandler = (<$> getHandlers)++-- * other response utilities.++-- | a way to use Maybe values to produce 404s+maybeNotFound :: (ReportableError e, MonadRespond m) => e -> (a -> m ResponseReceived) -> Maybe a -> m ResponseReceived+maybeNotFound = maybe . respondReportError notFound404 []++-- | catch Exceptions using MonadCatch, and use 'handleCaughtException' to+-- respond with an error report.+catchRespond :: (MonadCatch m, MonadRespond m, ReportableError r, Exception e) => (e -> r) -> m ResponseReceived -> m ResponseReceived+catchRespond = handle . (handleCaughtException .)

@@ -0,0 +1,60 @@+{-|+Description: building and running a RespondT app.++contains the tools to build and run a RespondT app+-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+module Web.Respond.Run where++import Network.Wai+import Control.Monad.IO.Class (MonadIO)++import Web.Respond.Monad+import Web.Respond.DefaultHandlers+import Web.Respond.DefaultServer+import qualified Network.Wai.Handler.Warp as Warp+import System.Log.FastLogger (LoggerSet)++-- * using RespondT++-- | build an 'Network.Wai.Application' from a 'RespondT' router stack.+respondApp :: MonadIO m  => FailureHandlers -- ^ however you want failures handled+              -> (forall a. m a -> IO a) -- ^ how to unpeel your monad to 'IO'+              -> RespondT m ResponseReceived -- ^ your api - must respond.+              -> Application -- ^ give this to warp or something+respondApp handlers lifter api req res = lifter (runRespondT api handlers req res)++-- | it's 'respondApp' with 'defaultHandlers' passed in.+respondAppDefault :: MonadIO m => (forall a. m a -> IO a)  -> RespondT m ResponseReceived -> Application +respondAppDefault = respondApp defaultHandlers++-- | serve a RespondT router app using 'runWaiApp' on 'respondApp'.+serveRespond :: MonadIO m => Warp.Port -> LoggerSet -> FailureHandlers -> (forall a. m a -> IO a) -> RespondT m ResponseReceived -> IO ()+serveRespond port loggerSet handlers lifter api = runWaiApp port loggerSet (respondApp handlers lifter api)++-- | serve a RespondT router app using 'runWaiApp' on 'respondAppDefault'+serveRespondDefault :: MonadIO m => Warp.Port -> LoggerSet -> (forall a. m a -> IO a) -> RespondT m ResponseReceived -> IO ()+serveRespondDefault port loggerSet lifter api = runWaiApp port loggerSet (respondAppDefault lifter api)++-- * the simpler Respond++-- | RespondT stacked on top of IO; the simplest stack for handlers.+type RespondM a = RespondT IO a++-- | build an Application out of a RespondM handler.+simpleRespondApp :: FailureHandlers -> RespondM ResponseReceived -> Application+simpleRespondApp handlers = respondApp handlers id ++-- | build an Application out of a RespondM handler using the default error handlers+simpleRespondAppDefault :: RespondM ResponseReceived -> Application+simpleRespondAppDefault = respondAppDefault id++-- | serve a RespondM handler+serveSimpleRespond :: Warp.Port -> LoggerSet -> FailureHandlers -> RespondM ResponseReceived -> IO ()+serveSimpleRespond port loggerSet handlers = serveRespond port loggerSet handlers id ++-- | serve a RespondM handler using the default error handlers+serveSimpleRespondDefault :: Warp.Port -> LoggerSet -> RespondM ResponseReceived -> IO ()+serveSimpleRespondDefault port loggerSet = serveRespondDefault port loggerSet id 

@@ -0,0 +1,35 @@+{-|+Description: base types ++= navigating the types modules+there are a bunch of type-defining modules here; hopefully you can find what you want++== "Web.Respond.Types.Path"+this module defines 'PathConsumer' and several functions for working with that type++== "Web.Respond.Types.Response"+defines the types 'Responder', 'ResponseBody', and 'MediaTypeMatcher'; also defines the typeclass 'ToResponseBody'.+provides tools for implementing instances of the 'ToResponseBody' by matching against Accept headerst++== "Web.Respond.Types.Errors"+defines the typeclass 'ReportableError', similar to 'ToResponseBody' except with a fallback 'ResponseBody' when unable to match the Accept header.+also defines the 'ErrorReport' datatype, and implements 'ReportableError' for it, defining the formats for rendering it to a response.+provides an instance of 'ReportableError' for unicode errors.++== "Web.Respond.Types.Request"+defines the 'FromBody' typeclass along with+- 'TextBody' newtype, with an appropriate 'FromBody' instance+- 'Json' and 'JsonS' newtypes, with appropriate 'FromBody' and 'ToResponseBody' instances++-}+module Web.Respond.Types (+                        module Web.Respond.Types.Path,+                        module Web.Respond.Types.Response,+                        module Web.Respond.Types.Errors,+                        module Web.Respond.Types.Request+                        ) where++import Web.Respond.Types.Path+import Web.Respond.Types.Response+import Web.Respond.Types.Request+import Web.Respond.Types.Errors

@@ -0,0 +1,172 @@+{-|+Description: types and tools for reporting errors++contains the ErrorReport data type and tools for constructing error reports, along with the ReportableError typeclass.+-}+{-# LANGUAGE RankNTypes #-}+module Web.Respond.Types.Errors where++import Data.Aeson+import Data.Aeson.Encode (encodeToTextBuilder)+import qualified Data.Text as T+import qualified Data.Text.Encoding.Error as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString as BS+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import Data.Int (Int64)+import Formatting+import Control.Applicative ((<$>), (<*>), pure)+import Data.Monoid+import Data.Vector ()+import Data.Bool (bool)+--import Control.Lens (lens, (%~))++import Network.HTTP.Types.Status+--import qualified Network.HTTP.Media as Media++import Web.Respond.Types.Response++-- * ErrorReport data+-- | an error report is something that can be sent back as a response+-- without having to worry about it too much.+data ErrorReport = ErrorReport {+    -- | the reason for the error. should describe the type of error that occurred to the api consumer.+    erReason :: T.Text,+    -- | a message that might explain why the error occurred.+    erMessage :: Maybe T.Text,+    -- | any details about the error that could be useful+    erDetails :: Maybe Value+}++-- | the ErrorReport json representation has the fields "reason",+-- "message", and "details". Absent message and details values are+-- represented as null in json.+instance ToJSON ErrorReport where+    toJSON er = object ["reason" .= erReason er, "message" .= erMessage er, "details" .= erDetails er]++-- ** building error reports++-- | constructor for the simplest error report+simpleErrorReport :: T.Text -> ErrorReport+simpleErrorReport reason = ErrorReport reason Nothing Nothing++-- | constructor for error report with reason and message+errorReportWithMessage :: T.Text -> T.Text -> ErrorReport+errorReportWithMessage reason message = ErrorReport reason (Just message) Nothing++-- | constructor for error report with reason and details+errorReportWithDetails :: ToJSON d => T.Text -> d -> ErrorReport+errorReportWithDetails reason details = ErrorReport reason Nothing (Just $ toJSON details)++-- | error report with all the fixings+fullErrorReport :: ToJSON d => T.Text -> T.Text -> d -> ErrorReport+fullErrorReport reason message details = ErrorReport reason (Just message) (Just $ toJSON details)++-- | construct a single-key json object if the value is present+single :: ToJSON a => T.Text -> Maybe a -> Value+single k = object . maybe mempty (pure . (k .=))++-- ** rendering ErrorReports++-- | format a Status into a single string.+--+-- for example, "200 OK", or "404 Not Found"+statusFormat :: Format Status+statusFormat = later (bprint (int % now " " % stext) <$> statusCode <*> T.decodeUtf8 . statusMessage)++-- | i am not sure what the type means, but you pass this a default string+-- and a format for a thing, and it gives you a formatter for maybe that+-- thing.+maybeFormat :: forall m r a. m -> Holey TLB.Builder TLB.Builder (a -> m) -> Holey m r (Maybe a -> r)+maybeFormat x f = later (maybe x (bprint f))++-- *** format-builders++-- | build a format for an error report+errorReportFormat :: Format T.Text -- ^ format for the reason+                  -> Format T.Text -- ^ format for the message, if there is one+                  -> Format Value -- ^ format for the details, if any+                  -> Format ErrorReport+errorReportFormat reasonFmt messageFmt erdFmt = later (bprint (reasonFmt % maybeFormat "" messageFmt % maybeFormat "" erdFmt ) <$> erReason <*> erMessage <*> erDetails) ++boolFormat :: Format Bool+boolFormat = later $ bprint . bool "false" "true"++mkIndent :: Int64 -> TLB.Builder+mkIndent = TLB.fromLazyText . flip TL.replicate " "++-- | format a JSON value in a simple way. let Aeson handle the formatting.+simpleJsonValue :: Format Value+simpleJsonValue = later encodeToTextBuilder++-- *** formatters for plain text++-- | the plaintext error report format+--+-- tries to be somewhat yaml+plaintextErrorReportFormat :: forall b. Holey TLB.Builder b (Status -> ErrorReport -> b)+plaintextErrorReportFormat = statusFormat % "---\n" % errorReportFormat ("reason: " % stext % "\n") ("message: " % stext % "\n") ("details: " % simpleJsonValue % "\n")++-- | renders error report as plain text+renderPlainTextErrorReport :: Status -> ErrorReport -> TL.Text+renderPlainTextErrorReport = format plaintextErrorReportFormat++-- *** formatters for HTML++pFormat :: Buildable a => Int64 -> Format a+pFormat indent = now (mkIndent indent) % "<p>" % build % "</p>\n"++-- | the html format+htmlErrorReportFormat :: forall b. Holey TLB.Builder b (Status -> ErrorReport -> b)+htmlErrorReportFormat = "<!DOCTYPE html>\n" %+    "<html>\n" % +    "  <head>\n" % +    "    <title>Error</title>\n" %+    "  </head>\n" %+    "  <body>\n" %+    "    <h1>" % statusFormat % "</h1>\n" %+    errorReportFormat reasonFmt msgFmt detailsFmt % +    "  </body>\n" %+    "</html>\n"+    where+    reasonFmt = pFormat 4 %. ("reason: " % stext)+    msgFmt = pFormat 4 %. ("message: " % stext)+    detailsFmt = pFormat 4 %. ("details: " % "<span>" % simpleJsonValue % "</span>")++-- | renders error report as HTML+renderHTMLErrorReport :: Status -> ErrorReport -> TL.Text+renderHTMLErrorReport = format htmlErrorReportFormat+++-- * ReportableError class++-- | type class for responses that report errors.+class ReportableError e where+    reportError :: Status -- ^ the http error code that'll be sent+                -> e -- ^ the error to be reported+                -> BS.ByteString -- ^ the Accept header on the receiving end+                -> ResponseBody -- ^ the http body to send.++instance ReportableError ErrorReport where+    reportError status = matchToContentTypesDefault (textUtf8 "text/html" $ renderHTMLErrorReport status) [jsonMatcher, textUtf8 "text/plain" $ renderPlainTextErrorReport status]++-- ** instances etc+reportAsErrorReport :: (a -> ErrorReport) -> Status -> a -> BS.ByteString -> ResponseBody+reportAsErrorReport f status = reportError status . f++-- | this instance constructs an 'ErrorReport' for the exception and uses+-- 'reportAsErrorReport'+instance ReportableError T.UnicodeException where+    reportError = reportAsErrorReport report+        where+        report :: T.UnicodeException -> ErrorReport+        report (T.DecodeError msg mInput) = fullErrorReport "unicode decode failed" (T.pack msg) (single "input" mInput)+        report (T.EncodeError msg mInput) = fullErrorReport "unicode encode failed" (T.pack msg) (single "input" mInput)++-- | newtype wrapper for the error messages produced while parsing json so+-- we can have a ReportableError instance for it.+newtype JsonParseError = JsonParseError { jsonParseErrorMsg :: String } deriving (Eq, Show)++instance ReportableError JsonParseError where+    reportError = reportAsErrorReport $ errorReportWithMessage "parse_failed" . T.pack . jsonParseErrorMsg

@@ -0,0 +1,47 @@+{-|+Description: path consumer++tools for consuming request path+-}+{-# LANGUAGE TemplateHaskell #-}+module Web.Respond.Types.Path where++import qualified Data.Text as T++import Control.Monad.Trans.State+import qualified Data.Sequence as S+import Data.Foldable (toList)+import Data.Monoid ((<>))++import Control.Lens (makeLenses, snoc, (%=), uses)+import Safe (headMay, tailSafe)++-- * working with the path.++-- | stores the path and how much of it has been consumed+data PathConsumer = PathConsumer {+    -- | the consumed part of the path.+    _pcConsumed :: S.Seq T.Text,+    -- | the unconsumed part+    _pcUnconsumed :: [T.Text]+} deriving (Eq, Show)++makeLenses ''PathConsumer++-- | build a path consumer starting with nothing consumed+mkPathConsumer :: [T.Text] -> PathConsumer+mkPathConsumer = PathConsumer S.empty ++-- | get the next path element+pcGetNext :: PathConsumer -> Maybe T.Text+pcGetNext = headMay . _pcUnconsumed++-- | move forward in the path+pcConsumeNext :: PathConsumer -> PathConsumer+pcConsumeNext = execState $ do+    next <- uses pcUnconsumed headMay+    pcConsumed %= maybe id (flip snoc) next+    pcUnconsumed %= tailSafe++getFullPath :: PathConsumer -> [T.Text]+getFullPath pc = toList (_pcConsumed pc) <> _pcUnconsumed pc

@@ -0,0 +1,71 @@+{-|+Description: defines the 'FromBody' typeclass++defines the 'FromBody' typeclass and instances for++- lazy Text+- lazy extracted json+- strict extracted json+-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+module Web.Respond.Types.Request where++import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import qualified Data.Text.Encoding.Error as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL++import Data.Aeson+import Data.Bifunctor++import Web.Respond.Types.Response+import Web.Respond.Types.Errors++-- | something that can be pulled from the body, restricted to+-- a ReportableError type.+class ReportableError e => FromBody e a | a -> e where+    -- | parse the body. note that the body is provided as a lazy+    -- ByteString. how that ByteString is loaded depends on the caller of+    -- fromBody.+    fromBody :: LBS.ByteString -> Either e a++-- * some instances++-- ** text+newtype TextBody = TextBody { getTextBody :: TL.Text } deriving (Eq, Show)++instance FromBody T.UnicodeException TextBody where+    fromBody = fmap TextBody . TL.decodeUtf8'++newtype TextBodyS = TextBodyS { getTextBodyS :: T.Text } deriving (Eq, Show)++instance FromBody T.UnicodeException TextBodyS where+    fromBody = fmap (TextBodyS . TL.toStrict) . TL.decodeUtf8'++-- ** JSON++-- | newtype for things that should be encoded as or parsed as Json.+-- +-- the FromBody instance uses 'Data.Aeson.eitherDecode' - the lazy version.+newtype Json a = Json { getJson :: a }++instance FromJSON a => FromBody JsonParseError (Json a) where+    fromBody = bimap JsonParseError Json . eitherDecode++instance ToJSON a => ToResponseBody (Json a) where+    toResponseBody = matchAcceptJson . getJson++-- | newtype for things that should be encoded as or parsed as Json.+--+-- the 'FromBody' instance uses the immediate 'Data.Aeson.eitherDecode'' +-- parser.+newtype JsonS a = JsonS { getJsonS :: a }++instance FromJSON a => FromBody JsonParseError (JsonS a) where+    fromBody = bimap JsonParseError JsonS . eitherDecode'++instance ToJSON a => ToResponseBody (JsonS a) where+    toResponseBody = matchAcceptJson . getJsonS+

@@ -0,0 +1,130 @@+{-|+Description: types and tools for making responses++types and tools for making responses+-}+{-# LANGUAGE TupleSections #-}+module Web.Respond.Types.Response where++import Network.HTTP.Types.Header+import Network.HTTP.Types.Status+import qualified Network.HTTP.Media as Media+import Network.Wai++import Data.Maybe (fromMaybe)+import Control.Applicative ((<$>), pure)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import Data.Aeson++-- * responding++-- | the type of the responder callback that is handed to a WAI+-- 'Network.Wai.Application'+type Responder = Response -> IO ResponseReceived++-- * response bodies.++-- | contains both the content type header value and the body.+type ResponseBody = (Media.MediaType, BSL.ByteString)++-- | instances of this class produce content-negotiated response bodies.+--+-- if you're in a situation where there are performance concerns around+-- building a lazy bytestring for the response, you should consider instead+-- building 'Response's by hand (i.e. by using the WAI functions).+class ToResponseBody a where+    -- | specify the conversion. this is supposed to fail if and only if+    -- there is no way for the instance to satisfy the accept header.+    -- otherwise. a successful conversion will include both a bytestring+    -- to use as the body and the value to use for the content type header+    toResponseBody :: a -- ^ the value to convert+                   -> BS.ByteString -- ^ the http accept header. will be "*/*" if the client didn't set it.+                   -> Maybe ResponseBody  -- ^ content type header, body+++-- ** tools to build instances++-- | pair of media type to match and a function that produces a builder for+-- a value+type MediaTypeMatcher a = (Media.MediaType, a -> BSL.ByteString)++-- | converts a media type matcher into a pair of media type and response+-- body...+--+-- yes, what it does is duplicate the media type and apply the builder to+-- the value+prepMediaTypeMatcher :: a -> MediaTypeMatcher a -> (Media.MediaType, ResponseBody)+prepMediaTypeMatcher v (mtype, builder) = (mtype, (mtype, builder v))++-- | find the media type matcher that matches the passed Accept header+-- value, and use it to produce a ResponseBuilder for the passed value.+-- fail with Nothing if no builder can be found given the header. see+-- 'prepMediaTypeMatcher'+matchToContentTypes :: [MediaTypeMatcher a] -> a -> BS.ByteString -> Maybe ResponseBody+matchToContentTypes matchers v = Media.mapAcceptMedia (prepMediaTypeMatcher v <$> matchers)++-- | try to match using 'matchToContents'; if that fails, use the response+-- body generated by the defaul matcher (first input)+matchToContentTypesDefault :: MediaTypeMatcher a -> [MediaTypeMatcher a] -> a -> BS.ByteString -> ResponseBody+matchToContentTypesDefault def matchers v = fromMaybe (snd $ prepMediaTypeMatcher v def) . matchToContentTypes matchers v++-- | the content type parameter charset=utf-8+charsetUtf8 :: (BS.ByteString, BS.ByteString)+charsetUtf8 = ("charset", "utf-8")++-- | takes a text producer and produces a media type matcher that'll encode+-- the text as utf-8 and annotate the content type with that parameter+--+-- you can use this in 'matchToContentTypes' and render your type into lazy+-- Text; this will make sure it gets encoded.+textUtf8 :: Media.MediaType -> (a -> TL.Text) -> MediaTypeMatcher a+textUtf8 mt b = (mt Media./: charsetUtf8, TL.encodeUtf8 . b)++-- ** working with instances++-- | take a ResponseBody instance and turn it into a response+mkResponseForBody :: Status -> ResponseHeaders -> ResponseBody -> Response+mkResponseForBody status headers (mtype, body) = responseLBS status ((hContentType, Media.renderHeader mtype):headers) body++-- | try to produce a Response object for an instance of ToResponseBody.+-- the last input must be the value of the accept header+mkResponse :: ToResponseBody a => Status -> ResponseHeaders -> a -> BS.ByteString -> Maybe Response+mkResponse status headers val accept = mkResponseForBody status headers <$> toResponseBody val accept++-- * working with content types++-- ** JSON+-- | make a MediaTypeMatcher that produces JSON+jsonMatcher :: ToJSON a => MediaTypeMatcher a+jsonMatcher = ("application/json" Media./: charsetUtf8, encode)++-- | matches only if client accepts "application/json"+matchAcceptJson :: ToJSON a => a -> BS.ByteString -> Maybe ResponseBody+matchAcceptJson = matchToContentTypes [jsonMatcher]++instance ToResponseBody Value where+    toResponseBody = matchAcceptJson++-- ** renderable content types++-- *** HTML++-- | builds an html matcher+htmlMatcher :: (a -> BSL.ByteString) -> MediaTypeMatcher a+htmlMatcher = ("text/html" Media./: charsetUtf8,)++-- | matches only html acceptance+matchAcceptHtml :: (a -> BSL.ByteString) -> a -> BS.ByteString -> Maybe ResponseBody+matchAcceptHtml = matchToContentTypes . pure . htmlMatcher++-- ** plaintext++textPlainMatcher :: (a -> BSL.ByteString) -> MediaTypeMatcher a+textPlainMatcher = ("text/plain" Media./: charsetUtf8,)++matchTextPlain :: (a -> BSL.ByteString) -> a -> BS.ByteString -> Maybe ResponseBody+matchTextPlain = matchToContentTypes . pure . textPlainMatcher+