From f4dc87bab6430d782474fa0b0e84c076d1f67ed7 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Mon, 21 Sep 2009 00:02:38 +0300
Subject: [PATCH] getRequest for the Response monad

---
 TODO                       |  2 --
 Web/Restful/Application.hs |  3 ++-
 Web/Restful/Handler.hs     | 14 +++++--------
 Web/Restful/Response.hs    | 40 ++++++++++++++++++++++++++------------
 4 files changed, 35 insertions(+), 24 deletions(-)

diff --git a/TODO b/TODO
index 443e2ed8..052dfd91 100644
--- a/TODO
+++ b/TODO
@@ -1,3 +1 @@
-Static files and directories
 Better error handling for invalid arguments (currently 500 error)
-Include request getting in Response monad.
diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs
index 0ac40106..3c61f556 100644
--- a/Web/Restful/Application.hs
+++ b/Web/Restful/Application.hs
@@ -124,7 +124,8 @@ toHackApplication sampleRN hm env = do
     runResponse (errorHandler sampleRN rr)
                 (responseWrapper sampleRN)
                 ctypes'
-                (handler rr)
+                handler
+                rr
 
 envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest
 envToRawRequest urlParams' env =
diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs
index 074240b6..bcfd86f9 100644
--- a/Web/Restful/Handler.hs
+++ b/Web/Restful/Handler.hs
@@ -23,18 +23,14 @@ module Web.Restful.Handler
 import Web.Restful.Request
 import Web.Restful.Response
 
-type Handler = RawRequest -> Response
+type Handler = Response -- FIXME maybe move some stuff around now...
 
 liftHandler :: (Request req, HasReps rep)
             => (req -> ResponseIO rep)
             -> Handler
-liftHandler f req = liftRequest req >>= wrapResponse . f
-
-liftRequest :: (Request req, Monad m) => RawRequest -> m req
-liftRequest r =
-    case runRequestParser parseRequest r of
-        Left errors -> fail $ unlines errors -- FIXME
-        Right req -> return req
+liftHandler f = do
+    req <- getRequest
+    wrapResponse $ f req
 
 noHandler :: Handler
-noHandler = const notFound
+noHandler = notFound
diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs
index 5336bfb9..b5d1c1fb 100644
--- a/Web/Restful/Response.hs
+++ b/Web/Restful/Response.hs
@@ -33,6 +33,7 @@ module Web.Restful.Response
     , HasRepsW (..)
     , byteStringResponse
     , htmlResponse
+    , getRequest
     ) where
 
 import Data.ByteString.Class
@@ -44,7 +45,10 @@ import qualified Data.ByteString.Lazy as B
 import Data.Object.Instances
 import Data.Maybe (fromJust)
 
+import Web.Restful.Request
+
 import Control.Monad.Trans
+import Control.Monad (liftM)
 
 import qualified Hack
 
@@ -79,7 +83,8 @@ getHeaders :: ErrorResult -> [Header]
 getHeaders (Redirect s) = [Header "Location" s]
 getHeaders _ = []
 
-newtype ResponseT m a = ResponseT (m (Either ErrorResult a, [Header]))
+newtype ResponseT m a =
+    ResponseT (RawRequest -> m (Either ErrorResult a, [Header]))
 type ResponseIO = ResponseT IO
 type Response = ResponseIO HasRepsW
 
@@ -87,9 +92,10 @@ runResponse :: (ErrorResult -> HasRepsW)
             -> (ContentType -> B.ByteString -> IO B.ByteString)
             -> [ContentType]
             -> Response
+            -> RawRequest
             -> IO Hack.Response
-runResponse eh wrapper ctypesAll (ResponseT inside) = do
-    (x, headers') <- inside
+runResponse eh wrapper ctypesAll (ResponseT inside) rr = do
+    (x, headers') <- inside rr
     let extraHeaders =
             case x of
                 Left r -> getHeaders r
@@ -135,7 +141,7 @@ wrapResponse :: (Monad m, HasReps rep)
 wrapResponse = fmap HasRepsW
 
 instance MonadTrans ResponseT where
-    lift ma = ResponseT $ do
+    lift ma = ResponseT $ const $ do
         a <- ma
         return (Right a, [])
 
@@ -143,24 +149,24 @@ instance MonadIO ResponseIO where
     liftIO = lift
 
 redirect :: Monad m => String -> ResponseT m a
-redirect s = ResponseT (return (Left $ Redirect s, []))
+redirect s = ResponseT (const $ return (Left $ Redirect s, []))
 
 notFound :: Monad m => ResponseT m a
-notFound = ResponseT (return (Left NotFound, []))
+notFound = ResponseT (const $ return (Left NotFound, []))
 
 instance Monad m => Functor (ResponseT m) where
-    fmap f x = x >>= return . f
+    fmap = liftM
 
 instance Monad m => Monad (ResponseT m) where
     return = lift . return
-    fail s = ResponseT (return (Left $ InternalError s, []))
-    (ResponseT mx) >>= f = ResponseT $ do
-        (x, hs1) <- mx
+    fail s = ResponseT (const $ return (Left $ InternalError s, []))
+    (ResponseT mx) >>= f = ResponseT $ \rr -> do
+        (x, hs1) <- mx rr
         case x of
             Left x' -> return (Left x', hs1)
             Right a -> do
                 let (ResponseT b') = f a
-                (b, hs2) <- b'
+                (b, hs2) <- b' rr
                 return (b, hs1 ++ hs2)
 
 -- | Headers to be added to a 'Result'.
@@ -179,7 +185,7 @@ header :: Monad m => String -> String -> ResponseT m ()
 header a b = addHeader $ Header a b
 
 addHeader :: Monad m => Header -> ResponseT m ()
-addHeader h = ResponseT (return (Right (), [h]))
+addHeader h = ResponseT (const $ return (Right (), [h]))
 
 instance HasReps () where
     reps _ = [("text/plain", toLazyByteString "")]
@@ -214,3 +220,13 @@ instance HasReps [(ContentType, B.ByteString)] where
 -- FIXME put in a separate module (maybe Web.Encodings)
 formatW3 :: UTCTime -> String
 formatW3 = formatTime defaultTimeLocale "%FT%X-08:00"
+
+getRequest :: (Monad m, Request r) => ResponseT m r
+getRequest = ResponseT $ \rr -> return (helper rr, []) where
+    helper :: Request r
+           => RawRequest
+           -> Either ErrorResult r
+    helper rr =
+        case runRequestParser parseRequest rr of
+            Left errors -> Left $ InternalError $ unlines errors -- FIXME better error output
+            Right r -> Right r