twain 1.0.0.0 → 2.0.0.0

raw patch · 6 files changed

+408/−275 lines, 6 filesdep +exceptionsdep +http2dep +vaultPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, http2, vault

API changes (from Hackage documentation)

Files

• README.md +22/−9
• changelog.md +26/−0
• src/Web/Twain.hs +189/−116
• src/Web/Twain/Internal.hs +94/−69
• src/Web/Twain/Types.hs +64/−70
• twain.cabal +13/−11

@@ -3,20 +3,33 @@ [![Hackage](https://img.shields.io/hackage/v/twain.svg?style=flat)](http://hackage.haskell.org/package/twain) ![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg) -Twain is a tiny web application framework for [WAI](http://hackage.haskell.org/package/wai).+Twain is a tiny web application framework for+[WAI](http://hackage.haskell.org/package/wai). -- Simple routing with path captures.-- Parameter parsing of cookies, path, query, and body.-- Compose responses from an app environment using a reader-like monad.-- Helpers for redirects, headers, status codes.-- Routes decompose into WAI middleware.+- `ResponderM` for composing responses with do notation.+- Routing with path captures that decompose `ResponderM` into middleware.+- Parameter parsing from cookies, path, query, and body.+- Helpers for redirects, headers, status codes, and errors.  ```haskell+import Network.Wai.Handler.Warp (run) import Web.Twain  main :: IO () main = do-  twain 8080 "my app" $ do-    get "/" $ do-      send $ html "Hello, World!"+  run 8080+    $ get "/" index+    $ post "/echo/:name" echoName+    $ notFound missing++index :: ResponderM a+index = send $ html "Hello World!"++echo :: ResponderM a+echo = do+  name <- param "name"+  send $ html $ "Hello, " <> name++missing :: ResponderM a+missing = send $ html "Not found..." ```

@@ -1,5 +1,31 @@ # Change Log +## 2.0.0.0 [2022-01-09]++Simplify API to decompose routes into WAI middleware.++### Breaking changes++- Removed `TwainM` monad in favor of composing WAI middleware.+- Replace `RouteM` with `ResponderM`, no longer parametized by environment in+  preference for middleware utilizing request vault.+- Replace string errors with new `HttpError`.+- Rename param and file functions to be consistent.+  - Renamed `param'` to `paramEither`.+  - Renamed `file` to `fileMaybe`.+  - Added `file` which matches `param` functionality.+  - Changed behavior of `paramMaybe` to throw `HttpError`.+- Set default cookie path and http-only.++### Added++- Add additional helpers `withMaxBodySize` and `withParseBodyOpts` for limiting+  request body parsing.++## 1.0.1.0 [2021-09-15]++- Export `parseBody` to allow custom `ParseRequestBodyOptions`.+ ## 1.0.0.0 [2021-05-11]  - Initial release.

@@ -1,33 +1,58 @@+-- | Twain is a tiny web application framework for WAI+--+-- - `ResponderM` for composing responses with do notation.+-- - Routing with path captures that decompose `ResponderM` into middleware.+-- - Parameter parsing for cookies, path, query, and body.+-- - Helpers for redirects, headers, status codes, and errors.+--+-- @+-- import Network.Wai.Handler.Warp (run)+-- import Web.Twain+--+-- main :: IO ()+-- main = do+--   run 8080+--     $ get "/" index+--     $ post "/echo/:name" echo+--     $ notFound missing+--+-- index :: ResponderM a+-- index = send $ html "Hello World!"+--+-- echo :: ResponderM a+-- echo = do+--   name <- param "name"+--   send $ html $ "Hello, " <> name+--+-- missing :: ResponderM a+-- missing = send $ html "Not found..."+-- @ module Web.Twain-  ( -- * Twain to WAI-    twain,-    twain',-    twainApp,+  ( ResponderM, -    -- * Middleware and Routes.-    middleware,+    -- * Routing     get,     put,     patch,     post,     delete,+    route,     notFound,-    onException,-    addRoute, -    -- * Request and Parameters.-    env,+    -- * Request and Parameters     param,-    param',+    paramEither,     paramMaybe,     params,     file,+    fileMaybe,     files,+    fromBody,     header,     headers,     request, -    -- * Responses.+    -- * Responses     send,     next,     redirect301,@@ -43,12 +68,24 @@     withCookie,     withCookie',     expireCookie,-    module Web.Twain.Types,++    -- * Errors+    HttpError (..),+    onException,++    -- * Middleware+    withParseBodyOpts,+    withMaxBodySize,++    -- * Re-exports     module Network.HTTP.Types,+    module Network.Wai,+    FileInfo (..),   ) where -import Control.Exception (SomeException)+import Control.Exception (SomeException, handle)+import Control.Monad.Catch (throwM) import Data.Aeson (ToJSON) import qualified Data.Aeson as JSON import Data.ByteString.Char8 as Char8@@ -56,151 +93,176 @@ import qualified Data.CaseInsensitive as CI import Data.Either.Combinators (rightToMaybe) import qualified Data.List as L+import Data.Maybe (fromMaybe) import Data.Text as T import Data.Text.Encoding import Data.Time+import qualified Data.Vault.Lazy as V+import Data.Word (Word64) import Network.HTTP.Types-import Network.Wai (Application, Middleware, Request, Response, mapResponseHeaders, mapResponseStatus, requestHeaders, responseLBS)-import Network.Wai.Handler.Warp (Port, Settings, defaultSettings, runEnv, runSettings, setOnExceptionResponse, setPort)-import Network.Wai.Parse (File, FileInfo, defaultParseRequestBodyOptions)+import Network.Wai+import Network.Wai.Handler.Warp hiding (FileInfo)+import Network.Wai.Parse hiding (Param)+import Network.Wai.Request import System.Environment (lookupEnv) import Web.Cookie import Web.Twain.Internal import Web.Twain.Types --- | Run a Twain app on `Port` using the given environment.------ If a PORT environment variable is set, it will take precendence.------ > twain 8080 "My App" $ do--- >   middleware logger--- >   get "/" $ do--- >     appTitle <- env--- >     send $ text ("Hello from " <> appTitle)--- >   get "/greetings/:name"--- >     name <- param "name"--- >     send $ text ("Hello, " <> name)--- >   notFound $ do--- >     send $ status status404 $ text "Not Found"-twain :: Port -> e -> TwainM e () -> IO ()-twain port env m = do-  mp <- lookupEnv "PORT"-  let p = maybe port read mp-      st = exec m env-      app = composeMiddleware $ middlewares st-      handler = onExceptionResponse st-      settings' = setOnExceptionResponse handler $ setPort p defaultSettings-  runSettings settings' app---- | Run a Twain app passing Warp `Settings`.-twain' :: Settings -> e -> TwainM e () -> IO ()-twain' settings env m = do-  let st = exec m env-      app = composeMiddleware $ middlewares st-      settings' = setOnExceptionResponse (onExceptionResponse st) settings-  runSettings settings' app---- | Create a WAI `Application` from a Twain app and environment.-twainApp :: e -> TwainM e () -> Application-twainApp env m = composeMiddleware $ middlewares $ exec m env---- | Use the given middleware. The first declared is the outermost middleware--- (it has first access to request and last action on response).-middleware :: Middleware -> TwainM e ()-middleware m = modify (\st -> st {middlewares = m : middlewares st})+get :: PathPattern -> ResponderM a -> Middleware+get = route (Just "GET") -get :: PathPattern -> RouteM e a -> TwainM e ()-get = addRoute (Just "GET")+put :: PathPattern -> ResponderM a -> Middleware+put = route (Just "PUT") -put :: PathPattern -> RouteM e a -> TwainM e ()-put = addRoute (Just "PUT")+patch :: PathPattern -> ResponderM a -> Middleware+patch = route (Just "PATCH") -patch :: PathPattern -> RouteM e a -> TwainM e ()-patch = addRoute (Just "PATCH")+post :: PathPattern -> ResponderM a -> Middleware+post = route (Just "POST") -post :: PathPattern -> RouteM e a -> TwainM e ()-post = addRoute (Just "POST")+delete :: PathPattern -> ResponderM a -> Middleware+delete = route (Just "DELETE") -delete :: PathPattern -> RouteM e a -> TwainM e ()-delete = addRoute (Just "DELETE")+-- | Route request matching optional `Method` and `PathPattern` to `ResponderM`.+route :: Maybe Method -> PathPattern -> ResponderM a -> Middleware+route method pat (ResponderM responder) app req respond = do+  let maxM = optsMaxBodySize <$> V.lookup responderOptsKey (vault req)+  req' <- maybe (pure req) (flip requestSizeCheck req) maxM+  case match method pat req' of+    Nothing -> app req' respond+    Just pathParams -> do+      let preq = parseRequest req'+          preq' = preq {preqPathParams = pathParams}+          req'' = req' {vault = V.insert parsedReqKey preq' (vault req')}+      eres <- responder req''+      case eres of+        Left (Respond res) -> respond res+        _ -> app req'' respond --- | Add a route if nothing else is found. This matches any request, so it--- should go last.-notFound :: RouteM e a -> TwainM e ()-notFound = addRoute Nothing (MatchPath (const (Just [])))+-- | Respond if no other route responds.+--+-- Sets the status to 404.+notFound :: ResponderM a -> Application+notFound (ResponderM responder) req respond = do+  let preq = parseRequest req+      req' = req {vault = V.insert parsedReqKey preq (vault req)}+  eres <- responder req'+  case eres of+    Left (Respond res) -> respond $ mapResponseStatus (const status404) res+    _ -> respond $ status status404 $ text "Not found." --- | Render a `Response` on exceptions.-onException :: (SomeException -> Response) -> TwainM e ()-onException handler = modify $ \st -> st {onExceptionResponse = handler}+onException :: (SomeException -> ResponderM a) -> Middleware+onException h app req respond = do+  handle handler $ app req respond+  where+    handler err = do+      let preq = parseRequest req+          req' = req {vault = V.insert parsedReqKey preq (vault req)}+      let (ResponderM responder) = h err+      eres <- responder req'+      case eres of+        Left (Respond res) -> respond res+        _ -> app req' respond --- | Add a route matching `Method` (optional) and `PathPattern`.-addRoute :: Maybe Method -> PathPattern -> RouteM e a -> TwainM e ()-addRoute method pat route =-  modify $ \st ->-    let m = routeMiddleware method pat route (environment st)-     in st {middlewares = m : middlewares st}+-- | Specify maximum request body size in bytes.+--+-- Defaults to 64KB.+withMaxBodySize :: Word64 -> Middleware+withMaxBodySize max app req respond = do+  let optsM = V.lookup responderOptsKey (vault req)+      opts = fromMaybe defaultResponderOpts optsM+      opts' = opts {optsMaxBodySize = max}+  let req' = req {vault = V.insert responderOptsKey opts' (vault req)}+  app req' respond --- | Get the app environment.-env :: RouteM e e-env = RouteM $ \st -> return $ Right (reqEnv st, st)+-- | Specify `ParseRequestBodyOptions` to use when parsing request body.+withParseBodyOpts :: ParseRequestBodyOptions -> Middleware+withParseBodyOpts parseBodyOpts app req respond = do+  let optsM = V.lookup responderOptsKey (vault req)+      opts = fromMaybe defaultResponderOpts optsM+      opts' = opts {optsParseBody = parseBodyOpts}+  let req' = req {vault = V.insert responderOptsKey opts' (vault req)}+  app req' respond  -- | Get a parameter. Looks in query, path, cookie, and body (in that order). -- -- If no parameter is found, or parameter fails to parse, `next` is called -- which passes control to subsequent routes and middleware.-param :: ParsableParam a => Text -> RouteM e a+param :: ParsableParam a => Text -> ResponderM a param name = do   pM <- fmap snd . L.find ((==) name . fst) <$> params   maybe next (either (const next) pure . parseParam) pM  -- | Get a parameter or error if missing or parse failure.-param' :: ParsableParam a => Text -> RouteM e (Either Text a)-param' name = do+paramEither :: ParsableParam a => Text -> ResponderM (Either HttpError a)+paramEither name = do   pM <- fmap snd . L.find ((==) name . fst) <$> params-  return $ maybe (Left ("missing parameter: " <> name)) parseParam pM+  return $ case pM of+    Nothing ->+      Left $ HttpError status400 ("missing parameter: " <> T.unpack name)+    Just p -> parseParam p --- | Get an optional parameter. `Nothing` is returned for missing parameter or--- parse failure.-paramMaybe :: ParsableParam a => Text -> RouteM e (Maybe a)+-- | Get an optional parameter.+--+-- Returns `Nothing` for missing parameter.+-- Throws `HttpError` on parse failure.+paramMaybe :: ParsableParam a => Text -> ResponderM (Maybe a) paramMaybe name = do   pM <- fmap snd . L.find ((==) name . fst) <$> params   return $ maybe Nothing (rightToMaybe . parseParam) pM  -- | Get all parameters from query, path, cookie, and body (in that order).-params :: RouteM e [Param]-params = fst <$> parseBody defaultParseRequestBodyOptions+params :: ResponderM [Param]+params = concatParams <$> parseBodyForm  -- | Get uploaded `FileInfo`.-file :: Text -> RouteM e (Maybe (FileInfo BL.ByteString))-file name = fmap snd . L.find ((==) (encodeUtf8 name) . fst) <$> files+--+-- If missing parameter or empty file, pass control to subsequent routes and+-- middleware.+file :: Text -> ResponderM (FileInfo BL.ByteString)+file name = maybe next pure =<< fileMaybe name +-- | Get optional uploaded `FileInfo`.+--+-- `Nothing` is returned for missing parameter or empty file content.+fileMaybe :: Text -> ResponderM (Maybe (FileInfo BL.ByteString))+fileMaybe name = do+  fM <- fmap snd . L.find ((==) (encodeUtf8 name) . fst) <$> files+  case fileContent <$> fM of+    Nothing -> return Nothing+    Just "" -> return Nothing+    Just _ -> return fM+ -- | Get all uploaded files.-files :: RouteM e [File BL.ByteString]-files = snd <$> parseBody defaultParseRequestBodyOptions+files :: ResponderM [File BL.ByteString]+files = fs . preqBody <$> parseBodyForm+  where+    fs bodyM = case bodyM of+      Just (FormBody (_, fs)) -> fs+      _ -> [] +-- | Get the JSON value from request body.+fromBody :: JSON.FromJSON a => ResponderM a+fromBody = do+  json <- parseBodyJson+  case JSON.fromJSON json of+    JSON.Error msg -> throwM $ HttpError status400 msg+    JSON.Success a -> return a+ -- | Get the value of a request `Header`. Header names are case-insensitive.-header :: Text -> RouteM e (Maybe Text)+header :: Text -> ResponderM (Maybe Text) header name = do   let ciname = CI.mk (encodeUtf8 name)   fmap (decodeUtf8 . snd) . L.find ((==) ciname . fst) <$> headers  -- | Get the request headers.-headers :: RouteM e [Header]+headers :: ResponderM [Header] headers = requestHeaders <$> request --- | Get the JSON value from request body.-bodyJson :: JSON.FromJSON a => RouteM e (Either String a)-bodyJson = do-  jsonE <- parseBodyJson-  case jsonE of-    Left e -> return (Left e)-    Right v -> case JSON.fromJSON v of-      JSON.Error e -> return (Left e)-      JSON.Success a -> return (Right a)- -- | Get the WAI `Request`.-request :: RouteM e Request-request = reqWai <$> routeState+request :: ResponderM Request+request = getRequest  -- | Send a `Response`. --@@ -221,12 +283,12 @@ -- Send a response `withCookie`: -- -- > send $ withCookie "key" "val" $ text "Hello"-send :: Response -> RouteM e a-send res = RouteM $ \_ -> return $ Left (Respond res)+send :: Response -> ResponderM a+send res = ResponderM $ \_ -> return $ Left (Respond res)  -- | Pass control to the next route or middleware.-next :: RouteM e a-next = RouteM $ \_ -> return (Left Next)+next :: ResponderM a+next = ResponderM $ \_ -> return (Left Next)  -- | Construct a `Text` response. --@@ -269,8 +331,15 @@    in raw status200 [typ, len] lbs  -- | Construct a raw response from a lazy `ByteString`.+--+-- Sets the Content-Length header if missing. raw :: Status -> [Header] -> BL.ByteString -> Response-raw status headers body = responseLBS status headers body+raw status headers body =+  if L.any ((hContentLength ==) . fst) headers+    then responseLBS status headers body+    else+      let len = (hContentLength, Char8.pack (show (BL.length body)))+       in responseLBS status (len : headers) body  -- | Set the `Status` for a `Response`. status :: Status -> Response -> Response@@ -288,7 +357,9 @@   let setCookie =         defaultSetCookie           { setCookieName = encodeUtf8 key,-            setCookieValue = encodeUtf8 val+            setCookieValue = encodeUtf8 val,+            setCookiePath = Just "/",+            setCookieHttpOnly = True           }       header = (CI.mk "Set-Cookie", setCookieByteString setCookie)    in mapResponseHeaders (header :) res@@ -306,6 +377,8 @@       setCookie =         defaultSetCookie           { setCookieName = encodeUtf8 key,+            setCookiePath = Just "/",+            setCookieHttpOnly = True,             setCookieExpires = Just zeroTime           }       header = (CI.mk "Set-Cookie", setCookieByteString setCookie)

@@ -1,7 +1,8 @@ module Web.Twain.Internal where -import Control.Exception (throwIO)+import Control.Exception (handle, throwIO) import Control.Monad (join)+import Control.Monad.Catch (throwM, try) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as JSON import qualified Data.ByteString as B@@ -9,90 +10,117 @@ import qualified Data.ByteString.Lazy as BL import Data.Int import Data.List as L+import Data.Maybe (fromMaybe) import Data.Text as T import Data.Text.Encoding-import Network.HTTP.Types (Method, hCookie, status204)-import Network.Wai (Application, Middleware, Request, lazyRequestBody, queryString, requestHeaders, requestMethod, responseLBS)-import Network.Wai.Parse (File, ParseRequestBodyOptions, lbsBackEnd, parseRequestBodyEx)+import qualified Data.Vault.Lazy as V+import Data.Word (Word64)+import Network.HTTP.Types (Method, hCookie, mkStatus, status204, status400, status413, status500)+import Network.HTTP2 (ErrorCodeId (..), HTTP2Error (..))+import Network.Wai (Application, Middleware, Request (..), lazyRequestBody, queryString, requestHeaders, requestMethod, responseLBS)+import Network.Wai.Handler.Warp (defaultOnExceptionResponse)+import Network.Wai.Parse (File, ParseRequestBodyOptions, lbsBackEnd, noLimitParseRequestBodyOptions, parseRequestBodyEx)+import Network.Wai.Request (RequestSizeException (..), requestSizeCheck)+import System.IO.Unsafe (unsafePerformIO) import Web.Cookie (SetCookie, parseCookiesText, renderSetCookie) import Web.Twain.Types -type MaxRequestSizeBytes = Int64+parsedReqKey :: V.Key ParsedRequest+parsedReqKey = unsafePerformIO V.newKey+{-# NOINLINE parsedReqKey #-} -routeState :: RouteM e (RouteState e)-routeState = RouteM $ \s -> return (Right (s, s))+responderOptsKey :: V.Key ResponderOptions+responderOptsKey = unsafePerformIO V.newKey+{-# NOINLINE responderOptsKey #-} -setRouteState :: RouteState e -> RouteM e ()-setRouteState s = RouteM $ \_ -> return (Right ((), s))+defaultResponderOpts :: ResponderOptions+defaultResponderOpts =+  ResponderOptions+    { optsMaxBodySize = 64000,+      optsParseBody = noLimitParseRequestBodyOptions+    } -concatParams :: RouteState e -> [Param]-concatParams p =-  reqBodyParams p-    <> reqCookieParams p-    <> reqPathParams p-    <> reqQueryParams p+getRequest :: ResponderM Request+getRequest = ResponderM $ \r -> return (Right (r, r)) -composeMiddleware :: [Middleware] -> Application-composeMiddleware = L.foldl' (\a m -> m a) emptyApp+setRequest :: Request -> ResponderM ()+setRequest r = ResponderM $ \_ -> return (Right ((), r)) -routeMiddleware ::-  Maybe Method ->-  PathPattern ->-  RouteM e a ->-  e ->-  Middleware-routeMiddleware method pat (RouteM route) env app req respond =-  case match method pat req of-    Nothing -> app req respond-    Just pathParams -> do-      let st =-            RouteState-              { reqBodyParams = [],-                reqBodyFiles = [],-                reqPathParams = pathParams,-                reqQueryParams = decodeQueryParam <$> queryString req,-                reqCookieParams = cookieParams req,-                reqBodyJson = Left "missing JSON body",-                reqBodyParsed = False,-                reqEnv = env,-                reqWai = req-              }-      action <- route st-      case action of-        Left (Respond res) -> respond res-        _ -> app req respond+concatParams :: ParsedRequest -> [Param]+concatParams+  ParsedRequest+    { preqBody = Just (FormBody (fps, _)),+      preqCookieParams = cps,+      preqPathParams = pps,+      preqQueryParams = qps+    } = qps <> pps <> cps <> fps+concatParams preq =+  preqQueryParams preq <> preqPathParams preq <> preqCookieParams preq +parseRequest :: Request -> ParsedRequest+parseRequest req =+  case V.lookup parsedReqKey (vault req) of+    Just preq -> preq+    Nothing ->+      ParsedRequest+        { preqPathParams = [],+          preqQueryParams = decodeQueryParam <$> queryString req,+          preqCookieParams = cookieParams req,+          preqBody = Nothing+        }+ match :: Maybe Method -> PathPattern -> Request -> Maybe [Param] match method (MatchPath f) req   | maybe True (requestMethod req ==) method = f req   | otherwise = Nothing -parseBody :: ParseRequestBodyOptions -> RouteM e ([Param], [File BL.ByteString])-parseBody opts = do-  s <- routeState-  if reqBodyParsed s-    then return (concatParams s, reqBodyFiles s)-    else do-      (ps, fs) <- liftIO $ parseRequestBodyEx opts lbsBackEnd (reqWai s)-      let sb =-            s-              { reqBodyParams = decodeBsParam <$> ps,-                reqBodyFiles = fs,-                reqBodyParsed = True-              }-      setRouteState sb-      return (concatParams sb, reqBodyFiles sb)+-- | Parse form request body.+parseBodyForm :: ResponderM ParsedRequest+parseBodyForm = do+  req <- getRequest+  let preq = fromMaybe (parseRequest req) $ V.lookup parsedReqKey (vault req)+  case preqBody preq of+    Just (FormBody _) -> return preq+    _ -> do+      let optsM = optsParseBody <$> V.lookup responderOptsKey (vault req)+          opts = fromMaybe noLimitParseRequestBodyOptions optsM+      (ps, fs) <- liftIO $ wrapErr $ parseRequestBodyEx opts lbsBackEnd req+      let parsedBody = FormBody (decodeBsParam <$> ps, fs)+          preq' = preq {preqBody = Just parsedBody}+      setRequest $ req {vault = V.insert parsedReqKey preq' (vault req)}+      return preq' -parseBodyJson :: RouteM e (Either String JSON.Value)+-- | Parse JSON request body.+parseBodyJson :: ResponderM JSON.Value parseBodyJson = do-  s <- routeState-  if reqBodyParsed s-    then return (reqBodyJson s)-    else do-      jsonE <- liftIO $ JSON.eitherDecode <$> lazyRequestBody (reqWai s)-      setRouteState $ s {reqBodyJson = jsonE, reqBodyParsed = True}-      return jsonE+  req <- getRequest+  let preq = fromMaybe (parseRequest req) $ V.lookup parsedReqKey (vault req)+  case preqBody preq of+    Just (JSONBody json) -> return json+    _ -> do+      jsonE <- liftIO $ wrapErr $ JSON.eitherDecode <$> lazyRequestBody req+      case jsonE of+        Left msg -> throwM $ HttpError status400 msg+        Right json -> do+          let preq' = preq {preqBody = Just (JSONBody json)}+          setRequest $ req {vault = V.insert parsedReqKey preq' (vault req)}+          return json +wrapErr = handle wrapMaxReqErr . handle wrapParseErr++wrapMaxReqErr :: RequestSizeException -> IO a+wrapMaxReqErr (RequestSizeException max) =+  throwIO $ HttpError status413 $+    "Request body size larger than " <> show max <> " bytes."++wrapParseErr :: HTTP2Error -> IO a+wrapParseErr (ConnectionError (UnknownErrorCode code) msg) = do+  let msg' = unpack $ decodeUtf8 msg+  throwIO $ HttpError (mkStatus (fromIntegral code) msg) msg'+wrapParseErr (ConnectionError _ msg) = do+  let msg' = unpack $ decodeUtf8 msg+  throwIO $ HttpError status500 msg'+ cookieParams :: Request -> [Param] cookieParams req =   let headers = snd <$> L.filter ((==) hCookie . fst) (requestHeaders req)@@ -107,6 +135,3 @@  decodeBsParam :: (B.ByteString, B.ByteString) -> Param decodeBsParam (a, b) = (decodeUtf8 a, decodeUtf8 b)--emptyApp :: Application-emptyApp req respond = respond $ responseLBS status204 [] ""

@@ -1,7 +1,8 @@ module Web.Twain.Types where -import Control.Exception (SomeException)+import Control.Exception (SomeException, throwIO, try) import Control.Monad (ap)+import Control.Monad.Catch hiding (throw, try) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson as JSON import qualified Data.ByteString as B@@ -14,86 +15,76 @@ import Data.Text.Encoding import qualified Data.Text.Lazy as TL import Data.Word+import Network.HTTP.Types (Status, status400) import Network.Wai (Middleware, Request, Response, pathInfo)-import Network.Wai.Handler.Warp (defaultOnExceptionResponse) import Network.Wai.Parse (File, ParseRequestBodyOptions) import Numeric.Natural --- | TwainM provides a monad interface for composing routes and middleware.-newtype TwainM e a = TwainM (TwainState e -> (a, TwainState e))--data TwainState e-  = TwainState-      { middlewares :: [Middleware],-        environment :: e,-        onExceptionResponse :: (SomeException -> Response)-      }--instance Functor (TwainM e) where-  fmap f (TwainM g) = TwainM $ \s ->-    let (a, sb) = g s-     in (f a, sb)--instance Applicative (TwainM e) where-  pure = return-  (<*>) = ap--instance Monad (TwainM e) where-  return a = TwainM (\s -> (a, s))-  (TwainM m) >>= fn = TwainM $ \s ->-    let (a, sb) = m s-        (TwainM mb) = fn a-     in mb sb--modify :: (TwainState e -> TwainState e) -> TwainM e ()-modify f = TwainM (\s -> ((), f s))--exec :: TwainM e a -> e -> TwainState e-exec (TwainM f) e = snd (f (TwainState [] e defaultOnExceptionResponse))---- | `RouteM` is a Reader-like monad that can "short-circuit" and return a WAI--- response using a given environment. This provides convenient branching with--- do notation for redirects, error responses, etc.-data RouteM e a-  = RouteM (RouteState e -> IO (Either RouteAction (a, RouteState e)))+-- | `ResponderM` is an Either-like monad that can "short-circuit" and return a+-- response, or pass control to the next middleware. This provides convenient+-- branching with do notation for redirects, error responses, etc.+data ResponderM a+  = ResponderM (Request -> IO (Either RouteAction (a, Request)))  data RouteAction   = Respond Response   | Next -data RouteState e-  = RouteState-      { reqBodyParams :: [Param],-        reqBodyFiles :: [File BL.ByteString],-        reqPathParams :: [Param],-        reqQueryParams :: [Param],-        reqCookieParams :: [Param],-        reqBodyJson :: Either String JSON.Value,-        reqBodyParsed :: Bool,-        reqEnv :: e,-        reqWai :: Request+data ParsedRequest+  = ParsedRequest+      { preqBody :: Maybe ParsedBody,+        preqCookieParams :: [Param],+        preqPathParams :: [Param],+        preqQueryParams :: [Param]       } -instance Functor (RouteM e) where-  fmap f (RouteM g) = RouteM $ \s -> mapRight (\(a, b) -> (f a, b)) `fmap` g s+data ResponderOptions+  = ResponderOptions+      { optsMaxBodySize :: Word64,+        optsParseBody :: ParseRequestBodyOptions+      } -instance Applicative (RouteM e) where+data ParsedBody+  = FormBody ([Param], [File BL.ByteString])+  | JSONBody JSON.Value++instance Functor ResponderM where+  fmap f (ResponderM g) = ResponderM $ \r -> mapRight (\(a, b) -> (f a, b)) `fmap` g r++instance Applicative ResponderM where   pure = return   (<*>) = ap -instance Monad (RouteM e) where-  return a = RouteM $ \s -> return (Right (a, s))-  (RouteM act) >>= fn = RouteM $ \s -> do-    eres <- act s+instance Monad ResponderM where+  return a = ResponderM $ \r -> return (Right (a, r))+  (ResponderM act) >>= fn = ResponderM $ \r -> do+    eres <- act r     case eres of       Left ract -> return (Left ract)-      Right (a, sb) -> do-        let (RouteM fres) = fn a-        fres sb+      Right (a, r') -> do+        let (ResponderM fres) = fn a+        fres r' -instance MonadIO (RouteM e) where-  liftIO act = RouteM $ \s -> act >>= \a -> return (Right (a, s))+instance MonadIO ResponderM where+  liftIO act = ResponderM $ \r -> act >>= \a -> return (Right (a, r)) +instance MonadThrow ResponderM where+  throwM = liftIO . throwIO++instance MonadCatch ResponderM where+  catch (ResponderM act) f = ResponderM $ \r -> do+    ea <- try (act r)+    case ea of+      Left e ->+        let (ResponderM h) = f e+         in h r+      Right a -> pure a++data HttpError = HttpError Status String+  deriving (Eq, Show)++instance Exception HttpError+ type Param = (Text, Text)  data PathPattern = MatchPath (Request -> Maybe [Param])@@ -115,10 +106,10 @@  -- | Parse values from request parameters. class ParsableParam a where-  parseParam :: Text -> Either Text a+  parseParam :: Text -> Either HttpError a    -- | Default implementation parses comma-delimited lists.-  parseParamList :: Text -> Either Text [a]+  parseParamList :: Text -> Either HttpError [a]   parseParamList t = mapM parseParam (T.split (== ',') t)  -- ParsableParam class and instance code is from Andrew Farmer and Scotty@@ -135,11 +126,14 @@ instance ParsableParam Char where   parseParam t = case T.unpack t of     [c] -> Right c-    _ -> Left "parseParam Char: no parse"+    _ -> Left $ HttpError status400 "parseParam Char: no parse"   parseParamList = Right . T.unpack -- String  instance ParsableParam () where-  parseParam t = if T.null t then Right () else Left "parseParam Unit: no parse"+  parseParam t =+    if T.null t+      then Right ()+      else Left $ HttpError status400 "parseParam Unit: no parse"  instance (ParsableParam a) => ParsableParam [a] where parseParam = parseParamList @@ -150,7 +144,7 @@       else         if t' == T.toCaseFold "false"           then Right False-          else Left "parseParam Bool: no parse"+          else Left $ HttpError status400 "parseParam Bool: no parse"     where       t' = T.toCaseFold t @@ -183,8 +177,8 @@ instance ParsableParam Natural where parseParam = readEither  -- | Useful for creating 'ParsableParam' instances for things that already implement 'Read'.-readEither :: Read a => Text -> Either Text a+readEither :: Read a => Text -> Either HttpError a readEither t = case [x | (x, "") <- reads (T.unpack t)] of   [x] -> Right x-  [] -> Left "readEither: no parse"-  _ -> Left "readEither: ambiguous parse"+  [] -> Left $ HttpError status400 "readEither: no parse"+  _ -> Left $ HttpError status400 "readEither: ambiguous parse"

@@ -1,15 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack------ hash: e9b3b8be1e3550c9e2a2a692102a1a947006bd579d57a084aacef52344e4b74d  name:           twain-version:        1.0.0.0+version:        2.0.0.0 synopsis:       Tiny web application framework for WAI.-description:    Twain is tiny web application framework for WAI. It provides routing, parameter parsing, and a reader-like monad for composing responses from an environment.+description:    Twain is tiny web application framework for WAI. It provides routing, parameter parsing, and an either-like monad for composing responses. category:       Web homepage:       https://github.com/alexmingoia/twain#readme bug-reports:    https://github.com/alexmingoia/twain/issues@@ -34,19 +32,23 @@       Web.Twain.Internal   hs-source-dirs:       src-  default-extensions: OverloadedStrings+  default-extensions:+      OverloadedStrings   build-depends:       aeson >=1.4 && <1.7     , base >=4.7 && <5-    , bytestring >=0.10 && <0.11-    , case-insensitive >=1.2 && <1.3+    , bytestring ==0.10.*+    , case-insensitive ==1.2.*     , cookie >=0.4 && <0.6-    , either >=5.0 && <5.1-    , http-types >=0.12 && <0.13+    , either ==5.0.*+    , exceptions ==0.10.*+    , http-types ==0.12.*+    , http2 >=2.0 && <3.1     , text >=1.2.3 && <1.3     , time >=1.8 && <1.9.9     , transformers >=0.5.6 && <0.6-    , wai >=3.2 && <3.3+    , vault ==0.3.*+    , wai ==3.2.*     , wai-extra >=3.0 && <3.2     , warp >=3.2 && <3.4   default-language: Haskell2010