X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=8e25904ac927d00da9d96fecdfff998328f7d6d7;hb=0dc3d31312a12f2b085242841b29eb0d96e9c4ac;hp=96863f044dad4c803bdd42360e27d67cac5b8105;hpb=858129cb755aa09da2b7bd758efb8519f2c89103;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 96863f0..8e25904 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,8 +1,9 @@
 -- #prune
 
 -- |This is the Resource Monad; monadic actions to define the behavior
--- of each resources. The 'Resource' Monad is a kind of IO Monad thus
--- it implements MonadIO class. It is also a state machine.
+-- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
+-- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
+-- also a state machine.
 -- 
 -- Request Processing Flow:
 --
@@ -61,6 +62,7 @@ module Network.HTTP.Lucu.Resource
     (
     -- * Monad
     Resource
+    , runRes -- private
 
     -- * Actions
 
@@ -74,11 +76,14 @@ module Network.HTTP.Lucu.Resource
     , getRequest
     , getMethod
     , getRequestURI
+    , getRequestVersion
     , getResourcePath
     , getPathInfo
     , getQueryForm
     , getHeader
     , getAccept
+    , getAcceptEncoding
+    , isEncodingAcceptable
     , getContentType
 
     -- ** Finding an entity
@@ -97,8 +102,8 @@ module Network.HTTP.Lucu.Resource
     -- Body/.
     , input
     , inputChunk
-    , inputBS
-    , inputChunkBS
+    , inputLBS
+    , inputChunkLBS
     , inputForm
     , defaultLimit
 
@@ -111,6 +116,7 @@ module Network.HTTP.Lucu.Resource
     , redirect
     , setContentType
     , setLocation
+    , setContentEncoding
 
     -- ** Writing a response body
 
@@ -118,8 +124,8 @@ module Network.HTTP.Lucu.Resource
     -- Body/.
     , output
     , outputChunk
-    , outputBS
-    , outputChunkBS
+    , outputLBS
+    , outputChunkLBS
 
     , driftTo
     )
@@ -128,13 +134,13 @@ module Network.HTTP.Lucu.Resource
 import           Control.Concurrent.STM
 import           Control.Monad.Reader
 import           Data.Bits
+import           Data.ByteString.Base (LazyByteString)
 import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.ByteString.Lazy.Char8 (ByteString)
 import           Data.List
 import           Data.Maybe
-import           GHC.Conc (unsafeIOToSTM)
 import           Network.HTTP.Lucu.Abortion
 import           Network.HTTP.Lucu.Config
+import           Network.HTTP.Lucu.ContentCoding
 import           Network.HTTP.Lucu.DefaultPage
 import           Network.HTTP.Lucu.ETag
 import qualified Network.HTTP.Lucu.Headers as H
@@ -151,27 +157,50 @@ import           Network.Socket
 import           Network.URI
 import           System.Time
 
--- |The 'Resource' monad. /Interaction/ is an internal state thus it
--- is not exposed to users. This monad implements 'MonadIO' so it can
--- do any IO actions.
-type Resource a = ReaderT Interaction IO a
+-- |The 'Resource' monad. This monad implements
+-- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'
+-- actions.
+newtype Resource a = Resource { unRes :: ReaderT Interaction IO a }
+
+instance Functor Resource where
+    fmap f c = Resource (fmap f (unRes c))
+
+instance Monad Resource where
+    c >>= f = Resource (unRes c >>= unRes . f)
+    return  = Resource . return
+    fail    = Resource . fail
+
+instance MonadIO Resource where
+    liftIO = Resource . liftIO
+
+
+runRes :: Resource a -> Interaction -> IO a
+runRes r itr
+    = runReaderT (unRes r) itr
+
+
+getInteraction :: Resource Interaction
+getInteraction = Resource ask
+
 
 -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for
 -- the httpd.
 getConfig :: Resource Config
