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.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 diff --git a/src/Web/Growler.hs b/src/Web/Growler.hs --- a/src/Web/Growler.hs +++ b/src/Web/Growler.hs @@ -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 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,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 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 @@ -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. 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 @@ -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 +