webapp 0.3.6 → 0.4.0
raw patch · 13 files changed
+393/−555 lines, 13 filesdep +vaultdep −aesondep −base16-bytestringdep −mtldep ~base
Dependencies added: vault
Dependencies removed: aeson, base16-bytestring, mtl, streaming-commons, zlib
Dependency ranges changed: base
Files
- CHANGELOG.md +4/−0
- README.md +12/−9
- Web/App.hs +1/−5
- Web/App/HTTP.hs +50/−48
- Web/App/Main.hs +42/−30
- Web/App/Middleware.hs +0/−7
- Web/App/Middleware/Gzip.hs +0/−53
- Web/App/Parameter.hs +2/−1
- Web/App/Path.hs +67/−73
- Web/App/RouteT.hs +205/−197
- Web/App/Stream.hs +4/−0
- Web/App/WebApp.hs +0/−119
- webapp.cabal +6/−13
CHANGELOG.md view
@@ -26,3 +26,7 @@ v 0.2.1 - `stream` function can now optionally flush. `stream'` will always flush. This may improve list streaming functionality.++v 0.4.0++ - Breaking change; refactor internals & simplify `Web.App.RouteT`
README.md view
@@ -1,13 +1,16 @@-# webapp - WAI web framework--Webapp is a web framework that is designed to provide everything needed to define & deploy a web app. For how to use, see Haddock documentation. For an example, see `example.hs`.--Webapp provides a function called `webappMain` (as well as a series of other similarly named functions) that start the built-in webserver. Your web application's `main` function should include a call to one of them at the end.+# Web.App - WAI web framework -# Using a webapp web app+[](https://travis-ci.org/natesymer/webapp) -Once you've written your web app, deploying is up to you. Webapp will probably work with services like Heroku or complicated load balancers, but it designed to be a standalone server (i.e. no need to run behind something like nginx).+Web.App is a general, minimalist Haskell web framework. See Haddock documentation and `example.hs`. -Webapp works by first binding to an IPv4 TCP port, immediately after which resigning privileges†. Then it builds a `WAI` app from your `WebAppT` app, applies middleware, and runs `Warp`.+## Usage notes -† The effective GID & UID are set to match the real GID & UID.+1. Web.App can either be ran standalone (i.e. look ma, no nginx!) or behind other server programs.+ - To bind to privileged ports, your program must be executable as root. Privileges are resigned after the port is bound.+ - Web.App uses Warp under the hood to serve a WAI app based on provided routes.+ - SSL & HTTP2 are supported.+2. Web.App provides a function called `webappMain` (as well as a series of other similarly named functions) that start your app.+ - Your program's `main` function should finish with a call to one of them.+3. Web.App also provides command line options for controlling the HTTP server.+ - It also provides
Web/App.hs view
@@ -13,20 +13,16 @@ ( module Web.App.HTTP, module Web.App.Main,- module Web.App.Middleware, module Web.App.Path, module Web.App.RouteT, module Web.App.State,- module Web.App.Stream,- module Web.App.WebApp+ module Web.App.Stream ) where import Web.App.HTTP import Web.App.Main-import Web.App.Middleware import Web.App.Path import Web.App.RouteT import Web.App.State import Web.App.Stream-import Web.App.WebApp
Web/App/HTTP.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings, RankNTypes #-} {-| Module : Web.App.HTTP@@ -7,65 +7,67 @@ Maintainer : nate@symer.io Stability : experimental Portability : POSIX--Start an HTTP server. -} module Web.App.HTTP (- -- * Running Warp- runSecure,- runInsecure,- -- * Configuring Warp- mkWarpSettings,- -- * Bind to a TCP port for HTTP- bindTCP+ runServer ) where -import Control.Monad- import Network.Wai (Application)-import Network.Wai.Handler.Warp (defaultSettings,runSettingsSocket,Port)-import Network.Wai.Handler.WarpTLS (tlsSettings,runTLSSocket,TLSSettings(..),OnInsecure(..))-import Network.Wai.Handler.Warp.Internal-import Network.Socket (sClose,withSocketsDo,Socket)-import Data.Streaming.Network (bindPortTCP)-import Control.Exception (bracket)+import Network.Wai.Handler.Warp (defaultSettings, runSettingsSocket, setPort)+import Network.Wai.Handler.WarpTLS (tlsSettings, runTLSSocket, TLSSettings(..), OnInsecure(..))+import Network.Socket (close, listen, bind, socket, Socket, SocketOption(..), AddrInfoFlag(..), SocketType(..), Family(..), isListening, setSocketOption, maxListenQueue, withSocketsDo, getAddrInfo, defaultHints, addrFamily, addrFlags, addrAddress, addrProtocol, addrSocketType)+import Control.Exception (bracket, bracketOnError) import System.Exit import System.Posix -bindTCP :: Port -> (Socket -> IO ()) -> IO ()-bindTCP port f = withSocketsDo $ bracket (bindPortTCP port "*4") sClose f+import Data.List (sortOn)+import Data.Maybe (fromJust)+import Data.Bool (bool) --- |Build a Warp Settings struct-mkWarpSettings :: IO () -- ^ function to be called on a SIGTERM or SIGINT- -> Int -- ^ port- -> Settings-mkWarpSettings teardown port = defaultSettings {- settingsPort = port,- settingsInstallShutdownHandler = \killSockets -> void $ do- installHandler sigTERM (handler $ killSockets >> teardown) Nothing- installHandler sigINT (handler $ killSockets >> teardown) Nothing- }- where handler = Catch . (>> exitImmediately ExitSuccess)- --- |Serve a WAI app using Warp over TLS.-runSecure :: FilePath -- ^ 'FilePath' to an SSL certificate- -> FilePath -- ^ 'FilePath' to an SSL private key- -> Socket -- ^ Socket to use- -> Settings -- ^ Warp settings structure- -> Application -- ^ WAI application+-- | Serve your application.+runServer :: Maybe (FilePath, FilePath) -- ^ Certificate pair to use (cert, key)+ -> Int -- ^ Port to bind to+ -> IO () -- ^ IO to be performed immediately after binding.+ -> IO () -- ^ IO to be performed on shutdown.+ -> Application -- ^ WAI 'Application'. -> IO ()-runSecure cert key sock set app = do- settingsInstallShutdownHandler set (sClose sock) -- ignored by Warp's @runTLSSocket@- runTLSSocket tset set sock app- where tset = (tlsSettings cert key) { onInsecure = AllowInsecure }+runServer cp port pre teardown app = withSocketsDo $ bracket (bindTCP port) close logic+ where+ logic sock = pre >> do+ installHandler sigTERM handler Nothing+ installHandler sigINT handler Nothing+ run cp sock+ where handler = Catch $ close sock >> teardown >> exitImmediately ExitSuccess+ run (Just (c, k)) sock = runTLSSocket tset set sock app+ where tset = (tlsSettings c k) { onInsecure = AllowInsecure }+ run _ sock = runSettingsSocket set sock app+ set = setPort port defaultSettings --- |Serve a WAI app using Warp over unencrypted HTTP.-runInsecure :: Socket -- ^ Socket to use- -> Settings -- ^ Warp settings structure- -> Application -- ^ WAI application- -> IO ()-runInsecure = flip runSettingsSocket+-- | Find a Socket capable of transmitting/receiving TCP data.+-- Has preference for IPv4 hosts over IPv6 hosts.+bindTCP :: Int -> IO Socket+bindTCP p = tryAddrs . sortOn sortf =<< getAddrInfo (Just hints) Nothing (Just $ show p)+ where hints = defaultHints {+ addrFlags = [AI_PASSIVE, AI_NUMERICSERV, AI_NUMERICHOST],+ addrSocketType = Stream+ } -- TODO: add port to these hints somehow+ sortf = (==) AF_INET6 . addrFamily -- sortOn odd [True, False, True] == [False, True, True]+ tryAddrs = fmap fromJust . findMLazy isListening . map theBody -- uses laziness+ theBody addr = bracketOnError aquire close action+ where aquire = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ action sock = do+ setSocketOption sock NoDelay 1+ setSocketOption sock ReuseAddr 1+ bind sock $ addrAddress addr+ listen sock $ max 2048 maxListenQueue+ return sock+ +-- | Performs monadic computations until it finds a result+-- for which p returns true. It returns this value. +findMLazy :: (Monad m) => (a -> m Bool) -> [m a] -> m (Maybe a)+findMLazy _ [] = return Nothing+findMLazy p (x:xs) = x >>= \x' -> p x' >>= bool (findMLazy p xs) (return $ Just x')
Web/App/Main.hs view
@@ -14,27 +14,35 @@ import Web.App +routes :: (WebAppState s, MonadIO m) => [Route s m]+routes = [] -- routes go here+ main :: IO ()-main = webappMain' app "My Application!"+main = webappMain' routes [] @ -} +{-# LANGUAGE TupleSections #-}+ module Web.App.Main ( webappMain, webappMain', webappMainIO,- webappMainIO'+ webappMainIO',+ webappMainSimple, ) where -import Web.App.WebApp-import Web.App.RouteT (RouteResult)+import Web.App.RouteT import Web.App.State import Web.App.HTTP +import Network.Wai (Middleware, Response)+ import Data.Maybe+import Data.Monoid import Control.Monad import Control.Monad.IO.Class @@ -58,15 +66,20 @@ _optionsErrorPath :: Maybe FilePath } +webappMainSimple :: (WebAppState s) => [Route s IO] -> IO ()+webappMainSimple = flip webappMainIO' []+ -- |Like 'webappMainIO' without the CLI extension arguments. webappMainIO' :: (WebAppState s)- => WebApp s IO -- ^ app to start+ => [Route s IO] -- ^ routes+ -> [Middleware] -- ^ middlewares -> IO ()-webappMainIO' a = webappMainIO a Nothing (const $ return ())+webappMainIO' a m = webappMainIO a m Nothing (const $ return ()) -- |Run a webapp based on IO. webappMainIO :: (WebAppState s)- => WebApp s IO -- ^ app to start+ => [Route s IO] -- ^ routes+ -> [Middleware] -- ^ middlewares -> Maybe (Parser a) -- ^ extra CLI parser (available under @util@ subcommand) -> (a -> IO ()) -- ^ action to apply to parse result of 'utilParser' -> IO ()@@ -74,20 +87,22 @@ -- |Like 'webappMain' without the CLI extension arguments. webappMain' :: (WebAppState s, MonadIO m)- => (m RouteResult -> IO RouteResult) -- ^ action to eval a monadic computation in @m@ in @IO@- -> WebApp s m -- ^ app to start+ => (m (Maybe Response) -> IO (Maybe Response)) -- ^ action to eval a monadic computation in @m@ in @IO@+ -> [Route s m] -- ^ routes+ -> [Middleware] -- ^ middlewares -> IO ()-webappMain' f a = webappMain f a Nothing (const $ return ())+webappMain' f a m = webappMain f a m Nothing (const $ return ()) -- | Read commandline arguments and start webapp accordingly. When passing an -- additional CLI parser, it is made available under the @util@ subcommand. webappMain :: (WebAppState s, MonadIO m)- => (m RouteResult -> IO RouteResult) -- ^ action to eval a monadic computation in @m@ in @IO@- -> WebApp s m -- ^ app to start+ => (m (Maybe Response) -> IO (Maybe Response)) -- ^ action to eval a monadic computation in @m@ in @IO@+ -> [Route s m] -- ^ routes+ -> [Middleware] -- ^ middlewares -> Maybe (Parser a) -- ^ extra CLI parser, parsed after the built-in parser -> (a -> IO ()) -- ^ action to apply the result of 'extraParser' -> IO ()-webappMain runToIO app extraParser extraf = parseArgs extraParser >>= either extraf f+webappMain runToIO app mws extraParser extraf = parseArgs extraParser >>= either extraf f where f (Options Nothing p c k o e) = start p c k o e f (Options (Just pidFile) p c k o e) = do@@ -102,22 +117,19 @@ start p c k Nothing Nothing exitImmediately ExitSuccess exitImmediately ExitSuccess- start port cert key out err = do- bindTCP port $ \sock -> do- -- drop privileges after binding to a port- getRealGroupID >>= setEffectiveGroupID- getRealUserID >>= setEffectiveUserID- -- redirect I/O- maybe (return ()) (redirectHandle stdout) out- maybe (return ()) (redirectHandle stderr) err- -- serve webapp- (wai,teardown) <- toApplication runToIO app- serveFunc cert key sock (mkWarpSettings teardown port) wai- where serveFunc c k = fromMaybe runInsecure $ runSecure <$> c <*> k- redirectHandle hdl path = do- exists <- fileExist path- when (not exists) $ writeFile path ""- h <- openFile path WriteMode+ start port cert key out err = runServer ((,) <$> cert <*> key) port pre teardown wai+ where (wai, teardown) = toApplication runToIO app mws+ pre = do+ -- drop privileges after binding to a port+ getRealGroupID >>= setEffectiveGroupID+ getRealUserID >>= setEffectiveUserID+ -- redirect I/O+ maybe (return ()) (redirectHandle stdout) out+ maybe (return ()) (redirectHandle stderr) err+ redirectHandle hdl pth = do+ exists <- fileExist pth+ when (not exists) $ writeFile pth ""+ h <- openFile pth WriteMode hDuplicateTo h hdl hClose h hSetBuffering hdl NoBuffering@@ -127,7 +139,7 @@ defaultPort <- ((=<<) readMaybe) <$> lookupEnv "PORT" customExecParser pprefs $ info (helper <*> parser defaultPort) fullDesc where- pprefs = ParserPrefs "" False False True 80+ pprefs = ParserPrefs "" False False True True 80 parser port = (Right <$> parseStart port) <|> (maybe empty (fmap Left) extra)-- <|> (Right <$> showHelp) parseStart port = Options <$> (optional $ strOption $ long "daemonize" <> short 'd' <> metavar "FILEPATH" <> help "Daemonize server and write its pid to FILEPATH.")
− Web/App/Middleware.hs
@@ -1,7 +0,0 @@-module Web.App.Middleware-(- module Web.App.Middleware.Gzip-)-where--import Web.App.Middleware.Gzip
− Web/App/Middleware/Gzip.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}-{-|-Module : Web.App.Middleware.Gzip-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : Cross-Platform--WAI middleware to GZIP HTTP responses.--}--module Web.App.Middleware.Gzip-(- gzip-)-where--import Network.Wai-import Network.Wai.Internal-import Data.Maybe (fromMaybe)-import qualified Codec.Compression.GZip as GZIP (compress)-import qualified Data.ByteString.Char8 as B (readInt,isInfixOf)-import Blaze.ByteString.Builder (toLazyByteString)-import Blaze.ByteString.Builder.ByteString (fromLazyByteString)---- | Creates a 'Middleware' that GZIPs HTTP responses-gzip :: Int -- ^ Minimum response length that's GZIP'd- -> Middleware-gzip minLen app env sendResponse = app env f- where- f res@ResponseRaw{} = sendResponse res- f res- | isCompressable = sendCompressed res sendResponse- | otherwise = sendResponse res- where- isCompressable = isAccepted && not isIE6 && isBigEnough && not isEncoded- isAccepted = headerContains "gzip" "Accept-Encoding" $ requestHeaders env- isIE6 = headerContains "MSIE 6" "User-Agent" $ requestHeaders env- isEncoded = headerContains "gzip" "Content-Encoding" $ responseHeaders res- isBigEnough = maybe True ((<=) minLen) contentLength- contentLength = getResHeader "Content-Length" >>= fmap fst . B.readInt- getResHeader k = lookup k $ responseHeaders res- headerContains s k hdrs = fromMaybe False $ B.isInfixOf s <$> lookup k hdrs--sendCompressed :: Response -> (Response -> IO a) -> IO a-sendCompressed res f = maybe (f res) (const send) $ lookup "Content-Type" hs- where- (s,hs,wb) = responseToStream res- invariants = [("Vary","Accept-Encoding"),("Content-Encoding","gzip")]- hs' = invariants ++ (filter ((/=) "Content-Length" . fst) hs)- send = wb $ \b -> f $ responseStream s hs' (b . (. compress))- compress = fromLazyByteString . GZIP.compress . toLazyByteString
Web/App/Parameter.hs view
@@ -41,6 +41,7 @@ f "n" = Just False f "on" = Just True -- HTML checkboxes f "off" = Just False -- HTML checkboxes+ f "null" = Just False -- treat nulls like False f _ = Nothing instance Parameter T.Text where@@ -70,7 +71,7 @@ maybeRead (B.uncons -> Just ('.',v)) = (*) e <$> v'' where v' = B.takeWhile isDigit v v'' = fromIntegral . fst <$> B.readInt v'- e = 10**(negate $ fromIntegral $ B.length v')+ e = 10 ** (negate $ fromIntegral $ B.length v') maybeRead x = (+) (fromMaybe 0 $ maybeRead xs) <$> x'' where (x',xs) = B.span isDigit x x'' = fromInteger . fst <$> B.readInteger x'
Web/App/Path.hs view
@@ -6,7 +6,7 @@ Stability : experimental Portability : POSIX -A URI pathInfo wrapper.+Path matching/parsing functionality -} {-# LANGUAGE OverloadedStrings #-}@@ -15,19 +15,18 @@ ( -- * Types Path,- PathInfo, -- * Path Constructors literal, captured, regex, -- * Path Operations- pathMatches,- -- * Text-Based Path Operations isRoot,- splitPath,- mkPathInfo,- joinPath,- pathCaptures+ pathMatches,+ pathCaptures,+ -- * Path Components Operations+ splitPathComps,+ joinPathComps,+ isValidPathComps ) where @@ -38,92 +37,87 @@ import Text.Regex.Posix import Data.List import Data.String+import Data.Char (isAlphaNum)+import Data.Maybe (isJust)+import Data.Bool (bool)+import Control.Monad (join) --- |Represents a PathInfo (e.g. from WAI)-type PathInfo = [Text]+{- TYPES -} +-- TODO: CapturedPath needs to store indeces of captures as an optimization+ -- |Describes a matchable path.-data Path = LiteralPath PathInfo -- ^ Match a path as-is- | CapturedPath PathInfo -- ^ Match a path with wildcards- | RegexPath Regex -- ^ Match a path with a regex- +data Path = LiteralPath [Text] -- ^ as-is+ | CapturedPath [Text] -- ^ path with named wildcards starting with a colon+ | RegexPath Regex -- ^ path with a regex+ instance IsString Path where- fromString = f . mkPathInfo . T.pack- where f pinfo = case find (T.isPrefixOf ":") pinfo of- Just _ -> CapturedPath pinfo- Nothing -> LiteralPath pinfo- + fromString = join getCtor . splitPathComps . T.pack+ where+ hasCapture = isJust . find (T.isPrefixOf ":")+ getCtor = bool LiteralPath CapturedPath . hasCapture++{- PATH CONSTRUCTORS -}+ -- |Construct a literal 'Path'. literal :: Text -> Path-literal = LiteralPath . mkPathInfo+literal = LiteralPath . splitPathComps -- |Construct a captured 'Path'. captured :: Text -> Path-captured = CapturedPath . mkPathInfo+captured = CapturedPath . splitPathComps -- |Construct a regex 'Path'. regex :: Text -> Path regex = RegexPath . makeRegex . T.encodeUtf8 --- |Returns @True@ if the given 'Path' matches the given 'PathInfo'-pathMatches :: Path -> PathInfo -> Bool-pathMatches (RegexPath ex) pin = matchTest ex $ T.encodeUtf8 $ joinPath pin-pathMatches (LiteralPath pin) pin2 = pin == pin2-pathMatches (CapturedPath pin) pin2 = f pin pin2- where f [] [] = True- f _ [] = False- f [] _ = False- f (c:cs) (p:ps)- | T.head c == ':' = f cs ps- | p == c = f cs ps- | otherwise = False+{- PATH OPERATIONS -} --- |Returns true if given path is the root.+-- | Returns @True@ if given path is the root. isRoot :: Path -> Bool-isRoot (RegexPath ex) = matchTest ex ("/" :: String)-isRoot (LiteralPath pin) = null pin-isRoot (CapturedPath pin) = null pin--{- General path operations -}---- |Splits path into (path,queryString).-splitPath :: Text -- ^ path- -> (Text,Text)-splitPath pth = (p,T.drop 1 q)- where (p,q) = T.break (== '?') pth---- |Split @path@ into a pathInfo list.-mkPathInfo :: Text -- ^ path- -> PathInfo-mkPathInfo = filter (not . T.null) . T.splitOn "/" . fst . splitPath+isRoot = flip pathMatches (splitPathComps "/") --- |Join pathInfo into a 'Text'ual path.-joinPath :: PathInfo -- ^ pathInfo- -> Text-joinPath = mconcat . (:) "/" . intersperse "/"+-- | Returns @True@ if the given 'Path' matches the given path components.+pathMatches :: Path -- ^ path+ -> [Text] -- ^ pathComps+ -> Bool+pathMatches (RegexPath ex) pin = matchTest ex $ T.encodeUtf8 $ joinPathComps $ delete "/" pin+pathMatches (LiteralPath lpin) pin = lpin == delete "/" pin+pathMatches (CapturedPath cpin) pin = pin == sanitizeCapts cpin (delete "/" pin)+ where sanitizeCapts = zipWith (\c p -> bool c p $ (fst <$> T.uncons c) == Just ':') -{- Captures & Regex Captures -}- --- |Returns path captures by comparing @path@ to @pathInfo@.+-- | Returns path captures by comparing @path@ to @pathComps@. pathCaptures :: Path -- ^ path- -> PathInfo -- ^ pathInfo- -> [(Text,Text)]+ -> [Text] -- ^ pathComps+ -> [(Text, Text)] pathCaptures (LiteralPath _) _ = []-pathCaptures (RegexPath r) pin = maybe [] (\(_,x,_,xs) -> f (x:xs)) matched+pathCaptures (RegexPath r) pin = maybe [] (\(_, x, _, xs) -> f (x:xs)) matched where- f = numberList . map T.decodeUtf8- matched :: Maybe (B.ByteString,B.ByteString,B.ByteString,[B.ByteString])- matched = matchM r $ T.encodeUtf8 $ joinPath pin-+ f = indexedList . map T.decodeUtf8+ indexedList = zipWith (\a b -> (T.pack $ show a, b)) ([0..] :: [Integer])+ + matched :: Maybe (B.ByteString, B.ByteString, B.ByteString, [B.ByteString])+ matched = matchM r $ T.encodeUtf8 $ joinPathComps pin pathCaptures (CapturedPath cap) pin = f [] cap pin where f acc [] [] = acc- f _ _ [] = []- f _ [] _ = []- f acc (c:cs) (p:ps)- | T.head c == ':' = f ((T.tail c,p):acc) cs ps- | p == c = f acc cs ps- | otherwise = []- -numberList :: [Text] -> [(Text,Text)]-numberList = zipWith (\a b -> (T.pack $ show a, b)) ([0..] :: [Integer])+ f _ [] _ = []+ f _ _ [] = []+ f acc (c:cs) (p:ps) = g $ T.uncons c+ where g (Just (':', xs)) = f ((xs, p):acc) cs ps+ g _ = bool [] (f acc cs ps) $ p == c++{- PATH COMPONENTS OPERATIONS -}++-- | Split a 'Text' into a path components.+splitPathComps :: Text -> [Text]+splitPathComps = filter (not . T.null) . T.split (== '/') . T.takeWhile (/= '?')++-- | Join path components into a 'Text'ual path.+joinPathComps :: [Text] -> Text+joinPathComps = mconcat . intersperse "/" . (:) ""++-- | Determine if some path components contain only valid characters.+isValidPathComps :: [Text] -> Bool+isValidPathComps = all $ \v -> not (T.null v) && T.all isPathChar v+ where isPathChar c = isAlphaNum c || (c `elem` ("-.~!$&'()*+,;=:@%" :: String))
Web/App/RouteT.hs view
@@ -1,35 +1,35 @@ {-|-Module : Web.App.Monad.WebAppT+Module : Web.App.RouteT Copyright : (c) Nathaniel Symer, 2015 License : MIT Maintainer : nate@symer.io Stability : experimental Portability : POSIX -Defines a monad transformer used for defining routes-and using middleware.+Monad transformer used for defining web app routes. -} -{-# LANGUAGE OverloadedStrings, TupleSections, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings, TupleSections #-} module Web.App.RouteT (- -- * RouteT monad transformer+ toApplication,+ -- * Types RouteT,- evalRouteT,+ Route(..), -- * Routes- RouteResult,- Predicate,- Route,- RouteInterrupt(..),- findRoute,+ get,+ post,+ put,+ patch,+ delete,+ options,+ method,+ matchAll, -- * Monadic actions halt,- halt', next, writeBody,- writeBodyBytes,- writeJSON, request, addHeader, status,@@ -39,234 +39,176 @@ params, param, maybeParam,- bodyReader, body,- urlencodedBody,- path+ getState,+ putState ) where- -{- -TODO-- * Rewite 'param' and 'maybeParam' to avoid calling next- * Allow 'InterruptNext' to carry state into- the evaluation of the next route.- --}- import Web.App.State import Web.App.Path import Web.App.Stream import Web.App.Parameter- -import Control.Monad (ap)++import Control.Exception+import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class-import Control.Monad.State.Class-import Control.Monad.Writer.Class import Control.Concurrent.STM-import Control.Applicative import Network.Wai import Network.HTTP.Types.Status import Network.HTTP.Types.Header import Network.HTTP.Types.URI+import Network.HTTP.Types.Method -import Data.Maybe+import Data.Bool import Data.Monoid-import Data.Aeson+import Data.Functor++import Data.IORef+import Data.Vault.Lazy (Vault, Key)+import qualified Data.Vault.Lazy as V import Data.CaseInsensitive (mk) import System.IO.Unsafe import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Lazy.Internal as BL (ByteString(Empty,Chunk))+import qualified Data.ByteString.Lazy.Internal as BL (ByteString(..)) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.Text.Encoding as T -type Predicate = Request -> Bool -- ^ Used to determine if a route can handle a request-type Route s m = (Predicate, Path, RouteT s m ()) -type RouteResult = Maybe (Status, ResponseHeaders, Stream) -- kind of like a Ruby Rack response.+data Route s m = Route {+ _routePredicate :: Request -> Bool,+ _routePath :: Path,+ _routeAction :: RouteT s m ()+} -data RouteInterrupt = InterruptNext -- ^ halt current route evaluation and start evaluating next route- | InterruptHalt (Maybe Status) ResponseHeaders (Maybe Stream) -- ^ halt & provide a response+data EvalState = Normal -- ^ continue executing as normal+ | Next -- ^ skip to the next route+ | Halt -- ^ stop evaluation altogether+ deriving (Eq) --- |Monad transformer in which routes are evaluated. It's essentially--- an ExceptT crossed with an RWST with the path, body, and push func--- as the "Reader" state, the response as the "Writer" state, and no--- "State" state.+data ResponseChange = SetStatus Status+ | AddHeaders [Header]+ | AddBytes Stream++-- | INTERNAL: apply ResponseChanges to an empty response and return the result+flattenResponse :: [ResponseChange] -> Response+flattenResponse = f (status200, [], mempty)+ where f (s, hdrs, sm) [] = responseStream s hdrs $ runStream sm+ f (_, hdrs, sm) ((SetStatus s):rs) = f (s, hdrs, sm) rs+ f (s, hdrs, sm) ((AddHeaders hdrs'):rs) = f (s, hdrs ++ hdrs', sm) rs+ f (s, hdrs, sm) ((AddBytes bs):rs) = f (s, hdrs, sm <> bs) rs++-- |Monad transformer in which routes are evaluated. Evaluation may be stopped+-- via 'halt', 'next', or 'redirect'. newtype RouteT s m a = RouteT { runRouteT :: TVar s -- ^ tvar containing state -> Path -- ^ path of route- -> TVar BL.ByteString -- ^ request body -> Request -- ^ request being served- -> m (Either RouteInterrupt (a, Maybe Status, ResponseHeaders, Maybe Stream))+ -> m (a, (EvalState, [ResponseChange])) } --- |Evaluate a 'RouteT' action into a 'RouteResult'.-evalRouteT :: (WebAppState s, MonadIO m)- => RouteT s m () -- ^ route to evaluate- -> TVar s -- ^ tvar containing state- -> Path -- ^ path of route- -> Request -- ^ request being served- -> m (RouteResult)-evalRouteT act st pth req = do- bdy <- liftIO $ newTVarIO BL.Empty- f <$> runRouteT act st pth bdy req- where- f (Left InterruptNext) = Nothing- f (Left (InterruptHalt s h b)) = Just (fromMaybe status200 s,h,maybe mempty flush b)- f (Right ~(_,s,h,b)) = Just (fromMaybe status200 s,h,maybe mempty flush b)- instance (WebAppState s, Functor m) => Functor (RouteT s m) where- fmap f m = RouteT $ \st pth bdy req -> fmap apply $ runRouteT m st pth bdy req- where- apply (Right (a,s,h,b)) = Right (f a,s,h,b)- apply (Left e) = Left e+ fmap f m = RouteT $ \st pth req -> fmap apply $ runRouteT m st pth req+ where apply (a, c) = (f a, c) instance (WebAppState s, Monad m) => Applicative (RouteT s m) where- pure a = RouteT $ \_ _ _ _ -> return $ Right (a,Nothing,[],Nothing)+ pure a = RouteT $ \_ _ _ -> return (a, (Normal, mempty)) (<*>) = ap instance (WebAppState s, Monad m) => Monad (RouteT s m) where- fail msg = RouteT $ \_ _ _ _ -> fail msg- m >>= k = RouteT $ \st pth bdy req -> do- v <- runRouteT m st pth bdy req- case v of- Left e -> return $ Left e- Right ~(x, s, h, b) -> do- v' <- runRouteT (k x) st pth bdy req- case v' of- Left InterruptNext -> return $ Left InterruptNext- Left (InterruptHalt s' h' b') -> return $ Left combined- where combined = InterruptHalt (s' <|> s) (h' <> h) (b <> b')- Right ~(y, s', h', b') -> return $ Right $ combined- where combined = (y, s' <|> s, h' <> h, b <> b')+ fail msg = RouteT $ \_ _ _ -> fail msg+ m >>= k = RouteT actionf+ where+ actionf st pth req = runRouteT m st pth req >>= handleFirst+ where+ handleFirst (x, (Normal, cng1)) = runRouteT (k x) st pth req >>= handleSecond+ where+ handleSecond (x', (sts, cng2)) = return (x', (sts, cng3))+ where cng3 = bool (cng1 <> cng2) cng2 $ sts == Halt+ handleFirst (_, c) = return (undefined, c) instance (WebAppState s) => MonadTrans (RouteT s) where- lift m = RouteT $ \_ _ _ _ -> m >>= return . Right . (,Nothing,[],Nothing)+ lift m = RouteT $ \_ _ _ -> m >>= return . (,(Normal, mempty)) instance (WebAppState s, MonadIO m) => MonadIO (RouteT s m) where liftIO = lift . liftIO- --- |MonadState instance for accessing the mutable state.-instance (WebAppState s, MonadIO m) => MonadState s (RouteT s m) where- get = RouteT $ \st _ _ _ ->- Right . (,Nothing,[],Nothing) <$> (liftIO $ readTVarIO st)- put v = RouteT $ \st _ _ _ ->- Right . (,Nothing,[],Nothing) <$> (liftIO $ atomically $ writeTVar st v) --- |MonadWriter instance for writing to the HTTP response body.-instance (WebAppState s, Monad m) => MonadWriter Stream (RouteT s m) where- tell s = RouteT $ \_ _ _ _ -> return $ Right ((),Nothing,[],Just s)- listen act = RouteT $ \st pth bdy req -> do- v <- runRouteT act st pth bdy req- case v of- Left e -> return $ Left e- Right (a,_,_,mw) -> return $ Right ((a,fromMaybe mempty mw),Nothing,[],Nothing)- pass act = RouteT $ \st pth bdy req -> do- v <- runRouteT act st pth bdy req- case v of- Left e -> return $ Left e- Right ((a,f),_,_,mw) ->- return $ Right (a,Nothing,[],maybe mempty (Just . f) mw)--{- Route Evaluation -}---- |Find the first route that can respond to @request@ in @routes@.-findRoute :: (WebAppState s, Monad m)- => [Route s m] -- ^ routes- -> Request -- ^ request- -> Maybe ([Route s m],Route s m)-findRoute [] _ = Nothing-findRoute (x@(pd,pth,_):xs) req- | pd req && pathMatches pth (pathInfo req) = Just (xs,x)- | otherwise = findRoute xs req- {- Monadic actions -} --- |Halt route evaluation and provide the given 'Status',--- 'ResponseHeaders', and 'Stream'.-halt :: (WebAppState s, Monad m)- => Status -- ^ status with which to terminate- -> ResponseHeaders -- ^ headers with which to terminate- -> Stream -- ^ body with which to terminate- -> RouteT s m a-halt s h b = act >> let x = x in x -- second action will never be evaluated- where act = RouteT $ \_ _ _ _ ->- return $ Left $ InterruptHalt (Just s) h (Just b)- --- |Halt route evaluation and provide the accumulated 'Status',--- 'ResponseHeaders', and 'Stream'.-halt' :: (WebAppState s, Monad m) => RouteT s m a-halt' = act >> let x = x in x -- second action will never be evaluated- where act = RouteT $ \_ _ _ _ ->- return $ Left $ InterruptHalt Nothing [] Nothing+-- |INTERNAL A helper to avoid having the RouteT constructor appear everywhere (DRY)+{-# INLINE context #-}+context :: (WebAppState s, Monad m) => EvalState -> [ResponseChange] -> RouteT s m ()+context st hc = RouteT $ \_ _ _ -> return ((), (st, hc)) --- |Halt route evaluation and move onto the next--- route that passes.-next :: (WebAppState s, Monad m) => RouteT s m a-next = act >> let x = x in x -- second action will never be evaluated- where act = RouteT $ \_ _ _ _ -> return $ Left InterruptNext+-- |INTERNAL Get the state TVar.+stateTVar :: (WebAppState s, Monad m) => RouteT s m (TVar s)+stateTVar = RouteT $ \st _ _ -> return (st, (Normal, mempty)) --- |Write a 'Stream' to the response body.-writeBody :: (WebAppState s, Monad m, ToStream w) => w -> RouteT s m ()-writeBody w = RouteT $ \_ _ _ _ ->- return $ Right ((),Nothing,[],Just $ stream' w)- --- |Same as 'writeBody', but designed for use--- with literals via OverloadedStrings-writeBodyBytes :: (WebAppState s, Monad m) => ByteString -> RouteT s m ()-writeBodyBytes = writeBody- --- |Write a JSON object to the response body.-writeJSON :: (WebAppState s, Monad m, ToJSON j) => j -> RouteT s m ()-writeJSON = writeBody . encode+-- |INTERNAL Get the route's path. This can be different across different evaluations of the same route.+path :: (WebAppState s, Monad m) => RouteT s m Path+path = RouteT $ \_ pth _ -> return (pth, (Normal, mempty)) -- |Get the 'Request' being served. request :: (WebAppState s, Monad m) => RouteT s m Request-request = RouteT $ \_ _ _ req -> return $ Right (req,Nothing,[],Nothing)+request = RouteT $ \_ _ req -> return (req, (Normal, mempty)) +-- | Get the web app state.+getState :: (WebAppState s, MonadIO m) => RouteT s m s+getState = liftIO . readTVarIO =<< stateTVar++-- | Set the web app state.+putState :: (WebAppState s, MonadIO m) => s -> RouteT s m ()+putState v = liftIO . atomically . flip writeTVar v =<< stateTVar+ -- |Add an HTTP header. addHeader :: (WebAppState s, Monad m) => HeaderName -> ByteString -> RouteT s m ()-addHeader k v = RouteT $ \_ _ _ _ -> return $ Right ((),Nothing,[(k,v)],Nothing)+addHeader k v = context Normal [AddHeaders [(k, v)]] -- |Set the HTTP status. status :: (WebAppState s, Monad m) => Status -> RouteT s m ()-status s = RouteT $ \_ _ _ _ -> return $ Right ((),Just s,[],Nothing)+status s = context Normal [SetStatus s] +-- |Write a 'Stream' to the response body.+writeBody :: (WebAppState s, Monad m, ToStream w) => w -> RouteT s m ()+writeBody w = context Normal [AddBytes (stream' w)]++-- |Halt route evaluation and provide a 'Status', '[Header]', and 'Stream'.+halt :: (WebAppState s, Monad m) => Status -> [Header] -> Stream -> RouteT s m a+halt s h b = context Halt [SetStatus s, AddBytes b, AddHeaders h] >> undefined++-- |Halt route evaluation and move onto the next matched route.+next :: (WebAppState s, Monad m) => RouteT s m a+next = context Next [] >> undefined+ -- |Redirect to the given path using a @Location@ header and--- an HTTP status of 302. Route evaluation continues.+-- an HTTP status of 302. Route evaluation halts.+{-# INLINE redirect #-} redirect :: (WebAppState s, MonadIO m) => ByteString -> RouteT s m () redirect url = halt status302 [("Location",url)] mempty -- |Get the 'Request''s headers.-headers :: (WebAppState s, Monad m) => RouteT s m RequestHeaders+headers :: (WebAppState s, Monad m) => RouteT s m [Header] headers = requestHeaders <$> request -- |Get a specific header. header :: (WebAppState s, Monad m) => ByteString -> RouteT s m (Maybe ByteString) header k = lookup (mk k) <$> headers --- |Get the 'Request''s parameters (in order captures, HTTP body, URI query).+-- |Read the 'Request''s parameters (in order captures, HTTP body, URI query). params :: (WebAppState s, MonadIO m) => RouteT s m Query-params = fmap mconcat $ sequence [cap, bdy, q]+params = maybe (readAll >>= insertMutVault cachedParamsKey) return =<< lookupMutVault cachedParamsKey where- cap = do- pinfo <- pathInfo <$> request- pth <- path- return $ map toQueryItem $ pathCaptures pth pinfo- where toQueryItem (a,b) = (T.encodeUtf8 a, Just $ T.encodeUtf8 b)- bdy = do- h <- requestHeaders <$> request- case lookup (mk "Content-Type") h of- Just "application/x-www-form-urlencoded" -> parseQuery . BL.toStrict <$> body- Just "multipart/form-data" -> return [] -- TODO: implement me- _ -> return []- q = queryString <$> request+ readAll = mconcat <$> sequence [cap, bdy, queryString <$> request]+ cap = map toQueryItem <$> (pathCaptures <$> path <*> (pathInfo <$> request))+ bdy = request >>= maybe (return []) bodyParamsFor . lookup (mk "Content-Type") . requestHeaders+ bodyParamsFor "application/x-www-form-urlencoded" = parseQuery . BL.toStrict <$> body+ bodyParamsFor "multipart/form-data" = return [] -- TODO: implement me+ bodyParamsFor _ = return []+ toQueryItem (a, b) = (T.encodeUtf8 a, Just $ T.encodeUtf8 b) -- |Get a specific header. Will call 'next' if the parameter isn't present. param :: (WebAppState s, MonadIO m, Parameter a) => ByteString -> RouteT s m a@@ -274,38 +216,104 @@ -- |Get a specific header. Will not interfere with route evaluation. maybeParam :: (WebAppState s, MonadIO m, Parameter a) => ByteString -> RouteT s m (Maybe a)-maybeParam k = f . lookup k <$> params- where f (Just (Just v)) = maybeRead v- f _ = Nothing---- |Get an action that reads a chunk from the request body.--- Incompatible with 'body'.-bodyReader :: (WebAppState s, MonadIO m) => RouteT s m (IO ByteString)-bodyReader = RouteT $ \_ _ _ r -> return $ Right (requestBody r,Nothing,[],Nothing)+maybeParam k = f . lookup k <$> params where f x = join x >>= maybeRead -- |Read the request body as a lazy 'ByteString'.--- Incompatible with 'bodyReader'. body :: (WebAppState s, MonadIO m) => RouteT s m BL.ByteString-body = do- tvar <- bodyTVar- act <- fmap requestBody request- liftIO $ persisted tvar act+body = maybe (request >>= liftIO . lazyRead . requestBody >>= insertMutVault cachedBodyKey) return =<< lookupMutVault cachedBodyKey+ where lazyRead rd = unsafeInterleaveIO $ rd >>= f+ where f c = bool (BL.Chunk c <$> lazyRead rd) (return BL.Empty) $ B.null c++{- ROUTE DEFINITION -}++-- |Match all requests and paths.+matchAll :: (WebAppState s, Monad m) => RouteT s m () -> Route s m+matchAll = Route (const True) (regex ".*")++{-# INLINE get #-}+{-# INLINE post #-}+{-# INLINE put #-}+{-# INLINE patch #-}+{-# INLINE delete #-}+{-# INLINE options #-}+get,post,put,patch,delete,options :: (WebAppState s, Monad m) => Path -> RouteT s m () -> Route s m+get = method methodGet+post = method methodPost+put = method methodPut+patch = method methodPatch+delete = method methodDelete+options = method methodOptions++-- |Match a route based on the request's HTTP method.+method :: (WebAppState s, Monad m) => Method -> Path -> RouteT s m () -> Route s m+method m = Route $ (==) m . requestMethod++{- Route Evaluation -}++-- |Makes an 'Application' from routes and middleware.+toApplication :: (WebAppState s, Monad m)+ => (m (Maybe Response) -> IO (Maybe Response)) -- ^ run your monadic type to IO+ -> [Route s m] -- ^ routes+ -> [Middleware] -- ^ middlewares+ -> (Application, IO ()) -- ^ (application, teardown action)+toApplication runToIO routes mws = (app', readTVarIO st >>= destroyState) where- bodyTVar = RouteT $ \_ _ b _ -> return $ Right (b,Nothing,[],Nothing)- persisted tvar act = do- remaining <- lazyRead act- atomically $ do- alreadyRead <- readTVar tvar- writeTVar tvar $ alreadyRead <> remaining- readTVar tvar- lazyRead f = unsafeInterleaveIO $ do- c <- f- if B.null c- then return BL.Empty- else BL.Chunk c <$> (lazyRead f)+ st = unsafePerformIO (newTVarIO =<< initState)+ {-# NOINLINE st #-}+ plainText = [("Content-Type", "text/plain; charset=utf-8")]+ app' = foldl (flip ($)) app mws+ app req callback = go =<< findSuccessful routeMatches runRoute routes+ where+ runRoute (Route _ pth act) = runToIO $ toResponse <$> runRouteT act st pth (addMutVault req)+ routeMatches (Route pd pth _) = pd req && pathMatches pth (pathInfo req)+ toResponse (_, (Next, _)) = Nothing+ toResponse (_, (_, cng)) = Just $ flattenResponse cng+ go Nothing = callback $ responseLBS status404 [] mempty+ go (Just (Left e)) = callback $ responseLBS status500 plainText $ BL.pack $ show (e :: SomeException)+ go (Just (Right jawn)) = callback jawn -urlencodedBody :: (WebAppState s, MonadIO m) => RouteT s m Query-urlencodedBody = parseQuery . BL.toStrict <$> body+-- | INTERNAL Find an a that passes a predicate and either errors out or returns something. Returns the error or the something.+findSuccessful :: (Exception e) => (a -> Bool) -> (a -> IO (Maybe b)) -> [a] -> IO (Maybe (Either e b))+findSuccessful _ _ [] = return Nothing+findSuccessful p f (x:xs) = if p x then (try $ f x) >>= go else findSuccessful p f xs+ where+ go (Right Nothing) = findSuccessful p f xs+ go (Right (Just v)) = return $ Just $ Right v+ go (Left e) = return $ Just $ Left e+ + +{- Vault (internal) -} -path :: (WebAppState s, Monad m) => RouteT s m Path-path = RouteT $ \_ pth _ _ -> return $ Right (pth,Nothing,[],Nothing)+-- Used to implement framework functionality + +cachedBodyKey :: Key BL.ByteString+cachedBodyKey = unsafePerformIO V.newKey+{-# NOINLINE cachedBodyKey #-}++cachedParamsKey :: Key Query+cachedParamsKey = unsafePerformIO V.newKey+{-# NOINLINE cachedParamsKey #-}+ +-- Used to implement mutable Vault.+ +mutableVaultKey :: Key (IORef Vault)+mutableVaultKey = unsafePerformIO V.newKey+{-# NOINLINE mutableVaultKey #-}++-- | Adds a "mutable" 'Vault' (@'IORef' 'Vault'@) to a 'Request'.+addMutVault :: Request -> Request+addMutVault r = r { vault = V.insert mutableVaultKey ioRef (vault r) }+ where ioRef = unsafePerformIO $ newIORef V.empty+ {-# NOINLINE ioRef #-}++-- | Exposes the "mutable" 'Vault' for modification/access. DRY.+withMutVaultM :: (WebAppState s, MonadIO m) => (Vault -> RouteT s m (Maybe a, Vault)) -> RouteT s m (Maybe a)+withMutVaultM xform = request >>= maybe (return Nothing) f . V.lookup mutableVaultKey . vault+ where f ior = (liftIO $ readIORef ior) >>= xform >>= uncurry (g ior)+ g ior ret vlt' = (liftIO $ writeIORef ior vlt') $> ret++lookupMutVault :: (WebAppState s, MonadIO m) => Key a -> RouteT s m (Maybe a)+lookupMutVault k = withMutVaultM $ \vlt -> return (V.lookup k vlt, vlt)++insertMutVault :: (WebAppState s, MonadIO m) => Key a -> a -> RouteT s m a+insertMutVault k v = (withMutVaultM $ return . (Nothing,) . V.insert k v) $> v
Web/App/Stream.hs view
@@ -30,6 +30,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Data.Monoid+import Data.Bool -- |An HTTP response body stream. newtype Stream = Stream { runStream :: StreamingBody }@@ -55,6 +56,9 @@ instance (ToStream a) => ToStream [a] where stream True b = (stream False b) <> flusher stream False b = mconcat $ map (stream False) b+ +instance ToStream Stream where+ stream = bool id flush instance ToStream () where stream _ _ = mempty
− Web/App/WebApp.hs
@@ -1,119 +0,0 @@-{-|-Module : Web.App.Monad.WebAppT-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Defines a monoid used for defining routes-and using middleware.--}--{-# LANGUAGE OverloadedStrings, TupleSections, FlexibleInstances #-}--module Web.App.WebApp-(- WebApp(..),- toApplication,- -- * Web App Operations- middleware,- route,- get,- post,- put,- patch,- delete,- options,- anyRequest,- matchAll-) where--import Web.App.State-import Web.App.RouteT-import Web.App.Path-import Web.App.Stream--import Control.Monad.IO.Class-import Control.Concurrent.STM--import Network.Wai-import Network.HTTP.Types.Status-import Network.HTTP.Types.Method--import Data.Monoid---- |Monoid for defining routes & adding middleware.-newtype WebApp s m = WebApp { runWebApp :: ([Route s m],[Middleware]) }--instance (WebAppState s, Monad m) => Monoid (WebApp s m) where- mempty = WebApp ([],[])- mappend (WebApp (r,mw)) (WebApp (r',mw')) = WebApp (r <> r',mw <> mw')---- |Turn a 'WebAppT' computation into a WAI 'Application'.-toApplication :: (WebAppState s, MonadIO m, MonadIO n)- => (m RouteResult -> IO RouteResult) -- ^ function to run WebApp-transformed monad m to IO- -> WebApp s m -- ^ a web app- -> n (Application, -- ^ WAI application- IO ()) -- ^ teardown action; call when shutting down app server-toApplication runToIO webapp = do- st <- liftIO $ newTVarIO =<< initState- let (rts,mws) = runWebApp webapp- app = foldl (flip ($)) (mkApp st rts) mws- teardown = readTVarIO st >>= destroyState- return (app, teardown)- where- plainText = [("Content-Type", "text/plain; charset=utf-8")]- mkApp tvar routes req callback = case findRoute routes req of- Nothing -> callback $ responseLBS status404 plainText "Not found."- Just (remainder,(_,pth,act)) -> do- res <- runToIO $ evalRouteT act tvar pth req- case res of- Nothing -> mkApp tvar remainder req callback- Just (s,h,b) -> callback $ responseStream s h $ runStream b---- |Use a middleware-middleware :: (WebAppState s, Monad m) => Middleware -> WebApp s m-middleware m = WebApp ([],[m])---- |Define a route-route :: (WebAppState s, Monad m) => Predicate -> Path -> RouteT s m () -> WebApp s m-route p pth act = WebApp ([(p,pth,act)],[])--{-# INLINE matchMethod #-}-matchMethod :: Method -> Predicate-matchMethod meth = \r -> (requestMethod r) == meth--{- Monadic matchers -}---- |Match a `GET` request.-get :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m-get p act = route (matchMethod methodGet) p act---- |Match a `POST` request.-post :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m-post p act = route (matchMethod methodPost) p act---- |Match a `PUT` request.-put :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m-put p act = route (matchMethod methodPut) p act---- |Match a `PATCH` request.-patch :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m-patch p act = route (matchMethod methodPatch) p act---- |Match a `DELETE` request.-delete :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m-delete p act = route (matchMethod methodDelete) p act---- |Match a `OPTIONS` request.-options :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m-options p act = route (matchMethod methodOptions) p act---- |Match any request given a path.-anyRequest :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m-anyRequest = route (const True)---- |Match all requests and paths.-matchAll :: (WebAppState s, Monad m) => RouteT s m () -> WebApp s m-matchAll = route (const True) (regex ".*")
webapp.cabal view
@@ -1,8 +1,8 @@ Name: webapp-Version: 0.3.6+Version: 0.4.0 Synopsis: Haskell web app framework based on WAI & Warp-Homepage: https://github.com/fhsjaagshs/webapp-Bug-reports: https://github.com/fhsjaagshs/webapp/issues+Homepage: https://github.com/natesymer/webapp+Bug-reports: https://github.com/natesymer/webapp/issues License: MIT License-file: LICENSE Author: Nathaniel Symer <nate@symer.io>@@ -21,35 +21,28 @@ Exposed-modules: Web.App Web.App.HTTP Web.App.State- Web.App.Middleware- Web.App.Middleware.Gzip Web.App.Parameter Web.App.Path Web.App.RouteT Web.App.Stream Web.App.Main- Web.App.WebApp default-language: Haskell2010- build-depends: base <4.9,+ build-depends: base < 5.0, bytestring,- base16-bytestring, text,- mtl, stm, transformers, wai, warp, warp-tls, network,- streaming-commons, regex-posix, http-types, unix, blaze-builder,- zlib, optparse-applicative,- aeson,- case-insensitive+ case-insensitive,+ vault source-repository head type: git