-getConfig = do itr <- ask
+getConfig = do itr <- getInteraction
                return $! itrConfig itr
 
 
--- |Get the SockAddr of the remote host. If you want a string
--- representation instead of SockAddr, use 'getRemoteAddr''.
+-- |Get the 'Network.Socket.SockAddr' of the remote host. If you want
+-- a string representation instead of 'Network.Socket.SockAddr', use
+-- 'getRemoteAddr''.
 getRemoteAddr :: Resource SockAddr
-getRemoteAddr = do itr <- ask
+getRemoteAddr = do itr <- getInteraction
                    return $! itrRemoteAddr itr
 
 
 -- |Get the string representation of the address of remote host. If
--- you want a SockAddr instead of String, use 'getRemoteAddr'.
+-- you want a 'Network.Socket.SockAddr' instead of String, use
+-- 'getRemoteAddr'.
 getRemoteAddr' :: Resource String
 getRemoteAddr' = do addr <- getRemoteAddr
                     case addr of
@@ -190,7 +219,7 @@ getRemoteAddr' = do addr <- getRemoteAddr
 -- |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
-getRequest = do itr <- ask
+getRequest = do itr <- getInteraction
                 req <- liftIO $! atomically $! readItr itr itrRequest fromJust
                 return req
 
@@ -204,6 +233,11 @@ getRequestURI :: Resource URI
 getRequestURI = do req <- getRequest
                    return $! reqURI req
 
+-- |Get the HTTP version of the request.
+getRequestVersion :: Resource HttpVersion
+getRequestVersion = do req <- getRequest
+                       return $! reqVersion req
+
 -- |Get the path of this 'Resource' (to be exact,
 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
@@ -227,7 +261,7 @@ getRequestURI = do req <- getRequest
 -- >   , ...
 -- >   }
 getResourcePath :: Resource [String]
-getResourcePath = do itr <- ask
+getResourcePath = do itr <- getInteraction
                      return $! fromJust $! itrResourcePath itr
 
 
@@ -265,25 +299,62 @@ getHeader name = name `seq`
 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
 -- header \"Accept\".
 getAccept :: Resource [MIMEType]
