X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=c75421378c89dd1c5eb6b25b5fea31cf354ce5a5;hb=895341e8b790e969be678c5cfb85c878e321c8fc;hp=b7f76f8d986a9849d6c8dea2905a8d7285ea84d8;hpb=2bb7a0baa35dadb5d36d3f9fa98bd242baabc6d1;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index b7f76f8..c754213 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -6,7 +6,6 @@
   , UnicodeSyntax
   #-}
 {-# 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'
 -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
@@ -70,7 +69,7 @@ module Network.HTTP.Lucu.Resource
     -- * Types
       Resource
     , FormData(..)
-    , runRes -- private
+    , runRes
 
     -- * Actions
 
@@ -212,7 +211,7 @@ getRemoteAddr = itrRemoteAddr <$> getInteraction
 getRemoteAddr' ∷ Resource HostName
 getRemoteAddr'
     = do sa          ← getRemoteAddr
-         (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
+         (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa
          return a
 
 -- |Resolve an address to the remote host.
@@ -236,9 +235,7 @@ getRemoteCertificate = itrRemoteCert <$> getInteraction
 -- |Get the 'Request' value which represents the request header. In
 -- general you don't have to use this action.
 getRequest ∷ Resource Request
-getRequest
-    = do itr ← getInteraction
-         liftIO $ atomically $ fromJust <$> readTVar (itrRequest itr)
+getRequest = (fromJust ∘ itrRequest) <$> getInteraction
 
 -- |Get the 'Method' value of the request.
 getMethod ∷ Resource Method
@@ -255,7 +252,7 @@ getRequestVersion = reqVersion <$> getRequest
 -- |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
--- action is the exact path in the tree even if the
+-- action is the exact path in the tree even when the
 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
 --
 -- Example:
@@ -265,9 +262,9 @@ getRequestVersion = reqVersion <$> getRequest
 -- >
 -- > resFoo = ResourceDef {
 -- >     resIsGreedy = True
--- >   , resGet = Just $ do requestURI   ← getRequestURI
--- >                        resourcePath ← getResourcePath
--- >                        pathInfo     ← getPathInfo
+-- >   , resGet = Just $ do requestURI   <- getRequestURI
+-- >                        resourcePath <- getResourcePath
+-- >                        pathInfo     <- getPathInfo
 -- >                        -- uriPath requestURI == "/foo/bar/baz"
 -- >                        -- resourcePath       == ["foo"]
 -- >                        -- pathInfo           == ["bar", "baz"]
@@ -459,7 +456,9 @@ foundETag tag
       
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
-              $ setHeader' "ETag" (printETag tag)
+              $ setHeader' "ETag"
+              $ A.fromAsciiBuilder
+              $ printETag tag
          when (method ≡ POST)
               $ abort InternalServerError []
                 (Just "Illegal computation of foundETag for POST request.")
@@ -608,8 +607,7 @@ input ∷ Int → Resource Lazy.ByteString
 input limit
     = do driftTo GettingBody
          itr     ← getInteraction
-         hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
-         chunk   ← if hasBody then
+         chunk   ← if reqHasBody $ fromJust $ itrRequest itr then
                        askForInput itr
                    else
                        do driftTo DecidingHeader
@@ -627,13 +625,7 @@ input limit
                         $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
                -- Reader にリクエスト
                liftIO $ atomically
-                      $ do chunkLen ← readTVar itrReqChunkLength
-                           writeTVar itrWillReceiveBody True
-                           if ((> actualLimit) <$> chunkLen) ≡ Just True then
-                               -- 受信前から多過ぎる事が分かってゐる
-                               tooLarge actualLimit
-                           else
-                               writeTVar itrReqBodyWanted (Just actualLimit)
+                      $ writeTVar itrReqBodyWanted actualLimit
                -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
                chunk ← liftIO $ atomically
                        $ do chunkLen    ← readTVar itrReceivedBodyLen
@@ -683,27 +675,25 @@ inputChunk ∷ Int → Resource Lazy.ByteString
 inputChunk limit
     = do driftTo GettingBody
          itr     ← getInteraction
-         hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
-         chunk   ← if hasBody then
-                        askForInput itr
-                    else
-                        do driftTo DecidingHeader
-                           return (∅)
+         chunk   ← if reqHasBody $ fromJust $ itrRequest itr then
+                       askForInput itr
+                   else
+                       do driftTo DecidingHeader
+                          return (∅)
          return chunk
     where
       askForInput ∷ Interaction → Resource Lazy.ByteString
       askForInput (Interaction {..})
           = do let confLimit   = cnfMaxEntityLength itrConfig
                    actualLimit = if limit < 0 then
-                                      confLimit
-                                  else
-                                      limit
-               when (actualLimit <= 0)
+                                     confLimit
+                                 else
+                                     limit
+               when (actualLimit ≤ 0)
                         $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
                -- Reader にリクエスト
                liftIO $ atomically
-                      $ do writeTVar itrReqBodyWanted   (Just actualLimit)
-                           writeTVar itrWillReceiveBody True
+                      $ writeTVar itrReqBodyWanted actualLimit
                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
                chunk ← liftIO $ atomically
                        $ do chunkLen ← readTVar itrReceivedBodyLen
@@ -793,15 +783,12 @@ defaultLimit = (-1)
 -- | Set the response status code. If you omit to compute this action,
 -- the status code will be defaulted to \"200 OK\".
 setStatus ∷ StatusCode → Resource ()
-setStatus code
+setStatus sc
     = do driftTo DecidingHeader
          itr ← getInteraction
-         liftIO $ atomically
-                $ do res ← readTVar $ itrResponse itr
-                     let res' = res {
-                                  resStatus = code
-                                }
-                     writeTVar (itrResponse itr) res'
+         liftIO
+             $ atomically
+             $ setResponseStatus itr sc
 
 -- | Set a value of given resource header. Comparison of header name
 -- is case-insensitive. Note that this action is not intended to be
@@ -896,33 +883,13 @@ output str = outputChunk str *> driftTo Done
 -- be repeated as many times as you want. It is safe to apply
 -- 'outputChunk' to an infinite string.
 outputChunk ∷ Lazy.ByteString → Resource ()
-outputChunk wholeChunk
+outputChunk str
     = do driftTo DecidingBody
          itr ← getInteraction
-         
-         let limit = cnfMaxOutputChunkLength $ itrConfig itr
-         when (limit ≤ 0)
-             $ abort InternalServerError []
-               (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
-
-         discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr
-         unless (discardBody)
-             $ sendChunks itr wholeChunk limit
-
-         unless (Lazy.null wholeChunk)
-             $ liftIO $ atomically $
-               writeTVar (itrSentNoBody itr) False
-    where
-      sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource ()
-      sendChunks itr@(Interaction {..}) str limit
-          | Lazy.null str = return ()
-          | otherwise     = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
-                               liftIO $ atomically
-                                      $ putTMVar itrBodyToSend (chunkToBuilder chunk)
-                               sendChunks itr remaining limit
-
-      chunkToBuilder ∷ Lazy.ByteString → Builder
-      chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
+         liftIO $ atomically
+                $ do putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
+                     unless (Lazy.null str)
+                         $ writeTVar (itrSentNoBodySoFar itr) False
 
 {-
 
@@ -969,7 +936,7 @@ driftTo newState
       drift itr DecidingHeader _
           = postprocess itr
       drift itr@(Interaction {..}) _ Done
-          = do bodyIsNull ← readTVar itrSentNoBody
+          = do bodyIsNull ← readTVar itrSentNoBodySoFar
                when bodyIsNull
                    $ writeDefaultPage itr
       drift _ _ _