module Web.Growler.Handler where
import Blaze.ByteString.Builder (Builder)
import Control.Applicative
import Control.Lens
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Either
import qualified Control.Monad.Trans.RWS.Strict as RWS
import qualified Control.Monad.Trans.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 Data.Monoid ((<>))
import qualified Data.HashMap.Strict as HM
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.Parsable
import Web.Growler.Types hiding (status, request, params)
import qualified Web.Growler.Types as L
import Pipes.Wai
import Pipes.Aeson
initialState :: ResponseState
initialState = ResponseState ok200 HM.empty (LBSSource "")
currentResponse :: Monad m => HandlerT m ResponseState
currentResponse = HandlerT RWS.get
abort :: Monad m => ResponseState -> HandlerT m ()
abort rs = HandlerT $ lift $ left rs
status :: Monad m => Status -> HandlerT m ()
status v = HandlerT $ L.status .= v
addHeader :: Monad m => CI C.ByteString -> C.ByteString -> HandlerT m ()
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 (L.headers %= HM.insert k [v])
body :: Monad m => BodySource -> HandlerT m ()
body = HandlerT . (bodySource .=)
file :: Monad m => FilePath
-> Maybe FilePart
-> HandlerT m ()
file fpath fpart = HandlerT (bodySource .= FileSource fpath fpart)
builder :: Monad m => Builder
-> HandlerT m ()
builder b = HandlerT (bodySource .= BuilderSource b)
bytestring :: Monad m => L.ByteString -> HandlerT m ()
bytestring bs = HandlerT (bodySource .= LBSSource bs)
stream :: Monad m => StreamingBody -> HandlerT m ()
stream s = HandlerT (bodySource .= StreamSource s)
raw :: MonadIO m => (IO C.ByteString -> (C.ByteString -> IO ()) -> IO ())
-> Response
-> HandlerT m ()
raw f r = HandlerT (bodySource .= RawSource f r)
json :: Monad m => ToJSON a => a -> HandlerT m ()
json x = do
body $ LBSSource $ encode x
addHeader "Content-Type" "application/json"
formData :: MonadIO m => BackEnd y -> HandlerT m ([(C.ByteString, C.ByteString)], [File y])
formData b = do
r <- request
liftIO $ parseRequestBody b r
headers :: Monad m => HandlerT m RequestHeaders
headers = liftM requestHeaders request
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 RequestBodyExhausted
Just res -> case res of
Left err -> Left $ JsonError err
Right r -> Right r
params :: Monad m => HandlerT m [Param]
params = HandlerT (view L.params)
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 $ L.request
text :: Monad m => TL.Text -> HandlerT m ()
text t = do
setHeader hContentType "text/plain; charset=utf-8"
bytestring $ TL.encodeUtf8 t
html :: Monad m => TL.Text -> HandlerT m ()
html t = do
setHeader hContentType "text/html; charset=utf-8"
bytestring $ TL.encodeUtf8 t
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
(dx, r, ()) <- RWS.runRWST (fromHandler m) (RequestState pat (qsParams ++ ps) rq) rs
return (dx, r)
where
qsParams = fmap (_2 %~ fromMaybe "") (queryString rq)
liftAround :: (Monad m) => (forall a. m a -> m a) -> HandlerT m a -> HandlerT m a
liftAround f m = HandlerT $ do
(RequestState pat ps req) <- RWS.ask
currentState <- RWS.get
r <- lift $ lift $ f $ runHandler currentState pat req ps m
case r of
Left err -> lift $ left err
Right (dx, state') -> do
RWS.put state'
return dx