X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=638d1b05bafc472f364cfb7626930f6f00a86423;hb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf;hp=91979c9d5449e7a1b2ee7811a0c8294a9d381fc7;hpb=d05d8c883eaca12ee621975a2b95c5ebdc2357d2;p=Lucu.git diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 91979c9..638d1b0 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Interaction ( Interaction(..) , InteractionState(..) @@ -15,42 +19,46 @@ module Network.HTTP.Lucu.Interaction where import Control.Concurrent.STM -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import Data.ByteString.Char8 as C8 hiding (ByteString) +import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) import qualified Data.Sequence as S import Data.Sequence (Seq) import Network.Socket import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response +import OpenSSL.X509 data Interaction = Interaction { itrConfig :: !Config + , itrLocalPort :: !PortNumber , itrRemoteAddr :: !SockAddr + , itrRemoteCert :: !(Maybe X509) , itrResourcePath :: !(Maybe [String]) - , itrRequest :: !(TVar (Maybe Request)) + , itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し , itrResponse :: !(TVar Response) - -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす - -- るに越した事は無いが、それは重要でない。 - , itrRequestHasBody :: !(TVar Bool) - , itrRequestIsChunked :: !(TVar Bool) - , itrExpectedContinue :: !(TVar Bool) + , itrRequestHasBody :: !(TVar Bool) -- FIXME: TVar である必要無し + , itrRequestIsChunked :: !(TVar Bool) -- FIXME: TVar である必要無し + , itrExpectedContinue :: !(TVar Bool) -- FIXME: TVar である必要無し , itrReqChunkLength :: !(TVar (Maybe Int)) , itrReqChunkRemaining :: !(TVar (Maybe Int)) , itrReqChunkIsOver :: !(TVar Bool) , itrReqBodyWanted :: !(TVar (Maybe Int)) , itrReqBodyWasteAll :: !(TVar Bool) - , itrReceivedBody :: !(TVar ByteString) -- Resource が受領した部分は削除される + , itrReceivedBody :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される , itrWillReceiveBody :: !(TVar Bool) , itrWillChunkBody :: !(TVar Bool) , itrWillDiscardBody :: !(TVar Bool) , itrWillClose :: !(TVar Bool) - , itrBodyToSend :: !(TVar ByteString) + , itrBodyToSend :: !(TVar Lazy.ByteString) , itrBodyIsNull :: !(TVar Bool) , itrState :: !(TVar InteractionState) @@ -75,18 +83,17 @@ newInteractionQueue :: IO InteractionQueue newInteractionQueue = newTVarIO S.empty -defaultPageContentType :: String -defaultPageContentType = "application/xhtml+xml" +defaultPageContentType :: Strict.ByteString +defaultPageContentType = C8.pack "application/xhtml+xml" -newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction -newInteraction conf addr req - = conf `seq` addr `seq` req `seq` - do request <- newTVarIO $ req - responce <- newTVarIO $ Response { +newInteraction :: Config -> PortNumber -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction +newInteraction !conf !port !addr !cert !req + = do request <- newTVarIO req + responce <- newTVarIO Response { resVersion = HttpVersion 1 1 , resStatus = Ok - , resHeaders = [("Content-Type", defaultPageContentType)] + , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)] } requestHasBody <- newTVarIO False @@ -98,14 +105,14 @@ newInteraction conf addr req reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長 reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求 - receivedBody <- newTVarIO B.empty + receivedBody <- newTVarIO L8.empty willReceiveBody <- newTVarIO False willChunkBody <- newTVarIO False willDiscardBody <- newTVarIO False willClose <- newTVarIO False - bodyToSend <- newTVarIO B.empty + bodyToSend <- newTVarIO L8.empty bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False state <- newTVarIO ExaminingRequest @@ -113,15 +120,17 @@ newInteraction conf addr req wroteContinue <- newTVarIO False wroteHeader <- newTVarIO False - return $ Interaction { + return Interaction { itrConfig = conf + , itrLocalPort = port , itrRemoteAddr = addr + , itrRemoteCert = cert , itrResourcePath = Nothing , itrRequest = request , itrResponse = responce - , itrRequestHasBody = requestHasBody - , itrRequestIsChunked = requestIsChunked + , itrRequestHasBody = requestHasBody + , itrRequestIsChunked = requestIsChunked , itrExpectedContinue = expectedContinue , itrReqChunkLength = reqChunkLength @@ -147,33 +156,28 @@ newInteraction conf addr req writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM () -writeItr itr accessor value - = itr `seq` accessor `seq` value `seq` - writeTVar (accessor itr) value +writeItr !itr !accessor !value + = writeTVar (accessor itr) value readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b -readItr itr accessor reader - = itr `seq` accessor `seq` reader `seq` - readTVar (accessor itr) >>= return . reader +readItr !itr !accessor !reader + = fmap reader $ readTVar (accessor itr) readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) -readItrF itr accessor reader - = itr `seq` accessor `seq` reader `seq` - readItr itr accessor (fmap reader) +readItrF !itr !accessor !reader + = readItr itr accessor (fmap reader) {-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-} updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM () -updateItr itr accessor updator - = itr `seq` accessor `seq` updator `seq` - do old <- readItr itr accessor id +updateItr !itr !accessor !updator + = do old <- readItr itr accessor id writeItr itr accessor (updator old) updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM () -updateItrF itr accessor updator - = itr `seq` accessor `seq` updator `seq` - updateItr itr accessor (fmap updator) +updateItrF !itr !accessor !updator + = updateItr itr accessor (fmap updator) {-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-} \ No newline at end of file