]> gitweb @ CieloNegro.org - Lucu.git/blobdiff - Network/HTTP/Lucu/Resource.hs
Still making many changes...
[Lucu.git] / Network / HTTP / Lucu / Resource.hs
index a54e04061c4ca9051a9cc4f71761a748d67e1153..ddff647364a4295361379926b5affcff571a7081 100644 (file)
@@ -1,13 +1,11 @@
 {-# LANGUAGE
-    BangPatterns
-  , GeneralizedNewtypeDeriving
+    GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings
   , RecordWildCards
   , 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
@@ -71,7 +69,7 @@ module Network.HTTP.Lucu.Resource
     -- * Types
       Resource
     , FormData(..)
-    , runRes -- private
+    , runRes
 
     -- * Actions
 
@@ -133,8 +131,8 @@ module Network.HTTP.Lucu.Resource
 
     -- |Computation of these actions changes the state to /Deciding
     -- Body/.
-    , output
-    , outputChunk
+    , putChunk
+    , putBuilder
 
     , driftTo -- private
     )
@@ -156,7 +154,6 @@ import Data.Foldable (toList)
 import Data.List
 import qualified Data.Map as M
 import Data.Maybe
-import Data.Monoid
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import Data.Text (Text)
@@ -168,7 +165,6 @@ 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
 import Network.HTTP.Lucu.ETag
 import qualified Network.HTTP.Lucu.Headers as H
 import Network.HTTP.Lucu.HttpVersion
@@ -213,7 +209,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.
@@ -237,9 +233,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 $ readItr itrRequest fromJust itr
+getRequest = (fromJust ∘ itrRequest) <$> getInteraction
 
 -- |Get the 'Method' value of the request.
 getMethod ∷ Resource Method
@@ -256,7 +250,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:
@@ -266,9 +260,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"]
@@ -417,7 +411,7 @@ getAuthorization
              return ac
 
 
-{- ExaminingRequest 時に使用するアクション群 -}
+-- Finding an entity
 
 -- |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
@@ -434,7 +428,7 @@ getAuthorization
 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
 -- \"ETag\" and \"Last-Modified\" headers into the response.
 foundEntity ∷ ETag → UTCTime → Resource ()
-foundEntity !tag !timeStamp
+foundEntity tag timeStamp
     = do driftTo ExaminingRequest
 
          method ← getMethod
@@ -455,12 +449,14 @@ foundEntity !tag !timeStamp
 -- This action is not preferred. You should use 'foundEntity' whenever
 -- possible.
 foundETag ∷ ETag → Resource ()
-foundETag !tag
+foundETag tag
     = do driftTo ExaminingRequest
       
          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.")
@@ -588,7 +584,7 @@ foundNoEntity msgM
          driftTo GettingBody
 
 
-{- GettingBody 時に使用するアクション群 -}
+-- Getting a request body
 
 -- | Computation of @'input' limit@ attempts to read the request body
 -- up to @limit@ bytes, and then make the 'Resource' transit to
@@ -609,8 +605,7 @@ input ∷ Int → Resource Lazy.ByteString
 input limit
     = do driftTo GettingBody
          itr     ← getInteraction
-         hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr
-         chunk   ← if hasBody then
+         chunk   ← if reqMustHaveBody $ fromJust $ itrRequest itr then
                        askForInput itr
                    else
                        do driftTo DecidingHeader
@@ -618,8 +613,8 @@ input limit
          return chunk
     where
       askForInput ∷ Interaction → Resource Lazy.ByteString
-      askForInput itr
-          = do let confLimit   = cnfMaxEntityLength $ itrConfig itr
+      askForInput (Interaction {..})
+          = do let confLimit   = cnfMaxEntityLength itrConfig
                    actualLimit = if limit ≤ 0 then
                                      confLimit
                                  else
@@ -628,17 +623,11 @@ input limit
                         $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
                -- Reader にリクエスト
                liftIO $ atomically
-                      $ do chunkLen ← readItr itrReqChunkLength id itr
-                           writeItr itrWillReceiveBody True itr
-                           if ((> actualLimit) <$> chunkLen) ≡ Just True then
-                               -- 受信前から多過ぎる事が分かってゐる
-                               tooLarge actualLimit
-                           else
-                               writeItr itrReqBodyWanted (Just actualLimit) itr
+                      $ writeTVar itrReqBodyWanted actualLimit
                -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
                chunk ← liftIO $ atomically
