diff --git a/growler.cabal b/growler.cabal --- a/growler.cabal +++ b/growler.cabal @@ -2,11 +2,24 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: growler -version: 0.3.2 +version: 0.4.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). . API is still in flux, so use at your own risk. Pull requests / issues are welcome. + . + @ + {-# LANGUAGE OverloadedStrings #-} + . + import Web.Growler + import Data.Monoid ((<>)) + . + main = growl id defaultConfig $ do + get "/" $ text "Hello, World!" + get "/:name" $ do + name <- param "name" + text ("Hello, " <> name <> "!") + @ homepage: http://github.com/iand675/growler license: MIT @@ -22,6 +35,26 @@ library exposed-modules: Web.Growler, Web.Growler.Handler, Web.Growler.Parsable, Web.Growler.Router, Web.Growler.Types other-extensions: OverloadedStrings, FlexibleContexts, FlexibleInstances, LambdaCase, RankNTypes, ScopedTypeVariables - build-depends: base >=4.7 && <4.8, lens >=4.4 && <5, mtl >=2.2 && <3, bytestring >=0.10 && <0.20, http-types >=0.8 && <1, text >=1.1 && <2, wai >=3.0 && <4, wai-extra >=3.0 && <4, regex-compat >=0.95 && <1, blaze-builder >=0.3 && <0.7, unordered-containers >=0.2 && <0.9, aeson, vector, case-insensitive, warp, pipes, pipes-aeson, pipes-wai, monad-control, either >= 4.3.1, transformers-base + build-depends: base >=4.6 && <5, + lens >=4.5 && <5, + mtl >=2.2 && <3, + bytestring >=0.10 && <0.20, + http-types >=0.8 && <1, + text >=1.1 && <2, + wai >=3.0 && <4, + wai-extra >=3.0 && <4, + regex-compat >=0.95 && <1, + blaze-builder >=0.3 && <0.7, + unordered-containers >=0.2 && <0.9, + aeson, + vector, + case-insensitive, + warp, + pipes, + pipes-aeson, + pipes-wai, + monad-control, + either >= 4.3.1, + transformers-base hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Web/Growler.hs b/src/Web/Growler.hs --- a/src/Web/Growler.hs +++ b/src/Web/Growler.hs @@ -1,58 +1,92 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} +{-| + +A Haskell web framework inspired by the Scotty framework, with an +eye towards performance, extensibility, and ease of use. + +> {-# LANGUAGE OverloadedStrings #-} +> module Main where +> import Data.Monoid ((<>)) +> import Web.Growler +> +> main = growl id defaultConfig $ do +> get "/" $ text "Hello, World!" +> get "/:name" $ do +> name <- param "name" +> text ("Hello, " <> name <> "!") + +-} module Web.Growler ( -- ** Running a growler app growl , growler +, defaultConfig +, GrowlerConfig (..) -- ** Routing , Growler , GrowlerT +, regex +, capture +, function +, literal +, mount +, handlerHook +, notFound +-- *** HTTP Methods , get , post , put , delete , patch , matchAny -, notFound +-- *** Primitives , addRoute -, regex -, capture -, function -, literal -, mount -, handlerHook -- ** Handlers , Handler , HandlerT +-- *** Primitive request functions +, request +, routePattern +, params +-- *** Primitive response functions +, file +, builder +, bytestring +, stream +, raw , currentResponse , abort -, status -, addHeader -, setHeader -, body -, html -, json -, file +-- *** Convenience functions +-- **** Request helpers +, lookupParam +, param , formData , headers , jsonData -, params -, raw +-- **** Response helpers +, status +, addHeader +, setHeader +, raise , redirect -, request -, stream , text -, routePattern +, html +, json +, JsonInputError (..) +, DecodingError (..) -- ** Parsable , Parsable (..) , readEither -- ** Internals +, body , BodySource (..) -, ResponseState +, ResponseState (..) , RoutePattern (..) ) where +import Control.Exception (catch) import Control.Lens hiding (get) import Control.Monad.Identity import Control.Monad.State hiding (get, put) @@ -64,23 +98,41 @@ import Network.HTTP.Types.Method import Network.Wai import qualified Network.Wai.Handler.Warp as Warp +import Pipes.Aeson (DecodingError (..)) import Web.Growler.Handler import Web.Growler.Parsable import Web.Growler.Router import Web.Growler.Types hiding (status, headers, params, request, capture) -growl :: MonadIO m => (forall a. m a -> IO a) -> HandlerT m () -> GrowlerT m () -> IO () +-- | The simple approach to starting up a web server +growl :: MonadIO m => (forall a. m a -> IO a) -- ^ A function to convert your base monad of choice into IO. + -> GrowlerConfig m + -> GrowlerT m () -- ^ The router for all the other routes + -> IO () growl trans fb g = do app <- growler trans fb g putStrLn "Growling" Warp.run 3000 app -growler :: MonadIO m => (forall a. m a -> IO a) -> HandlerT m () -> GrowlerT m () -> IO Application -growler trans fallback (GrowlerT m) = do +-- | For more complex needs, access to the actual WAI 'Application'. Useful for adding middleware. +growler :: MonadIO m => (forall a. m a -> IO a) -- ^ A function to convert your base monad of choice into IO. + -> GrowlerConfig m + -> GrowlerT m () -- ^ The router for all the other routes + -> IO Application +growler trans (GrowlerConfig nf er) (GrowlerT m) = do result <- trans $ execStateT m [] return $ app (reverse result ^. vector) where - app rv req respond = trans (growlerRouter rv fallback req) >>= respond + app rv req respond = catch (trans (growlerRouter rv nf req) >>= respond) $ \e -> do + mr <- trans (runHandler initialState Nothing req [] (er e)) + let (ResponseState status' groupedHeaders body') = either id snd mr + let headers = concatMap (\(k, vs) -> map (\v -> (k, v)) vs) $ HM.toList groupedHeaders + respond $ case body' of + FileSource fpath fpart -> responseFile status' headers fpath fpart + BuilderSource b -> responseBuilder status' headers b + LBSSource lbs -> responseLBS status' headers lbs + StreamSource sb -> responseStream status' headers sb + RawSource f r' -> responseRaw f r' growlerRouter :: forall m. MonadIO m => V.Vector (StdMethod, RoutePattern, HandlerT m ()) -> HandlerT m () -> Request -> m Response growlerRouter rv fb r = do @@ -88,13 +140,17 @@ let (ResponseState status' groupedHeaders body') = either id snd rs let headers = concatMap (\(k, vs) -> map (\v -> (k, v)) vs) $ HM.toList groupedHeaders return $! case body' of - FileSource (fpath, fpart) -> responseFile status' headers fpath fpart + FileSource fpath fpart -> responseFile status' headers fpath fpart BuilderSource b -> responseBuilder status' headers b LBSSource lbs -> responseLBS status' headers lbs StreamSource sb -> responseStream status' headers sb - RawSource f r' -> responseRaw f r' + RawSource f r' -> responseRaw f r' where processResponse (m, pat, respond) = case route r m pat of Nothing -> Nothing Just (patRep, ps) -> Just $ runHandler initialState (Just patRep) r ps respond +defaultConfig :: MonadIO m => GrowlerConfig m +defaultConfig = GrowlerConfig notFound $ \e -> do + liftIO $ print e + internalServerError diff --git a/src/Web/Growler/Handler.hs b/src/Web/Growler/Handler.hs --- a/src/Web/Growler/Handler.hs +++ b/src/Web/Growler/Handler.hs @@ -1,6 +1,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} module Web.Growler.Handler where +import Blaze.ByteString.Builder (Builder) import Control.Applicative import Control.Lens import Control.Monad.RWS @@ -10,10 +11,10 @@ import qualified Control.Monad.State.Strict as ST import Data.Aeson hiding ((.=)) import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy.Char8 as L import Data.CaseInsensitive import Data.Maybe import qualified Data.HashMap.Strict as HM -import qualified Data.ByteString.Lazy.Char8 as L import Data.Text as T import Data.Text.Encoding as T import Data.Text.Lazy as TL @@ -22,10 +23,11 @@ import Network.Wai import Network.Wai.Parse hiding (Param) import Network.HTTP.Types +import Web.Growler.Parsable import Web.Growler.Types hiding (status, request, params) import qualified Web.Growler.Types as L -import Pipes.Wai -import Pipes.Aeson +import Pipes.Wai +import Pipes.Aeson initialState :: ResponseState initialState = ResponseState ok200 HM.empty (LBSSource "") @@ -33,83 +35,144 @@ currentResponse :: Monad m => HandlerT m ResponseState currentResponse = HandlerT State.get +-- | End the handler early with an arbitrary 'ResponseState'. abort :: Monad m => ResponseState -> HandlerT m () abort rs = HandlerT $ lift $ left rs +-- | Set the response status code. status :: Monad m => Status -> HandlerT m () status v = HandlerT $ L.status .= v +-- | Add a header to the response. Header names are case-insensitive. addHeader :: Monad m => CI C.ByteString -> C.ByteString -> HandlerT m () addHeader k v = HandlerT (L.headers %= HM.insertWith (\_ v' -> v:v') k [v]) +-- | Set a response header. Overrides duplicate headers of the same name. setHeader :: Monad m => CI C.ByteString -> C.ByteString -> HandlerT m () setHeader k v = HandlerT (L.headers %= HM.insert k [v]) +-- | Set an arbitrary body source for the response. body :: Monad m => BodySource -> HandlerT m () body = HandlerT . (bodySource .=) +-- | Send a file as the response body. +file :: Monad m => FilePath -- ^ The file to send + -> Maybe FilePart -- ^ If 'Nothing', then send the whole file, otherwise, the part specified + -> HandlerT m () +file fpath fpart = HandlerT (bodySource .= FileSource fpath fpart) + +-- | Set the response body to a ByteString 'Builder'. Sets no headers. +builder :: Monad m => Builder + -> HandlerT m () +builder b = HandlerT (bodySource .= BuilderSource b) + +-- | Set the response body to a lazy 'ByteString'. Sets no headers. +bytestring :: Monad m => L.ByteString -> HandlerT m () +bytestring bs = HandlerT (bodySource .= LBSSource bs) + +-- | Send a streaming response body. Sets no headers. +stream :: Monad m => StreamingBody -> HandlerT m () +stream s = HandlerT (bodySource .= StreamSource s) + +-- | Send raw output as the response body. Useful for e.g. websockets. See WAI's @responseRaw@ for more details. +raw :: MonadIO m => (IO C.ByteString -> (C.ByteString -> IO ()) -> IO ()) + -> Response -- ^ Backup response when the WAI provider doesn't support upgrading (e.g. CGI) + -> HandlerT m () +raw f r = HandlerT (bodySource .= RawSource f r) + +-- | Send a value as JSON as the response body. Also sets the content type to application/json. json :: Monad m => ToJSON a => a -> HandlerT m () json x = do body $ LBSSource $ encode x addHeader "Content-Type" "application/json" -file :: Monad m => FilePath -> Maybe FilePart -> HandlerT m () -file fpath fpart = HandlerT (bodySource .= FileSource (fpath, fpart)) - +-- | Parse out the form parameters and the uploaded files. Consumes the request body. formData :: MonadIO m => BackEnd y -> HandlerT m ([(C.ByteString, C.ByteString)], [File y]) formData b = do r <- request liftIO $ parseRequestBody b r --- header :: Monad m => CI ByteString -> ByteString -> HandlerT m () - +-- | Get all the request headers. headers :: Monad m => HandlerT m RequestHeaders headers = liftM requestHeaders request -jsonData :: (FromJSON a, MonadIO m) => HandlerT m (Either String a) +-- | Consume the request body as a JSON value. Returns a 'JsonInputError' on failure. +jsonData :: (FromJSON a, MonadIO m) => HandlerT m (Either JsonInputError a) jsonData = do r <- request ejs <- ST.evalStateT Pipes.Aeson.decode $ producerRequestBody r return $! case ejs of - Nothing -> Left "Request body exhausted while parsing JSON" + Nothing -> Left RequestBodyExhausted Just res -> case res of - Left err -> Left $! case err of - AttoparsecError err -> show err - FromJSONError err -> err + Left err -> Left $ JsonError err Right r -> Right r --- param :: - +-- | Get all matched params. params :: Monad m => HandlerT m [Param] params = HandlerT (view L.params) -raw :: Monad m => L.ByteString -> HandlerT m () -raw bs = HandlerT (bodySource .= LBSSource bs) - -redirect :: Monad m => T.Text -> HandlerT m () +-- | Terminate the current handler and send a @302 Found@ redirect to the provided URL. +-- Other headers that have already been set will also be returned in the request. +redirect :: Monad m => T.Text -- ^ URL to redirect to. + -> HandlerT m () redirect url = do status found302 setHeader "Location" $ T.encodeUtf8 url currentResponse >>= abort +-- | Get the underlying WAI 'Request' request :: Monad m => HandlerT m Request request = HandlerT $ view $ L.request -stream :: Monad m => StreamingBody -> HandlerT m () -stream s = HandlerT (bodySource .= StreamSource s) - +-- | Return plain text as the response body. Sets the Content-Type header to \"text/plain; charset=utf-8\". text :: Monad m => TL.Text -> HandlerT m () text t = do setHeader hContentType "text/plain; charset=utf-8" - raw $ TL.encodeUtf8 t + bytestring $ TL.encodeUtf8 t +-- | Return HTML as the response body. Sets the Content-Type header to \"text/html; charset=utf-8\". +-- If you're using something like blaze-html or lucid, you'll probably get better performance by rolling +-- your own function that sets the response body to a 'Builder'. html :: Monad m => TL.Text -> HandlerT m () html t = do setHeader hContentType "text/html; charset=utf-8" - raw $ TL.encodeUtf8 t + bytestring $ TL.encodeUtf8 t +-- | Get the pattern that was matched in the router, e.g. @"/foo/:bar"@ routePattern :: Monad m => HandlerT m (Maybe T.Text) routePattern = HandlerT $ view $ L.matchedPattern + +lookupParam :: (Functor m, Monad m, Parsable a) => C.ByteString -> HandlerT m (Maybe a) +lookupParam k = do + mk <- lookup k <$> params + case mk of + Nothing -> return Nothing + Just v -> do + let ev = parseParam v + case ev of + Left err -> do + status badRequest400 + text $ TL.fromStrict $ decodeUtf8 err + currentResponse >>= abort + return Nothing + Right r -> return $ Just r + +param :: (Functor m, Monad m, Parsable a) => C.ByteString -> HandlerT m a +param k = do + p <- lookupParam k + case p of + Nothing -> do + status badRequest400 + text $ "Missing required parameter " <> TL.fromStrict (decodeUtf8 k) + currentResponse >>= abort + param k + Just r -> return r + +raise :: Monad m => C.ByteString -> HandlerT m () +raise msg = do + status badRequest400 + text $ TL.fromStrict $ decodeUtf8 msg + currentResponse >>= abort runHandler :: Monad m => ResponseState -> Maybe T.Text -> Request -> [Param] -> HandlerT m a -> m (Either ResponseState (a, ResponseState)) runHandler rs pat rq ps m = runEitherT $ 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 @@ -12,7 +12,6 @@ , patch , addRoute , matchAny - , notFound , capture , regex , function @@ -21,6 +20,8 @@ , route , handlerHook , RoutePattern(..) + , notFound + , internalServerError ) where import Control.Arrow ((***)) @@ -62,23 +63,23 @@ 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 = 'addRoute' 'GET' get :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m () get = addRoute GET --- | post = 'addroute' 'POST' +-- | post = 'addRoute' 'POST' post :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m () post = addRoute POST --- | put = 'addroute' 'PUT' +-- | put = 'addRoute' 'PUT' put :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m () put = addRoute PUT --- | delete = 'addroute' 'DELETE' +-- | delete = 'addRoute' 'DELETE' delete :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m () delete = addRoute DELETE --- | patch = 'addroute' 'PATCH' +-- | patch = 'addRoute' 'PATCH' patch :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m () patch = addRoute PATCH @@ -86,11 +87,14 @@ matchAny :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m () matchAny pattern action = mapM_ (\v -> addRoute v pattern action) [minBound..maxBound] --- | Specify an action to take if nothing else is found. Note: this _always_ matches, --- so should generally be the last route specified. -notFound :: (MonadIO m) => HandlerT m () +-- | A blank 404 Not Found handler for convenience. +notFound :: (Monad m) => HandlerT m () notFound = status status404 +-- | A blank 500 Internal Server Error handler for convenience. +internalServerError :: Monad m => HandlerT m () +internalServerError = status status500 + -- | Define a route with a 'StdMethod', 'T.Text' value representing the path spec, -- and a body ('Action') which modifies the response. -- @@ -114,7 +118,7 @@ else Nothing matchRoute :: RoutePattern -> Request -> Maybe (T.Text, [Param]) -matchRoute (RoutePattern p) req = let (pat, _, rps) = p req in case rps of +matchRoute (RoutePattern p) req = let (RoutePatternResult pat _ rps) = p req in case rps of Fail -> Nothing Partial _ -> Nothing Complete ps -> Just (pat, ps) @@ -138,7 +142,7 @@ regex :: String -> RoutePattern regex pattern = RoutePattern go where - go req = (T.pack pattern, req, maybe Fail Complete $ fmap convertParams match) + go req = RoutePatternResult (T.pack pattern) req $ maybe Fail Complete $ fmap convertParams match where rgx = Regex.mkRegex pattern strip (_, match, _, subs) = match : subs @@ -173,13 +177,13 @@ -- HTTP/1.1 -- function :: (Request -> T.Text) -> (Request -> MatchResult) -> RoutePattern -function fn fps = RoutePattern $ \r -> (fn r, r, fps r) +function fn fps = RoutePattern $ \r -> RoutePatternResult (fn r) r (fps r) -- | Build a route that requires the requested path match exactly, without captures. literal :: String -> RoutePattern literal pat = RoutePattern go where - go req = (packed, req { pathInfo = req' }, result) + go req = RoutePatternResult packed (req { pathInfo = req' }) result where packed = T.pack pat (result, req') = case T.stripPrefix packed (path req) of 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 @@ -10,6 +10,7 @@ module Web.Growler.Types where import Blaze.ByteString.Builder (Builder) import Control.Applicative +import Control.Exception import Control.Lens.TH import Control.Monad.Base (MonadBase(..), liftBaseDefault) import Control.Monad.Reader @@ -31,12 +32,19 @@ import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai +import Pipes.Aeson (DecodingError (..)) data MatchResult = Fail | Partial [Param] | Complete [Param] deriving (Show, Eq) -newtype RoutePattern = RoutePattern { runRoutePattern :: Request -> (Text, Request, MatchResult) } +newtype RoutePattern = RoutePattern { runRoutePattern :: Request -> RoutePatternResult } +data RoutePatternResult = RoutePatternResult + { routePatternResultName :: !Text + , routePatternResultRequest :: !Request -- ^ The (potentially) updated request after consuming a portion of the path + , routePatternResultMatchResult :: !MatchResult + } + instance Monoid MatchResult where mappend l r = case l of Fail -> Fail @@ -50,10 +58,10 @@ 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 []) + mappend (RoutePattern a) (RoutePattern b) = RoutePattern $ \r -> let (RoutePatternResult t1 r' p1) = a r in + let (RoutePatternResult t2 r'' p2) = b r' in + RoutePatternResult (t1 <> t2) r'' (p1 <> p2) + mempty = RoutePattern $ \r -> RoutePatternResult "" r $ Partial [] instance IsString RoutePattern where fromString = capture . T.pack @@ -69,7 +77,7 @@ capture :: Text -> RoutePattern capture pat = RoutePattern process where - process req = (pat, req { pathInfo = ss }, res) + process req = RoutePatternResult 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! @@ -84,7 +92,7 @@ type Param = (C.ByteString, C.ByteString) -data BodySource = FileSource !(FilePath, Maybe FilePart) +data BodySource = FileSource !FilePath !(Maybe FilePart) | BuilderSource !Builder | LBSSource !L.ByteString | StreamSource !StreamingBody @@ -129,7 +137,6 @@ return $ StHandlerT $ case res of Left s -> Left s Right (x, s, _) -> Right (x, s) - restoreT mSt = HandlerT $ do (StHandlerT stof) <- lift $ lift $ mSt @@ -163,4 +170,13 @@ liftIO = GrowlerT . liftIO type Growler = GrowlerT IO + +data JsonInputError = RequestBodyExhausted + | JsonError DecodingError + deriving (Show, Eq) + +data GrowlerConfig m = GrowlerConfig + { growlerConfigNotFoundHandler :: HandlerT m () -- ^ The 404 not found handler. If no route matches, then this handler will be evaluated. + , growlerConfigErrorHandler :: SomeException -> HandlerT m () -- ^ The uncaught exception handler. If an exception is thrown and not caught while trying to service a request, then this handler will be evaluated. + }