diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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..." ``` diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/src/Web/Twain.hs b/src/Web/Twain.hs --- a/src/Web/Twain.hs +++ b/src/Web/Twain.hs @@ -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) diff --git a/src/Web/Twain/Internal.hs b/src/Web/Twain/Internal.hs --- a/src/Web/Twain/Internal.hs +++ b/src/Web/Twain/Internal.hs @@ -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 [] "" diff --git a/src/Web/Twain/Types.hs b/src/Web/Twain/Types.hs --- a/src/Web/Twain/Types.hs +++ b/src/Web/Twain/Types.hs @@ -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" diff --git a/twain.cabal b/twain.cabal --- a/twain.cabal +++ b/twain.cabal @@ -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