-                       $ do chunkLen    ← readItr itrReceivedBodyLen id itr
-                            chunkIsOver ← readItr itrReqChunkIsOver  id itr
+                       $ do chunkLen    ← readTVar itrReceivedBodyLen
+                            chunkIsOver ← readTVar itrReqChunkIsOver
                             if chunkLen < actualLimit then
                                 -- 要求された量に滿たなくて、まだ殘りが
                                 -- あるなら再試行。
@@ -651,9 +640,9 @@ input limit
                                     $ tooLarge actualLimit
                             -- 成功。itr 内にチャンクを置いたままにする
                             -- とメモリの無駄になるので除去。
-                            chunk ← readItr itrReceivedBody seqToLBS itr
-                            writeItr itrReceivedBody    (∅) itr
-                            writeItr itrReceivedBodyLen 0   itr
+                            chunk ← seqToLBS <$> readTVar itrReceivedBody
+                            writeTVar itrReceivedBody    (∅)
+                            writeTVar itrReceivedBodyLen 0
                             return chunk
 
                driftTo DecidingHeader
@@ -684,40 +673,38 @@ inputChunk ∷ Int → Resource Lazy.ByteString
 inputChunk limit
     = do driftTo GettingBody
          itr     ← getInteraction
-         hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr
-         chunk   ← if hasBody then
-                        askForInput itr
-                    else
-                        do driftTo DecidingHeader
-                           return (∅)
+         chunk   ← if reqMustHaveBody $ fromJust $ itrRequest itr then
+                       askForInput itr
+                   else
+                       do driftTo DecidingHeader
+                          return (∅)
          return chunk
     where
       askForInput ∷ Interaction → Resource Lazy.ByteString
-      askForInput itr
-          = do let confLimit   = cnfMaxEntityLength $ itrConfig itr
+      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 writeItr itrReqBodyWanted (Just actualLimit) itr
-                           writeItr itrWillReceiveBody True itr
+                      $ writeTVar itrReqBodyWanted actualLimit
                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
                chunk ← liftIO $ atomically
-                       $ do chunkLen ← readItr itrReceivedBodyLen id itr
+                       $ do chunkLen ← readTVar itrReceivedBodyLen
                             -- 要求された量に滿たなくて、まだ殘りがある
                             -- なら再試行。
                             when (chunkLen < actualLimit)
-                                $ do chunkIsOver ← readItr itrReqChunkIsOver id itr
+                                $ do chunkIsOver ← readTVar itrReqChunkIsOver
                                      unless chunkIsOver
                                          $ retry
                             -- 成功
-                            chunk ← readItr itrReceivedBody seqToLBS itr
-                            writeItr itrReceivedBody    (∅) itr
-                            writeItr itrReceivedBodyLen 0   itr
+                            chunk ← seqToLBS <$> readTVar itrReceivedBody
+                            writeTVar itrReceivedBody    (∅)
+                            writeTVar itrReceivedBodyLen 0
                             return chunk
                when (Lazy.null chunk)
                    $ driftTo DecidingHeader
@@ -789,19 +776,17 @@ defaultLimit ∷ Int
 defaultLimit = (-1)
 
 
-{- DecidingHeader 時に使用するアクション群 -}
+-- Setting response headers
 
 -- | 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 $ updateItr itrResponse f itr
-    where
-      f res = res {
-                resStatus = code
-              }
+         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
@@ -825,7 +810,11 @@ setHeader' ∷ CIAscii → Ascii → Resource ()
 setHeader' name value
     = do itr ← getInteraction
          liftIO $ atomically
-                $ updateItr itrResponse (H.setHeader name value) itr
+                $ do res ← readTVar $ itrResponse itr
+                     let res' = H.setHeader name value res
+                     writeTVar (itrResponse itr) res'
+                     when (name ≡ "Content-Type")
+                         $ writeTVar (itrResponseHasCType itr) True
 
 -- | Computation of @'redirect' code uri@ sets the response status to
 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
@@ -845,8 +834,8 @@ redirect code uri
 -- | Computation of @'setContentType' mType@ sets the response header
 -- \"Content-Type\" to @mType@.
 setContentType ∷ MIMEType → Resource ()
