X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=f1186b7170635c4a4d7181cf84da509b2b24e08a;hb=1196f43ecedbb123515065f0440844864af906fb;hp=bf75de8a5f6b5bf4ad5b5a9060713282c833788c;hpb=15aa04a569fb13fb0793389f78f52b0255083cef;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index bf75de8..f1186b7 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'
@@ -85,6 +85,7 @@ module Network.HTTP.Lucu.Resource
     , getAcceptEncoding
     , isEncodingAcceptable
     , getContentType
+    , getAuthorization
 
     -- ** Finding an entity
 
@@ -117,6 +118,7 @@ module Network.HTTP.Lucu.Resource
     , setContentType
     , setLocation
     , setContentEncoding
+    , setWWWAuthenticate
 
     -- ** Writing a response body
 
@@ -134,12 +136,16 @@ module Network.HTTP.Lucu.Resource
 import           Control.Concurrent.STM
 import           Control.Monad.Reader
 import           Data.Bits
-import           Data.ByteString.Base (ByteString, LazyByteString(..))
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy.Char8 as L8
+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.Lazy.Char8 as L8 hiding (ByteString)
+import           Data.Char
 import           Data.List
 import           Data.Maybe
+import           Data.Time
 import           Network.HTTP.Lucu.Abortion
+import           Network.HTTP.Lucu.Authorization
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.ContentCoding
 import           Network.HTTP.Lucu.DefaultPage
@@ -147,6 +153,7 @@ import           Network.HTTP.Lucu.ETag
 import qualified Network.HTTP.Lucu.Headers as H
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
+import           Network.HTTP.Lucu.MultipartForm
 import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Postprocess
 import           Network.HTTP.Lucu.RFC1123DateTime
@@ -154,9 +161,8 @@ 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
+import           Network.Socket hiding (accept)
+import           Network.URI hiding (path)
 
 -- |The 'Resource' monad. This monad implements
 -- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'
@@ -206,15 +212,17 @@ getRemoteAddr' :: Resource String
 getRemoteAddr' = do addr <- getRemoteAddr
                     case addr of
                       -- Network.Socket は IPv6 を考慮してゐないやうだ…
-                      (SockAddrInet _ v4addr)
+                      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)
+                      SockAddrUnix path
                           -> return path
+                      _
+                          -> undefined
 
 
 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
@@ -271,8 +279,8 @@ getResourcePath = do itr <- getInteraction
 -- greedy. See 'getResourcePath'.
 getPathInfo :: Resource [String]
 getPathInfo = do rsrcPath <- getResourcePath
-                 reqURI   <- getRequestURI
-                 let reqPathStr = uriPath reqURI
+                 uri      <- getRequestURI
+                 let reqPathStr = uriPath uri
                      reqPath    = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
                  -- rsrcPath と reqPath の共通する先頭部分を reqPath か
                  -- ら全部取り除くと、それは PATH_INFO のやうなものにな
@@ -285,14 +293,14 @@ getPathInfo = do rsrcPath <- getResourcePath
 -- application\/x-www-form-urlencoded, and parse it. This action
 -- doesn't parse the request body. See 'inputForm'.
 getQueryForm :: Resource [(String, String)]
-getQueryForm = do reqURI <- getRequestURI
-                  return $! parseWWWFormURLEncoded $ uriQuery reqURI
+getQueryForm = do uri <- getRequestURI
+                  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
 -- so frequently: there should be actions like 'getContentType' for
 -- every common headers.
-getHeader :: ByteString -> Resource (Maybe ByteString)
+getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString)
 getHeader name = name `seq`
                  do req <- getRequest
                     return $! H.getHeader name req
@@ -305,7 +313,7 @@ getAccept = do acceptM <- getHeader (C8.pack "Accept")
                  Nothing 
                      -> return []
                  Just accept
