growler 0.1.0.1 → 0.2.0

raw patch · 5 files changed

+131/−69 lines, 5 filesdep +eitherdep +monad-controldep +transformers-basePVP ok

version bump matches the API change (PVP)

Dependencies added: either, monad-control, transformers-base

API changes (from Hackage documentation)

Files

• growler.cabal +2/−2
• src/Web/Growler.hs +10/−10
• src/Web/Growler/Handler.hs +43/−26
• src/Web/Growler/Router.hs +4/−4
• src/Web/Growler/Types.hs +72/−27

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                growler-version:             0.1.0.1+version:             0.2.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). 		     .@@ -23,6 +23,6 @@   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+  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   hs-source-dirs:      src   default-language:    Haskell2010

@@ -42,6 +42,7 @@ , request , stream , text+, routePattern -- ** Parsable , Parsable (..) , readEither@@ -64,7 +65,7 @@ import           Web.Growler.Handler import           Web.Growler.Parsable import           Web.Growler.Router-import           Web.Growler.Types+import           Web.Growler.Types         hiding (status, headers, params, request)  growl :: MonadIO m => (forall a. m a -> IO a) -> HandlerT m () -> GrowlerT m () -> IO () growl trans fb g = do@@ -81,18 +82,17 @@  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+  rs <- fromMaybe (runHandler initialState Nothing r [] fb) $ join $ V.find isJust $ V.map processResponse rv+  let (ResponseState status' groupedHeaders body') = either id snd rs   let headers = concatMap (\(k, vs) -> map (\v -> (k, v)) vs) $ HM.toList groupedHeaders-  liftIO $ print headers-  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+  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+      Just ps -> Just $ runHandler initialState (Just pat) r ps respond 