-setContentType
-    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
+{-# INLINE setContentType #-}
+setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
 
 -- | Computation of @'setLocation' uri@ sets the response header
 -- \"Location\" to @uri@.
@@ -881,105 +870,65 @@ setWWWAuthenticate challenge
     = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
 
 
-{- DecidingBody 時に使用するアクション群 -}
-
--- | Computation of @'output' str@ writes @str@ as a response body,
--- and then make the 'Resource' transit to /Done/ state. It is safe to
--- apply 'output' to an infinite string, such as a lazy stream of
--- \/dev\/random.
-output ∷ Lazy.ByteString → Resource ()
-{-# INLINE output #-}
-output str = outputChunk str *> driftTo Done
-
--- | 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.
-outputChunk ∷ Lazy.ByteString → Resource ()
-outputChunk wholeChunk
-    = 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 $
-                       readItr itrWillDiscardBody id itr
-
-         unless (discardBody)
-             $ sendChunks wholeChunk limit
-
-         unless (Lazy.null wholeChunk)
-             $ liftIO $ atomically $
-               writeItr itrBodyIsNull False itr
-    where
-      sendChunks ∷ Lazy.ByteString → Int → Resource ()
-      sendChunks str limit
-          | Lazy.null str = return ()
-          | otherwise     = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
-                               itr ← getInteraction
-                               liftIO $ atomically
-                                      $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk)
-                               sendChunks remaining limit
-
-      chunkToBuilder ∷ Lazy.ByteString → Builder
-      chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
-
-{-
-
-  [GettingBody からそれ以降の状態に遷移する時]
-  
-  body を讀み終へてゐなければ、殘りの body を讀み捨てる。
-
+-- Writing a response body
 
-  [DecidingHeader からそれ以降の状態に遷移する時]
-
-  postprocess する。
-
-
-  [Done に遷移する時]
+-- | Write a chunk in 'Lazy.ByteString' to the response body. It is
+-- safe to apply this function to an infinitely long
+-- 'Lazy.ByteString'.
+--
+-- Note that you must first set the response header \"Content-Type\"
+-- before applying this function. See: 'setContentType'
+putChunk ∷ Lazy.ByteString → Resource ()
+{-# INLINE putChunk #-}
+putChunk = putBuilder ∘ BB.fromLazyByteString
+
+-- | Run a 'Builder' to construct a chunk, and write it to the
+-- response body. It is safe to apply this function to a 'Builder'
+-- producing an infinitely long stream of octets.
+--
+-- Note that you must first set the response header \"Content-Type\"
+-- before applying this function. See: 'setContentType'
+putBuilder ∷ Builder → Resource ()
+putBuilder b
+    = do itr ← getInteraction
+         liftIO $ atomically
+                $ do driftTo' itr DecidingBody
+                     hasCType ← readTVar $ itrResponseHasCType itr
+                     unless hasCType
+                         $ abortSTM InternalServerError []
+                         $ Just "putBuilder: Content-Type has not been set."
+                     putTMVar (itrBodyToSend itr) b
 
-  bodyIsNull が False ならば何もしない。True だった場合は出力補完す
-  る。
 
--}
+-- Private
 
 driftTo ∷ InteractionState → Resource ()
 driftTo newState
     = do itr ← getInteraction
-         liftIO $ atomically $ do oldState ← readItr itrState id itr
-                                  if newState < oldState then
-                                      throwStateError oldState newState
-                                    else
-                                      do let a = [oldState .. newState]
-                                             b = tail a
-                                             c = zip a b
-                                         mapM_ (uncurry $ drift itr) c
-                                         writeItr itrState newState itr
+         liftIO $ atomically $ driftTo' itr newState
+
+driftTo' ∷ Interaction → InteractionState → STM ()
+driftTo' itr@(Interaction {..}) newState
+    = do oldState ← readTVar itrState
+         if newState < oldState then
+             throwStateError oldState newState
+         else
+             do let a = [oldState .. newState]
+                    b = tail a
+                    c = zip a b
+                mapM_ (uncurry drift) c
+                writeTVar itrState newState
     where
-      throwStateError ∷ Monad m => InteractionState → InteractionState → m a
-
+      throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
       throwStateError Done DecidingBody
-          = fail "It makes no sense to output something after finishing to output."
-
+          = fail "It makes no sense to output something after finishing outputs."
       throwStateError old new
           = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
 
-
-      drift ∷ Interaction → InteractionState → InteractionState → STM ()
-
-      drift itr GettingBody _
-          = writeItr itrReqBodyWasteAll True itr
-
-      drift itr DecidingHeader _
+      drift ∷ InteractionState → InteractionState → STM ()
+      drift GettingBody _
+          = writeTVar itrReqBodyWasteAll True
+      drift DecidingHeader _
           = postprocess itr
-
-      drift itr _ Done
-          = do bodyIsNull ← readItr itrBodyIsNull id itr
-               when bodyIsNull
-                        $ writeDefaultPage itr
-
-      drift _ _ _
+      drift _ _
           = return ()