Fix for insane memory usage

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 4fb836f065ef55ba4d0a9d2f48f73dae190cc0ed..e456fd278d93c976834a2ad993d3c1545413ddc6 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -61,7 +61,8 @@
 module Network.HTTP.Lucu.Resource
     (
     -- * Monad
 module Network.HTTP.Lucu.Resource
     (
     -- * Monad

-    Resource
+      Resource
+    , FormData(..)

     , runRes -- private
 
     -- * Actions
     , runRes -- private
 
     -- * Actions


@@ -73,6 +74,7 @@ module Network.HTTP.Lucu.Resource
     , getConfig
     , getRemoteAddr
     , getRemoteAddr'
     , getConfig
     , getRemoteAddr
     , getRemoteAddr'

+    , getRemoteHost

     , getRemoteCertificate
     , getRequest
     , getMethod
     , getRemoteCertificate
     , getRequest
     , getMethod


@@ -136,7 +138,6 @@ module Network.HTTP.Lucu.Resource
 
 import           Control.Concurrent.STM
 import           Control.Monad.Reader
 
 import           Control.Concurrent.STM
 import           Control.Monad.Reader

-import           Data.Bits

 import qualified Data.ByteString as Strict (ByteString)
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
 import qualified Data.ByteString as Strict (ByteString)
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)


@@ -211,20 +212,15 @@ getRemoteAddr = do itr <- getInteraction
 -- you want a 'Network.Socket.SockAddr' instead of 'Prelude.String',
 -- use 'getRemoteAddr'.
 getRemoteAddr' :: Resource String
 -- you want a 'Network.Socket.SockAddr' instead of 'Prelude.String',
 -- use 'getRemoteAddr'.
 getRemoteAddr' :: Resource String

-getRemoteAddr' = do addr <- getRemoteAddr
-                    case addr of
-                      -- Network.Socket は IPv6 を考慮してゐないやうだ…
-                      SockAddrInet _ v4addr
-                          -> let b1 = (v4addr `shiftR` 24) .&. 0xFF
-                                 b2 = (v4addr `shiftR` 16) .&. 0xFF
-                                 b3 = (v4addr `shiftR`  8) .&. 0xFF
-                                 b4 =  v4addr              .&. 0xFF
-                             in
-                               return $ concat $ intersperse "." $ map show [b1, b2, b3, b4]
-                      SockAddrUnix path
-                          -> return path
-                      _
-                          -> undefined
+getRemoteAddr' = do addr          <- getRemoteAddr
+                    (Just str, _) <- liftIO $! getNameInfo [NI_NUMERICHOST] True False addr
+                    return str
+
+-- |Resolve an address to the remote host.
+getRemoteHost :: Resource String
+getRemoteHost = do addr          <- getRemoteAddr
+                   (Just str, _) <- liftIO $! getNameInfo [] True False addr
+                   return str

 
 -- | Return the X.509 certificate of the client, or 'Nothing' if:
 --
 
 -- | Return the X.509 certificate of the client, or 'Nothing' if:
 --


@@ -307,9 +303,17 @@ getPathInfo = do rsrcPath <- getResourcePath
 -- | 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'.
 -- | 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 [(String, String)]
+getQueryForm :: Resource [FormData]

 getQueryForm = do uri <- getRequestURI
 getQueryForm = do uri <- getRequestURI

-                  return $! parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
+                  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
+      }

 
 -- |Get a value of given request header. Comparison of header name is
 -- case-insensitive. Note that this action is not intended to be used
 
 -- |Get a value of given request header. Comparison of header name is
 -- case-insensitive. Note that this action is not intended to be used


@@ -721,7 +725,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\".
 -- 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 [(String, String)]
+inputForm :: Int -> Resource [FormData]

 inputForm limit
     = limit `seq` 
       do cTypeM <- getContentType
 inputForm limit
     = limit `seq` 
       do cTypeM <- getContentType


@@ -738,7 +742,7 @@ inputForm limit
     where
       readWWWFormURLEncoded
           = do src <- input limit
     where
       readWWWFormURLEncoded
           = do src <- input limit

-               return $ parseWWWFormURLEncoded src
+               return $ map pairToFormData $ parseWWWFormURLEncoded src

 
       readMultipartFormData params
           = do case find ((== "boundary") . map toLower . fst) params of
 
       readMultipartFormData params
           = do case find ((== "boundary") . map toLower . fst) params of


@@ -747,7 +751,7 @@ inputForm limit
                  Just (_, boundary)
                      -> do src <- inputLBS limit
                            case parse (multipartFormP boundary) src of
                  Just (_, boundary)
                      -> do src <- inputLBS limit
                            case parse (multipartFormP boundary) src of

-                             (# Success pairs, _ #) -> return pairs
+                             (# Success fdList, _ #) -> return fdList

                              (# _, _ #)
                                  -> abort BadRequest [] (Just "Unparsable multipart/form-data")
 
                              (# _, _ #)
                                  -> abort BadRequest [] (Just "Unparsable multipart/form-data")