getRemoteAddr and getRemoteAddr'

darcs-hash:20070610095254-62b54-eee80f2bb75d1a78cc2f36b569820b9f0257e74f.gz

diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs
index c5e8f04981ee7845e9049feacbfe0d43121efa77..b8e1845dd32e41edfb966dbc6f460ba936948b90 100644 (file)
--- a/Network/HTTP/Lucu/Httpd.hs
+++ b/Network/HTTP/Lucu/Httpd.hs
@@ -6,11 +6,13 @@ module Network.HTTP.Lucu.Httpd
 
 import           Control.Concurrent
 import           Network
+import qualified Network.Socket as So
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.RequestReader
 import           Network.HTTP.Lucu.Resource.Tree
 import           Network.HTTP.Lucu.ResponseWriter
+import           System.IO
 import           System.Posix.Signals
 
 -- | This is the entry point of Lucu httpd. It listens to a socket and
@@ -54,8 +56,16 @@ runHttpd cnf tree
     where
       loop :: Socket -> IO ()
       loop so
-          = do (h, host, _) <- accept so
-               tQueue       <- newInteractionQueue
-               readerTID    <- forkIO $ requestReader cnf tree h host tQueue
-               writerTID    <- forkIO $ responseWriter cnf h tQueue readerTID
+          -- 本當は Network.accept を使ひたいが、このアクションは勝手に
+          -- リモートのIPを逆引きするので、使へない。
+          = do (h, addr) <- accept' so
+               tQueue    <- newInteractionQueue
+               readerTID <- forkIO $ requestReader cnf tree h addr tQueue
+               writerTID <- forkIO $ responseWriter cnf h tQueue readerTID
                loop so
+
+      accept' :: Socket -> IO (Handle, So.SockAddr)
+      accept' soSelf
+          = do (soPeer, addr) <- So.accept soSelf
+               hPeer          <- So.socketToHandle soPeer ReadWriteMode
+               return (hPeer, addr)

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 88cded5c339209fc2f1d023a50c28318747ca4fa..29c944e573bf8c41c1fbb2ca2cb00ba500181eab 100644 (file)
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -20,7 +20,7 @@ import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.Sequence as S
 import           Data.Sequence (Seq)
-import           Network
+import           Network.Socket
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Request
@@ -28,7 +28,7 @@ import           Network.HTTP.Lucu.Response
 
 data Interaction = Interaction {
       itrConfig       :: Config
-    , itrRemoteHost   :: HostName
+    , itrRemoteAddr   :: SockAddr
     , itrResourcePath :: Maybe [String]
     , itrRequest      :: TVar (Maybe Request)
     , itrResponse     :: TVar Response
@@ -82,8 +82,8 @@ defaultPageContentType :: String
 defaultPageContentType = "application/xhtml+xml"
 
 
-newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
-newInteraction conf host req
+newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
+newInteraction conf addr req
     = do request  <- newTVarIO $ req
          responce <- newTVarIO $ Response {
                        resVersion = HttpVersion 1 1
@@ -117,7 +117,7 @@ newInteraction conf host req
 
          return $ Interaction {
                       itrConfig       = conf
-                    , itrRemoteHost   = host
+                    , itrRemoteAddr   = addr
                     , itrResourcePath = Nothing
                     , itrRequest      = request
                     , itrResponse     = responce

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 800484cd0674a98d93dc214cb2c7ad94654cae36..57e0bdc29bf600dd7db44def5d1540d83ada1c26 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -14,7 +14,7 @@ import           Data.Map (Map)
 import           Data.Maybe
 import qualified Data.Sequence as S
 import           Data.Sequence (Seq, (<|), ViewR(..))
-import           Network
+import           Network.Socket
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Chunk
 import           Network.HTTP.Lucu.DefaultPage
@@ -31,8 +31,8 @@ import           Prelude hiding (catch)
 import           System.IO
 
 
-requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
-requestReader cnf tree h host tQueue
+requestReader :: Config -> ResTree -> Handle -> SockAddr -> InteractionQueue -> IO ()
+requestReader cnf tree h addr tQueue
     = do catch (do input <- B.hGetContents h
                    acceptRequest input) $ \ exc ->
              case exc of
@@ -59,7 +59,7 @@ requestReader cnf tree h host tQueue
 
       acceptNonparsableRequest :: StatusCode -> IO ()
       acceptNonparsableRequest status
-          = do itr <- newInteraction cnf host Nothing
+          = do itr <- newInteraction cnf addr Nothing
                atomically $ do updateItr itr itrResponse
                                              $ \ res -> res {
                                                           resStatus = status
@@ -72,7 +72,7 @@ requestReader cnf tree h host tQueue
 
       acceptParsableRequest :: Request -> ByteString -> IO ()
       acceptParsableRequest req input
-          = do itr <- newInteraction cnf host (Just req)
+          = do itr <- newInteraction cnf addr (Just req)
                action
                    <- atomically $
                       do preprocess itr

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 7c1ceb0f027ee03d7aacbdb565cb81b16944a237..af8c16917e154dd12e0661b671659a5c462b7b71 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -69,6 +69,8 @@ module Network.HTTP.Lucu.Resource
     -- |These actions can be computed regardless of the current state,
     -- and they don't change the state.
     , getConfig
+    , getRemoteAddr
+    , getRemoteAddr'
     , getRequest
     , getMethod
     , getRequestURI
@@ -125,6 +127,7 @@ module Network.HTTP.Lucu.Resource
 
 import           Control.Concurrent.STM
 import           Control.Monad.Reader
+import           Data.Bits
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
 import           Data.List
@@ -144,6 +147,7 @@ import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 import           Network.HTTP.Lucu.MIMEType
 import           Network.HTTP.Lucu.Utils
+import           Network.Socket
 import           Network.URI
 import           System.Time
 
@@ -158,6 +162,31 @@ getConfig :: Resource Config
 getConfig = do itr <- ask
                return $ itrConfig itr
 
+
+-- |Get the SockAddr of the remote host. If you want a string
+-- representation instead of SockAddr, use 'getRemoteAddr''.
+getRemoteAddr :: Resource SockAddr
+getRemoteAddr = do itr <- ask
+                   return $ itrRemoteAddr itr
+
+
+-- |Get the string representation of the address of remote host. If
+-- you want a SockAddr instead of 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
+
+
 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
 -- the request header. In general you don't have to use this action.
 getRequest :: Resource Request