webapp 0.4.0 → 0.4.1
raw patch · 18 files changed
+939/−921 lines, 18 filesdep +arraydep +hspecdep +regex-basedep −regex-posixdep ~base
Dependencies added: array, hspec, regex-base, regex-pcre-builtin, webapp
Dependencies removed: regex-posix
Dependency ranges changed: base
Files
- Web/App.hs +0/−28
- Web/App/HTTP.hs +0/−73
- Web/App/Main.hs +0/−150
- Web/App/Parameter.hs +0/−113
- Web/App/Path.hs +0/−123
- Web/App/RouteT.hs +0/−319
- Web/App/State.hs +0/−29
- Web/App/Stream.hs +0/−83
- src/Web/App.hs +28/−0
- src/Web/App/HTTP.hs +73/−0
- src/Web/App/Main.hs +150/−0
- src/Web/App/Parameter.hs +113/−0
- src/Web/App/Path.hs +123/−0
- src/Web/App/RouteT.hs +319/−0
- src/Web/App/State.hs +29/−0
- src/Web/App/Stream.hs +83/−0
- test/Spec.hs +1/−0
- webapp.cabal +20/−3
− Web/App.hs
@@ -1,28 +0,0 @@-{-|-Module : Web.App-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Root module of webapp.--}--module Web.App-(- module Web.App.HTTP,- module Web.App.Main,- module Web.App.Path,- module Web.App.RouteT,- module Web.App.State,- module Web.App.Stream-)-where--import Web.App.HTTP-import Web.App.Main-import Web.App.Path-import Web.App.RouteT-import Web.App.State-import Web.App.Stream
− Web/App/HTTP.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE OverloadedStrings, RankNTypes #-}--{-|-Module : Web.App.HTTP-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--}--module Web.App.HTTP-(- runServer-)-where--import Network.Wai (Application)-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--import Data.List (sortOn)-import Data.Maybe (fromJust)-import Data.Bool (bool)---- | 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 ()-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---- | 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
@@ -1,150 +0,0 @@-{-|-Module : Web.App.Main-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Main functions for running webapps. They provide a CLI interface-to the Web.App.HTTP module. They are designed to be used like--@-module Main where--import Web.App--routes :: (WebAppState s, MonadIO m) => [Route s m]-routes = [] -- routes go here--main :: IO ()-main = webappMain' routes []-@---}--{-# LANGUAGE TupleSections #-}--module Web.App.Main-(- webappMain,- webappMain',- webappMainIO,- webappMainIO',- webappMainSimple,-)-where--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--import Control.Applicative-import Options.Applicative-import System.Posix-import System.Exit-import System.Environment-import System.IO--import GHC.IO.Handle--import Text.Read--data Options = Options {- _optionsDaemonize :: Maybe FilePath,- _optionsPort :: Int,- _optionsHTTPSSLCert :: Maybe FilePath,- _optionsHTTPSSLKey :: Maybe FilePath,- _optionsOutputPath :: Maybe FilePath,- _optionsErrorPath :: Maybe FilePath-}--webappMainSimple :: (WebAppState s) => [Route s IO] -> IO ()-webappMainSimple = flip webappMainIO' []---- |Like 'webappMainIO' without the CLI extension arguments.-webappMainIO' :: (WebAppState s)- => [Route s IO] -- ^ routes- -> [Middleware] -- ^ middlewares- -> IO ()-webappMainIO' a m = webappMainIO a m Nothing (const $ return ())- --- |Run a webapp based on IO.-webappMainIO :: (WebAppState s)- => [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 ()-webappMainIO = webappMain id---- |Like 'webappMain' without the CLI extension arguments.-webappMain' :: (WebAppState s, MonadIO m)- => (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 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 (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 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- forkProcess $ do- createSession- forkProcess $ do- getProcessID >>= writeFile pidFile . show- redirectHandle stdout $ fromMaybe "/dev/null" o- redirectHandle stderr $ fromMaybe "/dev/null" e- redirectHandle stdin "/dev/null"- installHandler sigHUP Ignore Nothing- start p c k Nothing Nothing- exitImmediately ExitSuccess- exitImmediately ExitSuccess- 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- -parseArgs :: Maybe (Parser a) -> IO (Either a Options)-parseArgs extra = do- defaultPort <- ((=<<) readMaybe) <$> lookupEnv "PORT"- customExecParser pprefs $ info (helper <*> parser defaultPort) fullDesc- where- 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.")- <*> (option auto $ long "port" <> short 'p' <> metavar "PORT" <> help "Run server on PORT." <> value (fromMaybe 3000 port))- <*> (optional $ strOption $ long "ssl-cert" <> short 'c' <> metavar "FILEPATH" <> help "SSL certificate file. If a certificate and key are provided, the server will be run secure.")- <*> (optional $ strOption $ long "ssl-key" <> short 'k' <> metavar "FILEPATH" <> help "SSL private key file. If a certificate and key are provided, the server will be run secure.")- <*> (optional $ strOption $ long "output-log" <> short 'o' <> metavar "FILEPATH" <> help "Redirect output to FILEPATH.")- <*> (optional $ strOption $ long "error-log" <> short 'e' <> metavar "FILEPATH" <> help "Redirect error to FILEPATH.")
− Web/App/Parameter.hs
@@ -1,113 +0,0 @@-{-# LANGUAGE OverloadedStrings, ViewPatterns #-}--module Web.App.Parameter-(- Parameter(..)-)-where- -import GHC.Float (double2Float)-import Data.Maybe-import Data.Word-import Data.Int-import Data.Char-import qualified Data.Text as T (Text)-import qualified Data.Text.Encoding as T (decodeUtf8)-import qualified Data.Text.Lazy as TL (Text)-import qualified Data.Text.Lazy.Encoding as TL (decodeUtf8)-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as BL (ByteString,fromStrict)- -class Parameter a where- maybeRead :: B.ByteString -> Maybe a- maybeReadList :: B.ByteString -> [a]- maybeReadList = catMaybes . map maybeRead . B.split ','- -instance Parameter () where- maybeRead x- | B.null x = Just ()- | otherwise = Nothing- -instance Parameter Bool where- maybeRead = f . B.map toLower- where- f "true" = Just True- f "false" = Just False- f "t" = Just True- f "f" = Just False- f "yes" = Just True- f "no" = Just False- f "y" = Just True- 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- maybeRead = Just . T.decodeUtf8- -instance Parameter TL.Text where- maybeRead = fmap TL.decodeUtf8 . maybeRead--instance Parameter B.ByteString where- maybeRead = Just- -instance Parameter BL.ByteString where- maybeRead = Just . BL.fromStrict- -instance Parameter Char where- maybeRead x- | B.length x == 1 = Just $ B.head x- | otherwise = Nothing- maybeReadList = B.unpack- -instance (Parameter a) => Parameter [a] where- maybeRead = Just . maybeReadList- -instance Parameter Double where- maybeRead "" = Nothing- maybeRead (B.uncons -> Just ('-',xs)) = negate <$> maybeRead xs- 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')- maybeRead x = (+) (fromMaybe 0 $ maybeRead xs) <$> x''- where (x',xs) = B.span isDigit x- x'' = fromInteger . fst <$> B.readInteger x'--instance Parameter Float where- maybeRead = fmap double2Float . maybeRead--instance Parameter Integer where- maybeRead = fmap fst . B.readInteger--instance Parameter Int where- maybeRead = fmap fst . B.readInt--instance Parameter Int8 where- maybeRead = fmap (fromInteger . fst) . B.readInteger- -instance Parameter Int16 where- maybeRead = fmap (fromInteger . fst) . B.readInteger- -instance Parameter Int32 where- maybeRead = fmap (fromInteger . fst) . B.readInteger- -instance Parameter Int64 where- maybeRead = fmap (fromInteger . fst) . B.readInteger--instance Parameter Word where- maybeRead = fmap (fromInteger . fst) . B.readInteger- -instance Parameter Word8 where- maybeRead = fmap (fromInteger . fst) . B.readInteger- -instance Parameter Word16 where- maybeRead = fmap (fromInteger . fst) . B.readInteger- -instance Parameter Word32 where- maybeRead = fmap (fromInteger . fst) . B.readInteger- -instance Parameter Word64 where- maybeRead = fmap (fromInteger . fst) . B.readInteger
− Web/App/Path.hs
@@ -1,123 +0,0 @@-{-|-Module : Web.App.Path-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Path matching/parsing functionality--}--{-# LANGUAGE OverloadedStrings #-}--module Web.App.Path-(- -- * Types- Path,- -- * Path Constructors- literal,- captured,- regex,- -- * Path Operations- isRoot,- pathMatches,- pathCaptures,- -- * Path Components Operations- splitPathComps,- joinPathComps,- isValidPathComps-)-where--import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.ByteString as B-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)--{- TYPES -}---- TODO: CapturedPath needs to store indeces of captures as an optimization---- |Describes a matchable path.-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 = 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 . splitPathComps---- |Construct a captured 'Path'.-captured :: Text -> Path-captured = CapturedPath . splitPathComps---- |Construct a regex 'Path'.-regex :: Text -> Path-regex = RegexPath . makeRegex . T.encodeUtf8--{- PATH OPERATIONS -}---- | Returns @True@ if given path is the root.-isRoot :: Path -> Bool-isRoot = flip pathMatches (splitPathComps "/")---- | 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 ':')---- | Returns path captures by comparing @path@ to @pathComps@.-pathCaptures :: Path -- ^ path- -> [Text] -- ^ pathComps- -> [(Text, Text)]-pathCaptures (LiteralPath _) _ = []-pathCaptures (RegexPath r) pin = maybe [] (\(_, x, _, xs) -> f (x:xs)) matched- where- 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) = 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
@@ -1,319 +0,0 @@-{-|-Module : Web.App.RouteT-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Monad transformer used for defining web app routes.--}--{-# LANGUAGE OverloadedStrings, TupleSections #-}--module Web.App.RouteT-(- toApplication,- -- * Types- RouteT,- Route(..),- -- * Routes- get,- post,- put,- patch,- delete,- options,- method,- matchAll,- -- * Monadic actions- halt,- next,- writeBody,- request,- addHeader,- status,- headers,- header,- redirect,- params,- param,- maybeParam,- body,- getState,- putState-)-where--import Web.App.State-import Web.App.Path-import Web.App.Stream-import Web.App.Parameter--import Control.Exception-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Concurrent.STM--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.Bool-import Data.Monoid-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(..))-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.Text.Encoding as T--data Route s m = Route {- _routePredicate :: Request -> Bool,- _routePath :: Path,- _routeAction :: RouteT s m ()-}--data EvalState = Normal -- ^ continue executing as normal- | Next -- ^ skip to the next route- | Halt -- ^ stop evaluation altogether- deriving (Eq)--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- -> Request -- ^ request being served- -> m (a, (EvalState, [ResponseChange]))-}--instance (WebAppState s, Functor m) => Functor (RouteT s m) where- 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 (a, (Normal, mempty))- (<*>) = ap--instance (WebAppState s, Monad m) => Monad (RouteT s m) where- 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 . (,(Normal, mempty))--instance (WebAppState s, MonadIO m) => MonadIO (RouteT s m) where- liftIO = lift . liftIO--{- Monadic actions -}---- |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))---- |INTERNAL Get the state TVar.-stateTVar :: (WebAppState s, Monad m) => RouteT s m (TVar s)-stateTVar = RouteT $ \st _ _ -> return (st, (Normal, mempty))---- |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 (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 = context Normal [AddHeaders [(k, v)]]---- |Set the HTTP status.-status :: (WebAppState s, Monad m) => Status -> RouteT s m ()-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 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 [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---- |Read the 'Request''s parameters (in order captures, HTTP body, URI query).-params :: (WebAppState s, MonadIO m) => RouteT s m Query-params = maybe (readAll >>= insertMutVault cachedParamsKey) return =<< lookupMutVault cachedParamsKey- where- 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-param k = maybeParam k >>= maybe next return---- |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 x = join x >>= maybeRead---- |Read the request body as a lazy 'ByteString'.-body :: (WebAppState s, MonadIO m) => RouteT s m BL.ByteString-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- 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---- | 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) -}---- 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/State.hs
@@ -1,29 +0,0 @@-{-|-Module : Web.App.State-Copyright : (c) Nathaniel Symer, 2016-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Typeclass all types to be used as state for a WebApp-must have an instance of.--}--module Web.App.State-(- WebAppState(..)-)-where- --- |Defines a common interface for an app's state.-class WebAppState s where- -- |Create an app state- initState :: IO s- -- |Destroy an app state- destroyState :: s -- ^ the state to destroy- -> IO ()- -instance WebAppState () where- initState = return ()- destroyState _ = return ()
− Web/App/Stream.hs
@@ -1,83 +0,0 @@-{-|-Module : Web.App.Stream-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--@newtype@ wrapper around a WAI 'StreamingBody'.--}--{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}--module Web.App.Stream-(- Stream(..),- ToStream(..),- flush,- flusher-)-where- -import Network.Wai (StreamingBody)-import Blaze.ByteString.Builder hiding (flush)-import Blaze.ByteString.Builder.Char8 hiding (fromString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-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 }--instance Monoid Stream where- mempty = Stream $ \_ _ -> return ()- mappend (Stream a) (Stream b) = Stream $ \w f -> a w f >> b w f---- |Flush a stream.-flush :: Stream -> Stream-flush s = s <> flusher---- |A stream that flushes written data.-flusher :: Stream-flusher = Stream $ \_ f -> f---- |Turn data into a WAI stream.-class ToStream a where- stream :: Bool -> a -> Stream -- ^ stream with the option to flush- stream' :: a -> Stream -- ^ stream and flush- stream' = stream True--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- -instance ToStream Builder where- stream False b = Stream $ \w _ -> w b- stream True b = Stream $ \w f -> w b >> f--instance ToStream Char where- stream f = stream f . fromChar--instance ToStream T.Text where- stream f = stream f . T.encodeUtf8--instance ToStream TL.Text where- stream f = stream f . TL.encodeUtf8- -instance ToStream B.ByteString where- stream f = stream f . fromByteString- -instance ToStream BL.ByteString where- stream f = stream f . fromLazyByteString
+ src/Web/App.hs view
@@ -0,0 +1,28 @@+{-|+Module : Web.App+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Root module of webapp.+-}++module Web.App+(+ module Web.App.HTTP,+ module Web.App.Main,+ module Web.App.Path,+ module Web.App.RouteT,+ module Web.App.State,+ module Web.App.Stream+)+where++import Web.App.HTTP+import Web.App.Main+import Web.App.Path+import Web.App.RouteT+import Web.App.State+import Web.App.Stream
+ src/Web/App/HTTP.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings, RankNTypes #-}++{-|+Module : Web.App.HTTP+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX+-}++module Web.App.HTTP+(+ runServer+)+where++import Network.Wai (Application)+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++import Data.List (sortOn)+import Data.Maybe (fromJust)+import Data.Bool (bool)++-- | 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 ()+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++-- | 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')
+ src/Web/App/Main.hs view
@@ -0,0 +1,150 @@+{-|+Module : Web.App.Main+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Main functions for running webapps. They provide a CLI interface+to the Web.App.HTTP module. They are designed to be used like++@+module Main where++import Web.App++routes :: (WebAppState s, MonadIO m) => [Route s m]+routes = [] -- routes go here++main :: IO ()+main = webappMain' routes []+@++-}++{-# LANGUAGE TupleSections #-}++module Web.App.Main+(+ webappMain,+ webappMain',+ webappMainIO,+ webappMainIO',+ webappMainSimple,+)+where++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++import Control.Applicative+import Options.Applicative+import System.Posix+import System.Exit+import System.Environment+import System.IO++import GHC.IO.Handle++import Text.Read++data Options = Options {+ _optionsDaemonize :: Maybe FilePath,+ _optionsPort :: Int,+ _optionsHTTPSSLCert :: Maybe FilePath,+ _optionsHTTPSSLKey :: Maybe FilePath,+ _optionsOutputPath :: Maybe FilePath,+ _optionsErrorPath :: Maybe FilePath+}++webappMainSimple :: (WebAppState s) => [Route s IO] -> IO ()+webappMainSimple = flip webappMainIO' []++-- |Like 'webappMainIO' without the CLI extension arguments.+webappMainIO' :: (WebAppState s)+ => [Route s IO] -- ^ routes+ -> [Middleware] -- ^ middlewares+ -> IO ()+webappMainIO' a m = webappMainIO a m Nothing (const $ return ())+ +-- |Run a webapp based on IO.+webappMainIO :: (WebAppState s)+ => [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 ()+webappMainIO = webappMain id++-- |Like 'webappMain' without the CLI extension arguments.+webappMain' :: (WebAppState s, MonadIO m)+ => (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 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 (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 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+ forkProcess $ do+ createSession+ forkProcess $ do+ getProcessID >>= writeFile pidFile . show+ redirectHandle stdout $ fromMaybe "/dev/null" o+ redirectHandle stderr $ fromMaybe "/dev/null" e+ redirectHandle stdin "/dev/null"+ installHandler sigHUP Ignore Nothing+ start p c k Nothing Nothing+ exitImmediately ExitSuccess+ exitImmediately ExitSuccess+ 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+ +parseArgs :: Maybe (Parser a) -> IO (Either a Options)+parseArgs extra = do+ defaultPort <- ((=<<) readMaybe) <$> lookupEnv "PORT"+ customExecParser pprefs $ info (helper <*> parser defaultPort) fullDesc+ where+ 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.")+ <*> (option auto $ long "port" <> short 'p' <> metavar "PORT" <> help "Run server on PORT." <> value (fromMaybe 3000 port))+ <*> (optional $ strOption $ long "ssl-cert" <> short 'c' <> metavar "FILEPATH" <> help "SSL certificate file. If a certificate and key are provided, the server will be run secure.")+ <*> (optional $ strOption $ long "ssl-key" <> short 'k' <> metavar "FILEPATH" <> help "SSL private key file. If a certificate and key are provided, the server will be run secure.")+ <*> (optional $ strOption $ long "output-log" <> short 'o' <> metavar "FILEPATH" <> help "Redirect output to FILEPATH.")+ <*> (optional $ strOption $ long "error-log" <> short 'e' <> metavar "FILEPATH" <> help "Redirect error to FILEPATH.")
+ src/Web/App/Parameter.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings, ViewPatterns #-}++module Web.App.Parameter+(+ Parameter(..)+)+where+ +import GHC.Float (double2Float)+import Data.Maybe+import Data.Word+import Data.Int+import Data.Char+import qualified Data.Text as T (Text)+import qualified Data.Text.Encoding as T (decodeUtf8)+import qualified Data.Text.Lazy as TL (Text)+import qualified Data.Text.Lazy.Encoding as TL (decodeUtf8)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL (ByteString,fromStrict)+ +class Parameter a where+ maybeRead :: B.ByteString -> Maybe a+ maybeReadList :: B.ByteString -> [a]+ maybeReadList = catMaybes . map maybeRead . B.split ','+ +instance Parameter () where+ maybeRead x+ | B.null x = Just ()+ | otherwise = Nothing+ +instance Parameter Bool where+ maybeRead = f . B.map toLower+ where+ f "true" = Just True+ f "false" = Just False+ f "t" = Just True+ f "f" = Just False+ f "yes" = Just True+ f "no" = Just False+ f "y" = Just True+ 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+ maybeRead = Just . T.decodeUtf8+ +instance Parameter TL.Text where+ maybeRead = fmap TL.decodeUtf8 . maybeRead++instance Parameter B.ByteString where+ maybeRead = Just+ +instance Parameter BL.ByteString where+ maybeRead = Just . BL.fromStrict+ +instance Parameter Char where+ maybeRead x+ | B.length x == 1 = Just $ B.head x+ | otherwise = Nothing+ maybeReadList = B.unpack+ +instance (Parameter a) => Parameter [a] where+ maybeRead = Just . maybeReadList+ +instance Parameter Double where+ maybeRead "" = Nothing+ maybeRead (B.uncons -> Just ('-',xs)) = negate <$> maybeRead xs+ 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')+ maybeRead x = (+) (fromMaybe 0 $ maybeRead xs) <$> x''+ where (x',xs) = B.span isDigit x+ x'' = fromInteger . fst <$> B.readInteger x'++instance Parameter Float where+ maybeRead = fmap double2Float . maybeRead++instance Parameter Integer where+ maybeRead = fmap fst . B.readInteger++instance Parameter Int where+ maybeRead = fmap fst . B.readInt++instance Parameter Int8 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Int16 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Int32 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Int64 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger++instance Parameter Word where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Word8 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Word16 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Word32 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Word64 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger
+ src/Web/App/Path.hs view
@@ -0,0 +1,123 @@+{-|+Module : Web.App.Path+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Path matching/parsing functionality+-}++{-# LANGUAGE OverloadedStrings #-}++module Web.App.Path+(+ -- * Types+ Path,+ -- * Path Constructors+ literal,+ captured,+ regex,+ -- * Path Operations+ isRoot,+ pathMatches,+ pathCaptures,+ -- * Path Components Operations+ splitPathComps,+ joinPathComps,+ isValidPathComps+)+where++import qualified Data.Array as A+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Text.Regex.PCRE+import Data.List+import Data.String+import Data.Char (isAlphaNum)+import Data.Maybe (isJust)+import Data.Bool (bool)+import Control.Monad (join)++{- TYPES -}++-- TODO: CapturedPath needs to store indeces of captures as an optimization++-- |Describes a matchable path.+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 = 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 . splitPathComps++-- |Construct a captured 'Path'.+captured :: Text -> Path+captured = CapturedPath . splitPathComps++-- TODO: configure PCRE to use single line mode+-- |Construct a regex 'Path'.+regex :: Text -> Path+regex = RegexPath . makeRegexOpts comp exec . T.encodeUtf8+ where comp = defaultCompOpt+ exec = defaultExecOpt++{- PATH OPERATIONS -}++-- | Returns @True@ if given path is the root.+isRoot :: Path -> Bool+isRoot = flip pathMatches (splitPathComps "/")++-- | 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 ':')++-- | Returns path captures by comparing @path@ to @pathComps@.+pathCaptures :: Path -- ^ path+ -> [Text] -- ^ pathComps+ -> [(Text, Text)]+pathCaptures (LiteralPath _) _ = []+pathCaptures (RegexPath r) pin = maybe [(T.pack "fuck", T.pack "you")] (readMatches pstr) (matchOnce r pstr)+ where+ pstr = T.encodeUtf8 $ joinPathComps pin+ readMatches bs arr = [(T.pack $ show i, T.decodeUtf8 $ extract (arr A.! i) bs) | i <- A.range $ A.bounds arr]+pathCaptures (CapturedPath cap) pin = f [] cap pin+ where+ f acc [] [] = reverse acc+ 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))
+ src/Web/App/RouteT.hs view
@@ -0,0 +1,319 @@+{-|+Module : Web.App.RouteT+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Monad transformer used for defining web app routes.+-}++{-# LANGUAGE OverloadedStrings, TupleSections #-}++module Web.App.RouteT+(+ toApplication,+ -- * Types+ RouteT,+ Route(..),+ -- * Routes+ get,+ post,+ put,+ patch,+ delete,+ options,+ method,+ matchAll,+ -- * Monadic actions+ halt,+ next,+ writeBody,+ request,+ addHeader,+ status,+ headers,+ header,+ redirect,+ params,+ param,+ maybeParam,+ body,+ getState,+ putState+)+where++import Web.App.State+import Web.App.Path+import Web.App.Stream+import Web.App.Parameter++import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Concurrent.STM++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.Bool+import Data.Monoid+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(..))+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Text.Encoding as T++data Route s m = Route {+ _routePredicate :: Request -> Bool,+ _routePath :: Path,+ _routeAction :: RouteT s m ()+}++data EvalState = Normal -- ^ continue executing as normal+ | Next -- ^ skip to the next route+ | Halt -- ^ stop evaluation altogether+ deriving (Eq)++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+ -> Request -- ^ request being served+ -> m (a, (EvalState, [ResponseChange]))+}++instance (WebAppState s, Functor m) => Functor (RouteT s m) where+ 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 (a, (Normal, mempty))+ (<*>) = ap++instance (WebAppState s, Monad m) => Monad (RouteT s m) where+ 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 . (,(Normal, mempty))++instance (WebAppState s, MonadIO m) => MonadIO (RouteT s m) where+ liftIO = lift . liftIO++{- Monadic actions -}++-- |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))++-- |INTERNAL Get the state TVar.+stateTVar :: (WebAppState s, Monad m) => RouteT s m (TVar s)+stateTVar = RouteT $ \st _ _ -> return (st, (Normal, mempty))++-- |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 (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 = context Normal [AddHeaders [(k, v)]]++-- |Set the HTTP status.+status :: (WebAppState s, Monad m) => Status -> RouteT s m ()+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 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 [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++-- |Read the 'Request''s parameters (in order captures, HTTP body, URI query).+params :: (WebAppState s, MonadIO m) => RouteT s m Query+params = maybe (readAll >>= insertMutVault cachedParamsKey) return =<< lookupMutVault cachedParamsKey+ where+ 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+param k = maybeParam k >>= maybe next return++-- |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 x = join x >>= maybeRead++-- |Read the request body as a lazy 'ByteString'.+body :: (WebAppState s, MonadIO m) => RouteT s m BL.ByteString+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+ 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++-- | 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) -}++-- 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
+ src/Web/App/State.hs view
@@ -0,0 +1,29 @@+{-|+Module : Web.App.State+Copyright : (c) Nathaniel Symer, 2016+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Typeclass all types to be used as state for a WebApp+must have an instance of.+-}++module Web.App.State+(+ WebAppState(..)+)+where+ +-- |Defines a common interface for an app's state.+class WebAppState s where+ -- |Create an app state+ initState :: IO s+ -- |Destroy an app state+ destroyState :: s -- ^ the state to destroy+ -> IO ()+ +instance WebAppState () where+ initState = return ()+ destroyState _ = return ()
+ src/Web/App/Stream.hs view
@@ -0,0 +1,83 @@+{-|+Module : Web.App.Stream+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++@newtype@ wrapper around a WAI 'StreamingBody'.+-}++{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++module Web.App.Stream+(+ Stream(..),+ ToStream(..),+ flush,+ flusher+)+where+ +import Network.Wai (StreamingBody)+import Blaze.ByteString.Builder hiding (flush)+import Blaze.ByteString.Builder.Char8 hiding (fromString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+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 }++instance Monoid Stream where+ mempty = Stream $ \_ _ -> return ()+ mappend (Stream a) (Stream b) = Stream $ \w f -> a w f >> b w f++-- |Flush a stream.+flush :: Stream -> Stream+flush s = s <> flusher++-- |A stream that flushes written data.+flusher :: Stream+flusher = Stream $ \_ f -> f++-- |Turn data into a WAI stream.+class ToStream a where+ stream :: Bool -> a -> Stream -- ^ stream with the option to flush+ stream' :: a -> Stream -- ^ stream and flush+ stream' = stream True++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+ +instance ToStream Builder where+ stream False b = Stream $ \w _ -> w b+ stream True b = Stream $ \w f -> w b >> f++instance ToStream Char where+ stream f = stream f . fromChar++instance ToStream T.Text where+ stream f = stream f . T.encodeUtf8++instance ToStream TL.Text where+ stream f = stream f . TL.encodeUtf8+ +instance ToStream B.ByteString where+ stream f = stream f . fromByteString+ +instance ToStream BL.ByteString where+ stream f = stream f . fromLazyByteString
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
webapp.cabal view
@@ -1,5 +1,5 @@ Name: webapp-Version: 0.4.0+Version: 0.4.1 Synopsis: Haskell web app framework based on WAI & Warp Homepage: https://github.com/natesymer/webapp Bug-reports: https://github.com/natesymer/webapp/issues@@ -11,12 +11,13 @@ Category: Web Stability: experimental Build-type: Simple-Cabal-version: >= 1.10+Cabal-version: >= 1.24 Description: See README.md Extra-source-files: README.md CHANGELOG.md Library+ hs-source-dirs: src ghc-options: -Wall -fno-warn-unused-do-bind Exposed-modules: Web.App Web.App.HTTP@@ -28,6 +29,7 @@ Web.App.Main default-language: Haskell2010 build-depends: base < 5.0,+ array, bytestring, text, stm,@@ -36,13 +38,28 @@ warp, warp-tls, network,- regex-posix,+ regex-pcre-builtin,+ regex-base, http-types, unix, blaze-builder, optparse-applicative, case-insensitive, vault++Test-Suite test-webapp+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ default-language: Haskell2010+ build-depends: base,+ network,+ text,+ transformers,+ wai,+ http-types,+ hspec,+ webapp source-repository head type: git