From: pho Date: Sun, 10 Jun 2007 09:52:54 +0000 (+0900) Subject: getRemoteAddr and getRemoteAddr' X-Git-Tag: RELEASE-0_2_1~40 X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=5b255535f2c7d2a6d4622ad164b31e63746b906e;p=Lucu.git getRemoteAddr and getRemoteAddr' darcs-hash:20070610095254-62b54-eee80f2bb75d1a78cc2f36b569820b9f0257e74f.gz --- diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index c5e8f04..b8e1845 100644 --- 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 88cded5..29c944e 100644 --- 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 800484c..57e0bdc 100644 --- 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 7c1ceb0..af8c169 100644 --- 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