)
where
import Control.Applicative
-import Control.Concurrent.STM
-import Control.Exception
-import Control.Monad
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString.Lazy as Lazy
-import Data.Maybe
+import Data.Maybe
import qualified Data.Sequence as S
import Data.Sequence.Unicode
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Chunk
-import Network.HTTP.Lucu.DefaultPage
-import Network.HTTP.Lucu.HandleLike
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Postprocess
-import Network.HTTP.Lucu.Preprocess
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Resource.Tree
+import Data.Text (Text)
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Chunk
+import Network.HTTP.Lucu.DefaultPage
+import Network.HTTP.Lucu.HandleLike
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Postprocess
+import Network.HTTP.Lucu.Preprocess
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Resource.Tree
import Network.Socket
import Network.URI
import Prelude.Unicode
-import System.IO (hPutStrLn, stderr)
+import System.IO (hPutStrLn, stderr)
data Context h
= Context {
-- Request 應答を設定し、それを出力してから切斷するやうに
-- ResponseWriter に通知する。
case LP.parse requestP input of
- LP.Done input' req → acceptParsableRequest req input'
+ LP.Done input' req → acceptParsableRequest ctx req input'
LP.Fail _ _ _ → acceptNonparsableRequest ctx BadRequest
acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
-acceptNonparsableRequest (Context {..}) status
- = do itr ← newInteraction cConfig cPort cAddr Nothing Nothing
+acceptNonparsableRequest ctx@(Context {..}) sc
+ = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
atomically $
- do setResponseStatus itr status
- writeTVar (itrWillClose itr) True
- writeTVar (itrState itr) Done
+ do writeTVar (itrState itr) Done
writeDefaultPage itr
postprocess itr
- enqueue itr
+ enqueue ctx itr
acceptParsableRequest ∷ HandleLike h
⇒ Context h
→ Request
→ Lazy.ByteString
→ IO ()
-acceptParsableRequest (Context {..}) req input
+acceptParsableRequest ctx@(Context {..}) req input
= do cert ← hGetPeerCert cHandle
itr ← newInteraction cConfig cPort cAddr cert (Right req)
join $ atomically
- $ do preprocess itr
- isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
+ $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
if isErr then
- acceptSemanticallyInvalidRequest itr input
+ acceptSemanticallyInvalidRequest ctx itr input
else
- acceptSemanticallyValidRequest itr (reqURI req) input
+ return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input
-acceptSemanticallyInvalidRequest ∷ Interaction → Lazy.ByteString → STM (IO ())
-acceptSemanticallyInvalidRequest itr input
- = do writeTVar (itr itrState) Done
+acceptSemanticallyInvalidRequest ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → STM (IO ())
+acceptSemanticallyInvalidRequest ctx itr input
+ = do writeTVar (itrState itr) Done
writeDefaultPage itr
postprocess itr
- enqueue itr
- return $ acceptRequest input
+ enqueue ctx itr
+ return $ acceptRequest ctx input
acceptSemanticallyValidRequest ∷ HandleLike h
⇒ Context h
→ URI
→ Lazy.ByteString
→ IO ()
-acceptSemanticallyValidRequest (Context {..}) itr uri input
+acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input
= do rsrcM ← findResource cResTree cFallbacks uri
case rsrcM of
Nothing
- → acceptRequestForNonexistentResource itr input
+ → acceptRequestForNonexistentResource ctx itr input
Just (rsrcPath, rsrcDef)
- → acceptRequestForExistentResource itr input rsrcPath rsrcDef
+ → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef
-acceptRequestForNonexistentResource ∷ Interaction → Lazy.ByteString → STM (IO ())
-acceptRequestForNonexistentResource itr input
- = do setResponseStatus itr NotFound
- writeTVar (itrState itr) Done
- writeDefaultPage itr
- postprocess itr
- enqueue itr
- return $ acceptRequest input
+acceptRequestForNonexistentResource ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → IO ()
+acceptRequestForNonexistentResource ctx itr input
+ = do atomically $
+ do setResponseStatus itr NotFound
+ writeTVar (itrState itr) Done
+ writeDefaultPage itr
+ postprocess itr
+ enqueue ctx itr
+ acceptRequest ctx input
-acceptRequestForExistentResource ∷ Interaction → Lazy.ByteString → [String] → ResourceDef → STM (IO ())
-acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
+acceptRequestForExistentResource ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → [Text]
+ → ResourceDef
+ → IO ()
+acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
= do let itr = oldItr { itrResourcePath = Just rsrcPath }
- enqueue itr
- return $ do _ ← runResource rsrcDef itr
- if reqHasBody $ fromJust $ itrRequest itr then
- observeRequest itr input
- else
- acceptRequest input
+ atomically $ enqueue ctx itr
+ do _ ← runResource rsrcDef itr
+ if reqHasBody $ fromJust $ itrRequest itr then
+ observeRequest ctx itr input
+ else
+ acceptRequest ctx input
-observeRequest ∷ Interaction → Lazy.ByteString → IO ()
-observeRequest itr input
- | itrReqBodyLength itr ≡ Just Chunked
- = observeChunkedRequest itr input
- | otherwise
- = observeNonChunkedRequest itr input
+observeRequest ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → IO ()
+observeRequest ctx itr input
+ = case fromJust $ itrReqBodyLength itr of
+ Chunked
+ → observeChunkedRequest ctx itr input 0
+ Fixed len
+ → observeNonChunkedRequest ctx itr input len
-observeChunkedRequest ∷ Interaction → Lazy.ByteString → IO ()
-observeChunkedRequest itr input
+observeChunkedRequest ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → Int
+ → IO ()
+observeChunkedRequest ctx itr input remaining
= join $
atomically $
do isOver ← readTVar $ itrReqChunkIsOver itr
if isOver then
- return $ acceptRequest input
+ return $ acceptRequest ctx input
else
do wantedM ← readTVar $ itrReqBodyWanted itr
- if isNothing wantedM then
- do wasteAll ← readTVar $ itrReqBodyWasteAll itr
- if wasteAll then
- wasteCurrentChunk input
- else
- retry
- else
- readCurrentChunk (fromJust wantedM)
+ case wantedM of
+ Nothing
+ → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
+ if wasteAll then
+ return $ wasteCurrentChunk ctx itr input remaining
+ else
+ retry
+ Just wanted
+ → return $ readCurrentChunk ctx itr input wanted remaining
-wasteCurrentChunk ∷ Interaction → Lazy.ByteString → Int → IO ()
-wasteCurrentChunk itr input len
+wasteCurrentChunk ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → Int
+ → IO ()
+wasteCurrentChunk ctx itr input len
| len > 0
= let input' = Lazy.drop (fromIntegral len) input
in
case LP.parse chunkFooterP input' of
LP.Done input'' _
- → observeChunkedRequest itr input''
+ → observeChunkedRequest ctx itr input'' 0
LP.Fail _ _ _
→ chunkWasMalformed itr
| otherwise
- = seekNextChunk itr input
+ = seekNextChunk ctx itr input
-readCurrentChunk ∷ Interaction → Lazy.ByteString → Int → Int → IO ()
-readCurrentChunk itr input wanted remaining
+readCurrentChunk ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → Int
+ → Int
+ → IO ()
+readCurrentChunk ctx itr input wanted remaining
| remaining > 0
= do let bytesToRead = fromIntegral $ min wanted remaining
(chunk, input') = Lazy.splitAt bytesToRead input
newWanted = case wanted - actualReadBytes of
0 → Nothing
n → Just n
- newRemaining = Just $ remaining - actualReadBytes
- updateStates = do writeTVar (itrReqBodyWanted itr) newWanted
+ newRemaining = remaining - actualReadBytes
+ chunk' = S.fromList $ Lazy.toChunks chunk
+ updateStates = atomically $
+ do writeTVar (itrReqBodyWanted itr) newWanted
oldBody ← readTVar $ itrReceivedBody itr
oldBodyLen ← readTVar $ itrReceivedBodyLen itr
- writeTVar (itrReceivedBody itr) $ oldBody â\8a³ chunk
+ writeTVar (itrReceivedBody itr) $ oldBody â\8b\88 chunk'
writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes
- if newRemaining ≡ Just 0 then
+ if newRemaining ≡ 0 then
case LP.parse chunkFooterP input' of
LP.Done input'' _
→ do updateStates
- observeChunkedRequest itr input''
+ observeChunkedRequest ctx itr input'' 0
LP.Fail _ _ _
→ chunkWasMalformed itr
else
do updateStates
- observeChunkedRequest itr input'
+ observeChunkedRequest ctx itr input' newRemaining
| otherwise
- = seekNextChunk itr input
+ = seekNextChunk ctx itr input
-seekNextChunk ∷ Interaction → Lazy.ByteString → IO ()
-seekNextChunk itr input
+seekNextChunk ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → IO ()
+seekNextChunk ctx itr input
= case LP.parse chunkHeaderP input of
LP.Done input' len
| len ≡ 0 -- Final chunk
→ case LP.parse chunkTrailerP input' of
LP.Done input'' _
- → do writeTVar (itrReqChunkIsOver itr) True
- acceptRequest input''
+ → do atomically $
+ writeTVar (itrReqChunkIsOver itr) True
+ acceptRequest ctx input''
LP.Fail _ _ _
→ chunkWasMalformed itr
| otherwise -- Non-final chunk
- → do observeChunkedRequest itr input'
+ → observeChunkedRequest ctx itr input' len
LP.Fail _ _ _
→ chunkWasMalformed itr
chunkWasMalformed ∷ Interaction → IO ()
chunkWasMalformed itr
= atomically $
- do setResponseStatus BadRequest
- writeTVar (itrWillClose itr) True
- writeTVar (itrState itr) Done
- writeDefaultPage itr
- postprocess itr
+ do setResponseStatus itr BadRequest
+ writeTVar (itrWillClose itr) True
+ writeTVar (itrState itr) Done
+ writeDefaultPage itr
+ postprocess itr
-observeNonChunkedRequest ∷ Interaction → Lazy.ByteString → IO ()
-observeNonChunkedRequest itr input
+observeNonChunkedRequest ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → Int
+ → IO ()
+observeNonChunkedRequest ctx itr input remaining
= join $
atomically $
do wantedM ← readTVar $ itrReqBodyWanted itr
- if isNothing wantedM then
- do wasteAll ← readTVar itr itrReqBodyWasteAll id
- if wasteAll then
- wasteNonChunkedRequestBody itr input
- else
- retry
- else
- readNonChunkedRequestBody itr input
+ case wantedM of
+ Nothing
+ → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
+ if wasteAll then
+ return $ wasteNonChunkedRequestBody ctx itr input remaining
+ else
+ retry
+ Just wanted
+ → return $ readNonChunkedRequestBody ctx itr input wanted remaining
-wasteNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Maybe Int → IO ()
-wasteNonChunkedRequestBody itr input remaining
- = do let input' = case remaining of
- Just len → Lazy.drop len input
- Nothing → (∅)
- writeTVar (itrReqChunkIsOver itr) True
- acceptRequest input'
+wasteNonChunkedRequestBody ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → Int
+ → IO ()
+wasteNonChunkedRequestBody ctx itr input remaining
+ = do let input' = Lazy.drop (fromIntegral remaining) input
+ atomically $ writeTVar (itrReqChunkIsOver itr) True
+ acceptRequest ctx input'
-readNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Int → Maybe Int → IO ()
-readNonChunkedRequestBody itr input wanted remaining
- = do let bytesToRead = fromIntegral $ maybe wanted (min wanted) remaining
- (chunk, input') = Lazy.splitAt bytesToRead input
+readNonChunkedRequestBody ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → Int
+ → Int
+ → IO ()
+readNonChunkedRequestBody ctx itr input wanted remaining
+ = do let bytesToRead = min wanted remaining
+ (chunk, input') = Lazy.splitAt (fromIntegral bytesToRead) input
actualReadBytes = fromIntegral $ Lazy.length chunk
- newRemaining = (- actualReadBytes) <$> remaining
- isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0
- writeTVar (itrReqChunkIsOver itr) isOver
- writeTVar (itrReqBodyWanted itr) Nothing
- writeTVar (itrReceivedBody itr) chunk
- writeTVar (itrReceivedBodyLen itr) actualReadBytes
+ newRemaining = remaining - actualReadBytes
+ isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ 0
+ chunk' = S.fromList $ Lazy.toChunks chunk
+ atomically $
+ do writeTVar (itrReqChunkIsOver itr) isOver
+ writeTVar (itrReqBodyWanted itr) Nothing
+ writeTVar (itrReceivedBody itr) chunk'
+ writeTVar (itrReceivedBodyLen itr) actualReadBytes
if isOver then
- acceptRequest input'
+ acceptRequest ctx input'
else
- observeNonChunkedRequest itr input'
+ observeNonChunkedRequest ctx itr input' newRemaining
enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
enqueue (Context {..}) itr
projects / Lucu.git / commitdiff