Fixed build failure on recent GHC and other libraries

[Lucu.git] / Network / HTTP / Lucu / Resource.hs

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 08fb6f19ce50b434457d42f0deef09710f6c31f1..15b211fba6d17872dc6201a55d8a69bdfd42c326 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -301,20 +301,26 @@ getPathInfo = do rsrcPath <- getResourcePath
                  -- rsrcPath の長さの分だけ削除すれば良い。
                  return $! drop (length rsrcPath) reqPath
 
--- | Assume the query part of request URI as
--- application\/x-www-form-urlencoded, and parse it. This action
--- doesn't parse the request body. See 'inputForm'.
-getQueryForm :: Resource [FormData]
-getQueryForm = do uri <- getRequestURI
-                  return $! map pairToFormData $ parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
-
-pairToFormData :: (String, String) -> FormData
-pairToFormData (name, value)
-    = FormData {
-        fdName     = name
-      , fdFileName = Nothing
-      , fdContent  = L8.pack value
-      }
+-- |Assume the query part of request URI as
+-- application\/x-www-form-urlencoded, and parse it to pairs of
+-- @(name, formData)@. This action doesn't parse the request body. See
+-- 'inputForm'.
+getQueryForm :: Resource [(String, FormData)]
+getQueryForm = liftM parse' getRequestURI
+    where
+      parse' = map toPairWithFormData .
+               parseWWWFormURLEncoded .
+               snd .
+               splitAt 1 .
+               uriQuery
+
+toPairWithFormData :: (String, String) -> (String, FormData)
+toPairWithFormData (name, value)
+    = let fd = FormData {
+                 fdFileName = Nothing
+               , fdContent  = L8.pack value
+               }
+      in (name, fd)
 
 -- |Get a value of given request header. Comparison of header name is
 -- case-insensitive. Note that this action is not intended to be used
@@ -407,7 +413,7 @@ getAuthorization
 -- |Tell the system that the 'Resource' found an entity for the
 -- request URI. If this is a GET or HEAD request, a found entity means
 -- a datum to be replied. If this is a PUT or DELETE request, it means
--- a datum which was stored for the URI up to now. It is an error to
+-- a datum which was stored for the URI until now. It is an error to
 -- compute 'foundEntity' if this is a POST request.
 --
 -- Computation of 'foundEntity' performs \"If-Match\" test or
@@ -428,7 +434,7 @@ foundEntity tag timeStamp
                   $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)
          when (method == POST)
                   $ abort InternalServerError []
-                        (Just "Illegal computation of foundEntity for POST request.")
+                        (Just "Illegal computation of foundEntity for a POST request.")
          foundETag tag
 
          driftTo GettingBody
@@ -726,7 +732,7 @@ inputChunkLBS limit
 -- makes 'Resource' abort with status \"415 Unsupported Media
 -- Type\". If the request has no \"Content-Type\", it aborts with
 -- \"400 Bad Request\".
-inputForm :: Int -> Resource [FormData]
+inputForm :: Int -> Resource [(String, FormData)]
 inputForm limit
     = limit `seq` 
       do cTypeM <- getContentType
@@ -742,8 +748,7 @@ inputForm limit
                                                           ++ show cType)
     where
       readWWWFormURLEncoded
-          = do src <- input limit
-               return $ map pairToFormData $ parseWWWFormURLEncoded src
+          = liftM (map toPairWithFormData . parseWWWFormURLEncoded) (input limit)
 
       readMultipartFormData params
           = do case find ((== "boundary") . map toLower . fst) params of
@@ -752,7 +757,8 @@ inputForm limit
                  Just (_, boundary)
                      -> do src <- inputLBS limit
                            case parse (multipartFormP boundary) src of
-                             (# Success fdList, _ #) -> return fdList
+                             (# Success formList, _ #)
+                                 -> return formList
                              (# _, _ #)
                                  -> abort BadRequest [] (Just "Unparsable multipart/form-data")