Voker57's fix for getRemoteAddr' only works on little-endian architectures. We should...

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 12056ee8ec4fd2ac73fa9c8aac1682cdf1e88bd3..3a27e9ca5e1acbe786d83a949e7711c6d0657ffb 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,4 +1,4 @@
--- #prune
+{-# OPTIONS_HADDOCK prune #-}

 
 -- |This is the Resource Monad; monadic actions to define the behavior
 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
 
 -- |This is the Resource Monad; monadic actions to define the behavior
 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'


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

+    , getRemoteHost
+    , getRemoteCertificate

     , getRequest
     , getMethod
     , getRequestURI
     , getRequest
     , getMethod
     , getRequestURI


@@ -135,7 +137,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)


@@ -163,6 +164,7 @@ import           Network.HTTP.Lucu.MIMEType
 import           Network.HTTP.Lucu.Utils
 import           Network.Socket hiding (accept)
 import           Network.URI hiding (path)
 import           Network.HTTP.Lucu.Utils
 import           Network.Socket hiding (accept)
 import           Network.URI hiding (path)

+import           OpenSSL.X509

 
 -- |The 'Resource' monad. This monad implements
 -- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'
 
 -- |The 'Resource' monad. This monad implements
 -- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'


@@ -209,21 +211,29 @@ 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:
+--
+--   * This request didn't came through an SSL stream.
+--
+--   * The client didn't send us its certificate.
+--
+--   * The 'OpenSSL.Session.VerificationMode' of
+--     'OpenSSL.Session.SSLContext' in
+--     'Network.HTTP.Lucu.Config.SSLConfig' has not been set to
+--     'OpenSSL.Session.VerifyPeer'.
+getRemoteCertificate :: Resource (Maybe X509)
+getRemoteCertificate = do itr <- getInteraction
+                          return $! itrRemoteCert itr

 
 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
 -- the request header. In general you don't have to use this action.
 
 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
 -- the request header. In general you don't have to use this action.


@@ -294,7 +304,7 @@ getPathInfo = do rsrcPath <- getResourcePath
 -- doesn't parse the request body. See 'inputForm'.
 getQueryForm :: Resource [(String, String)]
 getQueryForm = do uri <- getRequestURI
 -- doesn't parse the request body. See 'inputForm'.
 getQueryForm :: Resource [(String, String)]
 getQueryForm = do uri <- getRequestURI

-                  return $! parseWWWFormURLEncoded $ uriQuery uri
+                  return $! parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri

 
 -- |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