, mkDefaultPage
)
where
+import qualified Blaze.ByteString.Builder.ByteString as BB
import Control.Arrow
import Control.Arrow.ArrowList
import Control.Arrow.ListArrow
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
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)
, 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
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
{-# 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"
, 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\".
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)
, 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
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import OpenSSL.X509
-import Prelude.Unicode
data Interaction = Interaction {
itrConfig ∷ !Config
, 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)
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
, itrReqBodyWanted = reqBodyWanted
, itrReqBodyWasteAll = reqBodyWasteAll
, itrReceivedBody = receivedBody
+ , itrReceivedBodyLen = receivedBodyLen
, itrWillReceiveBody = willReceiveBody
, itrWillChunkBody = willChunkBody
, itrWroteHeader = wroteHeader
}
+{-
chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
{-# INLINE chunksToLBS #-}
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 #-}
)
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
, 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.
[] (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
= 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
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
= 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
-- チャンクフッタを讀む
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'
, 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
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
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
askForInput itr
else
do driftTo DecidingHeader
- return L8.empty
+ return (∅)
return chunk
where
askForInput ∷ Interaction → Resource Lazy.ByteString
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
$ tooLarge actualLimit
-- 成功。itr 内にチャンクを置いたままにする
-- とメモリの無駄になるので除去。
+ chunk ← readItr itrReceivedBody seqToLBS itr
writeItr itrReceivedBody (∅) itr
return chunk
+
driftTo DecidingHeader
return chunk
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
askForInput itr
else
do driftTo DecidingHeader
- return L8.empty
+ return (∅)
return chunk
where
askForInput ∷ Interaction → Resource Lazy.ByteString
$ 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
→ 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)
(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")
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@.
-- \/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
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
{-
, 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
, 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
| 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
)
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
projects / Lucu.git / commitdiff