From c7a8bc012b1b70353d567bfab86fc6e849d60c20 Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 6 Aug 2011 02:58:33 +0900 Subject: [PATCH] Authorization / DefaultPage Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- Network/HTTP/Lucu/Authorization.hs | 13 +- Network/HTTP/Lucu/Interaction.hs | 187 ++++++++++++++--------------- 2 files changed, 99 insertions(+), 101 deletions(-) diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs index 6472fb4..64183ff 100644 --- a/Network/HTTP/Lucu/Authorization.hs +++ b/Network/HTTP/Lucu/Authorization.hs @@ -21,7 +21,6 @@ import qualified Data.Ascii as A import Data.Attoparsec.Char8 import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as C8 -import Data.Maybe import Data.Monoid.Unicode import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils @@ -69,10 +68,14 @@ authCredentialP | C8.null cPassword → fail "no colons in the basic auth credential" | otherwise - → let u = fromJust $ A.fromByteString user - p = fromJust $ A.fromByteString (C8.tail cPassword) - in - return (BasicAuthCredential u p) + → do u ← asc user + p ← asc (C8.tail cPassword) + return (BasicAuthCredential u p) where base64 ∷ Char → Bool base64 = inClass "a-zA-Z0-9+/=" + + asc ∷ C8.ByteString → Parser Ascii + asc bs = case A.fromByteString bs of + Just as → return as + Nothing → fail "Non-ascii character in auth credential" diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 638d1b0..19faec2 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns + , OverloadedStrings , UnicodeSyntax #-} module Network.HTTP.Lucu.Interaction @@ -17,58 +18,57 @@ module Network.HTTP.Lucu.Interaction , updateItrF ) where - -import Control.Concurrent.STM -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 Control.Applicative +import Control.Concurrent.STM +import Data.Ascii (Ascii) +import qualified Data.ByteString as BS +import Data.Sequence (Seq) 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 +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 +import Prelude.Unicode data Interaction = Interaction { - itrConfig :: !Config - , itrLocalPort :: !PortNumber - , itrRemoteAddr :: !SockAddr - , itrRemoteCert :: !(Maybe X509) - , itrResourcePath :: !(Maybe [String]) - , itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し - , itrResponse :: !(TVar Response) - - , 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 Lazy.ByteString) -- Resource が受領した部分は削除される - - , itrWillReceiveBody :: !(TVar Bool) - , itrWillChunkBody :: !(TVar Bool) - , itrWillDiscardBody :: !(TVar Bool) - , itrWillClose :: !(TVar Bool) - - , itrBodyToSend :: !(TVar Lazy.ByteString) - , itrBodyIsNull :: !(TVar Bool) - - , itrState :: !(TVar InteractionState) - - , itrWroteContinue :: !(TVar Bool) - , itrWroteHeader :: !(TVar Bool) + itrConfig ∷ !Config + , itrLocalPort ∷ !PortNumber + , itrRemoteAddr ∷ !SockAddr + , itrRemoteCert ∷ !(Maybe X509) + , itrResourcePath ∷ !(Maybe [Ascii]) + , itrRequest ∷ !(TVar (Maybe Request)) + , itrResponse ∷ !(TVar Response) + + , itrRequestHasBody ∷ !(TVar Bool) + , itrRequestIsChunked ∷ !(TVar Bool) + , itrExpectedContinue ∷ !(TVar Bool) + + , itrReqChunkLength ∷ !(TVar (Maybe Int)) + , itrReqChunkRemaining ∷ !(TVar (Maybe Int)) + , itrReqChunkIsOver ∷ !(TVar Bool) + , itrReqBodyWanted ∷ !(TVar (Maybe Int)) + , itrReqBodyWasteAll ∷ !(TVar Bool) + , itrReceivedBody ∷ !(TVar (Seq BS.ByteString)) + + , itrWillReceiveBody ∷ !(TVar Bool) + , itrWillChunkBody ∷ !(TVar Bool) + , itrWillDiscardBody ∷ !(TVar Bool) + , itrWillClose ∷ !(TVar Bool) + + , itrBodyToSend ∷ !(TVar (Seq BS.ByteString)) + , itrBodyIsNull ∷ !(TVar Bool) + + , itrState ∷ !(TVar InteractionState) + + , itrWroteContinue ∷ !(TVar Bool) + , itrWroteHeader ∷ !(TVar Bool) } --- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期 --- 状態は ExaminingRequest。 +-- |The interaction state of Resource monad. 'ExaminingRequest' is the +-- initial state. data InteractionState = ExaminingRequest | GettingBody | DecidingHeader @@ -78,47 +78,44 @@ data InteractionState = ExaminingRequest type InteractionQueue = TVar (Seq Interaction) - -newInteractionQueue :: IO InteractionQueue +newInteractionQueue ∷ IO InteractionQueue newInteractionQueue = newTVarIO S.empty +defaultPageContentType ∷ Ascii +defaultPageContentType = "application/xhtml+xml" -defaultPageContentType :: Strict.ByteString -defaultPageContentType = C8.pack "application/xhtml+xml" - - -newInteraction :: Config -> PortNumber -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction +newInteraction ∷ Config → PortNumber → SockAddr → Maybe X509 → Maybe Request → IO Interaction newInteraction !conf !port !addr !cert !req - = do request <- newTVarIO req - responce <- newTVarIO Response { + = do request ← newTVarIO req + responce ← newTVarIO Response { resVersion = HttpVersion 1 1 , resStatus = Ok - , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)] + , resHeaders = toHeaders [("Content-Type", defaultPageContentType)] } - requestHasBody <- newTVarIO False - requestIsChunked <- newTVarIO False - expectedContinue <- newTVarIO False + requestHasBody ← newTVarIO False + requestIsChunked ← newTVarIO False + expectedContinue ← newTVarIO False - reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長 - reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り - reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた - reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長 - reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求 - receivedBody <- newTVarIO L8.empty + reqChunkLength ← newTVarIO Nothing -- 現在のチャンク長 + reqChunkRemaining ← newTVarIO Nothing -- 現在のチャンクの殘り + reqChunkIsOver ← newTVarIO False -- 最後のチャンクを讀み終へた + reqBodyWanted ← newTVarIO Nothing -- Resource が要求してゐるチャンク長 + reqBodyWasteAll ← newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求 + receivedBody ← newTVarIO S.empty - willReceiveBody <- newTVarIO False - willChunkBody <- newTVarIO False - willDiscardBody <- newTVarIO False - willClose <- newTVarIO False + willReceiveBody ← newTVarIO False + willChunkBody ← newTVarIO False + willDiscardBody ← newTVarIO False + willClose ← newTVarIO False - bodyToSend <- newTVarIO L8.empty - bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False + bodyToSend ← newTVarIO S.empty + bodyIsNull ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False - state <- newTVarIO ExaminingRequest + state ← newTVarIO ExaminingRequest - wroteContinue <- newTVarIO False - wroteHeader <- newTVarIO False + wroteContinue ← newTVarIO False + wroteHeader ← newTVarIO False return Interaction { itrConfig = conf @@ -154,30 +151,28 @@ newInteraction !conf !port !addr !cert !req , itrWroteHeader = wroteHeader } +writeItr ∷ Interaction → (Interaction → TVar a) → a → STM () +{-# INLINE writeItr #-} +writeItr itr accessor + = writeTVar (accessor itr) -writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM () -writeItr !itr !accessor !value - = writeTVar (accessor itr) value - +readItr ∷ Interaction → (Interaction → TVar a) → (a → b) → STM b +{-# INLINE readItr #-} +readItr itr accessor reader + = reader <$> readTVar (accessor itr) -readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b -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 +readItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → b) → STM (f b) +{-# INLINE readItrF #-} +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 - = do old <- readItr itr accessor id +updateItr ∷ Interaction → (Interaction → TVar a) → (a → a) → STM () +{-# INLINE updateItr #-} +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 - = updateItr itr accessor (fmap updator) -{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-} \ No newline at end of file +updateItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → a) → STM () +{-# INLINE updateItrF #-} +updateItrF itr accessor + = updateItr itr accessor ∘ fmap -- 2.40.0