X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=3a27e9ca5e1acbe786d83a949e7711c6d0657ffb;hb=d0558f77cf306aa2cab58a71aeecff04c1ffcd06;hp=12056ee8ec4fd2ac73fa9c8aac1682cdf1e88bd3;hpb=497cbd0e695fa05a0db8dd17dad7b303321ed1e0;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 12056ee..3a27e9c 100644
--- 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'
@@ -73,6 +73,8 @@ module Network.HTTP.Lucu.Resource
     , getConfig
     , getRemoteAddr
     , getRemoteAddr'
+    , getRemoteHost
+    , getRemoteCertificate
     , getRequest
     , getMethod
     , getRequestURI
@@ -135,7 +137,6 @@ module Network.HTTP.Lucu.Resource
 
 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)
@@ -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           OpenSSL.X509
 
 -- |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
-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.
@@ -294,7 +304,7 @@ getPathInfo = do rsrcPath <- getResourcePath
 -- 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