From: PHO Date: Tue, 4 Oct 2011 04:16:01 +0000 (+0900) Subject: many changes... X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=3fe5ca3bca04e0124a5f2440e893dc5375e0bb51;p=Lucu.git many changes... Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 5b62418..bc75af5 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -10,6 +10,7 @@ module Network.HTTP.Lucu.DefaultPage , mkDefaultPage ) where +import qualified Blaze.ByteString.Builder.ByteString as BB import Control.Arrow import Control.Arrow.ArrowList import Control.Arrow.ListArrow @@ -18,7 +19,6 @@ import Control.Concurrent.STM import Control.Monad import qualified Data.Ascii as A import Data.Maybe -import qualified Data.Sequence as S import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding @@ -55,13 +55,13 @@ writeDefaultPage !itr let conf = itrConfig itr page = getDefaultPage conf reqM res - writeTVar (itrBodyToSend itr) - (S.singleton (encodeUtf8 page)) + putTMVar (itrBodyToSend itr) + (BB.fromByteString $ encodeUtf8 page) mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree {-# INLINEABLE mkDefaultPage #-} mkDefaultPage !conf !status !msgA - = let sStr = A.toString $ printStatusCode status + = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status sig = concat [ A.toString (cnfServerSoftware conf) , " at " , T.unpack (cnfServerHost conf) diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index f87ae5c..a5fdb02 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -12,11 +12,11 @@ module Network.HTTP.Lucu.Headers , fromHeaders , headersP - , hPutHeaders + , printHeaders ) where import Control.Applicative -import Data.Ascii (Ascii, CIAscii) +import Data.Ascii (Ascii, AsciiBuilder, CIAscii) import qualified Data.Ascii as A import Data.Attoparsec.Char8 as P import qualified Data.ByteString as BS @@ -24,7 +24,6 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Monoid import Data.Monoid.Unicode -import Network.HTTP.Lucu.HandleLike import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils import Prelude.Unicode @@ -124,13 +123,14 @@ headersP = do xs ← P.many header {-# INLINE joinValues #-} joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" ∘ map A.toAsciiBuilder -hPutHeaders ∷ HandleLike h => h → Headers → IO () -hPutHeaders !h !(Headers m) - = mapM_ putH (M.toList m) >> hPutBS h "\r\n" +printHeaders ∷ Headers → AsciiBuilder +printHeaders (Headers m) + = mconcat (map printHeader (M.toList m)) ⊕ + A.toAsciiBuilder "\x0D\x0A" where - putH ∷ (CIAscii, Ascii) → IO () - putH (!name, !value) - = do hPutBS h (A.ciToByteString name) - hPutBS h ": " - hPutBS h (A.toByteString value) - hPutBS h "\r\n" + printHeader ∷ (CIAscii, Ascii) → AsciiBuilder + printHeader (name, value) + = A.toAsciiBuilder (A.fromCIAscii name) ⊕ + A.toAsciiBuilder ": " ⊕ + A.toAsciiBuilder value ⊕ + A.toAsciiBuilder "\x0D\x0A" diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index 4531c83..a5db1e2 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -3,18 +3,21 @@ , OverloadedStrings , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} -- |Manipulation of HTTP version string. module Network.HTTP.Lucu.HttpVersion ( HttpVersion(..) , httpVersionP - , hPutHttpVersion + , printHttpVersion ) where -import Control.Monad.Unicode +import qualified Blaze.Text.Int as BT +import Control.Applicative +import Control.Applicative.Unicode +import Data.Ascii (AsciiBuilder) +import qualified Data.Ascii as A import Data.Attoparsec.Char8 -import Network.HTTP.Lucu.HandleLike +import Data.Monoid.Unicode import Prelude hiding (min) -- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\". @@ -32,24 +35,22 @@ instance Ord HttpVersion where httpVersionP ∷ Parser HttpVersion httpVersionP = string "HTTP/" - ≫ - choice [ string "1.1" ≫ return (HttpVersion 1 1) - , string "1.0" ≫ return (HttpVersion 1 0) - , do major ← decimal - _ ← char '.' - minor ← decimal - return $ HttpVersion major minor + *> + choice [ string "1.1" *> pure (HttpVersion 1 1) + , string "1.0" *> pure (HttpVersion 1 0) + , HttpVersion <$> decimal ⊛ (char '.' *> decimal) ] -hPutHttpVersion ∷ HandleLike h ⇒ h → HttpVersion → IO () -hPutHttpVersion !h !v +-- |Convert an 'HttpVersion' to 'AsciiBuilder'. +printHttpVersion ∷ HttpVersion → AsciiBuilder +printHttpVersion v = case v of -- 頻出するので高速化 - HttpVersion 1 0 → hPutBS h "HTTP/1.0" - HttpVersion 1 1 → hPutBS h "HTTP/1.1" + HttpVersion 1 0 → A.toAsciiBuilder "HTTP/1.0" + HttpVersion 1 1 → A.toAsciiBuilder "HTTP/1.1" -- 一般の場合 - HttpVersion !maj !min - → do hPutBS h "HTTP/" - hPutStr h (show maj) - hPutChar h '.' - hPutStr h (show min) + HttpVersion maj min + → A.toAsciiBuilder "HTTP/" ⊕ + A.unsafeFromBuilder (BT.integral maj) ⊕ + A.toAsciiBuilder "." ⊕ + A.unsafeFromBuilder (BT.integral min) diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 52a5e2e..ac9c46f 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -11,20 +11,16 @@ module Network.HTTP.Lucu.Interaction , newInteraction , defaultPageContentType - , chunksToLBS - , chunksFromLBS - , writeItr , readItr , updateItr ) where +import Blaze.ByteString.Builder (Builder) import Control.Applicative import Control.Concurrent.STM import Data.Ascii (Ascii) import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import Data.Foldable import Data.Sequence (Seq) import qualified Data.Sequence as S import Network.Socket @@ -34,7 +30,6 @@ import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import OpenSSL.X509 -import Prelude.Unicode data Interaction = Interaction { itrConfig ∷ !Config @@ -55,13 +50,14 @@ data Interaction = Interaction { , itrReqBodyWanted ∷ !(TVar (Maybe Int)) , itrReqBodyWasteAll ∷ !(TVar Bool) , itrReceivedBody ∷ !(TVar (Seq BS.ByteString)) + , itrReceivedBodyLen ∷ !(TVar Int) , itrWillReceiveBody ∷ !(TVar Bool) , itrWillChunkBody ∷ !(TVar Bool) , itrWillDiscardBody ∷ !(TVar Bool) , itrWillClose ∷ !(TVar Bool) - , itrBodyToSend ∷ !(TVar (Seq BS.ByteString)) + , itrBodyToSend ∷ !(TMVar Builder) , itrBodyIsNull ∷ !(TVar Bool) , itrState ∷ !(TVar InteractionState) @@ -106,13 +102,14 @@ newInteraction !conf !port !addr !cert !req reqBodyWanted ← newTVarIO Nothing -- Resource が要求してゐるチャンク長 reqBodyWasteAll ← newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求 receivedBody ← newTVarIO S.empty + receivedBodyLen ← newTVarIO 0 willReceiveBody ← newTVarIO False willChunkBody ← newTVarIO False willDiscardBody ← newTVarIO False willClose ← newTVarIO False - bodyToSend ← newTVarIO S.empty + bodyToSend ← newEmptyTMVarIO bodyIsNull ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False state ← newTVarIO ExaminingRequest @@ -139,6 +136,7 @@ newInteraction !conf !port !addr !cert !req , itrReqBodyWanted = reqBodyWanted , itrReqBodyWasteAll = reqBodyWasteAll , itrReceivedBody = receivedBody + , itrReceivedBodyLen = receivedBodyLen , itrWillReceiveBody = willReceiveBody , itrWillChunkBody = willChunkBody @@ -154,6 +152,7 @@ newInteraction !conf !port !addr !cert !req , itrWroteHeader = wroteHeader } +{- chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString {-# INLINE chunksToLBS #-} chunksToLBS = LBS.fromChunks ∘ toList @@ -161,6 +160,7 @@ chunksToLBS = LBS.fromChunks ∘ toList chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString {-# INLINE chunksFromLBS #-} chunksFromLBS = S.fromList ∘ LBS.toChunks +-} writeItr ∷ (Interaction → TVar a) → a → Interaction → STM () {-# INLINE writeItr #-} diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index dfaef11..ce637d5 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -15,7 +15,7 @@ module Network.HTTP.Lucu.MIMEType ) where import Control.Applicative -import Data.Ascii (Ascii, CIAscii) +import Data.Ascii (Ascii, AsciiBuilder, CIAscii) import qualified Data.Ascii as A import Data.Attoparsec.Char8 as P import qualified Data.ByteString.Char8 as C8 @@ -35,15 +35,13 @@ data MIMEType = MIMEType { , mtParams ∷ !(Map CIAscii Text) } deriving (Eq, Show) --- |Convert a 'MIMEType' to 'Ascii'. -printMIMEType ∷ MIMEType → Ascii +-- |Convert a 'MIMEType' to 'AsciiBuilder'. +printMIMEType ∷ MIMEType → AsciiBuilder printMIMEType (MIMEType maj min params) - = A.fromAsciiBuilder $ - ( A.toAsciiBuilder (A.fromCIAscii maj) ⊕ - A.toAsciiBuilder "/" ⊕ - A.toAsciiBuilder (A.fromCIAscii min) ⊕ - printParams params - ) + = A.toAsciiBuilder (A.fromCIAscii maj) ⊕ + A.toAsciiBuilder "/" ⊕ + A.toAsciiBuilder (A.fromCIAscii min) ⊕ + printParams params -- |Parse 'MIMEType' from an 'Ascii'. This function throws an -- exception for parse error. diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 3344f4b..226e014 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -115,11 +115,11 @@ serializeExtMap extMap moduleName variableName [] (HsUnGuardedRhs extMapExp) []] ] extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records) - comment = "{- !!! WARNING !!!\n" - ++ " This file is automatically generated.\n" - ++ " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n" + comment = "{- !!! WARNING !!!\n" + ⧺ " This file is automatically generated.\n" + ⧺ " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n" in - comment ++ prettyPrint hsModule ++ "\n" + comment ⧺ prettyPrint hsModule ⧺ "\n" where records ∷ [HsExp] records = map record $ M.assocs extMap @@ -137,4 +137,7 @@ serializeExtMap extMap moduleName variableName = HsApp (HsVar (UnQual (HsIdent "parseMIMEType"))) (HsParen (HsApp (HsVar (Qual (Module "A") (HsIdent "unsafeFromString"))) - (HsLit (HsString $ A.toString $ printMIMEType mt)))) + (HsLit (HsString $ mimeToString mt)))) + + mimeToString ∷ MIMEType → String + mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index a7c2e07..0e089ca 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -71,22 +71,28 @@ postprocess !itr unless (any (\ p → p sc) [isSuccessful, isRedirection, isError]) $ abortSTM InternalServerError [] $ Just - $ A.toText ( "The status code is not good for a final status of a response: " - ⊕ printStatusCode sc ) + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "The status code is not good for a final status of a response: " + ⊕ printStatusCode sc when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing) $ abortSTM InternalServerError [] $ Just - $ A.toText ( "The status was " - ⊕ printStatusCode sc - ⊕ " but no Allow header." ) + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "The status was " + ⊕ printStatusCode sc + ⊕ A.toAsciiBuilder " but no Allow header." when (sc ≢ NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing) $ abortSTM InternalServerError [] $ Just - $ A.toText ( "The status code was " - ⊕ printStatusCode sc - ⊕ " but no Location header." ) + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "The status code was " + ⊕ printStatusCode sc + ⊕ A.toAsciiBuilder " but no Location header." when (reqM ≢ Nothing) relyOnRequest diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index ab8e5c7..9307c8d 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -190,6 +190,7 @@ requestReader !cnf !tree !fbs !h !port !addr !tQueue = do writeItr itr itrReqChunkRemaining newRemaining writeItr itr itrReqBodyWanted newWanted updateItr itr itrReceivedBody $ flip B.append chunk + updateItr itrReceivedBodyLen (+ actualReadBytes) itr if newRemaining == Just 0 then -- チャンクフッタを讀む @@ -276,15 +277,15 @@ requestReader !cnf !tree !fbs !h !port !addr !tQueue let wanted = fromJust wantedM bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM (chunk, input') = B.splitAt bytesToRead input - newRemaining = fmap - (\ x -> x - (fromIntegral $ B.length chunk)) - remainingM - isOver = B.length chunk < bytesToRead || newRemaining == Just 0 + actualReadBytes = fromIntegral $ B.length chunk + newRemaining = (- actualReadBytes) <$> remainingM + isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0 writeItr itr itrReqChunkRemaining newRemaining writeItr itr itrReqChunkIsOver isOver writeItr itr itrReqBodyWanted Nothing writeItr itr itrReceivedBody chunk + writeItr itrReceivedBody actualReadBytes if isOver then return $ acceptRequest input' diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 2672399..c8525af 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -139,6 +139,8 @@ module Network.HTTP.Lucu.Resource , driftTo -- private ) where +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder.ByteString as BB import Control.Applicative import Control.Concurrent.STM import Control.Monad.Reader @@ -148,18 +150,19 @@ import qualified Data.Ascii as A 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.Char8 as L8 +import Data.Foldable (toList) import Data.List import qualified Data.Map as M import Data.Maybe +import Data.Monoid import Data.Monoid.Unicode -import qualified Data.Sequence as S +import Data.Sequence (Seq) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T import Data.Time import qualified Data.Time.HTTP as HTTP import Network.HTTP.Lucu.Abortion @@ -310,9 +313,9 @@ toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData) toPairWithFormData (name, value) = let fd = FormData { fdFileName = Nothing - , fdContent = L8.fromChunks [value] + , fdContent = Lazy.fromChunks [value] } - in (T.decodeUtf8With T.lenientDecode name, fd) + in (T.decodeUtf8 name, fd) -- |Get a value of given request header. Comparison of header name is -- case-insensitive. Note that this action is not intended to be used @@ -612,7 +615,7 @@ input limit askForInput itr else do driftTo DecidingHeader - return L8.empty + return (∅) return chunk where askForInput ∷ Interaction → Resource Lazy.ByteString @@ -628,16 +631,16 @@ input limit liftIO $ atomically $ do chunkLen ← readItr itrReqChunkLength id itr writeItr itrWillReceiveBody True itr - if fmap (> actualLimit) chunkLen ≡ Just True then + if ((> actualLimit) <$> chunkLen) ≡ Just True then -- 受信前から多過ぎる事が分かってゐる tooLarge actualLimit else writeItr itrReqBodyWanted (Just actualLimit) itr -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。 chunk ← liftIO $ atomically - $ do chunk ← readItr itrReceivedBody chunksToLBS itr - chunkIsOver ← readItr itrReqChunkIsOver id itr - if L8.length chunk < fromIntegral actualLimit then + $ do chunkLen ← readItr itrReceivedBodyLen id itr + chunkIsOver ← readItr itrReqChunkIsOver id itr + if chunkLen < actualLimit then -- 要求された量に滿たなくて、まだ殘りが -- あるなら再試行。 unless chunkIsOver @@ -649,8 +652,10 @@ input limit $ tooLarge actualLimit -- 成功。itr 内にチャンクを置いたままにする -- とメモリの無駄になるので除去。 + chunk ← readItr itrReceivedBody seqToLBS itr writeItr itrReceivedBody (∅) itr return chunk + driftTo DecidingHeader return chunk @@ -658,6 +663,10 @@ input limit tooLarge lim = abortSTM RequestEntityTooLarge [] (Just $ "Request body must be smaller than " ⊕ T.pack (show lim) ⊕ " bytes.") + +seqToLBS ∷ Seq ByteString → Lazy.ByteString +{-# INLINE seqToLBS #-} +seqToLBS = Lazy.fromChunks ∘ toList -- | Computation of @'inputChunk' limit@ attempts to read a part of -- request body up to @limit@ bytes. You can read any large request by @@ -680,7 +689,7 @@ inputChunk limit askForInput itr else do driftTo DecidingHeader - return L8.empty + return (∅) return chunk where askForInput ∷ Interaction → Resource Lazy.ByteString @@ -694,31 +703,37 @@ inputChunk limit $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do writeItr itrReqBodyWanted (Just actualLimit) itr - writeItr itrWillReceiveBody True itr + $ do writeItr itrReqBodyWanted (Just actualLimit) itr + writeItr itrWillReceiveBody True itr -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk ← liftIO $ atomically - $ do chunk ← readItr itrReceivedBody chunksToLBS itr - -- 要求された量に滿たなくて、まだ殘りがあ - -- るなら再試行。 - when (L8.length chunk < fromIntegral actualLimit) - $ do chunkIsOver ← readItr itrReqChunkIsOver id itr - unless chunkIsOver - $ retry - -- 成功 - writeItr itrReceivedBody (∅) itr - return chunk - when (L8.null chunk) + $ do chunkLen ← readItr itrReceivedBodyLen id itr + -- 要求された量に滿たなくて、まだ殘りがある + -- なら再試行。 + when (chunkLen < actualLimit) + $ do chunkIsOver ← readItr itrReqChunkIsOver id itr + unless chunkIsOver + $ retry + -- 成功 + chunk ← readItr itrReceivedBody seqToLBS itr + writeItr itrReceivedBody (∅) itr + return chunk + when (Lazy.null chunk) $ driftTo DecidingHeader return chunk -- | Computation of @'inputForm' limit@ attempts to read the request -- body with 'input' and parse it as --- application\/x-www-form-urlencoded or multipart\/form-data. If the --- request header \"Content-Type\" is neither of them, 'inputForm' +-- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If +-- the request header \"Content-Type\" is neither of them, 'inputForm' -- makes 'Resource' abort with status \"415 Unsupported Media -- Type\". If the request has no \"Content-Type\", it aborts with -- \"400 Bad Request\". +-- +-- Field names in @multipart\/form-data@ will be precisely decoded in +-- accordance with RFC 2231. On the other hand, +-- @application\/x-www-form-urlencoded@ says nothing about the +-- encoding of field names, so they'll always be decoded in UTF-8. inputForm ∷ Int → Resource [(Text, FormData)] inputForm limit = do cTypeM ← getContentType @@ -731,7 +746,11 @@ inputForm limit → readMultipartFormData params Just cType → abort UnsupportedMediaType [] - (Just $ "Unsupported media type: " ⊕ A.toText (printMIMEType cType)) + $ Just + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Unsupported media type: " + ⊕ printMIMEType cType where readWWWFormURLEncoded = (map toPairWithFormData ∘ parseWWWFormURLEncoded) @@ -739,7 +758,7 @@ inputForm limit (bsToAscii =≪ input limit) bsToAscii bs - = case A.fromByteString (C8.concat (L8.toChunks bs)) of + = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of Just a → return a Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded") @@ -814,15 +833,19 @@ redirect ∷ StatusCode → URI → Resource () redirect code uri = do when (code ≡ NotModified ∨ not (isRedirection code)) $ abort InternalServerError [] - (Just $ "Attempted to redirect with status " ⊕ A.toText (printStatusCode code)) + $ Just + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Attempted to redirect with status " + ⊕ printStatusCode code setStatus code setLocation uri -- | Computation of @'setContentType' mType@ sets the response header -- \"Content-Type\" to @mType@. setContentType ∷ MIMEType → Resource () -setContentType mType - = setHeader "Content-Type" (printMIMEType mType) +setContentType + = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType -- | Computation of @'setLocation' uri@ sets the response header -- \"Location\" to @uri@. @@ -865,8 +888,7 @@ setWWWAuthenticate challenge -- \/dev\/random. output ∷ Lazy.ByteString → Resource () {-# INLINE output #-} -output str = do outputChunk str - driftTo Done +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 @@ -888,30 +910,21 @@ outputChunk wholeChunk unless (discardBody) $ sendChunks wholeChunk limit - unless (L8.null wholeChunk) + unless (Lazy.null wholeChunk) $ liftIO $ atomically $ writeItr itrBodyIsNull False itr where - -- チャンクの大きさは Config で制限されてゐる。もし例へば - -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま - -- ResponseWriter に渡したりすると大變な事が起こる。何故なら - -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書 - -- く爲にチャンクの大きさを測るからだ。 sendChunks ∷ Lazy.ByteString → Int → Resource () sendChunks str limit - | L8.null str = return () - | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str - itr ← getInteraction - liftIO $ atomically $ - do buf ← readItr itrBodyToSend id itr - if S.null buf then - -- バッファが消化された - writeItr itrBodyToSend (chunksFromLBS chunk) itr - else - -- 消化されるのを待つ - retry - -- 殘りのチャンクについて繰り返す - sendChunks remaining 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 {- diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index df98bf7..a593b3a 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -6,14 +6,13 @@ , UnicodeSyntax , ViewPatterns #-} -{-# OPTIONS_HADDOCK prune #-} -- |Definition of things related on HTTP response. module Network.HTTP.Lucu.Response ( StatusCode(..) , Response(..) , printStatusCode - , hPutResponse + , printResponse , isInformational , isSuccessful , isRedirection @@ -23,11 +22,10 @@ module Network.HTTP.Lucu.Response , statusCode ) where -import Data.Ascii (Ascii) +import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A import Data.Monoid.Unicode import Data.Typeable -import Network.HTTP.Lucu.HandleLike import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Utils @@ -89,11 +87,10 @@ data StatusCode = Continue | InsufficientStorage deriving (Eq, Show, Typeable) --- |Convert a 'StatusCode' to 'Ascii'. -printStatusCode ∷ StatusCode → Ascii +-- |Convert a 'StatusCode' to 'AsciiBuilder'. +printStatusCode ∷ StatusCode → AsciiBuilder printStatusCode (statusCode → (# num, msg #)) - = A.fromAsciiBuilder $ - ( show3 num ⊕ + = ( show3 num ⊕ A.toAsciiBuilder " " ⊕ A.toAsciiBuilder msg ) @@ -108,19 +105,14 @@ instance HasHeaders Response where getHeaders = resHeaders setHeaders res hdr = res { resHeaders = hdr } -hPutResponse ∷ HandleLike h ⇒ h → Response → IO () -hPutResponse h (Response {..}) - = do hPutHttpVersion h resVersion - hPutChar h ' ' - hPutStatus h resStatus - hPutBS h "\r\n" - hPutHeaders h resHeaders - -hPutStatus ∷ HandleLike h ⇒ h → StatusCode → IO () -hPutStatus h (statusCode → (# num, msg #)) - = do hPutBS h (A.toByteString $ A.fromAsciiBuilder $ show3 num) - hPutChar h ' ' - hPutBS h (A.toByteString msg) +-- |Convert a 'Response' to 'AsciiBuilder'. +printResponse ∷ Response → AsciiBuilder +printResponse (Response {..}) + = printHttpVersion resVersion ⊕ + A.toAsciiBuilder " " ⊕ + printStatusCode resStatus ⊕ + A.toAsciiBuilder "\x0D\x0A" ⊕ + printHeaders resHeaders -- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@. isInformational ∷ StatusCode → Bool