growler (empty) → 0.1.0.0
raw patch · 8 files changed
+560/−0 lines, 8 filesdep +aesondep +basedep +blaze-buildersetup-changed
Dependencies added: aeson, base, blaze-builder, bytestring, case-insensitive, http-types, lens, mtl, pipes, pipes-aeson, pipes-wai, regex-compat, text, unordered-containers, vector, wai, wai-extra, warp
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- growler.cabal +28/−0
- src/Web/Growler.hs +97/−0
- src/Web/Growler/Handler.hs +113/−0
- src/Web/Growler/Parsable.hs +56/−0
- src/Web/Growler/Router.hs +170/−0
- src/Web/Growler/Types.hs +74/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Ian Duncan++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ growler.cabal view
@@ -0,0 +1,28 @@+-- Initial growler.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: growler+version: 0.1.0.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.++homepage: http://github.com/iand675/growler+license: MIT+license-file: LICENSE+author: Ian Duncan+maintainer: ian@iankduncan.com+-- copyright: +category: Web+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++library+ exposed-modules: Web.Growler+ other-modules: 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+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Web/Growler.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Growler+(+-- ** Running a growler app+ growl+, growler+-- ** Routing+, Growler+, GrowlerT+, get+, post+, put+, delete+, patch+, matchAny+, notFound+, addRoute+, regex+, capture+, function+, literal+-- ** Handlers+, Handler+, HandlerT+, currentResponse+, abort+, status+, addHeader+, setHeader+, body+, html+, json+, file+, formData+, headers+, jsonData+, params+, raw+, redirect+, request+, stream+, text+-- ** Parsable+, Parsable (..)+, readEither+-- ** Internals+, BodySource (..)+, ResponseState+, RoutePattern (..)+) where+import Control.Lens hiding (get)+import Control.Monad.Identity+import Control.Monad.State hiding (get, put)+import Control.Monad.Trans+import qualified Data.HashMap.Strict as HM+import Data.Maybe+import qualified Data.Vector as V+import Data.Vector.Lens+import Network.HTTP.Types.Method+import Network.Wai+import qualified Network.Wai.Handler.Warp as Warp+import Web.Growler.Handler+import Web.Growler.Parsable+import Web.Growler.Router+import Web.Growler.Types++growl :: MonadIO m => (forall a. m a -> IO a) -> HandlerT m () -> GrowlerT m () -> 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+ result <- trans $ execStateT m []+ return $ app (result ^. vector)+ where+ app rv req respond = trans (growlerRouter rv fallback req) >>= respond++growlerRouter :: forall m. MonadIO m => V.Vector (StdMethod, RoutePattern, HandlerT m ()) -> HandlerT m () -> Request -> m Response+growlerRouter rv fb r = do+ (status, groupedHeaders, body) <- fromMaybe (runHandler initialState r [] fb) $ join $ V.find isJust $ V.map processResponse rv+ 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+ BuilderSource b -> responseBuilder status headers b+ LBSSource lbs -> responseLBS status headers lbs+ StreamSource sb -> responseStream status headers sb+ RawSource f r' -> responseRaw f r'+ where+ processResponse :: (StdMethod, RoutePattern, HandlerT m ()) -> Maybe (m ResponseState)+ processResponse (m, pat, respond) = case route r m pat of+ Nothing -> Nothing+ Just ps -> Just $ runHandler initialState r ps respond+
+ src/Web/Growler/Handler.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Growler.Handler where+import Control.Applicative+import Control.Lens+import Control.Monad.Cont+import Control.Monad.RWS+import Control.Monad.Trans+import qualified Control.Monad.State as State+import qualified Control.Monad.State.Strict as ST+import Data.Aeson hiding ((.=))+import qualified Data.ByteString.Char8 as C+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+import qualified Data.Text.Lazy.Encoding as TL+import Network.HTTP.Types.Status+import Network.Wai+import Network.Wai.Parse hiding (Param)+import Network.HTTP.Types+import Web.Growler.Types+import Pipes.Wai+import Pipes.Aeson++initialState :: ResponseState+initialState = (ok200, HM.empty, LBSSource "")++currentResponse :: Monad m => HandlerT m ResponseState+currentResponse = HandlerT State.get++abort :: Monad m => ResponseState -> HandlerT m ()+abort rs = do+ (q, _, _) <- HandlerT ask+ HandlerT $ lift $ q rs++status :: Monad m => Status -> HandlerT m ()+status v = HandlerT $ _1 .= v++addHeader :: Monad m => CI C.ByteString -> C.ByteString -> HandlerT m ()+addHeader k v = HandlerT (_2 %= HM.insertWith (\_ v' -> v:v') k [v])++setHeader :: Monad m => CI C.ByteString -> C.ByteString -> HandlerT m ()+setHeader k v = HandlerT (_2 %= HM.insert k [v])++body :: Monad m => BodySource -> HandlerT m ()+body = HandlerT . (_3 .=)++json :: Monad m => ToJSON a => a -> HandlerT m ()+json = body . LBSSource . encode++file :: Monad m => FilePath -> Maybe FilePart -> HandlerT m ()+file fpath fpart = HandlerT (_3 .= FileSource (fpath, fpart))++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 ()++headers :: Monad m => HandlerT m RequestHeaders+headers = liftM requestHeaders request++jsonData :: (FromJSON a, MonadIO m) => HandlerT m (Either String 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"+ Just res -> case res of+ Left err -> Left $! case err of+ AttoparsecError err -> show err+ FromJSONError err -> err+ Right r -> Right r++-- param :: ++params :: Monad m => HandlerT m [Param]+params = HandlerT (view _3)++raw :: Monad m => L.ByteString -> HandlerT m ()+raw bs = HandlerT (_3 .= LBSSource bs)++redirect :: Monad m => T.Text -> HandlerT m ()+redirect url = do+ status found302+ setHeader "Location" $ T.encodeUtf8 url+ currentResponse >>= abort++request :: Monad m => HandlerT m Request+request = HandlerT $ view _2++stream :: Monad m => StreamingBody -> HandlerT m ()+stream s = HandlerT (_3 .= StreamSource s)++text :: Monad m => TL.Text -> HandlerT m ()+text t = do+ setHeader hContentType "text/plain; charset=utf-8"+ raw $ TL.encodeUtf8 t++html :: Monad m => TL.Text -> HandlerT m ()+html t = do+ setHeader hContentType "text/html; charset=utf-8"+ raw $ TL.encodeUtf8 t++runHandler :: Monad m => ResponseState -> Request -> [Param] -> HandlerT m a -> m ResponseState+runHandler rs rq ps m = runContT runInner return+ where+ qsParams = fmap (_2 %~ fromMaybe "") (queryString rq) + runInner = callCC $ \e -> fst <$> execRWST (fromHandler m >> Control.Monad.RWS.get) (e, rq, qsParams ++ ps) rs
+ src/Web/Growler/Parsable.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Growler.Parsable where+import qualified Data.ByteString.Char8 as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL++-- | Minimum implemention: 'parseParam'+class Parsable a where+ -- | Take a 'ByteString' value and parse it as 'a', or fail with a message.+ parseParam :: BS.ByteString -> Either BS.ByteString a++ -- | Default implementation parses comma-delimited lists.+ --+ -- > parseParamList t = mapM parseParam (BS.split ',' t)+ parseParamList :: BS.ByteString -> Either BS.ByteString [a]+ parseParamList t = mapM parseParam (BS.split ',' t)++-- No point using 'read' for Text, ByteString, Char, and String.+instance Parsable T.Text where parseParam = Right . T.decodeUtf8+instance Parsable TL.Text where parseParam = Right . TL.fromStrict . T.decodeUtf8+instance Parsable BS.ByteString where parseParam = Right+-- | Overrides default 'parseParamList' to parse String.+instance Parsable Char where+ parseParam t = case T.unpack $ T.decodeUtf8 t of+ [c] -> Right c+ _ -> Left "parseParam Char: no parse"+ parseParamList = Right . T.unpack . T.decodeUtf8 -- String+-- | Checks if parameter is present and is null-valued, not a literal '()'.+-- If the URI requested is: '/foo?bar=()&baz' then 'baz' will parse as (), where 'bar' will not.+instance Parsable () where+ parseParam t = if BS.null t then Right () else Left "parseParam Unit: no parse"++instance (Parsable a) => Parsable [a] where parseParam = parseParamList++instance Parsable Bool where+ parseParam t = if t' == T.toCaseFold "true"+ then Right True+ else if t' == T.toCaseFold "false"+ then Right False+ else Left "parseParam Bool: no parse"+ where t' = T.toCaseFold $ T.decodeUtf8 t++instance Parsable Double where parseParam = readEither+instance Parsable Float where parseParam = readEither+instance Parsable Int where parseParam = readEither+instance Parsable Integer where parseParam = readEither++-- | Useful for creating 'Parsable' instances for things that already implement 'Read'. Ex:+--+-- > instance Parsable Int where parseParam = readEither+readEither :: (Read a) => BS.ByteString -> Either BS.ByteString a+readEither t = case [ x | (x, "") <- reads (T.unpack $ T.decodeUtf8 t) ] of+ [x] -> Right x+ [] -> Left "readEither: no parse"+ _ -> Left "readEither: ambiguous parse"
+ src/Web/Growler/Router.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Growler.Router+ ( get+ , post+ , put+ , delete+ , patch+ , addRoute+ , matchAny+ , notFound+ , capture+ , regex+ , function+ , literal+ , route+ , RoutePattern(..)+ ) where++import Control.Arrow ((***))++import Control.Monad.State hiding (get, put)+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.String (fromString)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL++import Network.HTTP.Types+import Network.Wai (Request (..))+import qualified Network.Wai.Parse as Parse++import qualified Text.Regex as Regex++import Web.Growler.Handler+import Web.Growler.Types++-- | get = 'addroute' 'GET'+get :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m ()+get = addRoute GET++-- | post = 'addroute' 'POST'+post :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m ()+post = addRoute POST++-- | put = 'addroute' 'PUT'+put :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m ()+put = addRoute PUT++-- | delete = 'addroute' 'DELETE'+delete :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m ()+delete = addRoute DELETE++-- | patch = 'addroute' 'PATCH'+patch :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m ()+patch = addRoute PATCH++-- | Add a route that matches regardless of the HTTP verb.+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 ()+notFound = status status404++-- | Define a route with a 'StdMethod', 'T.Text' value representing the path spec,+-- and a body ('Action') which modifies the response.+--+-- > addroute GET "/" $ text "beam me up!"+--+-- The path spec can include values starting with a colon, which are interpreted+-- as /captures/. These are named wildcards that can be looked up with 'param'.+--+-- > addroute GET "/foo/:bar" $ do+-- > v <- param "bar"+-- > text v+--+-- >>> curl http://localhost:3000/foo/something+-- something+addRoute :: (MonadIO m) => StdMethod -> RoutePattern -> HandlerT m () -> GrowlerT m ()+addRoute method pat action = GrowlerT $ modify ((method, pat, action):)++route :: Request -> StdMethod -> RoutePattern -> Maybe [Param]+route req method pat = if Right method == parseMethod (requestMethod req)+ then matchRoute pat req+ 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++-- 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 ]++-- | Match requests using a regular expression.+-- Named captures are not yet supported.+--+-- > get (regex "^/f(.*)r$") $ do+-- > path <- param "0"+-- > cap <- param "1"+-- > text $ mconcat ["Path: ", path, "\nCapture: ", cap]+--+-- >>> curl http://localhost:3000/foo/bar+-- Path: /foo/bar+-- Capture: oo/ba+--+regex :: String -> RoutePattern+regex pattern = Function $ \ 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++-- | Standard Sinatra-style route. Named captures are prepended with colons.+-- This is the default route type generated by OverloadedString routes. i.e.+--+-- > get (capture "/foo/:bar") $ ...+--+-- and+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > ...+-- > get "/foo/:bar" $ ...+--+-- are equivalent.+capture :: String -> RoutePattern+capture = fromString++-- | Build a route based on a function which can match using the entire 'Request' object.+-- 'Nothing' indicates the route does not match. A 'Just' value indicates+-- a successful match, optionally returning a list of key-value pairs accessible+-- by 'param'.+--+-- > get (function $ \req -> Just [("version", T.pack $ show $ httpVersion req)]) $ do+-- > v <- param "version"+-- > text v+--+-- >>> curl http://localhost:3000/+-- HTTP/1.1+--+function :: (Request -> Maybe [Param]) -> RoutePattern+function = Function++-- | Build a route that requires the requested path match exactly, without captures.+literal :: String -> RoutePattern+literal = Literal . T.pack
+ src/Web/Growler/Types.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+module Web.Growler.Types where+import Blaze.ByteString.Builder (Builder)+import Control.Applicative+import Control.Monad.Cont+import Control.Monad.Reader+import Control.Monad.RWS+import Control.Monad.State+import Control.Monad.Trans+import Data.Aeson hiding ((.=))+import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy as L+import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Strict as HM+import Data.String (IsString (..))+import Data.Text (Text, pack)+import Network.HTTP.Types.Header+import Network.HTTP.Types.Method+import Network.HTTP.Types.Status+import Network.Wai++data BodySource = FileSource !(FilePath, Maybe FilePart)+ | BuilderSource !Builder+ | LBSSource !L.ByteString+ | StreamSource !StreamingBody+ | RawSource !(IO C.ByteString -> (C.ByteString -> IO ()) -> IO ()) !Response++type ResponseState = (Status, HM.HashMap (CI.CI C.ByteString) [C.ByteString], BodySource)++type HandlerAbort m = ContT ResponseState m+newtype HandlerT m a = HandlerT+ { fromHandler :: RWST (ResponseState -> HandlerAbort m (), Request, [Param]) () ResponseState (HandlerAbort m) a+ }++instance Functor m => Functor (HandlerT m) where+ fmap f (HandlerT m) = HandlerT (fmap f m)++instance Applicative m => Applicative (HandlerT m) where+ pure = HandlerT . pure+ (HandlerT f) <*> (HandlerT r) = HandlerT (f <*> r)++deriving instance Monad m => Monad (HandlerT m)++instance MonadTrans HandlerT where+ lift m = HandlerT $ lift $ lift m++deriving instance MonadIO m => MonadIO (HandlerT m)++type Handler = HandlerT IO++type Param = (C.ByteString, C.ByteString)+data RoutePattern = Capture Text+ | Literal Text+ | Function (Request -> Maybe [Param])++instance IsString RoutePattern where+ fromString = Capture . pack++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)++instance (Functor m, Monad m) => Applicative (GrowlerT m) where+ pure = GrowlerT . pure+ (GrowlerT f) <*> (GrowlerT r) = GrowlerT (f <*> r)++deriving instance Monad m => Monad (GrowlerT m)++instance MonadIO m => MonadIO (GrowlerT m) where+ liftIO = GrowlerT . liftIO++type Growler = GrowlerT IO