module Web.Growler
(
growl
, growler
, defaultConfig
, GrowlerConfig (..)
, Growler
, GrowlerT
, regex
, capture
, function
, literal
, mount
, handlerHook
, notFound
, get
, post
, put
, delete
, patch
, matchAny
, addRoute
, Handler
, HandlerT
, request
, routePattern
, params
, file
, builder
, bytestring
, stream
, raw
, currentResponse
, abort
, lookupParam
, param
, formData
, headers
, jsonData
, status
, addHeader
, setHeader
, raise
, redirect
, text
, html
, json
, JsonInputError (..)
, DecodingError (..)
, Parsable (..)
, readEither
, body
, BodySource (..)
, ResponseState (..)
, RoutePattern (..)
) where
import Control.Exception (catch)
import Control.Lens hiding (get)
import Control.Monad.Identity
import Control.Monad.Trans.State.Strict 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 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)
-> GrowlerConfig 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)
-> GrowlerConfig m
-> GrowlerT m ()
-> IO Application
growler trans (GrowlerConfig nf er) (GrowlerT m) = do
result <- trans $ execStateT m []
return $ app (reverse result ^. vector)
where
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
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
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 (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