X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=0dd73c96113971e2aa20d41f71eff4045bc1e6e6;hb=cc55fb9;hp=c8525af7497b0219c0ede9b54cf25198fe29c3ee;hpb=3fe5ca3bca04e0124a5f2440e893dc5375e0bb51;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index c8525af..0dd73c9 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -151,8 +151,7 @@ import qualified Data.Attoparsec.Char8 as P import qualified Data.Attoparsec.Lazy as LP import Data.ByteString (ByteString) import qualified Data.ByteString as Strict -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString.Lazy as Lazy import Data.Foldable (toList) import Data.List import qualified Data.Map as M @@ -240,7 +239,7 @@ getRemoteCertificate = itrRemoteCert <$> getInteraction getRequest ∷ Resource Request getRequest = do itr ← getInteraction - liftIO $ atomically $ readItr itrRequest fromJust itr + liftIO $ atomically $ fromJust <$> readItr itrRequest itr -- |Get the 'Method' value of the request. getMethod ∷ Resource Method @@ -276,24 +275,24 @@ getRequestVersion = reqVersion <$> getRequest -- > ... -- > , ... -- > } -getResourcePath ∷ Resource [Ascii] +getResourcePath ∷ Resource [Text] getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction -- |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 [ByteString] +-- +-- Note that the returned path is URI-decoded and then UTF-8 decoded. +getPathInfo ∷ Resource [Text] getPathInfo = do rsrcPath ← getResourcePath - uri ← getRequestURI - let reqPathStr = uriPath uri - reqPath = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)] + reqPath ← splitPathInfo <$> getRequestURI -- rsrcPath と reqPath の共通する先頭部分を reqPath か -- ら全部取り除くと、それは PATH_INFO のやうなものにな -- る。rsrcPath は全部一致してゐるに決まってゐる（でな -- ければこの Resource が撰ばれた筈が無い）ので、 -- rsrcPath の長さの分だけ削除すれば良い。 - return $ map C8.pack $ drop (length rsrcPath) reqPath + return $ drop (length rsrcPath) reqPath -- |Assume the query part of request URI as -- application\/x-www-form-urlencoded, and parse it to pairs of @@ -610,7 +609,7 @@ input ∷ Int → Resource Lazy.ByteString input limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr + hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr chunk ← if hasBody then askForInput itr else @@ -629,7 +628,7 @@ input limit $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do chunkLen ← readItr itrReqChunkLength id itr + $ do chunkLen ← readItr itrReqChunkLength itr writeItr itrWillReceiveBody True itr if ((> actualLimit) <$> chunkLen) ≡ Just True then -- 受信前から多過ぎる事が分かってゐる @@ -638,8 +637,8 @@ input limit writeItr itrReqBodyWanted (Just actualLimit) itr -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。 chunk ← liftIO $ atomically - $ do chunkLen ← readItr itrReceivedBodyLen id itr - chunkIsOver ← readItr itrReqChunkIsOver id itr + $ do chunkLen ← readItr itrReceivedBodyLen itr + chunkIsOver ← readItr itrReqChunkIsOver itr if chunkLen < actualLimit then -- 要求された量に滿たなくて、まだ殘りが -- あるなら再試行。 @@ -652,8 +651,9 @@ input limit $ tooLarge actualLimit -- 成功。itr 内にチャンクを置いたままにする -- とメモリの無駄になるので除去。 - chunk ← readItr itrReceivedBody seqToLBS itr - writeItr itrReceivedBody (∅) itr + chunk ← seqToLBS <$> readItr itrReceivedBody itr + writeItr itrReceivedBody (∅) itr + writeItr itrReceivedBodyLen 0 itr return chunk driftTo DecidingHeader @@ -684,7 +684,7 @@ inputChunk ∷ Int → Resource Lazy.ByteString inputChunk limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr + hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr chunk ← if hasBody then askForInput itr else @@ -707,16 +707,17 @@ inputChunk limit writeItr itrWillReceiveBody True itr -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk ← liftIO $ atomically - $ do chunkLen ← readItr itrReceivedBodyLen id itr + $ do chunkLen ← readItr itrReceivedBodyLen itr -- 要求された量に滿たなくて、まだ殘りがある -- なら再試行。 when (chunkLen < actualLimit) - $ do chunkIsOver ← readItr itrReqChunkIsOver id itr + $ do chunkIsOver ← readItr itrReqChunkIsOver itr unless chunkIsOver $ retry -- 成功 - chunk ← readItr itrReceivedBody seqToLBS itr - writeItr itrReceivedBody (∅) itr + chunk ← seqToLBS <$> readItr itrReceivedBody itr + writeItr itrReceivedBody (∅) itr + writeItr itrReceivedBodyLen 0 itr return chunk when (Lazy.null chunk) $ driftTo DecidingHeader @@ -905,14 +906,14 @@ outputChunk wholeChunk (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit)) discardBody ← liftIO $ atomically $ - readItr itrWillDiscardBody id itr + readItr itrWillDiscardBody itr unless (discardBody) $ sendChunks wholeChunk limit unless (Lazy.null wholeChunk) $ liftIO $ atomically $ - writeItr itrBodyIsNull False itr + writeItr itrSentNoBody False itr where sendChunks ∷ Lazy.ByteString → Int → Resource () sendChunks str limit @@ -948,7 +949,7 @@ outputChunk wholeChunk driftTo ∷ InteractionState → Resource () driftTo newState = do itr ← getInteraction - liftIO $ atomically $ do oldState ← readItr itrState id itr + liftIO $ atomically $ do oldState ← readItr itrState itr if newState < oldState then throwStateError oldState newState else @@ -976,9 +977,9 @@ driftTo newState = postprocess itr drift itr _ Done - = do bodyIsNull ← readItr itrBodyIsNull id itr + = do bodyIsNull ← readItr itrSentNoBody itr when bodyIsNull - $ writeDefaultPage itr + $ writeDefaultPage itr drift _ _ _ = return ()