-                     -> case parse mimeTypeListP (LPS [accept]) of
+                     -> case parse mimeTypeListP (L8.fromChunks [accept]) of
                           (# Success xs, _ #) -> return xs
                           (# _         , _ #) -> abort BadRequest []
                                                  (Just $ "Unparsable Accept: " ++ C8.unpack accept)
@@ -326,12 +334,13 @@ getAcceptEncoding
                      case ver of
                        HttpVersion 1 0 -> return [("identity", Nothing)]
                        HttpVersion 1 1 -> return [("*"       , Nothing)]
+                       _               -> undefined
            Just value
                -> if C8.null value then
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                   else
-                      case parse acceptEncodingListP (LPS [value]) of
+                      case parse acceptEncodingListP (L8.fromChunks [value]) of
                         (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
                         (# _        , _ #) -> abort BadRequest []
                                               (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
@@ -353,12 +362,26 @@ getContentType
            Nothing
                -> return Nothing
            Just cType
-               -> case parse mimeTypeP (LPS [cType]) of
+               -> case parse mimeTypeP (L8.fromChunks [cType]) of
                     (# Success t, _ #) -> return $ Just t
                     (# _        , _ #) -> abort BadRequest []
                                           (Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
 
 
+-- |Get the header \"Authorization\" as
+-- 'Network.HTTP.Lucu.Authorization.AuthCredential'.
+getAuthorization :: Resource (Maybe AuthCredential)
+getAuthorization
+    = do authM <- getHeader (C8.pack "Authorization")
+         case authM of
+           Nothing
+               -> return Nothing
+           Just auth
+               -> case parse authCredentialP (L8.fromChunks [auth]) of
+                    (# Success a, _ #) -> return $ Just a
+                    (# _        , _ #) -> return Nothing
+
+
 {- ExaminingRequest 時に使用するアクション群 -}
 
 -- |Tell the system that the 'Resource' found an entity for the
@@ -375,7 +398,7 @@ getContentType
 --
 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
 -- \"ETag\" and \"Last-Modified\" headers into the response.
-foundEntity :: ETag -> ClockTime -> Resource ()
+foundEntity :: ETag -> UTCTime -> Resource ()
 foundEntity tag timeStamp
     = tag `seq` timeStamp `seq`
       do driftTo ExaminingRequest
@@ -416,7 +439,7 @@ foundETag tag
            Just value -> if value == C8.pack "*" then
                              return ()
                          else
-                             case parse eTagListP (LPS [value]) of
+                             case parse eTagListP (L8.fromChunks [value]) of
                                (# Success tags, _ #)
                                  -- tags の中に一致するものが無ければ
                                  -- PreconditionFailed で終了。
@@ -438,7 +461,7 @@ foundETag tag
            Just value -> if value == C8.pack "*" then
                              abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
                          else
-                             case parse eTagListP (LPS [value]) of
+                             case parse eTagListP (L8.fromChunks [value]) of
                                (# Success tags, _ #)
                                    -> when (any (== tag) tags)
                                       $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value)
@@ -457,7 +480,7 @@ foundETag tag
 --
 -- This action is not preferred. You should use 'foundEntity' whenever
 -- possible.
-foundTimeStamp :: ClockTime -> Resource ()
+foundTimeStamp :: UTCTime -> Resource ()
 foundTimeStamp timeStamp
     = timeStamp `seq`
       do driftTo ExaminingRequest
@@ -477,7 +500,7 @@ foundTimeStamp timeStamp
          -- If-Modified-Since があればそれを見る。
          ifModSince <- getHeader (C8.pack "If-Modified-Since")
          case ifModSince of
-           Just str -> case parseHTTPDateTime (LPS [str]) of
+           Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
                          Just lastTime
                              -> when (timeStamp <= lastTime)
                                 $ abort statusForIfModSince []
@@ -489,7 +512,7 @@ foundTimeStamp timeStamp
          -- If-Unmodified-Since があればそれを見る。
          ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
          case ifUnmodSince of
-           Just str -> case parseHTTPDateTime (LPS [str]) of
+           Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
                          Just lastTime
                              -> when (timeStamp > lastTime)
                                 $ abort PreconditionFailed []
@@ -548,13 +571,12 @@ input limit = limit `seq`
 
 
 -- | This is mostly the same as 'input' but is more
--- efficient. 'inputLBS' returns a
--- 'Data.ByteString.Base.LazyByteString' but it's not really lazy:
--- reading from the socket just happens at the computation of
--- 'inputLBS', not at the evaluation of the
--- 'Data.ByteString.Base.LazyByteString'. The same goes for
+-- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString'
+-- but it's not really lazy: reading from the socket just happens at
+-- the computation of 'inputLBS', not at the evaluation of the
+-- 'Data.ByteString.Lazy.ByteString'. The same goes for
 -- 'inputChunkLBS'.
-inputLBS :: Int -> Resource LazyByteString
+inputLBS :: Int -> Resource Lazy.ByteString
 inputLBS limit
     = limit `seq`
       do driftTo GettingBody
@@ -567,14 +589,14 @@ inputLBS limit
                            return L8.empty
          return chunk
     where
-      askForInput :: Interaction -> Resource LazyByteString
+      askForInput :: Interaction -> Resource Lazy.ByteString
       askForInput itr
           = itr `seq`
-            do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
-                   actualLimit  = if limit <= 0 then
-                                      defaultLimit
-                                  else
-                                      limit
+            do let confLimit   = cnfMaxEntityLength $ itrConfig itr
+                   actualLimit = if limit <= 0 then
+                                     confLimit
+                                 else
+                                     limit
                when (actualLimit <= 0)
                         $ fail ("inputLBS: limit must be positive: " ++ show actualLimit)
                -- Reader にリクエスト
@@ -634,7 +656,7 @@ inputChunk limit = limit `seq`
 
 -- | This is mostly the same as 'inputChunk' but is more
 -- efficient. See 'inputLBS'.
-inputChunkLBS :: Int -> Resource LazyByteString
+inputChunkLBS :: Int -> Resource Lazy.ByteString
 inputChunkLBS limit
     = limit `seq`
       do driftTo GettingBody
@@ -647,12 +669,12 @@ inputChunkLBS limit
                            return L8.empty
          return chunk
     where
-      askForInput :: Interaction -> Resource LazyByteString
+      askForInput :: Interaction -> Resource Lazy.ByteString
       askForInput itr
           = itr `seq`
-            do let defaultLimit = cnfMaxEntityLength $! itrConfig itr
-                   actualLimit  = if limit < 0 then
-                                      defaultLimit
+            do let confLimit   = cnfMaxEntityLength $! itrConfig itr
+                   actualLimit = if limit < 0 then
+                                      confLimit
                                   else
                                       limit
                when (actualLimit <= 0)
@@ -679,14 +701,11 @@ inputChunkLBS limit
 
 -- | Computation of @'inputForm' limit@ attempts to read the request
 -- body with 'input' and parse it as
--- application\/x-www-form-urlencoded. If the request header
--- \"Content-Type\" is not application\/x-www-form-urlencoded,
--- 'inputForm' makes 'Resource' abort with status \"415 Unsupported
--- Media Type\". If the request has no \"Content-Type\", it aborts
--- with \"400 Bad Request\".
---
--- This action should also support multipart\/form-data somehow, but
--- it is not (yet) done.
+-- application\/x-www-form-urlencoded or multipart\/form-data. If the
+-- request header \"Content-Type\" is neither of them, 'inputForm'
+-- 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 limit
     = limit `seq` 
@@ -696,8 +715,8 @@ inputForm limit
                -> abort BadRequest [] (Just "Missing Content-Type")
            Just (MIMEType "application" "x-www-form-urlencoded" _)
                -> readWWWFormURLEncoded
-           Just (MIMEType "multipart" "form-data" _)
-               -> readMultipartFormData
+           Just (MIMEType "multipart" "form-data" params)
+               -> readMultipartFormData params
            Just cType
                -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "
                                                           ++ show cType)
@@ -706,9 +725,16 @@ inputForm limit
           = do src <- input limit
                return $ parseWWWFormURLEncoded src
 
-      readMultipartFormData -- FIXME: 未對應
-          = abort UnsupportedMediaType []
-            (Just $! "Sorry, inputForm does not currently support multipart/form-data.")
+      readMultipartFormData params
+          = do case find ((== "boundary") . map toLower . fst) params of
+                 Nothing
+                     -> abort BadRequest [] (Just "Missing boundary of multipart/form-data")
+                 Just (_, boundary)
+                     -> do src <- inputLBS limit
+                           case parse (multipartFormP boundary) src of
+                             (# Success pairs, _ #) -> return pairs
+                             (# _, _ #)
+                                 -> abort BadRequest [] (Just "Unparsable multipart/form-data")
 
 -- | This is just a constant @-1@. It's better to say @'input'
 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
@@ -746,13 +772,13 @@ setStatus code
 -- 20 bytes long. In this case the client shall only accept the first
 -- 10 bytes of response body and thinks that the residual 10 bytes is
 -- a part of header of the next response.
-setHeader :: ByteString -> ByteString -> Resource ()
+setHeader :: Strict.ByteString -> Strict.ByteString -> Resource ()
 setHeader name value
     = name `seq` value `seq`
       driftTo DecidingHeader >> setHeader' name value
          
 
-setHeader' :: ByteString -> ByteString -> Resource ()
+setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource ()
 setHeader' name value
     = name `seq` value `seq`
       do itr <- getInteraction
@@ -794,8 +820,15 @@ setContentEncoding codings
          let tr = case ver of
                     HttpVersion 1 0 -> unnormalizeCoding
                     HttpVersion 1 1 -> id
+                    _               -> undefined
          setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
 
+-- |Computation of @'setWWWAuthenticate' challenge@ sets the response
+-- header \"WWW-Authenticate\" to @challenge@.
+setWWWAuthenticate :: AuthChallenge -> Resource ()
+setWWWAuthenticate challenge
+    = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge)
+
 
 {- DecidingBody 時に使用するアクション群 -}
 
@@ -811,7 +844,7 @@ output str = outputLBS $! L8.pack str
 {-# INLINE output #-}
 
 -- | This is mostly the same as 'output' but is more efficient.
-outputLBS :: LazyByteString -> Resource ()
+outputLBS :: Lazy.ByteString -> Resource ()
 outputLBS str = do outputChunkLBS str
                    driftTo Done
 {-# INLINE outputLBS #-}
@@ -828,9 +861,9 @@ outputChunk str = outputChunkLBS $! L8.pack str
 {-# INLINE outputChunk #-}
 
 -- | This is mostly the same as 'outputChunk' but is more efficient.
-outputChunkLBS :: LazyByteString -> Resource ()
-outputChunkLBS str
-    = str `seq`
+outputChunkLBS :: Lazy.ByteString -> Resource ()
+outputChunkLBS wholeChunk
+    = wholeChunk `seq`
       do driftTo DecidingBody
          itr <- getInteraction
          
@@ -843,18 +876,18 @@ outputChunkLBS str
                         readItr itr itrWillDiscardBody id
 
          unless (discardBody)
-                    $ sendChunks str limit
+                    $ sendChunks wholeChunk limit
 
-         unless (L8.null str)
+         unless (L8.null wholeChunk)
                     $ liftIO $ atomically $
                       writeItr itr itrBodyIsNull False
     where
       -- チャンクの大きさは Config で制限されてゐる。もし例へば
-      -- "/dev/zero" を L8.readFile して作った LazyByteString をそのまま
+      -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
       -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
       -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
       -- く爲にチャンクの大きさを測る。
-      sendChunks :: LazyByteString -> Int -> Resource ()
+      sendChunks :: Lazy.ByteString -> Int -> Resource ()
       sendChunks str limit
           | L8.null str = return ()
           | otherwise   = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str