Fixed build failure on recent GHC and other libraries

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index f1186b7170635c4a4d7181cf84da509b2b24e08a..15b211fba6d17872dc6201a55d8a69bdfd42c326 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -60,8 +60,9 @@
 
 module Network.HTTP.Lucu.Resource
     (
 
 module Network.HTTP.Lucu.Resource
     (

-    -- * Monad
-    Resource
+    -- * Types
+      Resource
+    , FormData(..)

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


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

+    , getRemoteHost
+    , getRemoteCertificate

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


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


@@ -144,6 +146,7 @@ import           Data.Char
 import           Data.List
 import           Data.Maybe
 import           Data.Time
 import           Data.List
 import           Data.Maybe
 import           Data.Time

+import qualified Data.Time.HTTP as HTTP

 import           Network.HTTP.Lucu.Abortion
 import           Network.HTTP.Lucu.Authorization
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Abortion
 import           Network.HTTP.Lucu.Authorization
 import           Network.HTTP.Lucu.Config


@@ -156,13 +159,13 @@ import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.MultipartForm
 import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Postprocess
 import           Network.HTTP.Lucu.MultipartForm
 import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Postprocess

-import           Network.HTTP.Lucu.RFC1123DateTime

 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 import           Network.HTTP.Lucu.MIMEType
 import           Network.HTTP.Lucu.Utils
 import           Network.Socket hiding (accept)
 import           Network.URI hiding (path)
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 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'
 
 -- |The 'Resource' monad. This monad implements
 -- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'


@@ -209,21 +212,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.


@@ -274,14 +285,15 @@ getResourcePath = do itr <- getInteraction
                      return $! fromJust $! itrResourcePath itr
 
 
                      return $! fromJust $! itrResourcePath itr
 
 

--- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if
--- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not
--- greedy. See 'getResourcePath'.
+-- |This is an analogy of CGI PATH_INFO. The result is
+-- URI-unescaped. It is always @[]@ if the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
+-- 'getResourcePath'.

 getPathInfo :: Resource [String]
 getPathInfo = do rsrcPath <- getResourcePath
                  uri      <- getRequestURI
                  let reqPathStr = uriPath uri
 getPathInfo :: Resource [String]
 getPathInfo = do rsrcPath <- getResourcePath
                  uri      <- getRequestURI
                  let reqPathStr = uriPath uri

-                     reqPath    = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
+                     reqPath    = [unEscapeString x | x <- splitBy (== '/') reqPathStr, x /= ""]

                  -- rsrcPath と reqPath の共通する先頭部分を reqPath か
                  -- ら全部取り除くと、それは PATH_INFO のやうなものにな
                  -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
                  -- rsrcPath と reqPath の共通する先頭部分を reqPath か
                  -- ら全部取り除くと、それは PATH_INFO のやうなものにな
                  -- る。rsrcPath は全部一致してゐるに決まってゐる（でな


@@ -289,12 +301,26 @@ getPathInfo = do rsrcPath <- getResourcePath
                  -- rsrcPath の長さの分だけ削除すれば良い。
                  return $! drop (length rsrcPath) reqPath
 
                  -- rsrcPath の長さの分だけ削除すれば良い。
                  return $! drop (length rsrcPath) reqPath
 

--- | 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 = do uri <- getRequestURI
-                  return $! parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
+-- |Assume the query part of request URI as
+-- application\/x-www-form-urlencoded, and parse it to pairs of
+-- @(name, formData)@. This action doesn't parse the request body. See
+-- 'inputForm'.
+getQueryForm :: Resource [(String, FormData)]
+getQueryForm = liftM parse' getRequestURI
+    where
+      parse' = map toPairWithFormData .
+               parseWWWFormURLEncoded .
+               snd .
+               splitAt 1 .
+               uriQuery
+
+toPairWithFormData :: (String, String) -> (String, FormData)
+toPairWithFormData (name, value)
+    = let fd = FormData {
+                 fdFileName = Nothing
+               , fdContent  = L8.pack value
+               }
+      in (name, fd)

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


@@ -387,7 +413,7 @@ getAuthorization
 -- |Tell the system that the 'Resource' found an entity for the
 -- request URI. If this is a GET or HEAD request, a found entity means
 -- a datum to be replied. If this is a PUT or DELETE request, it means
 -- |Tell the system that the 'Resource' found an entity for the
 -- request URI. If this is a GET or HEAD request, a found entity means
 -- a datum to be replied. If this is a PUT or DELETE request, it means

--- a datum which was stored for the URI up to now. It is an error to
+-- a datum which was stored for the URI until now. It is an error to

 -- compute 'foundEntity' if this is a POST request.
 --
 -- Computation of 'foundEntity' performs \"If-Match\" test or
 -- compute 'foundEntity' if this is a POST request.
 --
 -- Computation of 'foundEntity' performs \"If-Match\" test or


@@ -405,10 +431,10 @@ foundEntity tag timeStamp
 
          method <- getMethod
          when (method == GET || method == HEAD)
 
          method <- getMethod
          when (method == GET || method == HEAD)

-                  $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
+                  $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)

          when (method == POST)
                   $ abort InternalServerError []
          when (method == POST)
                   $ abort InternalServerError []

-                        (Just "Illegal computation of foundEntity for POST request.")
+                        (Just "Illegal computation of foundEntity for a POST request.")

          foundETag tag
 
          driftTo GettingBody
          foundETag tag
 
          driftTo GettingBody


@@ -487,7 +513,7 @@ foundTimeStamp timeStamp
 
          method <- getMethod
          when (method == GET || method == HEAD)
 
          method <- getMethod
          when (method == GET || method == HEAD)

-                  $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
+                  $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)

          when (method == POST)
                   $ abort InternalServerError []
                         (Just "Illegal computation of foundTimeStamp for POST request.")
          when (method == POST)
                   $ abort InternalServerError []
                         (Just "Illegal computation of foundTimeStamp for POST request.")


