growler 0.3.2 → 0.4.0

raw patch · 5 files changed

+245/−73 lines, 5 filesdep ~basedep ~lensPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, lens

API changes (from Hackage documentation)

Files

• growler.cabal +35/−2
• src/Web/Growler.hs +82/−26
• src/Web/Growler/Handler.hs +87/−24
• src/Web/Growler/Router.hs +17/−13
• src/Web/Growler/Types.hs +24/−8

@@ -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.+                     .+                     @+                       &#123;-&#35; LANGUAGE OverloadedStrings &#35;-&#125;+                       .+                       import Web.Growler+                       import Data.Monoid ((&#60;&#62;))+                       .+                       main = growl id defaultConfig $ do+                       &#32;&#32;get &#34;/&#34; $ text &#34;Hello, World!&#34;+                       &#32;&#32;get &#34;/:name&#34; $ do+                       &#32;&#32;&#32;&#32;name <- param &#34;name&#34;+                       &#32;&#32;&#32;&#32;text (&#34;Hello, &#34; &#60;&#62; name &#60;&#62; &#34;!&#34;)+                     @  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

@@ -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

@@ -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

@@ -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

@@ -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.+  }