diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. 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/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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])) + diff --git a/respond.cabal b/respond.cabal new file mode 100644 --- /dev/null +++ b/respond.cabal @@ -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 diff --git a/src/Web/Respond.hs b/src/Web/Respond.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond.hs @@ -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 diff --git a/src/Web/Respond/DefaultHandlers.hs b/src/Web/Respond/DefaultHandlers.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/DefaultHandlers.hs @@ -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 [] diff --git a/src/Web/Respond/DefaultServer.hs b/src/Web/Respond/DefaultServer.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/DefaultServer.hs @@ -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 + } diff --git a/src/Web/Respond/HListUtils.hs b/src/Web/Respond/HListUtils.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/HListUtils.hs @@ -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 diff --git a/src/Web/Respond/Method.hs b/src/Web/Respond/Method.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/Method.hs @@ -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 + diff --git a/src/Web/Respond/Monad.hs b/src/Web/Respond/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/Monad.hs @@ -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 + diff --git a/src/Web/Respond/Path.hs b/src/Web/Respond/Path.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/Path.hs @@ -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) + diff --git a/src/Web/Respond/Request.hs b/src/Web/Respond/Request.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/Request.hs @@ -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 diff --git a/src/Web/Respond/Response.hs b/src/Web/Respond/Response.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/Response.hs @@ -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 .) diff --git a/src/Web/Respond/Run.hs b/src/Web/Respond/Run.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/Run.hs @@ -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 diff --git a/src/Web/Respond/Types.hs b/src/Web/Respond/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/Types.hs @@ -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 diff --git a/src/Web/Respond/Types/Errors.hs b/src/Web/Respond/Types/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/Types/Errors.hs @@ -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) % "

" % build % "

\n" + +-- | the html format +htmlErrorReportFormat :: forall b. Holey TLB.Builder b (Status -> ErrorReport -> b) +htmlErrorReportFormat = "\n" % + "\n" % + " \n" % + " Error\n" % + " \n" % + " \n" % + "

" % statusFormat % "

\n" % + errorReportFormat reasonFmt msgFmt detailsFmt % + " \n" % + "\n" + where + reasonFmt = pFormat 4 %. ("reason: " % stext) + msgFmt = pFormat 4 %. ("message: " % stext) + detailsFmt = pFormat 4 %. ("details: " % "" % simpleJsonValue % "") + +-- | 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 diff --git a/src/Web/Respond/Types/Path.hs b/src/Web/Respond/Types/Path.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/Types/Path.hs @@ -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 diff --git a/src/Web/Respond/Types/Request.hs b/src/Web/Respond/Types/Request.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/Types/Request.hs @@ -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 + diff --git a/src/Web/Respond/Types/Response.hs b/src/Web/Respond/Types/Response.hs new file mode 100644 --- /dev/null +++ b/src/Web/Respond/Types/Response.hs @@ -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 +