From: PHO Date: Mon, 17 Oct 2011 14:01:16 +0000 (+0900) Subject: Fixed many bugs... X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=72a3e24;p=Lucu.git Fixed many bugs... Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 4e237c4..eeb1c6b 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -16,7 +16,7 @@ module Network.HTTP.Lucu.Abortion , abortPage ) where -import Control.Arrow +import Control.Arrow.ArrowIO import Control.Arrow.ListArrow import Control.Arrow.Unicode import Control.Concurrent.STM @@ -38,9 +38,9 @@ import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.XmlState data Abortion = Abortion { - aboStatus :: !StatusCode - , aboHeaders :: !Headers - , aboMessage :: !(Maybe Text) + aboStatus ∷ !StatusCode + , aboHeaders ∷ !Headers + , aboMessage ∷ !(Maybe Text) } deriving (Eq, Show, Typeable) instance Exception Abortion @@ -69,36 +69,36 @@ instance Exception Abortion -- > abort MovedPermanently -- > [("Location", "http://example.net/")] -- > (Just "It has been moved to example.net") -abort :: MonadIO m ⇒ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → m a +abort ∷ MonadIO m ⇒ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → m a {-# INLINE abort #-} abort status headers = liftIO ∘ throwIO ∘ Abortion status (toHeaders headers) -- |This is similar to 'abort' but computes it with -- 'System.IO.Unsafe.unsafePerformIO'. -abortPurely :: StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → a +abortPurely ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → a {-# INLINE abortPurely #-} abortPurely status headers = throw ∘ Abortion status (toHeaders headers) -- |Computation of @'abortSTM' status headers msg@ just computes -- 'abort' in a 'Control.Monad.STM.STM' monad. -abortSTM :: StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → STM a +abortSTM ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → STM a {-# INLINE abortSTM #-} abortSTM status headers = throwSTM ∘ Abortion status (toHeaders headers) -- | Computation of @'abortA' -< (status, (headers, msg))@ just -- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'. -abortA :: Arrow (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c +abortA ∷ ArrowIO (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c {-# INLINE abortA #-} abortA = proc (status, (headers, msg)) → - returnA ⤙ abortPurely status headers msg + arrIO throwIO ⤙ Abortion status (toHeaders headers) msg -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な -- ければならない。 -abortPage :: Config → Maybe Request → Response → Abortion → Lazy.Text +abortPage ∷ Config → Maybe Request → Response → Abortion → Lazy.Text abortPage conf reqM res abo = case aboMessage abo of Just msg diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index b530455..785e4c1 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -5,24 +5,21 @@ #-} module Network.HTTP.Lucu.DefaultPage ( getDefaultPage - , writeDefaultPage + , defaultPageContentType , mkDefaultPage ) where -import qualified Blaze.ByteString.Builder.Char.Utf8 as BB import Control.Arrow import Control.Arrow.ArrowList import Control.Arrow.ListArrow import Control.Arrow.Unicode -import Control.Concurrent.STM -import Control.Monad +import Data.Ascii (Ascii) import qualified Data.Ascii as A import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Lazy as Lazy import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.URI hiding (path) @@ -43,13 +40,9 @@ getDefaultPage conf req res in Lazy.pack xmlStr -writeDefaultPage ∷ Interaction → STM () -writeDefaultPage (Interaction {..}) - -- Content-Type が正しくなければ補完できない。 - = do res ← readTVar itrResponse - when (getHeader "Content-Type" res ≡ Just defaultPageContentType) - $ do let page = getDefaultPage itrConfig itrRequest res - putTMVar itrBodyToSend (BB.fromLazyText page) +defaultPageContentType ∷ Ascii +{-# INLINE defaultPageContentType #-} +defaultPageContentType = "application/xhtml+xml" mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree {-# INLINEABLE mkDefaultPage #-} diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index e72022c..06dc8f9 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -23,6 +23,7 @@ import Data.Attoparsec.Char8 as P import qualified Data.ByteString as BS import Data.Map (Map) import qualified Data.Map as M +import qualified Data.Map.Unicode as M import Data.Monoid import Data.Monoid.Unicode import Network.HTTP.Lucu.Parser.Http @@ -42,6 +43,12 @@ class HasHeaders a where = case getHeaders a of Headers m → M.lookup key m + hasHeader ∷ CIAscii → a → Bool + {-# INLINE hasHeader #-} + hasHeader key a + = case getHeaders a of + Headers m → key M.∈ m + getCIHeader ∷ CIAscii → a → Maybe CIAscii {-# INLINE getCIHeader #-} getCIHeader key a diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 3ecc912..4ac7c09 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -9,21 +9,19 @@ module Network.HTTP.Lucu.Interaction , InteractionQueue , newInteractionQueue , newInteraction - , defaultPageContentType , setResponseStatus ) where import Blaze.ByteString.Builder (Builder) import Control.Concurrent.STM -import Data.Ascii (Ascii) import qualified Data.ByteString as BS +import Data.Monoid.Unicode import Data.Sequence (Seq) import qualified Data.Sequence as S import Data.Text (Text) import Network.Socket import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Preprocess import Network.HTTP.Lucu.Request @@ -51,8 +49,8 @@ data Interaction = Interaction { , itrWillChunkBody ∷ !(TVar Bool) , itrWillDiscardBody ∷ !(TVar Bool) , itrWillClose ∷ !(TVar Bool) + , itrResponseHasCType ∷ !(TVar Bool) , itrBodyToSend ∷ !(TMVar Builder) - , itrSentNoBodySoFar ∷ !(TVar Bool) , itrState ∷ !(TVar InteractionState) } @@ -71,9 +69,6 @@ type InteractionQueue = TVar (Seq Interaction) newInteractionQueue ∷ IO InteractionQueue newInteractionQueue = newTVarIO S.empty -defaultPageContentType ∷ Ascii -defaultPageContentType = "application/xhtml+xml" - newInteraction ∷ Config → PortNumber → SockAddr @@ -85,7 +80,7 @@ newInteraction conf@(Config {..}) port addr cert request res = Response { resVersion = HttpVersion 1 1 , resStatus = arInitialStatus ar - , resHeaders = singleton "Content-Type" defaultPageContentType + , resHeaders = (∅) } reqBodyWanted ← newTVarIO 0 @@ -94,14 +89,14 @@ newInteraction conf@(Config {..}) port addr cert request receivedBody ← newTVarIO S.empty receivedBodyLen ← newTVarIO 0 - response ← newTVarIO res - willChunkBody ← newTVarIO False - willDiscardBody ← newTVarIO (arWillDiscardBody ar) - willClose ← newTVarIO (arWillClose ar) - bodyToSend ← newEmptyTMVarIO - sentNoBodySoFar ← newTVarIO True + response ← newTVarIO res + willChunkBody ← newTVarIO False + willDiscardBody ← newTVarIO (arWillDiscardBody ar) + willClose ← newTVarIO (arWillClose ar) + bodyToSend ← newEmptyTMVarIO + responseHasCType ← newTVarIO False - state ← newTVarIO ExaminingRequest + state ← newTVarIO ExaminingRequest return Interaction { itrConfig = conf @@ -124,8 +119,8 @@ newInteraction conf@(Config {..}) port addr cert request , itrWillChunkBody = willChunkBody , itrWillDiscardBody = willDiscardBody , itrWillClose = willClose + , itrResponseHasCType = responseHasCType , itrBodyToSend = bodyToSend - , itrSentNoBodySoFar = sentNoBodySoFar , itrState = state } diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index fdc112c..36cdf0f 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -33,7 +33,10 @@ data MIMEType = MIMEType { mtMajor ∷ !CIAscii , mtMinor ∷ !CIAscii , mtParams ∷ !(Map CIAscii Text) - } deriving (Eq, Show) + } deriving (Eq) + +instance Show MIMEType where + show = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType -- |Construct a 'MIMEType' without any parameters. mkMIMEType ∷ CIAscii → CIAscii → MIMEType diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 2664d79..37a3ad6 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -21,6 +21,7 @@ import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Map as M import Data.Map (Map) import Data.Maybe +import Data.Monoid.Unicode import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding @@ -38,17 +39,25 @@ type ExtMap = Map Text MIMEType -- |Guess the MIME Type of file. guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType guessTypeByFileName extMap fpath - = let ext = T.pack $ takeExtension fpath - in - M.lookup ext extMap + = case takeExtension fpath of + [] → Nothing + (_:ext) → M.lookup (T.pack ext) extMap -- |Read an Apache mime.types and parse it. parseExtMapFile ∷ FilePath → IO ExtMap parseExtMapFile fpath = do file ← B.readFile fpath case LP.parse extMapP file of - LP.Done _ xs → return $ compile xs - LP.Fail _ _ e → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e) + LP.Done _ xs + → case compile xs of + Right m → return m + Left e → fail (concat [ "Duplicate extension \"" + , show e + , "\" in: " + , fpath + ]) + LP.Fail _ _ e + → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e) extMapP ∷ Parser [ (MIMEType, [Text]) ] extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine) @@ -82,11 +91,21 @@ extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine) _ ← char '\x0A' return Nothing -compile ∷ [ (MIMEType, [Text]) ] → Map Text MIMEType -compile = M.fromList ∘ concat ∘ map tr +compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v) +compile = go (∅) ∘ concat ∘ map tr where - tr ∷ (MIMEType, [Text]) → [ (Text, MIMEType) ] - tr (mime, exts) = [ (ext, mime) | ext ← exts ] + tr ∷ (v, [k]) → [(k, v)] + tr (v, ks) = [(k, v) | k ← ks] + + go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v) + go m [] = Right m + go m ((k, v):xs) + = case M.insertLookupWithKey' f k v m of + (Nothing, m') → go m' xs + (Just v0, _ ) → Left (k, v0, v) + + f ∷ k → v → v → v + f _ _ = id -- |@'serializeExtMap' extMap moduleName variableName@ generates a -- Haskell source code which contains the following things: diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 732c47a..39b6b4c 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -9,11 +9,12 @@ module Network.HTTP.Lucu.Postprocess , completeUnconditionalHeaders ) where +import qualified Blaze.ByteString.Builder.Char.Utf8 as BB import Control.Applicative import Control.Concurrent.STM import Control.Monad import Control.Monad.Unicode -import Data.Ascii (Ascii, CIAscii) +import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import qualified Data.Ascii as A import Data.Monoid.Unicode import Data.Time @@ -21,6 +22,7 @@ import qualified Data.Time.HTTP as HTTP import GHC.Conc (unsafeIOToSTM) import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction @@ -28,137 +30,119 @@ import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Prelude.Unicode -{- - TODO: Tanslate this memo into English. It doesn't make sense to - non-Japanese speakers. - - * Response が未設定なら、200 OK にする。 - - * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。 - - * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。 - - * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に - する。 - - * Content-Length があれば、それを削除する。Transfer-Encoding があって - も削除する。 - - * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を - chunked に設定する。 - - * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。 - 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除 - する。 - - * body を持つ事が出來ない時、body 破棄フラグを立てる。 - - * Connection: close が設定されてゐる時、切斷フラグを立てる。 - - * 切斷フラグが立ってゐる時、Connection: close を設定する。 - - * Server が無ければ設定。 - - * Date が無ければ設定。 - --} - postprocess ∷ Interaction → STM () -postprocess (Interaction {..}) - = do res ← readTVar itrResponse - let sc = resStatus res - - unless (any (\ p → p sc) [isSuccessful, isRedirection, isError]) - $ abortSTM InternalServerError [] - $ Just - $ 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 - $ 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 - $ A.fromAsciiBuilder - $ A.toAsciiBuilder "The status code was " - ⊕ printStatusCode sc - ⊕ A.toAsciiBuilder " but no Location header." +postprocess itr@(Interaction {..}) + = do abortOnCertainConditions itr + writeDefaultPageIfNeeded itr case itrRequest of - Just req → postprocessWithRequest sc req + Just req → postprocessWithRequest itr req Nothing → return () - -- itrResponse の内容は relyOnRequest によって變へられてゐる可 - -- 能性が高い。 - do oldRes ← readTVar itrResponse - newRes ← unsafeIOToSTM - $ completeUnconditionalHeaders itrConfig oldRes - writeTVar itrResponse newRes + updateResIO itr $ completeUnconditionalHeaders itrConfig + +abortOnCertainConditions ∷ Interaction → STM () +abortOnCertainConditions (Interaction {..}) + = readTVar itrResponse ≫= go where - postprocessWithRequest ∷ StatusCode → Request → STM () - postprocessWithRequest sc (Request {..}) - = do let canHaveBody = if reqMethod ≡ HEAD then - False - else - (¬) (isInformational sc ∨ - sc ≡ NoContent ∨ - sc ≡ ResetContent ∨ - sc ≡ NotModified ) - - updateRes $ deleteHeader "Content-Length" - updateRes $ deleteHeader "Transfer-Encoding" - - cType ← readHeader "Content-Type" - when (cType ≡ Nothing) - $ updateRes $ setHeader "Content-Type" defaultPageContentType - - if canHaveBody then - when (reqVersion ≡ HttpVersion 1 1) - $ do updateRes $ setHeader "Transfer-Encoding" "chunked" - writeTVar itrWillChunkBody True - else - -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す - when (reqMethod ≢ HEAD) - $ do updateRes $ deleteHeader "Content-Type" - updateRes $ deleteHeader "Etag" - updateRes $ deleteHeader "Last-Modified" - - conn ← readCIHeader "Connection" - case conn of - Nothing → return () - Just value → when (value ≡ "close") - $ writeTVar itrWillClose True - - willClose ← readTVar itrWillClose - when willClose - $ updateRes $ setHeader "Connection" "close" - - when (reqMethod ≡ HEAD ∨ not canHaveBody) - $ writeTVar itrWillDiscardBody True - - readHeader ∷ CIAscii → STM (Maybe Ascii) - {-# INLINE readHeader #-} - 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 - = do old ← readTVar itrResponse - writeTVar itrResponse (f old) + go ∷ Response → STM () + go res@(Response {..}) + = do unless (any (\ p → p resStatus) [ isSuccessful + , isRedirection + , isError + ]) + $ abort' + $ A.toAsciiBuilder "Inappropriate status code for a response: " + ⊕ printStatusCode resStatus + + when ( resStatus ≡ MethodNotAllowed ∧ + hasHeader "Allow" res ) + $ abort' + $ A.toAsciiBuilder "The status was " + ⊕ printStatusCode resStatus + ⊕ A.toAsciiBuilder " but no \"Allow\" header." + + when ( resStatus ≢ NotModified ∧ + isRedirection resStatus ∧ + hasHeader "Location" res ) + $ abort' + $ A.toAsciiBuilder "The status code was " + ⊕ printStatusCode resStatus + ⊕ A.toAsciiBuilder " but no Location header." + + abort' ∷ AsciiBuilder → STM () + abort' = abortSTM InternalServerError [] + ∘ Just + ∘ A.toText + ∘ A.fromAsciiBuilder + +postprocessWithRequest ∷ Interaction → Request → STM () +postprocessWithRequest itr@(Interaction {..}) (Request {..}) + = do willDiscardBody ← readTVar itrWillDiscardBody + canHaveBody ← if willDiscardBody then + return False + else + resCanHaveBody <$> readTVar itrResponse + + updateRes itr + $ deleteHeader "Content-Length" + ∘ deleteHeader "Transfer-Encoding" + + if canHaveBody then + do when (reqVersion ≡ HttpVersion 1 1) + $ do writeHeader itr "Transfer-Encoding" (Just "chunked") + writeTVar itrWillChunkBody True + writeDefaultPageIfNeeded itr + else + do writeTVar itrWillDiscardBody True + -- These headers make sense for HEAD requests even + -- when there won't be a response entity body. + when (reqMethod ≢ HEAD) + $ updateRes itr + $ deleteHeader "Content-Type" + ∘ deleteHeader "Etag" + ∘ deleteHeader "Last-Modified" + + hasConnClose ← (≡ Just "close") <$> readCIHeader itr "Connection" + willClose ← readTVar itrWillClose + when (hasConnClose ∧ (¬) willClose) + $ writeTVar itrWillClose True + when ((¬) hasConnClose ∧ willClose) + $ writeHeader itr "Connection" (Just "close") + +writeDefaultPageIfNeeded ∷ Interaction → STM () +writeDefaultPageIfNeeded itr@(Interaction {..}) + = do resHasCType ← readTVar itrResponseHasCType + unless resHasCType + $ do writeHeader itr "Content-Type" (Just defaultPageContentType) + res ← readTVar itrResponse + let page = getDefaultPage itrConfig itrRequest res + putTMVar itrBodyToSend (BB.fromLazyText page) + +writeHeader ∷ Interaction → CIAscii → Maybe Ascii → STM () +{-# INLINE writeHeader #-} +writeHeader itr k v + = case v of + Just v' → updateRes itr $ setHeader k v' + Nothing → updateRes itr $ deleteHeader k + +readCIHeader ∷ Interaction → CIAscii → STM (Maybe CIAscii) +{-# INLINE readCIHeader #-} +readCIHeader (Interaction {..}) k + = getCIHeader k <$> readTVar itrResponse + +updateRes ∷ Interaction → (Response → Response) → STM () +{-# INLINE updateRes #-} +updateRes (Interaction {..}) f + = do old ← readTVar itrResponse + writeTVar itrResponse (f old) + +updateResIO ∷ Interaction → (Response → IO Response) → STM () +{-# INLINE updateResIO #-} +updateResIO (Interaction {..}) f + = do old ← readTVar itrResponse + new ← unsafeIOToSTM $ f old + writeTVar itrResponse new completeUnconditionalHeaders ∷ Config → Response → IO Response completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 99c4beb..739dec8 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -216,7 +216,7 @@ examineBodyLength ∷ State AugmentedRequest () examineBodyLength = do req ← gets (fromJust ∘ arRequest) len ← gets arReqBodyLength - if reqHasBody req then + if reqMustHaveBody req then -- POST and PUT requests must have an entity body. when (isNothing len) $ setStatus LengthRequired diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index d23dc63..66511e2 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -9,7 +9,7 @@ module Network.HTTP.Lucu.Request ( Method(..) , Request(..) - , reqHasBody + , reqMustHaveBody , requestP ) where @@ -48,13 +48,18 @@ data Request deriving (Eq, Show) instance HasHeaders Request where + {-# INLINE getHeaders #-} getHeaders = reqHeaders + {-# INLINE setHeaders #-} setHeaders req hdr = req { reqHeaders = hdr } -- |Returns 'True' iff the 'Request' must have an entity body. -reqHasBody ∷ Request → Bool -reqHasBody (reqMethod → m) - = m ≡ POST ∨ m ≡ PUT +reqMustHaveBody ∷ Request → Bool +{-# INLINEABLE reqMustHaveBody #-} +reqMustHaveBody (reqMethod → m) + | m ≡ POST = True + | m ≡ PUT = True + | otherwise = False requestP ∷ Parser Request requestP = do skipMany crlf diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 49317a9..554fa39 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -20,7 +20,6 @@ import Data.Sequence.Unicode import Data.Text (Text) import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Chunk -import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.HandleLike import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Postprocess @@ -85,7 +84,6 @@ acceptNonparsableRequest ctx@(Context {..}) sc = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc) atomically $ do writeTVar (itrState itr) Done - writeDefaultPage itr postprocess itr enqueue ctx itr @@ -111,7 +109,6 @@ acceptSemanticallyInvalidRequest ∷ HandleLike h → STM (IO ()) acceptSemanticallyInvalidRequest ctx itr input = do writeTVar (itrState itr) Done - writeDefaultPage itr postprocess itr enqueue ctx itr return $ acceptRequest ctx input @@ -139,7 +136,6 @@ acceptRequestForNonexistentResource ctx itr input = do atomically $ do setResponseStatus itr NotFound writeTVar (itrState itr) Done - writeDefaultPage itr postprocess itr enqueue ctx itr acceptRequest ctx input @@ -155,7 +151,7 @@ acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef = do let itr = oldItr { itrResourcePath = Just rsrcPath } atomically $ enqueue ctx itr do _ ← runResource rsrcDef itr - if reqHasBody $ fromJust $ itrRequest itr then + if reqMustHaveBody $ fromJust $ itrRequest itr then observeRequest ctx itr input else acceptRequest ctx input @@ -273,7 +269,6 @@ chunkWasMalformed itr do setResponseStatus itr BadRequest writeTVar (itrWillClose itr) True writeTVar (itrState itr) Done - writeDefaultPage itr postprocess itr observeNonChunkedRequest ∷ HandleLike h diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index c754213..d0454c4 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -137,7 +137,6 @@ module Network.HTTP.Lucu.Resource , driftTo -- private ) where -import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder.ByteString as BB import Control.Applicative import Control.Concurrent.STM @@ -154,7 +153,6 @@ import Data.Foldable (toList) import Data.List import qualified Data.Map as M import Data.Maybe -import Data.Monoid import Data.Monoid.Unicode import Data.Sequence (Seq) import Data.Text (Text) @@ -166,7 +164,6 @@ import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Authorization import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.ContentCoding -import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H import Network.HTTP.Lucu.HttpVersion @@ -607,7 +604,7 @@ input ∷ Int → Resource Lazy.ByteString input limit = do driftTo GettingBody itr ← getInteraction - chunk ← if reqHasBody $ fromJust $ itrRequest itr then + chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then askForInput itr else do driftTo DecidingHeader @@ -675,7 +672,7 @@ inputChunk ∷ Int → Resource Lazy.ByteString inputChunk limit = do driftTo GettingBody itr ← getInteraction - chunk ← if reqHasBody $ fromJust $ itrRequest itr then + chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then askForInput itr else do driftTo DecidingHeader @@ -815,6 +812,8 @@ setHeader' name value $ do res ← readTVar $ itrResponse itr let res' = H.setHeader name value res writeTVar (itrResponse itr) res' + when (name ≡ "Content-Type") + $ writeTVar (itrResponseHasCType itr) True -- | Computation of @'redirect' code uri@ sets the response status to -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy @@ -834,8 +833,8 @@ redirect code uri -- | Computation of @'setContentType' mType@ sets the response header -- \"Content-Type\" to @mType@. setContentType ∷ MIMEType → Resource () -setContentType - = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType +{-# INLINE setContentType #-} +setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType -- | Computation of @'setLocation' uri@ sets the response header -- \"Location\" to @uri@. @@ -875,6 +874,9 @@ setWWWAuthenticate challenge -- | 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. +-- +-- Note that you must first set the \"Content-Type\" response header +-- before applying this function. See: 'setContentType' output ∷ Lazy.ByteString → Resource () {-# INLINE output #-} output str = outputChunk str *> driftTo Done @@ -882,33 +884,19 @@ output str = outputChunk str *> driftTo Done -- | 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. +-- +-- Note that you must first set the \"Content-Type\" response header +-- before applying this function. See: 'setContentType' outputChunk ∷ Lazy.ByteString → Resource () outputChunk str = do driftTo DecidingBody itr ← getInteraction liftIO $ atomically - $ do putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str) - unless (Lazy.null str) - $ writeTVar (itrSentNoBodySoFar itr) False - -{- - - [GettingBody からそれ以降の状態に遷移する時] - - body を讀み終へてゐなければ、殘りの body を讀み捨てる。 - - - [DecidingHeader からそれ以降の状態に遷移する時] - - postprocess する。 - - - [Done に遷移する時] - - bodyIsNull が False ならば何もしない。True だった場合は出力補完す - る。 - --} + $ do hasCType ← readTVar $ itrResponseHasCType itr + unless hasCType + $ abortSTM InternalServerError [] + $ Just "outputChunk: Content-Type has not been set." + putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str) driftTo ∷ InteractionState → Resource () driftTo newState @@ -926,7 +914,7 @@ driftTo newState where throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a throwStateError Done DecidingBody - = fail "It makes no sense to output something after finishing to output." + = fail "It makes no sense to output something after finishing outputs." throwStateError old new = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new) @@ -935,9 +923,5 @@ driftTo newState = writeTVar itrReqBodyWasteAll True drift itr DecidingHeader _ = postprocess itr - drift itr@(Interaction {..}) _ Done - = do bodyIsNull ← readTVar itrSentNoBodySoFar - when bodyIsNull - $ writeDefaultPage itr drift _ _ _ = return () diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 11d5b2b..7f816e8 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -19,33 +19,34 @@ module Network.HTTP.Lucu.Resource.Tree , runResource ) where -import Control.Arrow +import Control.Arrow import Control.Applicative import Data.Ascii (Ascii) 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.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as LT -import Data.List +import Data.List import qualified Data.Map as M -import Data.Map (Map) -import Data.Maybe +import Data.Map (Map) +import Data.Maybe import Data.Monoid.Unicode -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Headers (fromHeaders) -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Resource -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Utils -import Network.URI hiding (path) -import System.IO -import Prelude hiding (catch) +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.Headers (fromHeaders) +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Resource +import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Utils +import Network.URI hiding (path) +import System.IO +import Prelude hiding (catch) import Prelude.Unicode @@ -292,10 +293,10 @@ runResource (ResourceDef {..}) itr@(Interaction {..}) if state ≤ DecidingHeader then flip runRes itr $ do setStatus $ aboStatus abo + setHeader "Content-Type" defaultPageContentType mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo else - do when (cnfDumpTooLateAbortionToStderr itrConfig) - $ hPutStrLn stderr $ show abo - atomically $ writeTVar itrWillClose True + when (cnfDumpTooLateAbortionToStderr itrConfig) + $ hPutStrLn stderr $ show abo runRes (driftTo Done) itr diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index a593b3a..547947b 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -10,15 +10,19 @@ -- |Definition of things related on HTTP response. module Network.HTTP.Lucu.Response ( StatusCode(..) - , Response(..) , printStatusCode + + , Response(..) + , resCanHaveBody , printResponse + , isInformational , isSuccessful , isRedirection , isError , isClientError , isServerError + , statusCode ) where @@ -89,6 +93,7 @@ data StatusCode = Continue -- |Convert a 'StatusCode' to 'AsciiBuilder'. printStatusCode ∷ StatusCode → AsciiBuilder +{-# INLINEABLE printStatusCode #-} printStatusCode (statusCode → (# num, msg #)) = ( show3 num ⊕ A.toAsciiBuilder " " ⊕ @@ -102,11 +107,25 @@ data Response = Response { } deriving (Show, Eq) instance HasHeaders Response where + {-# INLINE getHeaders #-} getHeaders = resHeaders + {-# INLINE setHeaders #-} setHeaders res hdr = res { resHeaders = hdr } +-- |Returns 'True' iff a given 'Response' allows the existence of +-- response entity body. +resCanHaveBody ∷ Response → Bool +{-# INLINEABLE resCanHaveBody #-} +resCanHaveBody (Response {..}) + | isInformational resStatus = False + | resStatus ≡ NoContent = False + | resStatus ≡ ResetContent = False + | resStatus ≡ NotModified = False + | otherwise = True + -- |Convert a 'Response' to 'AsciiBuilder'. printResponse ∷ Response → AsciiBuilder +{-# INLINEABLE printResponse #-} printResponse (Response {..}) = printHttpVersion resVersion ⊕ A.toAsciiBuilder " " ⊕ @@ -114,37 +133,44 @@ printResponse (Response {..}) A.toAsciiBuilder "\x0D\x0A" ⊕ printHeaders resHeaders --- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@. +-- |@'isInformational' sc@ returns 'True' iff @sc < 200@. isInformational ∷ StatusCode → Bool -isInformational = doesMeet (< 200) +{-# INLINE isInformational #-} +isInformational = satisfy (< 200) --- |@'isSuccessful' sc@ is 'Prelude.True' iff @200 <= sc < 300@. +-- |@'isSuccessful' sc@ returns 'True' iff @200 <= sc < 300@. isSuccessful ∷ StatusCode → Bool -isSuccessful = doesMeet (\ n → n ≥ 200 ∧ n < 300) +{-# INLINE isSuccessful #-} +isSuccessful = satisfy (\ n → n ≥ 200 ∧ n < 300) --- |@'isRedirection' sc@ is 'Prelude.True' iff @300 <= sc < 400@. +-- |@'isRedirection' sc@ returns 'True' iff @300 <= sc < 400@. isRedirection ∷ StatusCode → Bool -isRedirection = doesMeet (\ n → n ≥ 300 ∧ n < 400) +{-# INLINE isRedirection #-} +isRedirection = satisfy (\ n → n ≥ 300 ∧ n < 400) --- |@'isError' sc@ is 'Prelude.True' iff @400 <= sc@ +-- |@'isError' sc@ returns 'True' iff @400 <= sc@ isError ∷ StatusCode → Bool -isError = doesMeet (≥ 400) +{-# INLINE isError #-} +isError = satisfy (≥ 400) --- |@'isClientError' sc@ is 'Prelude.True' iff @400 <= sc < 500@. +-- |@'isClientError' sc@ returns 'True' iff @400 <= sc < 500@. isClientError ∷ StatusCode → Bool -isClientError = doesMeet (\ n → n ≥ 400 ∧ n < 500) +{-# INLINE isClientError #-} +isClientError = satisfy (\ n → n ≥ 400 ∧ n < 500) --- |@'isServerError' sc@ is 'Prelude.True' iff @500 <= sc@. +-- |@'isServerError' sc@ returns 'True' iff @500 <= sc@. isServerError ∷ StatusCode → Bool -isServerError = doesMeet (≥ 500) +{-# INLINE isServerError #-} +isServerError = satisfy (≥ 500) -doesMeet ∷ (Int → Bool) → StatusCode → Bool -{-# INLINE doesMeet #-} -doesMeet p (statusCode → (# num, _ #)) = p num +satisfy ∷ (Int → Bool) → StatusCode → Bool +{-# INLINE satisfy #-} +satisfy p (statusCode → (# num, _ #)) = p num -- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual -- representation of @sc@. statusCode ∷ StatusCode → (# Int, Ascii #) +{-# INLINEABLE statusCode #-} statusCode Continue = (# 100, "Continue" #) statusCode SwitchingProtocols = (# 101, "Switching Protocols" #) diff --git a/data/mime.types b/data/mime.types index f65dd32..7b7601b 100644 --- a/data/mime.types +++ b/data/mime.types @@ -75,7 +75,6 @@ audio/mp4a-latm m4a m4p audio/mpeg mpga mp2 mp3 audio/x-ac3 ac3 audio/x-aiff aif aiff aifc -audio/x-au au snd audio/x-ircam sf audio/x-flac flac audio/x-mod 669 amf dsm gdm far imf it med mod mtm okt sam s3m stm stx ult xm @@ -133,11 +132,13 @@ text/richtext rtx text/rtf rtf text/sgml sgml sgm text/tab-separated-values tsv -text/uri-list ram +text/uri-list uni unis uri uris text/vnd.wap.wml wml text/vnd.wap.wmlscript wmls +text/x-c c h +text/x-c++ cc cpp cxx hpp hxx text/x-cabal cabal -text/x-haskell hs +text/x-haskell hs hsc lhs text/x-setext etx video/mp4 mp4 video/mpeg mpeg mpg mpe diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index 7515347..ec5b542 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -39,4 +39,4 @@ helloWorld str3 ← inputChunk 3 setContentType $ parseMIMEType "text/hello" output ("[" ⊕ str1 ⊕ " - " ⊕ str2 ⊕ "#" ⊕ str3 ⊕ "]") - } \ No newline at end of file + }