@@ -1,58 +1,60 @@+{-# LANGUAGE Rank2Types        #-} {-# 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           Control.Monad.Trans.Either 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           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           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           Network.Wai.Parse hiding (Param)+import           Network.HTTP.Types+import           Web.Growler.Types hiding (status, request, params)+import qualified Web.Growler.Types as L import Pipes.Wai import Pipes.Aeson  initialState :: ResponseState-initialState = (ok200, HM.empty, LBSSource "")+initialState = ResponseState 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+abort rs = HandlerT $ lift $ left rs  status :: Monad m => Status -> HandlerT m ()-status v = HandlerT $ _1 .= v+status v = HandlerT $ L.status .= v  addHeader :: Monad m => CI C.ByteString -> C.ByteString -> HandlerT m ()-addHeader k v = HandlerT (_2 %= HM.insertWith (\_ v' -> v:v') k [v])+addHeader k v = HandlerT (L.headers %= 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])+setHeader k v = HandlerT (L.headers %= HM.insert k [v])  body :: Monad m => BodySource -> HandlerT m ()-body = HandlerT . (_3 .=)+body = HandlerT . (bodySource .=)  json :: Monad m => ToJSON a => a -> HandlerT m ()-json = body . LBSSource . encode+json x = do+  body $ LBSSource $ encode x+  addHeader "Content-Type" "application/json"  file :: Monad m => FilePath -> Maybe FilePart -> HandlerT m ()-file fpath fpart = HandlerT (_3 .= FileSource (fpath, fpart))+file fpath fpart = HandlerT (bodySource .= FileSource (fpath, fpart))  formData :: MonadIO m => BackEnd y -> HandlerT m ([(C.ByteString, C.ByteString)], [File y]) formData b = do@@ -79,10 +81,10 @@ -- param ::   params :: Monad m => HandlerT m [Param]-params = HandlerT (view _3)+params = HandlerT (view L.params)  raw :: Monad m => L.ByteString -> HandlerT m ()-raw bs = HandlerT (_3 .= LBSSource bs)+raw bs = HandlerT (bodySource .= LBSSource bs)  redirect :: Monad m => T.Text -> HandlerT m () redirect url = do@@ -91,10 +93,10 @@   currentResponse >>= abort  request :: Monad m => HandlerT m Request-request = HandlerT $ view _2+request = HandlerT $ view $ L.request  stream :: Monad m => StreamingBody -> HandlerT m ()-stream s = HandlerT (_3 .= StreamSource s)+stream s = HandlerT (bodySource .= StreamSource s)  text :: Monad m => TL.Text -> HandlerT m () text t = do@@ -106,8 +108,23 @@   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+routePattern :: Monad m => HandlerT m (Maybe RoutePattern)+routePattern = HandlerT $ view $ L.matchedPattern++runHandler :: Monad m => ResponseState -> Maybe RoutePattern -> Request -> [Param] -> HandlerT m a -> m (Either ResponseState (a, ResponseState))+runHandler rs pat rq ps m = runEitherT $ do+  (dx, r, ()) <- runRWST (fromHandler m) (RequestState pat (qsParams ++ ps) rq) rs+  return (dx, r)   where     qsParams = fmap (_2 %~ fromMaybe "") (queryString rq) -    runInner = callCC $ \e -> fst <$> execRWST (fromHandler m >> Control.Monad.RWS.get) (e, rq, qsParams ++ ps) rs++liftAround :: (Monad m) => (forall a. m a -> m a) -> HandlerT m a -> HandlerT m a+liftAround f m = HandlerT $ do+  (RequestState pat ps req) <- ask+  currentState <- get+  r <- lift $ lift $ f $ runHandler currentState pat req ps m+  case r of+    Left err -> lift $ left err+    Right (dx, state') -> do+      put state'+      return dx 

@@ -42,7 +42,7 @@ import qualified Text.Regex                 as Regex  import           Web.Growler.Handler-import           Web.Growler.Types+import           Web.Growler.Types          hiding (status)  -- | get = 'addroute' 'GET' get :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m ()@@ -98,7 +98,7 @@ matchRoute :: RoutePattern -> Request -> Maybe [Param] matchRoute (Literal pat)  req | pat == path req = Just []                               | otherwise       = Nothing-matchRoute (Function fun) req = fun req+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@@ -130,7 +130,7 @@ -- Capture: oo/ba -- regex :: String -> RoutePattern-regex pattern = Function $ \ req -> fmap (map (B.pack . show *** (T.encodeUtf8 . T.pack)) . zip [0 :: Int ..] . strip)+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@@ -162,7 +162,7 @@ -- >>> curl http://localhost:3000/ -- HTTP/1.1 ---function :: (Request -> Maybe [Param]) -> RoutePattern+function :: (Request -> T.Text) -> (Request -> Maybe [Param]) -> RoutePattern function = Function  -- | Build a route that requires the requested path match exactly, without captures.

@@ -1,62 +1,106 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE UndecidableInstances       #-} module Web.Growler.Types where import           Blaze.ByteString.Builder  (Builder) import           Control.Applicative-import           Control.Monad.Cont+import           Control.Lens.TH+import           Control.Monad.Base (MonadBase(..), liftBaseDefault) 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           Control.Monad.Trans.Either+import           Control.Monad.Trans.Control+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 RoutePattern = Capture  Text+                  | Literal  Text+                  | Function (Request -> Text) (Request -> Maybe [Param])++instance IsString RoutePattern where+    fromString = Capture . pack++type Param = (C.ByteString, C.ByteString)+ 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+data RequestState = RequestState+  { requestMatchedPattern :: Maybe RoutePattern+  , requestParams         :: [Param]+  , requestRequest        :: Request   } -instance Functor m => Functor (HandlerT m) where-  fmap f (HandlerT m) = HandlerT (fmap f m)+data ResponseState = ResponseState+  { responseStatus     :: !Status+  , responseHeaders    :: !(HM.HashMap (CI.CI C.ByteString) [C.ByteString])+  , responseBodySource :: !BodySource+  } -instance Applicative m => Applicative (HandlerT m) where-  pure = HandlerT . pure-  (HandlerT f) <*> (HandlerT r) = HandlerT (f <*> r)+makeFields ''ResponseState+makeFields ''RequestState -deriving instance Monad m => Monad (HandlerT m)+type EarlyTermination = ResponseState+type HandlerAbort m = EitherT EarlyTermination m+newtype HandlerT m a = HandlerT+  { fromHandler :: RWST RequestState () ResponseState (HandlerAbort m) a+  } deriving (Functor, Monad, Applicative)  instance MonadTrans HandlerT where   lift m = HandlerT $ lift $ lift m  deriving instance MonadIO m => MonadIO (HandlerT m) -type Handler = HandlerT IO+instance MonadBase b m => MonadBase b (HandlerT m) where+  liftBase = liftBaseDefault -type Param = (C.ByteString, C.ByteString)-data RoutePattern = Capture   Text-                  | Literal   Text-                  | Function  (Request -> Maybe [Param])+instance MonadTransControl HandlerT where+  newtype StT HandlerT a = StHandlerT { unStHandlerT :: Either ResponseState (a, ResponseState) }+  liftWith f = do+    r <- HandlerT ask+    s <- HandlerT get+    lift $ f $ \h -> do+      res <- runEitherT $ runRWST (fromHandler h) r s+      return $ StHandlerT $ case res of+        Left s -> Left s+        Right (x, s, _) -> Right (x, s)+         -instance IsString RoutePattern where-    fromString = Capture . pack+  restoreT mSt = HandlerT $ do+    (StHandlerT stof) <- lift $ lift $ mSt+    case stof of+      Left s -> do+        put s+        lift $ left s+      Right (x, s) -> do+        put s+        return x +instance MonadBaseControl b m => MonadBaseControl b (HandlerT m) where+  newtype StM (HandlerT m) a = StMHandlerT { unStMHandlerT :: StM m (StT HandlerT a) }+  liftBaseWith = defaultLiftBaseWith StMHandlerT+  restoreM = defaultRestoreM unStMHandlerT++type Handler = HandlerT IO+ newtype GrowlerT m a = GrowlerT { fromGrowlerT :: StateT [(StdMethod, RoutePattern, HandlerT m ())] m a}  instance Functor m => Functor (GrowlerT m) where@@ -72,3 +116,4 @@   liftIO = GrowlerT . liftIO  type Growler = GrowlerT IO+