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
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
-- > ...
-- > , ...
-- > }
-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
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
$ 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
-- 受信前から多過ぎる事が分かってゐる
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
-- 要求された量に滿たなくて、まだ殘りが
-- あるなら再試行。
$ 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
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
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
(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
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
= postprocess itr
drift itr _ Done
- = do bodyIsNull ← readItr itrBodyIsNull id itr
+ = do bodyIsNull ← readItr itrSentNoBody itr
when bodyIsNull
- $ writeDefaultPage itr
+ $ writeDefaultPage itr
drift _ _ _
= return ()