diff --git a/growler.cabal b/growler.cabal --- a/growler.cabal +++ b/growler.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: growler -version: 0.2.0 +version: 0.3.0 synopsis: A revised version of the scotty library that attempts to be simpler and more performant. description: Growler provides a very similar interface to scotty, with slight tweaks for performance and a few feature tradeoffs. Growler provides the ability to abort actions (handlers) with arbitrary responses, not just in the event of redirects or raising errors. Growler avoids coercing everything into lazy Text values and reading the whole request body into memory. It also eliminates the ability to abort the handler and have another handler handle the request instead (Scotty's 'next' function). . diff --git a/src/Web/Growler.hs b/src/Web/Growler.hs --- a/src/Web/Growler.hs +++ b/src/Web/Growler.hs @@ -65,7 +65,7 @@ import Web.Growler.Handler import Web.Growler.Parsable import Web.Growler.Router -import Web.Growler.Types hiding (status, headers, params, request) +import Web.Growler.Types hiding (status, headers, params, request, capture) growl :: MonadIO m => (forall a. m a -> IO a) -> HandlerT m () -> GrowlerT m () -> IO () growl trans fb g = do diff --git a/src/Web/Growler/Router.hs b/src/Web/Growler/Router.hs --- a/src/Web/Growler/Router.hs +++ b/src/Web/Growler/Router.hs @@ -16,6 +16,7 @@ , capture , regex , function + , mount , literal , route , RoutePattern(..) @@ -24,12 +25,13 @@ import Control.Arrow ((***)) import Control.Monad.State hiding (get, put) +import qualified Control.Monad.State as S import Control.Monad.Trans import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import Data.Maybe (fromMaybe) -import Data.Monoid (mconcat) +import Data.Monoid ((<>), mconcat) import Data.String (fromString) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -42,8 +44,23 @@ import qualified Text.Regex as Regex import Web.Growler.Handler -import Web.Growler.Types hiding (status) +import Web.Growler.Types hiding (status, capture) + +mount :: Monad m => RoutePattern -> GrowlerT m () -> GrowlerT m () +mount pat m = GrowlerT $ do + previous <- S.get + -- create inner scope that doesn't affect external routes + S.put [] + fromGrowlerT m + modify' (fmap $ \(m, p, h) -> (m, pat <> p, h)) + new <- S.get + S.put (new ++ previous) + + +handlerHook :: Monad m => (HandlerT m () -> HandlerT m ()) -> GrowlerT m () +handlerHook f = GrowlerT $ modify' (fmap $ \(m, p, h) -> (m, p, f h)) + -- | get = 'addroute' 'GET' get :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m () get = addRoute GET @@ -96,24 +113,12 @@ else Nothing matchRoute :: RoutePattern -> Request -> Maybe [Param] -matchRoute (Literal pat) req | pat == path req = Just [] - | otherwise = Nothing -matchRoute (Function _ fun) req = fun req -matchRoute (Capture pat) req = go (T.split (== '/') pat) (T.split (== '/') $ path req) [] - where go [] [] prs = Just prs -- request string and pattern match! - go [] r prs | T.null (mconcat r) = Just prs -- in case request has trailing slashes - | otherwise = Nothing -- request string is longer than pattern - go p [] prs | T.null (mconcat p) = Just prs -- in case pattern has trailing slashes - | otherwise = Nothing -- request string is not long enough - go (p:ps) (r:rs) prs | p == r = go ps rs prs -- equal literals, keeping checking - | T.null p = Nothing -- p is null, but r is not, fail - | T.head p == ':' = go ps rs $ (T.encodeUtf8 $ T.tail p, T.encodeUtf8 r) : prs -- p is a capture, add to params - | otherwise = Nothing -- both literals, but unequal, fail +matchRoute (RoutePattern p) req = let (_, _, rps) = p req in case rps of + Fail -> Nothing + Partial _ -> Nothing + Complete ps -> Just ps -- Pretend we are at the top level. -path :: Request -> T.Text -path = T.cons '/' . T.intercalate "/" . pathInfo - parseEncodedParams :: B.ByteString -> [Param] parseEncodedParams bs = [ (T.encodeUtf8 k, T.encodeUtf8 $ fromMaybe "" v) | (k,v) <- parseQueryText bs ] @@ -130,10 +135,14 @@ -- Capture: oo/ba -- regex :: String -> RoutePattern -regex pattern = Function (const $ T.pack pattern) $ \ req -> fmap (map (B.pack . show *** (T.encodeUtf8 . T.pack)) . zip [0 :: Int ..] . strip) - (Regex.matchRegexAll rgx $ T.unpack $ path req) - where rgx = Regex.mkRegex pattern - strip (_, match, _, subs) = match : subs +regex pattern = RoutePattern go + where + go req = (T.pack pattern, req, maybe Fail Complete $ fmap convertParams match) + where + rgx = Regex.mkRegex pattern + strip (_, match, _, subs) = match : subs + match = Regex.matchRegexAll rgx $ T.unpack $ path req + convertParams = map (B.pack . show *** (T.encodeUtf8 . T.pack)) . zip [0 :: Int ..] . strip -- | Standard Sinatra-style route. Named captures are prepended with colons. -- This is the default route type generated by OverloadedString routes. i.e. @@ -162,9 +171,16 @@ -- >>> curl http://localhost:3000/ -- HTTP/1.1 -- -function :: (Request -> T.Text) -> (Request -> Maybe [Param]) -> RoutePattern -function = Function +function :: (Request -> T.Text) -> (Request -> MatchResult) -> RoutePattern +function fn fps = RoutePattern $ \r -> (fn r, r, fps r) -- | Build a route that requires the requested path match exactly, without captures. literal :: String -> RoutePattern -literal = Literal . T.pack +literal pat = RoutePattern go + where + go req = (packed, req { pathInfo = req' }, result) + where + packed = T.pack pat + (result, req') = case T.stripPrefix packed (path req) of + Nothing -> (Fail, []) + Just rem -> if T.null rem then (Complete [], []) else (Partial [], dropWhile (== "") $ T.split (== '/') rem) diff --git a/src/Web/Growler/Types.hs b/src/Web/Growler/Types.hs --- a/src/Web/Growler/Types.hs +++ b/src/Web/Growler/Types.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Web.Growler.Types where import Blaze.ByteString.Builder (Builder) import Control.Applicative @@ -21,20 +22,59 @@ import qualified Data.ByteString.Lazy as L import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Strict as HM +import Data.Monoid import Data.String (IsString (..)) import Data.Text (Text, pack) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Network.HTTP.Types.Header import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai -data RoutePattern = Capture Text - | Literal Text - | Function (Request -> Text) (Request -> Maybe [Param]) +data MatchResult = Fail | Partial [Param] | Complete [Param] + deriving (Show, Eq) +newtype RoutePattern = RoutePattern { runRoutePattern :: Request -> (Text, Request, MatchResult) } + +instance Monoid MatchResult where + mappend l r = case l of + Fail -> Fail + Partial lps -> case r of + Fail -> Fail + Partial rps -> Partial (lps <> rps) + Complete rps -> Complete (lps <> rps) + Complete lps -> Fail + mempty = Partial [] + +instance Monoid RoutePattern where + mappend (RoutePattern a) (RoutePattern b) = RoutePattern $ \r -> let (t1, r', p1) = a r in + let (t2, r'', p2) = b r' in + (t1 <> t2, r'', p1 <> p2) + mempty = RoutePattern $ \r -> ("", r, Partial []) + instance IsString RoutePattern where - fromString = Capture . pack + fromString = capture . T.pack +path :: Request -> T.Text +path = T.cons '/' . T.intercalate "/" . pathInfo + +capture :: Text -> RoutePattern +capture pat = RoutePattern process + where + process req = (pat, req { pathInfo = ss }, res) + where + (res, ss) = go (T.split (== '/') pat) (T.split (== '/') $ path req) [] + go [] [] prs = (Complete prs, []) -- request string and pattern match! + go [] r prs | T.null (mconcat r) = (Complete prs, []) -- in case request has trailing slashes + | otherwise = (Partial prs, r) -- request string is longer than pattern + go p [] prs | T.null (mconcat p) = (Complete prs, []) -- in case pattern has trailing slashes + | otherwise = (Fail, []) -- request string is not long enough + go (p:ps) (r:rs) prs | p == r = go ps rs prs -- equal literals, keeping checking + | T.null p = (Fail, []) -- p is null, but r is not, fail + | T.head p == ':' = go ps rs $ (T.encodeUtf8 $ T.tail p, T.encodeUtf8 r) : prs -- p is a capture, add to params + | otherwise = (Fail, []) -- both literals, but unequal, fail + type Param = (C.ByteString, C.ByteString) data BodySource = FileSource !(FilePath, Maybe FilePart) @@ -101,7 +141,7 @@ type Handler = HandlerT IO -newtype GrowlerT m a = GrowlerT { fromGrowlerT :: StateT [(StdMethod, RoutePattern, HandlerT m ())] m a} +newtype GrowlerT m a = GrowlerT { fromGrowlerT :: StateT [(StdMethod, RoutePattern, HandlerT m ())] m a } instance Functor m => Functor (GrowlerT m) where fmap f (GrowlerT m) = GrowlerT (fmap f m)