{-# LANGUAGE
- BangPatterns
- , OverloadedStrings
+ OverloadedStrings
+ , RecordWildCards
, UnboxedTuples
, UnicodeSyntax
#-}
getDefaultPage ∷ Config → Maybe Request → Response → Lazy.Text
{-# INLINEABLE getDefaultPage #-}
-getDefaultPage !conf !req !res
+getDefaultPage conf req res
= let msgA = getMsg req res
[xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
⋙
Lazy.pack xmlStr
writeDefaultPage ∷ Interaction → STM ()
-writeDefaultPage !itr
+writeDefaultPage (Interaction {..})
-- Content-Type が正しくなければ補完できない。
- = do res ← readItr itrResponse itr
- when (getHeader "Content-Type" res == Just defaultPageContentType)
- $ do reqM ← readItr itrRequest itr
-
- let conf = itrConfig itr
- page = getDefaultPage conf reqM res
-
- putTMVar (itrBodyToSend itr) (BB.fromLazyText page)
+ = do res ← readTVar itrResponse
+ when (getHeader "Content-Type" res ≡ Just defaultPageContentType)
+ $ do reqM ← readTVar itrRequest
+ let page = getDefaultPage itrConfig reqM res
+ putTMVar itrBodyToSend (BB.fromLazyText page)
mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
{-# INLINEABLE mkDefaultPage #-}
-mkDefaultPage !conf !status !msgA
+mkDefaultPage conf status msgA
= let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
sig = concat [ A.toString (cnfServerSoftware conf)
, " at "
getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
{-# INLINEABLE getMsg #-}
-getMsg !req !res
+getMsg req res
= case resStatus res of
-- 1xx は body を持たない
-- 2xx の body は補完しない
{-# LANGUAGE
- BangPatterns
- , GeneralizedNewtypeDeriving
+ GeneralizedNewtypeDeriving
, OverloadedStrings
, UnicodeSyntax
#-}
setHeaders ∷ a → Headers → a
getHeader ∷ CIAscii → a → Maybe Ascii
- {-# INLINE getHeader #-}
- getHeader !key !a
+ getHeader key a
= case getHeaders a of
Headers m → M.lookup key m
+ getCIHeader ∷ CIAscii → a → Maybe CIAscii
+ {-# INLINE getCIHeader #-}
+ getCIHeader key a
+ = A.toCIAscii <$> getHeader key a
+
deleteHeader ∷ CIAscii → a → a
{-# INLINE deleteHeader #-}
- deleteHeader !key !a
+ deleteHeader key a
= case getHeaders a of
Headers m
→ setHeaders a $ Headers $ M.delete key m
setHeader ∷ CIAscii → Ascii → a → a
{-# INLINE setHeader #-}
- setHeader !key !val !a
+ setHeader key val a
= case getHeaders a of
Headers m
→ setHeaders a $ Headers $ M.insert key val m
, newInteractionQueue
, newInteraction
, defaultPageContentType
-
+{-
, writeItr
, readItr
, updateItr
+-}
)
where
import Blaze.ByteString.Builder (Builder)
{-# LANGUAGE
DoAndIfThenElse
, OverloadedStrings
+ , RecordWildCards
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Postprocess
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
-import Data.Maybe
import Data.Monoid.Unicode
import Data.Time
import qualified Data.Time.HTTP as HTTP
import Prelude.Unicode
{-
+ TODO: Tanslate this memo into English. It doesn't make sense to
+ non-Japanese speakers.
* Response が未設定なら、200 OK にする。
-}
postprocess ∷ Interaction → STM ()
-postprocess itr
- = do reqM ← readItr itrRequest itr
- res ← readItr itrResponse itr
+postprocess (Interaction {..})
+ = do res ← readTVar itrResponse
let sc = resStatus res
unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
⊕ printStatusCode sc
⊕ A.toAsciiBuilder " but no Location header."
- when (reqM ≢ Nothing) relyOnRequest
+ reqM ← readTVar itrRequest
+ case reqM of
+ Just req → postprocessWithRequest sc req
+ Nothing → return ()
-- itrResponse の内容は relyOnRequest によって變へられてゐる可
-- 能性が高い。
- do oldRes ← readItr itrResponse itr
+ do oldRes ← readTVar itrResponse
newRes ← unsafeIOToSTM
- $ completeUnconditionalHeaders (itrConfig itr) oldRes
- writeItr itrResponse newRes itr
+ $ completeUnconditionalHeaders itrConfig oldRes
+ writeTVar itrResponse newRes
where
- relyOnRequest ∷ STM ()
- relyOnRequest
- = do status ← resStatus <$> readItr itrResponse itr
- req ← fromJust <$> readItr itrRequest itr
-
- let reqVer = reqVersion req
- canHaveBody = if reqMethod req ≡ HEAD then
+ postprocessWithRequest ∷ StatusCode → Request → STM ()
+ postprocessWithRequest sc (Request {..})
+ = do let canHaveBody = if reqMethod ≡ HEAD then
False
else
- not (isInformational status ∨
- status ≡ NoContent ∨
- status ≡ ResetContent ∨
- status ≡ NotModified )
+ (¬) (isInformational sc ∨
+ sc ≡ NoContent ∨
+ sc ≡ ResetContent ∨
+ sc ≡ NotModified )
updateRes $ deleteHeader "Content-Length"
updateRes $ deleteHeader "Transfer-Encoding"
$ updateRes $ setHeader "Content-Type" defaultPageContentType
if canHaveBody then
- when (reqVer ≡ HttpVersion 1 1)
+ when (reqVersion ≡ HttpVersion 1 1)
$ do updateRes $ setHeader "Transfer-Encoding" "chunked"
- writeItr itrWillChunkBody True itr
+ writeTVar itrWillChunkBody True
else
-- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
- when (reqMethod req ≢ HEAD)
+ when (reqMethod ≢ HEAD)
$ do updateRes $ deleteHeader "Content-Type"
updateRes $ deleteHeader "Etag"
updateRes $ deleteHeader "Last-Modified"
- conn ← readHeader "Connection"
+ conn ← readCIHeader "Connection"
case conn of
Nothing → return ()
- Just value → when (A.toCIAscii value ≡ "close")
- $ writeItr itrWillClose True itr
+ Just value → when (value ≡ "close")
+ $ writeTVar itrWillClose True
- willClose ← readItr itrWillClose itr
+ willClose ← readTVar itrWillClose
when willClose
$ updateRes $ setHeader "Connection" "close"
- when (reqMethod req ≡ HEAD ∨ not canHaveBody)
- $ writeTVar (itrWillDiscardBody itr) True
+ when (reqMethod ≡ HEAD ∨ not canHaveBody)
+ $ writeTVar itrWillDiscardBody True
readHeader ∷ CIAscii → STM (Maybe Ascii)
{-# INLINE readHeader #-}
- readHeader k = getHeader k <$> readItr itrResponse itr
+ readHeader k = getHeader k <$> readTVar itrResponse
+
+ readCIHeader ∷ CIAscii → STM (Maybe CIAscii)
+ {-# INLINE readCIHeader #-}
+ readCIHeader k = getCIHeader k <$> readTVar itrResponse
updateRes ∷ (Response → Response) → STM ()
{-# INLINE updateRes #-}
- updateRes f = updateItr itrResponse f itr
+ updateRes f
+ = do old ← readTVar itrResponse
+ writeTVar itrResponse (f old)
completeUnconditionalHeaders ∷ Config → Response → IO Response
completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
{-# LANGUAGE
- BangPatterns
+ DoAndIfThenElse
+ , OverloadedStrings
+ , RecordWildCards
+ , UnicodeSyntax
#-}
module Network.HTTP.Lucu.Preprocess
( preprocess
)
where
-
-import Control.Concurrent.STM
-import Control.Monad
-import qualified Data.ByteString as Strict (ByteString)
-import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
-import Data.Char
-import Data.Maybe
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.HttpVersion
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
-import Network.URI
+import Control.Applicative
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as C8
+import Data.Char
+import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Network.URI
+import Prelude.Unicode
{-
+ TODO: Tanslate this memo into English. It doesn't make sense to
+ non-Japanese speakers.
* URI にホスト名が存在しない時、
[1] HTTP/1.0 ならば Config を使って補完
Request にする。
* willDiscardBody その他の變數を設定する。
-
-}
-preprocess :: Interaction -> STM ()
-preprocess !itr
- = do req <- readItr itr itrRequest fromJust
+preprocess ∷ Interaction → STM ()
+preprocess itr@(Interaction {..})
+ = do req ← fromJust <$> readTVar itrRequest
let reqVer = reqVersion req
- if reqVer /= HttpVersion 1 0 &&
- reqVer /= HttpVersion 1 1 then
+ if reqVer ≢ HttpVersion 1 0 ∧
+ reqVer ≢ HttpVersion 1 1 then
- do setStatus HttpVersionNotSupported
- writeItr itr itrWillClose True
+ do setStatus itr HttpVersionNotSupported
+ writeTVar itrWillClose True
- else
+ else
-- HTTP/1.0 では Keep-Alive できない
- do when (reqVer == HttpVersion 1 0)
- $ writeItr itr itrWillClose True
+ do when (reqVer ≡ HttpVersion 1 0)
+ $ writeTVar itrWillClose True
-- ホスト部の補完
- completeAuthority req
+ completeAuthority itr req
case reqMethod req of
- GET -> return ()
- HEAD -> writeItr itr itrWillDiscardBody True
- POST -> writeItr itr itrRequestHasBody True
- PUT -> writeItr itr itrRequestHasBody True
- DELETE -> return ()
- _ -> setStatus NotImplemented
+ GET → return ()
+ HEAD → writeTVar itrWillDiscardBody True
+ POST → writeTVar itrRequestHasBody True
+ PUT → writeTVar itrRequestHasBody True
+ DELETE → return ()
+ _ → setStatus itr NotImplemented
- preprocessHeader req
- where
- setStatus :: StatusCode -> STM ()
- setStatus !status
- = updateItr itr itrResponse
- $! \ res -> res {
- resStatus = status
- }
-
- completeAuthority :: Request -> STM ()
- completeAuthority !req
- = when (uriAuthority (reqURI req) == Nothing)
- $ if reqVersion req == HttpVersion 1 0 then
- -- HTTP/1.0 なので Config から補完
- do let conf = itrConfig itr
- host = cnfServerHost conf
- port = itrLocalPort itr
- portStr
- = case port of
- 80 -> ""
- n -> ':' : show n
- updateAuthority host (C8.pack portStr)
- else
- case getHeader (C8.pack "Host") req of
- Just str -> let (host, portStr) = parseHost str
- in updateAuthority host portStr
- Nothing -> setStatus BadRequest
-
-
- parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
- parseHost = C8.break (== ':')
-
-
- updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM ()
- updateAuthority !host !portStr
- = updateItr itr itrRequest
- $! \ (Just req) -> Just req {
- reqURI = let uri = reqURI req
- in uri {
- uriAuthority = Just URIAuth {
- uriUserInfo = ""
- , uriRegName = C8.unpack host
- , uriPort = C8.unpack portStr
- }
- }
- }
-
-
- preprocessHeader :: Request -> STM ()
- preprocessHeader !req
- = do case getHeader (C8.pack "Expect") req of
- Nothing -> return ()
- Just value -> if value `noCaseEq` C8.pack "100-continue" then
- writeItr itr itrExpectedContinue True
- else
- setStatus ExpectationFailed
-
- case getHeader (C8.pack "Transfer-Encoding") req of
- Nothing -> return ()
- Just value -> unless (value `noCaseEq` C8.pack "identity")
- $ if value `noCaseEq` C8.pack "chunked" then
- writeItr itr itrRequestIsChunked True
- else
- setStatus NotImplemented
-
- case getHeader (C8.pack "Content-Length") req of
- Nothing -> return ()
- Just value -> if C8.all isDigit value then
- do let Just (len, _) = C8.readInt value
- writeItr itr itrReqChunkLength $ Just len
- writeItr itr itrReqChunkRemaining $ Just len
- else
- setStatus BadRequest
-
- case getHeader (C8.pack "Connection") req of
- Nothing -> return ()
- Just value -> when (value `noCaseEq` C8.pack "close")
- $ writeItr itr itrWillClose True
+ preprocessHeader itr req
+
+setStatus ∷ Interaction → StatusCode → STM ()
+setStatus (Interaction {..}) sc
+ = do res ← readTVar itrResponse
+ let res' = res {
+ resStatus = sc
+ }
+ writeTVar itrResponse res'
+
+completeAuthority ∷ Interaction → Request → STM ()
+completeAuthority itr@(Interaction {..}) req
+ = when (isNothing $ uriAuthority $ reqURI req)
+ $ if reqVersion req == HttpVersion 1 0 then
+ -- HTTP/1.0 なので Config から補完
+ do let host = cnfServerHost itrConfig
+ portStr = case itrLocalPort of
+ 80 → ""
+ n → ':' : show n
+ updateAuthority host $ A.unsafeFromString portStr
+ else
+ case getHeader "Host" req of
+ Just str → let (host, portStr) = parseHost str
+ in
+ updateAuthority host portStr
+ Nothing → setStatus itr BadRequest
+
+parseHost ∷ Ascii → (Text, Ascii)
+parseHost = C8.break (≡ ':')
+
+updateAuthority ∷ Text → Ascii → STM ()
+updateAuthority host portStr
+ = do Just req ← readTVar itrRequest
+ let uri = reqURI req
+ uri' = uri {
+ uriAuthority = Just URIAuth {
+ uriUserInfo = ""
+ , uriRegName = T.unpack host
+ , uriPort = A.toString portStr
+ }
+ }
+ req' = req { reqURI = uri' }
+ writeTVar itrRequest $ Just req'
+
+preprocessHeader ∷ Interaction → Request → STM ()
+preprocessHeader (Interaction {..}) req
+ = do case getCIHeader "Expect" req of
+ Nothing → return ()
+ Just value → if value ≡ "100-continue" then
+ writeTVar itrExpectedContinue True
+ else
+ setStatus ExpectationFailed
+
+ case getCIHeader "Transfer-Encoding" req of
+ Nothing → return ()
+ Just value → unless (value ≡ "identity")
+ $ if value ≡ "chunked" then
+ writeTVar itrRequestIsChunked True
+ else
+ setStatus NotImplemented
+
+ case getHeader "Content-Length" req of
+ Nothing → return ()
+ Just value → if C8.all isDigit value then
+ do let Just (len, _) = C8.readInt value
+ writeTVar itrReqChunkLength $ Just len
+ writeTVar itrReqChunkRemaining $ Just len
+ else
+ setStatus BadRequest
+
+ case getCIHeader "Connection" req of
+ Nothing → return ()
+ Just value → when (value ≡ "close")
+ $ writeTVar itrWillClose True
{-# LANGUAGE
- BangPatterns
- , GeneralizedNewtypeDeriving
+ GeneralizedNewtypeDeriving
, DoAndIfThenElse
, OverloadedStrings
, RecordWildCards
getRequest ∷ Resource Request
getRequest
= do itr ← getInteraction
- liftIO $ atomically $ fromJust <$> readItr itrRequest itr
+ liftIO $ atomically $ fromJust <$> readTVar (itrRequest itr)
-- |Get the 'Method' value of the request.
getMethod ∷ Resource Method
-- If this is a GET or HEAD request, 'foundEntity' automatically puts
-- \"ETag\" and \"Last-Modified\" headers into the response.
foundEntity ∷ ETag → UTCTime → Resource ()
-foundEntity !tag !timeStamp
+foundEntity tag timeStamp
= do driftTo ExaminingRequest
method ← getMethod
-- This action is not preferred. You should use 'foundEntity' whenever
-- possible.
foundETag ∷ ETag → Resource ()
-foundETag !tag
+foundETag tag
= do driftTo ExaminingRequest
method ← getMethod
input limit
= do driftTo GettingBody
itr ← getInteraction
- hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr
+ hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
chunk ← if hasBody then
askForInput itr
else
return chunk
where
askForInput ∷ Interaction → Resource Lazy.ByteString
- askForInput itr
- = do let confLimit = cnfMaxEntityLength $ itrConfig itr
+ askForInput (Interaction {..})
+ = do let confLimit = cnfMaxEntityLength itrConfig
actualLimit = if limit ≤ 0 then
confLimit
else
$ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
-- Reader にリクエスト
liftIO $ atomically
- $ do chunkLen ← readItr itrReqChunkLength itr
- writeItr itrWillReceiveBody True itr
+ $ do chunkLen ← readTVar itrReqChunkLength
+ writeTVar itrWillReceiveBody True
if ((> actualLimit) <$> chunkLen) ≡ Just True then
-- 受信前から多過ぎる事が分かってゐる
tooLarge actualLimit
else
- writeItr itrReqBodyWanted (Just actualLimit) itr
+ writeTVar itrReqBodyWanted (Just actualLimit)
-- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
chunk ← liftIO $ atomically
- $ do chunkLen ← readItr itrReceivedBodyLen itr
- chunkIsOver ← readItr itrReqChunkIsOver itr
+ $ do chunkLen ← readTVar itrReceivedBodyLen
+ chunkIsOver ← readTVar itrReqChunkIsOver
if chunkLen < actualLimit then
-- 要求された量に滿たなくて、まだ殘りが
-- あるなら再試行。
$ tooLarge actualLimit
-- 成功。itr 内にチャンクを置いたままにする
-- とメモリの無駄になるので除去。
- chunk ← seqToLBS <$> readItr itrReceivedBody itr
- writeItr itrReceivedBody (∅) itr
- writeItr itrReceivedBodyLen 0 itr
+ chunk ← seqToLBS <$> readTVar itrReceivedBody
+ writeTVar itrReceivedBody (∅)
+ writeTVar itrReceivedBodyLen 0
return chunk
driftTo DecidingHeader
inputChunk limit
= do driftTo GettingBody
itr ← getInteraction
- hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr
+ hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
chunk ← if hasBody then
askForInput itr
else
return chunk
where
askForInput ∷ Interaction → Resource Lazy.ByteString
- askForInput itr
- = do let confLimit = cnfMaxEntityLength $ itrConfig itr
+ askForInput (Interaction {..})
+ = do let confLimit = cnfMaxEntityLength itrConfig
actualLimit = if limit < 0 then
confLimit
else
$ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
-- Reader にリクエスト
liftIO $ atomically
- $ do writeItr itrReqBodyWanted (Just actualLimit) itr
- writeItr itrWillReceiveBody True itr
+ $ do writeTVar itrReqBodyWanted (Just actualLimit)
+ writeTVar itrWillReceiveBody True
-- 應答を待つ。トランザクションを分けなければ當然デッドロック。
chunk ← liftIO $ atomically
- $ do chunkLen ← readItr itrReceivedBodyLen itr
+ $ do chunkLen ← readTVar itrReceivedBodyLen
-- 要求された量に滿たなくて、まだ殘りがある
-- なら再試行。
when (chunkLen < actualLimit)
- $ do chunkIsOver ← readItr itrReqChunkIsOver itr
+ $ do chunkIsOver ← readTVar itrReqChunkIsOver
unless chunkIsOver
$ retry
-- 成功
- chunk ← seqToLBS <$> readItr itrReceivedBody itr
- writeItr itrReceivedBody (∅) itr
- writeItr itrReceivedBodyLen 0 itr
+ chunk ← seqToLBS <$> readTVar itrReceivedBody
+ writeTVar itrReceivedBody (∅)
+ writeTVar itrReceivedBodyLen 0
return chunk
when (Lazy.null chunk)
$ driftTo DecidingHeader
setStatus code
= do driftTo DecidingHeader
itr ← getInteraction
- liftIO $ atomically $ updateItr itrResponse f itr
- where
- f res = res {
- resStatus = code
- }
+ liftIO $ atomically
+ $ do res ← readTVar $ itrResponse itr
+ let res' = res {
+ resStatus = code
+ }
+ writeTVar (itrResponse itr) res'
-- | Set a value of given resource header. Comparison of header name
-- is case-insensitive. Note that this action is not intended to be
setHeader' name value
= do itr ← getInteraction
liftIO $ atomically
- $ updateItr itrResponse (H.setHeader name value) itr
+ $ do res ← readTVar $ itrResponse itr
+ let res' = H.setHeader name value res
+ writeTVar (itrResponse itr) res'
-- | Computation of @'redirect' code uri@ sets the response status to
-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
{- DecidingBody 時に使用するアクション群 -}
--- | Computation of @'output' str@ writes @str@ as a response body,
--- and then make the 'Resource' transit to /Done/ state. It is safe to
--- apply 'output' to an infinite string, such as a lazy stream of
--- \/dev\/random.
+-- | Write a 'Lazy.ByteString' to the response body, and then transit
+-- to the /Done/ state. It is safe to apply 'output' to an infinite
+-- string, such as the lazy stream of \/dev\/random.
output ∷ Lazy.ByteString → Resource ()
{-# INLINE output #-}
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
--- a body little at a time. It is safe to apply 'outputChunk' to an
--- infinite string.
+-- | Write a 'Lazy.ByteString' to the response body. This action can
+-- be repeated as many times as you want. It is safe to apply
+-- 'outputChunk' to an infinite string.
outputChunk ∷ Lazy.ByteString → Resource ()
outputChunk wholeChunk
= do driftTo DecidingBody
$ abort InternalServerError []
(Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
- discardBody ← liftIO $ atomically $
- readItr itrWillDiscardBody itr
-
+ discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr
unless (discardBody)
- $ sendChunks wholeChunk limit
+ $ sendChunks itr wholeChunk limit
unless (Lazy.null wholeChunk)
$ liftIO $ atomically $
- writeItr itrSentNoBody False itr
+ writeTVar (itrSentNoBody itr) False
where
- sendChunks ∷ Lazy.ByteString → Int → Resource ()
- sendChunks str limit
+ sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource ()
+ sendChunks itr@(Interaction {..}) str 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
+ $ putTMVar itrBodyToSend (chunkToBuilder chunk)
+ sendChunks itr remaining limit
chunkToBuilder ∷ Lazy.ByteString → Builder
chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
driftTo ∷ InteractionState → Resource ()
driftTo newState
= do itr ← getInteraction
- liftIO $ atomically $ do oldState ← readItr itrState itr
- if newState < oldState then
- throwStateError oldState newState
- else
- do let a = [oldState .. newState]
- b = tail a
- c = zip a b
- mapM_ (uncurry $ drift itr) c
- writeItr itrState newState itr
+ liftIO $ atomically
+ $ do oldState ← readTVar $ itrState itr
+ if newState < oldState then
+ throwStateError oldState newState
+ else
+ do let a = [oldState .. newState]
+ b = tail a
+ c = zip a b
+ mapM_ (uncurry $ drift itr) c
+ writeTVar (itrState itr) newState
where
- throwStateError ∷ Monad m => InteractionState → InteractionState → m a
-
+ throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
throwStateError Done DecidingBody
= fail "It makes no sense to output something after finishing to output."
-
throwStateError old new
= fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
-
drift ∷ Interaction → InteractionState → InteractionState → STM ()
-
- drift itr GettingBody _
- = writeItr itrReqBodyWasteAll True itr
-
+ drift (Interaction {..}) GettingBody _
+ = writeTVar itrReqBodyWasteAll True
drift itr DecidingHeader _
= postprocess itr
-
- drift itr _ Done
- = do bodyIsNull ← readItr itrSentNoBody itr
+ drift itr@(Interaction {..}) _ Done
+ = do bodyIsNull ← readTVar itrSentNoBody
when bodyIsNull
$ writeDefaultPage itr
-
drift _ _ _
= return ()
{-# LANGUAGE
DoAndIfThenElse
, OverloadedStrings
+ , RecordWildCards
, UnicodeSyntax
#-}
{-# OPTIONS_HADDOCK prune #-}
runResource ∷ ResourceDef → Interaction → IO ThreadId
-runResource def itr
- = def `seq` itr `seq`
- fork
- $! catch ( runRes ( do req ← getRequest
- fromMaybe notAllowed $ rsrc req
- driftTo Done
- ) itr
- )
- processException
+runResource (ResourceDef {..}) itr@(Interaction {..})
+ = fork $ ( runRes ( do req ← getRequest
+ fromMaybe notAllowed $ rsrc req
+ driftTo Done
+ ) itr
+ )
+ `catch`
+ processException
where
fork ∷ IO () → IO ThreadId
- fork = if resUsesNativeThread def
- then forkOS
- else forkIO
+ fork | resUsesNativeThread = forkOS
+ | otherwise = forkIO
rsrc ∷ Request → Maybe (Resource ())
rsrc req
= case reqMethod req of
- GET → resGet def
- HEAD → case resHead def of
+ GET → resGet
+ HEAD → case resHead of
Just r → Just r
- Nothing → resGet def
- POST → resPost def
- PUT → resPut def
- DELETE → resDelete def
- _ → undefined
+ Nothing → resGet
+ POST → resPost
+ PUT → resPut
+ DELETE → resDelete
+ _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
notAllowed ∷ Resource ()
notAllowed
, methods resDelete ["DELETE"]
]
- methods ∷ (ResourceDef → Maybe a) → [Ascii] → [Ascii]
- methods f xs = case f def of
- Just _ → xs
- Nothing → []
+ methods ∷ Maybe a → [Ascii] → [Ascii]
+ methods m xs
+ = case m of
+ Just _ → xs
+ Nothing → []
toAbortion ∷ SomeException → Abortion
toAbortion e
processException ∷ SomeException → IO ()
processException exc
= do let abo = toAbortion exc
- conf = itrConfig itr
-- まだ DecidingHeader 以前の状態だったら、この途中終了
-- を應答に反映させる餘地がある。さうでなければ stderr
-- にでも吐くしか無い。
- state ← atomically $ readItr itrState itr
- reqM ← atomically $ readItr itrRequest itr
- res ← atomically $ readItr itrResponse itr
+ state ← atomically $ readTVar itrState
+ reqM ← atomically $ readTVar itrRequest
+ res ← atomically $ readTVar itrResponse
if state ≤ DecidingHeader then
- flip runRes itr
- $ do setStatus $ aboStatus abo
- mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
- output $ LT.encodeUtf8 $ abortPage conf reqM res abo
+ flip runRes itr $
+ do setStatus $ aboStatus abo
+ mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
+ output $ LT.encodeUtf8 $ abortPage itrConfig reqM res abo
else
- when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
+ when (cnfDumpTooLateAbortionToStderr itrConfig)
$ hPutStrLn stderr $ show abo
- flip runRes itr $ driftTo Done
+ runRes (driftTo Done) itr
where
import qualified Blaze.ByteString.Builder.HTTP as BB
import qualified Data.Ascii as A
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Exception
-import Control.Monad
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
import Data.Monoid.Unicode
import qualified Data.Sequence as S
-import Data.Sequence (ViewR(..))
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.HandleLike
-import Network.HTTP.Lucu.HttpVersion
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Postprocess
-import Network.HTTP.Lucu.Response
-import Prelude hiding (catch)
+import Data.Sequence (ViewR(..))
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.HandleLike
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Postprocess
+import Network.HTTP.Lucu.Response
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)
-- だ送信前なのであれば、Continue を送信する。
case S.viewr queue of
EmptyR → retry
- _ :> itr → do state ← readItr itrState itr
+ _ :> itr → do state ← readTVar $ itrState itr
if state ≡ GettingBody then
writeContinueIfNeeded ctx itr
else
retry
writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
-writeContinueIfNeeded ctx itr
- = do expectedContinue ← readItr itrExpectedContinue itr
+writeContinueIfNeeded ctx itr@(Interaction {..})
+ = do expectedContinue ← readTVar itrExpectedContinue
if expectedContinue then
- do wroteContinue ← readItr itrWroteContinue itr
+ do wroteContinue ← readTVar itrWroteContinue
if wroteContinue then
-- 既に Continue を書込み濟
retry
else
- do reqBodyWanted ← readItr itrReqBodyWanted itr
+ do reqBodyWanted ← readTVar itrReqBodyWanted
if reqBodyWanted ≢ Nothing then
return $ writeContinue ctx itr
else
-- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
-- 出力する。空である時は、もし状態がDone であれば後処理をする。
writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
-writeHeaderOrBodyIfNeeded ctx itr
- = do wroteHeader ← readItr itrWroteHeader itr
+writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..})
+ = do wroteHeader ← readTVar itrWroteHeader
if not wroteHeader then
return $ writeHeader ctx itr
else
- do noBodyToWrite ← isEmptyTMVar (itrBodyToSend itr)
+ do noBodyToWrite ← isEmptyTMVar itrBodyToSend
if noBodyToWrite then
- do state ← readItr itrState itr
+ do state ← readTVar itrState
if state ≡ Done then
return $ finalize ctx itr
else
return $ writeBodyChunk ctx itr
writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeContinue ctx@(Context {..}) itr
+writeContinue ctx@(Context {..}) (Interaction {..})
= do let cont = Response {
resVersion = HttpVersion 1 1
, resStatus = Continue
cont' ← completeUnconditionalHeaders cConfig cont
hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
hFlush cHandle
- atomically $ writeItr itrWroteContinue True itr
+ atomically $ writeTVar itrWroteContinue True
awaitSomethingToWrite ctx
writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeHeader ctx@(Context {..}) itr
+writeHeader ctx@(Context {..}) (Interaction {..})
= do res ← atomically
- $ do writeItr itrWroteHeader True itr
- readItr itrResponse itr
+ $ do writeTVar itrWroteHeader True
+ readTVar itrResponse
hPutBuilder cHandle $ A.toBuilder $ printResponse res
hFlush cHandle
awaitSomethingToWrite ctx
writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeBodyChunk ctx@(Context {..}) itr
+writeBodyChunk ctx@(Context {..}) (Interaction {..})
= join $
atomically $
- do willDiscardBody ← readItr itrWillDiscardBody itr
+ do willDiscardBody ← readTVar itrWillDiscardBody
if willDiscardBody then
- do _ ← tryTakeTMVar (itrBodyToSend itr)
+ do _ ← tryTakeTMVar itrBodyToSend
return $ awaitSomethingToWrite ctx
else
- do willChunkBody ← readItr itrWillChunkBody itr
- chunk ← takeTMVar (itrBodyToSend itr)
+ do willChunkBody ← readTVar itrWillChunkBody
+ chunk ← takeTMVar itrBodyToSend
return $
do if willChunkBody then
hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
awaitSomethingToWrite ctx
finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finishBodyChunk (Context {..}) itr
+finishBodyChunk (Context {..}) (Interaction {..})
= join $
atomically $
- do willDiscardBody ← readItr itrWillDiscardBody itr
- willChunkBody ← readItr itrWillChunkBody itr
+ do willDiscardBody ← readTVar itrWillDiscardBody
+ willChunkBody ← readTVar itrWillChunkBody
if ((¬) willDiscardBody) ∧ willChunkBody then
return $
do hPutBuilder cHandle BB.chunkedTransferTerminator
return $ return ()
finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finalize ctx@(Context {..}) itr
+finalize ctx@(Context {..}) itr@(Interaction {..})
= do finishBodyChunk ctx itr
willClose ← atomically $
do queue ← readTVar cQueue
case S.viewr queue of
EmptyR → return () -- this should never happen
remaining :> _ → writeTVar cQueue remaining
- readItr itrWillClose itr
+ readTVar itrWillClose
if willClose then
-- reader は恐らく hWaitForInput してゐる最中なので、スレッ
-- ドを豫め殺して置かないとをかしくなる。
projects / Lucu.git / commitdiff