-getAccept = do accept <- getHeader "Accept"
-               if accept == Nothing then
-                   return []
-                 else
-                   case parseStr mimeTypeListP $ fromJust accept of
-                     (Success xs, _) -> return xs
-                     _               -> return []
+getAccept = do acceptM <- getHeader "Accept"
+               case acceptM of
+                 Nothing 
+                     -> return []
+                 Just accept
+                     -> case parseStr mimeTypeListP accept of
+                          (# Success xs, _ #) -> return xs
+                          (# _         , _ #) -> abort BadRequest []
+                                                 (Just $ "Unparsable Accept: " ++ accept)
+
+-- |Get a list of @(contentCoding, qvalue)@ enumerated on header
+-- \"Accept-Encoding\". The list is sorted in descending order by
+-- qvalue.
+getAcceptEncoding :: Resource [(String, Maybe Double)]
+getAcceptEncoding
+    = do accEncM <- getHeader "Accept-Encoding"
+         case accEncM of
+           Nothing
+               -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
+               -- ので安全の爲 identity が指定された事にする。HTTP/1.1
+               -- の場合は何でも受け入れて良い事になってゐるので "*" が
+               -- 指定された事にする。
+               -> do ver <- getRequestVersion
+                     case ver of
+                       HttpVersion 1 0 -> return [("identity", Nothing)]
+                       HttpVersion 1 1 -> return [("*"       , Nothing)]
+           Just ""
+               -- identity のみが許される。
+               -> return [("identity", Nothing)]
+           Just accEnc
+               -> case parseStr acceptEncodingListP accEnc of
+                    (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
+                    (# _        , _ #) -> abort BadRequest []
+                                          (Just $ "Unparsable Accept-Encoding: " ++ accEnc)
+
+-- |Check whether a given content-coding is acceptable.
+isEncodingAcceptable :: String -> Resource Bool
+isEncodingAcceptable coding
+    = do accList <- getAcceptEncoding
+         return (flip any accList $ \ (c, q) ->
+                     (c == "*" || c `noCaseEq` coding) && q /= Just 0)
+
 
 -- |Get the header \"Content-Type\" as
 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
 getContentType :: Resource (Maybe MIMEType)
-getContentType = do cType <- getHeader "Content-Type"
-                    if cType == Nothing then
-                        return Nothing
-                      else
-                        case parseStr mimeTypeP $ fromJust cType of
-                          (Success t, _) -> return $ Just t
-                          _              -> return Nothing
-
+getContentType
+    = do cTypeM <- getHeader "Content-Type"
+         case cTypeM of
+           Nothing
+               -> return Nothing
+           Just cType
+               -> case parseStr mimeTypeP cType of
+                    (# Success t, _ #) -> return $ Just t
+                    (# _        , _ #) -> abort BadRequest []
+                                          (Just $ "Unparsable Content-Type: " ++ cType)
 
 
 {- ExaminingRequest 時に使用するアクション群 -}
@@ -322,7 +393,7 @@ foundEntity tag timeStamp
 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
 -- the response.
 --
--- This action is not preferred. You should use 'foundEntity' when
+-- This action is not preferred. You should use 'foundEntity' whenever
 -- possible.
 foundETag :: ETag -> Resource ()
 foundETag tag
@@ -342,13 +413,14 @@ foundETag tag
            Nothing   -> return ()
            Just "*"  -> return ()
            Just list -> case parseStr eTagListP list of
-                          (Success tags, _)
+                          (# Success tags, _ #)
                               -- tags の中に一致するものが無ければ
                               -- PreconditionFailed で終了。
                               -> when (not $ any (== tag) tags)
                                  $ abort PreconditionFailed []
                                        $! Just ("The entity tag doesn't match: " ++ list)
-                          _   -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch)
+                          (# _, _ #)
+                              -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch)
 
          let statusForNoneMatch = if method == GET || method == HEAD then
                                       NotModified
@@ -361,10 +433,11 @@ foundETag tag
            Nothing   -> return ()
            Just "*"  -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
            Just list -> case parseStr eTagListP list of
-                          (Success tags, _)
+                          (# Success tags, _ #)
                               -> when (any (== tag) tags)
                                  $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list)
-                          _   -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
+                          (# _, _ #)
+                              -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
 
          driftTo GettingBody
 
@@ -376,7 +449,7 @@ foundETag tag
 -- modification time are unsafe because it is possible to mess up such
 -- tests by modifying the entity twice in a second.
 --
--- This action is not preferred. You should use 'foundEntity' when
+-- This action is not preferred. You should use 'foundEntity' whenever
 -- possible.
 foundTimeStamp :: ClockTime -> Resource ()
 foundTimeStamp timeStamp
@@ -461,23 +534,25 @@ foundNoEntity msgM
 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
 -- 'defaultLimit'.
 --
--- Note that 'inputBS' is more efficient than 'input' so you should
+-- Note that 'inputLBS' is more efficient than 'input' so you should
 -- use it whenever possible.
 input :: Int -> Resource String
 input limit = limit `seq`
-              inputBS limit >>= return . B.unpack
+              inputLBS limit >>= return . B.unpack
 
 
 -- | This is mostly the same as 'input' but is more
--- efficient. 'inputBS' returns a lazy ByteString but it's not really
--- lazy: reading from the socket just happens at the computation of
--- 'inputBS', not at the lazy evaluation of the ByteString. The same
--- goes for 'inputChunkBS'.
-inputBS :: Int -> Resource ByteString
-inputBS limit
+-- 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
+-- 'inputChunkLBS'.
+inputLBS :: Int -> Resource LazyByteString
+inputLBS limit
     = limit `seq`
       do driftTo GettingBody
-         itr     <- ask
+         itr     <- getInteraction
          hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
          chunk   <- if hasBody then
                         askForInput itr
@@ -486,7 +561,7 @@ inputBS limit
                            return B.empty
          return chunk
     where
-      askForInput :: Interaction -> Resource ByteString
+      askForInput :: Interaction -> Resource LazyByteString
       askForInput itr
           = itr `seq`
             do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
@@ -495,7 +570,7 @@ inputBS limit
                                   else
                                       limit
                when (actualLimit <= 0)
-                        $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
+                        $ fail ("inputLBS: limit must be positive: " ++ show actualLimit)
                -- Reader にリクエスト
                liftIO $! atomically
                           $! do chunkLen <- readItr itr itrReqChunkLength id
@@ -544,20 +619,20 @@ inputBS limit
 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
 -- 'defaultLimit'.
 --
--- Note that 'inputChunkBS' is more efficient than 'inputChunk' so you
+-- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
 -- should use it whenever possible.
 inputChunk :: Int -> Resource String
 inputChunk limit = limit `seq`
-                   inputChunkBS limit >>= return . B.unpack
+                   inputChunkLBS limit >>= return . B.unpack
 
 
 -- | This is mostly the same as 'inputChunk' but is more
--- efficient. See 'inputBS'.
-inputChunkBS :: Int -> Resource ByteString
-inputChunkBS limit
+-- efficient. See 'inputLBS'.
+inputChunkLBS :: Int -> Resource LazyByteString
+inputChunkLBS limit
     = limit `seq`
       do driftTo GettingBody
-         itr <- ask
+         itr     <- getInteraction
          hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
          chunk   <- if hasBody then
                         askForInput itr
@@ -566,7 +641,7 @@ inputChunkBS limit
                            return B.empty
          return chunk
     where
-      askForInput :: Interaction -> Resource ByteString
+      askForInput :: Interaction -> Resource LazyByteString
       askForInput itr
           = itr `seq`
             do let defaultLimit = cnfMaxEntityLength $! itrConfig itr
@@ -575,7 +650,7 @@ inputChunkBS limit
                                   else
                                       limit
                when (actualLimit <= 0)
-                        $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
+                        $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
                -- Reader にリクエスト
                liftIO $! atomically
                           $! do writeItr itr itrReqBodyWanted $! Just actualLimit
@@ -629,7 +704,7 @@ inputForm limit
           = abort UnsupportedMediaType []
             (Just $! "Sorry, inputForm does not currently support multipart/form-data.")
 
--- | This is just a constant -1. It's better to say @'input'
+-- | This is just a constant @-1@. It's better to say @'input'
 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
 -- the same.
 defaultLimit :: Int
@@ -645,7 +720,7 @@ setStatus :: StatusCode -> Resource ()
 setStatus code
     = code `seq`
       do driftTo DecidingHeader
-         itr <- ask
+         itr <- getInteraction
          liftIO $! atomically $! updateItr itr itrResponse
                     $! \ res -> res {
                                   resStatus = code
@@ -674,13 +749,13 @@ setHeader name value
 setHeader' :: String -> String -> Resource ()
 setHeader' name value
     = name `seq` value `seq`
-      do itr <- ask
+      do itr <- getInteraction
          liftIO $ atomically
                     $ updateItr itr itrResponse
                           $ H.setHeader name value
 
 -- | Computation of @'redirect' code uri@ sets the response status to
--- @code@ and \"Location\" header to @uri@. @code@ must satisfy
+-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
 -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
 redirect :: StatusCode -> URI -> Resource ()
 redirect code uri
@@ -705,6 +780,16 @@ setLocation :: URI -> Resource ()
 setLocation uri
     = setHeader "Location" $ uriToString id uri $ ""
 
+-- |Computation of @'setContentEncoding' codings@ sets the response
+-- header \"Content-Encoding\" to @codings@.
+setContentEncoding :: [String] -> Resource ()
+setContentEncoding codings
+    = do ver <- getRequestVersion
+         let tr = case ver of
+                    HttpVersion 1 0 -> unnormalizeCoding
+                    HttpVersion 1 1 -> id
+         setHeader "Content-Encoding" $ joinWith ", " $ map tr codings
+
 
 {- DecidingBody 時に使用するアクション群 -}
 
@@ -713,35 +798,35 @@ setLocation uri
 -- apply 'output' to an infinite string, such as a lazy stream of
 -- \/dev\/random.
 --
--- Note that 'outputBS' is more efficient than 'output' so you should
+-- Note that 'outputLBS' is more efficient than 'output' so you should
 -- use it whenever possible.
 output :: String -> Resource ()
-output str = outputBS $! B.pack str
+output str = outputLBS $! B.pack str
 {-# INLINE output #-}
 
 -- | This is mostly the same as 'output' but is more efficient.
-outputBS :: ByteString -> Resource ()
-outputBS str = do outputChunkBS str
-                  driftTo Done
-{-# INLINE outputBS #-}
+outputLBS :: LazyByteString -> Resource ()
+outputLBS str = do outputChunkLBS str
+                   driftTo Done
+{-# INLINE outputLBS #-}
 
 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
 -- response body. You can compute this action multiple times to write
 -- a body little at a time. It is safe to apply 'outputChunk' to an
 -- infinite string.
 --
--- Note that 'outputChunkBS' is more efficient than 'outputChunk' so
+-- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so
 -- you should use it whenever possible.
 outputChunk :: String -> Resource ()
-outputChunk str = outputChunkBS $! B.pack str
+outputChunk str = outputChunkLBS $! B.pack str
 {-# INLINE outputChunk #-}
 
 -- | This is mostly the same as 'outputChunk' but is more efficient.
-outputChunkBS :: ByteString -> Resource ()
-outputChunkBS str
+outputChunkLBS :: LazyByteString -> Resource ()
+outputChunkLBS str
     = str `seq`
       do driftTo DecidingBody
-         itr <- ask
+         itr <- getInteraction
          
          let limit = cnfMaxOutputChunkLength $ itrConfig itr
          when (limit <= 0)
@@ -758,17 +843,16 @@ outputChunkBS str
                     $ liftIO $ atomically $
                       writeItr itr itrBodyIsNull False
     where
-      {- チャンクの大きさは Config で制限されてゐる。もし例へば
-         /dev/zero を B.readFile して作った ByteString をそのまま
-         ResponseWriter に渡したりすると大變な事が起こる。何故なら
-         ResponseWriter はTransfer-Encoding: chunked の時、ヘッダを書く
-         爲にチャンクの大きさを測るから、その時に起こるであらう事は言ふ
-         までも無い。 -}
-      sendChunks :: ByteString -> Int -> Resource ()
+      -- チャンクの大きさは Config で制限されてゐる。もし例へば
+      -- "/dev/zero" を B.readFile して作った LazyByteString をそのまま
+      -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
+      -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
+      -- く爲にチャンクの大きさを測る。
+      sendChunks :: LazyByteString -> Int -> Resource ()
       sendChunks str limit
           | B.null str = return ()
           | otherwise  = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
-                            itr <- ask
+                            itr <- getInteraction
                             liftIO $ atomically $ 
                                    do buf <- readItr itr itrBodyToSend id
                                       if B.null buf then
@@ -802,7 +886,7 @@ outputChunkBS str
 driftTo :: InteractionState -> Resource ()
 driftTo newState
     = newState `seq`
-      do itr <- ask
+      do itr <- getInteraction
          liftIO $ atomically $ do oldState <- readItr itr itrState id
                                   if newState < oldState then
                                       throwStateError oldState newState