@@ -500,7 +526,7 @@ foundTimeStamp timeStamp
          -- If-Modified-Since があればそれを見る。
          ifModSince <- getHeader (C8.pack "If-Modified-Since")
          case ifModSince of
          -- If-Modified-Since があればそれを見る。
          ifModSince <- getHeader (C8.pack "If-Modified-Since")
          case ifModSince of

-           Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
+           Just str -> case HTTP.parse (C8.unpack str) of

                          Just lastTime
                              -> when (timeStamp <= lastTime)
                                 $ abort statusForIfModSince []
                          Just lastTime
                              -> when (timeStamp <= lastTime)
                                 $ abort statusForIfModSince []


@@ -512,7 +538,7 @@ foundTimeStamp timeStamp
          -- If-Unmodified-Since があればそれを見る。
          ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
          case ifUnmodSince of
          -- If-Unmodified-Since があればそれを見る。
          ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
          case ifUnmodSince of

-           Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
+           Just str -> case HTTP.parse (C8.unpack str) of

                          Just lastTime
                              -> when (timeStamp > lastTime)
                                 $ abort PreconditionFailed []
                          Just lastTime
                              -> when (timeStamp > lastTime)
                                 $ abort PreconditionFailed []


@@ -706,7 +732,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 [(String, FormData)]

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


@@ -722,8 +748,7 @@ inputForm limit
                                                           ++ show cType)
     where
       readWWWFormURLEncoded
                                                           ++ show cType)
     where
       readWWWFormURLEncoded

-          = do src <- input limit
-               return $ parseWWWFormURLEncoded src
+          = liftM (map toPairWithFormData . parseWWWFormURLEncoded) (input limit)

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


@@ -732,7 +757,8 @@ 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 formList, _ #)
+                                 -> return formList

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