Authorization / DefaultPage

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs
index 6472fb4e6ce6f5668a35382dc20d13defbb32a82..64183ff1c86ef1317efd3352d94ff051fa6cd429 100644 (file)
--- 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 638d1b05bafc472f364cfb7626930f6f00a86423..19faec28fe7a1fb506f42d5416123f17ec52a61d 100644 (file)
--- 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