From: PHO Date: Sun, 4 Sep 2011 12:19:53 +0000 (+0900) Subject: Merge branch 'master' into attoparsec X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=e34910f85f459f049b9e6e6b79db9ef95dfccc13;hp=3177a876bea6b8a2c34f51cc96c98c2cbb1e4aa9 Merge branch 'master' into attoparsec Conflicts: Network/HTTP/Lucu/Utils.hs --- diff --git a/.gitignore b/.gitignore index 0b4ee08..00bc286 100644 --- a/.gitignore +++ b/.gitignore @@ -8,6 +8,10 @@ Setup dist report.html +Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs + +data/CompileMimeTypes + examples/HelloWorld examples/Implanted examples/ImplantedSmall diff --git a/GNUmakefile b/GNUmakefile index 8b9ab31..3b5520e 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -4,14 +4,5 @@ CONFIGURE_ARGS = -O include cabal-package.mk -update-web: update-web-doc update-web-ditz - -update-web-doc: doc - rsync -av --delete \ - dist/doc/html/Lucu/ \ - www@nem.cielonegro.org:static.cielonegro.org/htdocs/doc/Lucu - -update-web-ditz: ditz - rsync -av --delete \ - dist/ditz/ \ - www@nem.cielonegro.org:static.cielonegro.org/htdocs/ditz/Lucu +build-hook: + $(MAKE) -C data diff --git a/Lucu.cabal b/Lucu.cabal index f9c03c7..0200e77 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -24,6 +24,7 @@ Extra-Source-Files: ImplantFile.hs NEWS data/CompileMimeTypes.hs + data/Makefile data/mime.types examples/HelloWorld.hs examples/Implanted.hs @@ -44,23 +45,29 @@ Flag build-lucu-implant-file Library Build-Depends: - HsOpenSSL == 0.10.*, - base == 4.3.*, - base-unicode-symbols == 0.2.*, - base64-bytestring == 0.1.*, - bytestring == 0.9.*, - containers == 0.4.*, - filepath == 1.2.*, - directory == 1.1.*, - haskell-src == 1.0.*, - hxt == 9.1.*, - mtl == 2.0.*, - network == 2.3.*, - stm == 2.2.*, - time == 1.2.*, - time-http == 0.1.*, - unix == 2.4.*, - zlib == 0.5.* + HsOpenSSL == 0.10.*, + ascii == 0.0.*, + attoparsec == 0.9.*, + base == 4.3.*, + base-unicode-symbols == 0.2.*, + base64-bytestring == 0.1.*, + blaze-builder == 0.3.*, + bytestring == 0.9.*, + containers == 0.4.*, + containers-unicode-symbols == 0.3.*, + filepath == 1.2.*, + directory == 1.1.*, + haskell-src == 1.0.*, + hxt == 9.1.*, + mtl == 2.0.*, + network == 2.3.*, + stm == 2.2.*, + text == 0.11.*, + text-icu == 0.6.*, + time == 1.2.*, + time-http == 0.1.*, + unix == 2.4.*, + zlib == 0.5.* Exposed-Modules: Network.HTTP.Lucu @@ -73,8 +80,8 @@ Library Network.HTTP.Lucu.MIMEType Network.HTTP.Lucu.MIMEType.DefaultExtensionMap Network.HTTP.Lucu.MIMEType.Guess - Network.HTTP.Lucu.Parser Network.HTTP.Lucu.Parser.Http + Network.HTTP.Lucu.RFC2231 Network.HTTP.Lucu.Request Network.HTTP.Lucu.Resource Network.HTTP.Lucu.Resource.Tree diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 26ea8b0..9ef433b 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -1,5 +1,8 @@ {-# LANGUAGE - DeriveDataTypeable + Arrows + , BangPatterns + , DeriveDataTypeable + , TypeOperators , UnicodeSyntax #-} {-# OPTIONS_HADDOCK prune #-} @@ -15,31 +18,31 @@ module Network.HTTP.Lucu.Abortion , abortPage ) where - -import Control.Arrow -import Control.Arrow.ArrowIO -import Control.Concurrent.STM -import Control.Exception -import Control.Monad.Trans -import qualified Data.ByteString.Char8 as C8 -import Data.Typeable -import GHC.Conc (unsafeIOToSTM) -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.DefaultPage -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import System.IO.Unsafe -import Text.XML.HXT.Arrow.WriteDocument -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlState - +import Control.Arrow +import Control.Arrow.ListArrow +import Control.Arrow.Unicode +import Control.Concurrent.STM +import Control.Exception +import Control.Monad.Trans +import Data.Ascii (Ascii, CIAscii) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Prelude.Unicode +import Text.XML.HXT.Arrow.WriteDocument +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlState data Abortion = Abortion { aboStatus :: !StatusCode , aboHeaders :: !Headers - , aboMessage :: !(Maybe String) - } deriving (Show, Typeable) + , aboMessage :: !(Maybe Text) + } deriving (Eq, Show, Typeable) instance Exception Abortion @@ -67,51 +70,48 @@ instance Exception Abortion -- > abort MovedPermanently -- > [("Location", "http://example.net/")] -- > (Just "It has been moved to example.net") -abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a -abort status headers msg - = status `seq` headers `seq` msg `seq` - let abo = Abortion status (toHeaders $ map pack headers) msg - in - liftIO $ throwIO abo - where - pack (x, y) = (C8.pack x, C8.pack y) +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 -> [ (String, String) ] -> Maybe String -> a -abortPurely = ((unsafePerformIO .) .) . abort +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 -> [ (String, String) ] -> Maybe String -> STM a -abortSTM status headers msg - = status `seq` headers `seq` msg `seq` - unsafeIOToSTM $! abort status headers msg +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 :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c -abortA - = arrIO3 abort +abortA :: Arrow (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c +{-# INLINE abortA #-} +abortA = proc (status, (headers, msg)) → + returnA ⤙ abortPurely status headers msg -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な -- ければならない。 -abortPage :: Config -> Maybe Request -> Response -> Abortion -> String -abortPage conf reqM res abo - = conf `seq` reqM `seq` res `seq` abo `seq` - case aboMessage abo of +abortPage :: Config → Maybe Request → Response → Abortion → Text +abortPage !conf !reqM !res !abo + = case aboMessage abo of Just msg - -> let [html] = unsafePerformIO - $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg) - >>> - writeDocumentToString [ withIndent True ] - ) - in - html + → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg) + ⋙ + writeDocumentToString [ withIndent True ] + ) () + in + T.pack html Nothing - -> let res' = res { resStatus = aboStatus abo } - res'' = foldl (.) id [setHeader name value - | (name, value) <- fromHeaders $ aboHeaders abo] res' + → let res' = res { resStatus = aboStatus abo } + res'' = foldl (∘) id [setHeader name value + | (name, value) ← fromHeaders $ aboHeaders abo] res' in getDefaultPage conf reqM res'' diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs index 6b0e1c2..11de199 100644 --- a/Network/HTTP/Lucu/Authorization.hs +++ b/Network/HTTP/Lucu/Authorization.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - UnicodeSyntax + OverloadedStrings + , UnicodeSyntax #-} {-# OPTIONS_HADDOCK prune #-} @@ -11,12 +12,16 @@ module Network.HTTP.Lucu.Authorization , UserID , Password + , printAuthChallenge , authCredentialP -- private ) where +import Data.Ascii (Ascii) +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 Network.HTTP.Lucu.Parser +import Data.Monoid.Unicode import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils import Prelude.Unicode @@ -29,7 +34,7 @@ data AuthChallenge deriving (Eq) -- |'Realm' is just a string which must not contain any non-ASCII letters. -type Realm = String +type Realm = Ascii -- |Authorization credential to be sent by client with -- \"Authorization\" header. See @@ -40,32 +45,36 @@ data AuthCredential -- |'UserID' is just a string which must not contain colon and any -- non-ASCII letters. -type UserID = String +type UserID = Ascii -- |'Password' is just a string which must not contain any non-ASCII -- letters. -type Password = String +type Password = Ascii -instance Show AuthChallenge where - show (BasicAuthChallenge realm) - = "Basic realm=" ⧺ quoteStr realm +-- |Convert an 'AuthChallenge' to 'Ascii'. +printAuthChallenge ∷ AuthChallenge → Ascii +printAuthChallenge (BasicAuthChallenge realm) + = A.fromAsciiBuilder $ + A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm authCredentialP ∷ Parser AuthCredential authCredentialP - = allowEOF $! - do _ ← string "Basic" - _ ← many1 lws - b64 ← many1 - $ satisfy (\c → (c ≥ 'a' ∧ c ≤ 'z') ∨ - (c ≥ 'A' ∧ c ≤ 'Z') ∨ - (c ≥ '0' ∧ c ≤ '9') ∨ - c ≡ '+' ∨ - c ≡ '/' ∨ - c ≡ '=') - case break (≡ ':') (decode b64) of - (uid, ':' : password) - → return (BasicAuthCredential uid password) - _ → failP + = do _ ← string "Basic" + skipMany1 lws + b64 ← takeWhile1 base64 + case C8.break (≡ ':') (B64.decodeLenient b64) of + (user, cPassword) + | C8.null cPassword + → fail "no colons in the basic auth credential" + | otherwise + → do u ← asc user + p ← asc (C8.tail cPassword) + return (BasicAuthCredential u p) where - decode ∷ String → String - decode = C8.unpack ∘ B64.decodeLenient ∘ C8.pack + 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/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs index 27deb74..a419464 100644 --- a/Network/HTTP/Lucu/Chunk.hs +++ b/Network/HTTP/Lucu/Chunk.hs @@ -1,38 +1,35 @@ +{-# LANGUAGE + UnicodeSyntax + #-} module Network.HTTP.Lucu.Chunk ( chunkHeaderP -- Num a => Parser a , chunkFooterP -- Parser () , chunkTrailerP -- Parser Headers ) where - -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Numeric - - -chunkHeaderP :: Num a => Parser a -chunkHeaderP = do hexLen <- many1 hexDigit - _ <- extension - _ <- crlf - - let [(len, _)] = readHex hexLen +import Control.Applicative +import Data.Attoparsec.Char8 +import Data.Bits +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Parser.Http + +chunkHeaderP ∷ (Integral a, Bits a) ⇒ Parser a +{-# INLINEABLE chunkHeaderP #-} +chunkHeaderP = do len ← hexadecimal + extension + crlf return len where - extension :: Parser () - extension = many ( char ';' >> - token >> - char '=' >> - ( token <|> quotedStr ) - ) - >> - return () -{-# SPECIALIZE chunkHeaderP :: Parser Int #-} - - -chunkFooterP :: Parser () -chunkFooterP = crlf >> return () - - -chunkTrailerP :: Parser Headers + extension ∷ Parser () + extension = skipMany $ + do _ ← char ';' + _ ← token + _ ← char '=' + _ ← token <|> quotedStr + return () + +chunkFooterP ∷ Parser () +chunkFooterP = crlf + +chunkTrailerP ∷ Parser Headers chunkTrailerP = headersP diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index cb3f4a8..5a241b7 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} -- |Configurations for the Lucu httpd like a port to listen. module Network.HTTP.Lucu.Config ( Config(..) @@ -5,68 +9,68 @@ module Network.HTTP.Lucu.Config , defaultConfig ) where - -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Network -import Network.BSD -import Network.HTTP.Lucu.MIMEType.Guess -import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap -import OpenSSL.Session -import System.IO.Unsafe +import Data.Ascii (Ascii) +import Data.Text (Text) +import qualified Data.Text as T +import Network +import Network.BSD +import Network.HTTP.Lucu.MIMEType.Guess +import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap +import OpenSSL.Session +import System.IO.Unsafe -- |Configuration record for the Lucu httpd. You need to use -- 'defaultConfig' or setup your own configuration to run the httpd. data Config = Config { -- |A string which will be sent to clients as \"Server\" field. - cnfServerSoftware :: !Strict.ByteString + cnfServerSoftware ∷ !Ascii -- |The host name of the server. This value will be used in -- built-in pages like \"404 Not Found\". - , cnfServerHost :: !Strict.ByteString + , cnfServerHost ∷ !Text -- |A port number (or service name) to listen to HTTP clients. - , cnfServerPort :: !ServiceName + , cnfServerPort ∷ !ServiceName -- |Local IPv4 address to listen to both HTTP and HTTPS -- clients. Set this to @('Just' "0.0.0.0")@ if you want to accept -- any IPv4 connections. Set this to 'Nothing' to disable IPv4. - , cnfServerV4Addr :: !(Maybe HostName) + , cnfServerV4Addr ∷ !(Maybe HostName) -- |Local IPv6 address to listen to both HTTP and HTTPS -- clients. Set this to @('Just' "::")@ if you want to accept any -- IPv6 connections. Set this to 'Nothing' to disable IPv6. Note -- that there is currently no way to assign separate ports to IPv4 -- and IPv6 server sockets. - , cnfServerV6Addr :: !(Maybe HostName) + , cnfServerV6Addr ∷ !(Maybe HostName) -- |Configuration for HTTPS connections. Set this 'Nothing' to -- disable HTTPS. - , cnfSSLConfig :: !(Maybe SSLConfig) + , cnfSSLConfig ∷ !(Maybe SSLConfig) -- |The maximum number of requests to accept in one connection -- simultaneously. If a client exceeds this limitation, its last -- request won't be processed until a response for its earliest -- pending request is sent back to the client. - , cnfMaxPipelineDepth :: !Int + , cnfMaxPipelineDepth ∷ !Int -- |The maximum length of request entity to accept in bytes. Note -- that this is nothing but the default value which is used when -- 'Network.HTTP.Lucu.Resource.input' and such like are applied to -- 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no -- guarantee that this value always constrains all the requests. - , cnfMaxEntityLength :: !Int + , cnfMaxEntityLength ∷ !Int -- |The maximum length of chunk to output. This value is used by -- 'Network.HTTP.Lucu.Resource.output' and such like to limit the -- chunk length so you can safely output an infinite string (like -- a lazy stream of \/dev\/random) using those actions. - , cnfMaxOutputChunkLength :: !Int + , cnfMaxOutputChunkLength ∷ !Int -- | Whether to dump too late abortion to the stderr or not. See -- 'Network.HTTP.Lucu.Abortion.abort'. - , cnfDumpTooLateAbortionToStderr :: !Bool + , cnfDumpTooLateAbortionToStderr ∷ !Bool -- |A mapping from extension to MIME Type. This value is used by -- 'Network.HTTP.Lucu.StaticFile.staticFile' to guess the MIME @@ -79,7 +83,7 @@ data Config = Config { -- good idea to use GnomeVFS -- () -- instead of vanilla FS. - , cnfExtToMIMEType :: !ExtMap + , cnfExtToMIMEType ∷ !ExtMap } -- |Configuration record for HTTPS connections. @@ -88,19 +92,19 @@ data SSLConfig -- |A port ID to listen to HTTPS clients. Local addresses -- (both for IPv4 and IPv6) will be derived from the parent -- 'Config'. - sslServerPort :: !ServiceName + sslServerPort ∷ !ServiceName -- |An SSL context for accepting connections. - , sslContext :: !SSLContext + , sslContext ∷ !SSLContext } -- |The default configuration. Generally you can use this value as-is, -- or possibly you just want to replace the 'cnfServerSoftware' and -- 'cnfServerPort'. SSL connections are disabled by default. -defaultConfig :: Config +defaultConfig ∷ Config defaultConfig = Config { - cnfServerSoftware = C8.pack "Lucu/1.0" - , cnfServerHost = C8.pack (unsafePerformIO getHostName) + cnfServerSoftware = "Lucu/1.0" + , cnfServerHost = T.pack (unsafePerformIO getHostName) , cnfServerPort = "http" , cnfServerV4Addr = Just "0.0.0.0" , cnfServerV6Addr = Just "::" diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs index 27a8941..7a0918a 100644 --- a/Network/HTTP/Lucu/ContentCoding.hs +++ b/Network/HTTP/Lucu/ContentCoding.hs @@ -1,48 +1,63 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} module Network.HTTP.Lucu.ContentCoding - ( acceptEncodingListP + ( AcceptEncoding(..) + + , acceptEncodingListP , normalizeCoding , unnormalizeCoding - , orderAcceptEncodings ) where - -import Data.Char -import Data.Ord -import Data.Maybe -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http - - -acceptEncodingListP :: Parser [(String, Maybe Double)] -acceptEncodingListP = allowEOF $! listOf accEncP - - -accEncP :: Parser (String, Maybe Double) -accEncP = do coding <- token - qVal <- option Nothing - $ do _ <- string ";q=" - q <- qvalue - return $ Just q +import Control.Applicative +import Data.Ascii (CIAscii, toCIAscii) +import Data.Attoparsec.Char8 +import Data.Ord +import Data.Maybe +import Network.HTTP.Lucu.Parser.Http +import Prelude.Unicode + +data AcceptEncoding + = AcceptEncoding !CIAscii !(Maybe Double) + deriving (Eq, Show) + +instance Ord AcceptEncoding where + (AcceptEncoding c1 q1) `compare` (AcceptEncoding c2 q2) + | q1' > q1' = GT + | q1' < q2' = LT + | otherwise = compare c1 c2 + where + q1' = fromMaybe 0 q1 + q2' = fromMaybe 0 q2 + +acceptEncodingListP ∷ Parser [(CIAscii, Maybe Double)] +acceptEncodingListP = listOf accEncP + +accEncP ∷ Parser (CIAscii, Maybe Double) +accEncP = do coding ← toCIAscii <$> token + qVal ← option Nothing + $ do _ ← string ";q=" + q ← qvalue + return $ Just q return (normalizeCoding coding, qVal) - -normalizeCoding :: String -> String +normalizeCoding ∷ CIAscii → CIAscii normalizeCoding coding - = case map toLower coding of - "x-gzip" -> "gzip" - "x-compress" -> "compress" - other -> other - - -unnormalizeCoding :: String -> String + = if coding ≡ "x-gzip" then + "gzip" + else + if coding ≡ "x-compress" then + "compress" + else + coding + +unnormalizeCoding ∷ CIAscii → CIAscii unnormalizeCoding coding - = case map toLower coding of - "gzip" -> "x-gzip" - "compress" -> "x-compress" - other -> other - - -orderAcceptEncodings :: (String, Maybe Double) -> (String, Maybe Double) -> Ordering -orderAcceptEncodings (_, q1) (_, q2) - = comparing (fromMaybe 0) q1 q2 - + = if coding ≡ "gzip" then + "x-gzip" + else + if coding ≡ "compress" then + "x-compress" + else + coding diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 12aba15..dbc3835 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns + , OverloadedStrings , UnboxedTuples , UnicodeSyntax #-} @@ -9,77 +10,79 @@ module Network.HTTP.Lucu.DefaultPage , mkDefaultPage ) where - -import Control.Arrow -import Control.Arrow.ArrowList -import Control.Concurrent.STM -import Control.Monad -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy.Char8 as L8 -import Data.Maybe -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Format -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) -import System.IO.Unsafe -import Text.XML.HXT.Arrow.WriteDocument -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlState -import Text.XML.HXT.DOM.TypeDefs - - -getDefaultPage :: Config -> Maybe Request -> Response -> String +import Control.Arrow +import Control.Arrow.ArrowList +import Control.Arrow.ListArrow +import Control.Arrow.Unicode +import Control.Concurrent.STM +import Control.Monad +import qualified Data.Ascii as A +import Data.Maybe +import qualified Data.Sequence as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +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) +import Prelude.Unicode +import Text.XML.HXT.Arrow.WriteDocument +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlState +import Text.XML.HXT.DOM.TypeDefs + +getDefaultPage ∷ Config → Maybe Request → Response → Text +{-# INLINEABLE getDefaultPage #-} getDefaultPage !conf !req !res - = let msgA = getMsg req res + = let msgA = getMsg req res + [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA + ⋙ + writeDocumentToString [ withIndent True ] + ) () in - unsafePerformIO $ - do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA - >>> - writeDocumentToString [ withIndent True ] - ) - return xmlStr - + T.pack xmlStr -writeDefaultPage :: Interaction -> STM () +writeDefaultPage ∷ Interaction → STM () writeDefaultPage !itr -- Content-Type が正しくなければ補完できない。 - = do res <- readItr itr itrResponse id - when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType) - $ do reqM <- readItr itr itrRequest id + = do res ← readItr itr itrResponse id + when (getHeader "Content-Type" res == Just defaultPageContentType) + $ do reqM ← readItr itr itrRequest id let conf = itrConfig itr - page = L8.pack $ getDefaultPage conf reqM res + page = getDefaultPage conf reqM res writeTVar (itrBodyToSend itr) - $ page + (S.singleton (encodeUtf8 page)) - -mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree +mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree +{-# INLINEABLE mkDefaultPage #-} mkDefaultPage !conf !status !msgA - = let (# sCode, sMsg #) = statusCode status - sig = C8.unpack (cnfServerSoftware conf) - ++ " at " - ++ C8.unpack (cnfServerHost conf) + = let sStr = A.toString $ printStatusCode status + sig = concat [ A.toString (cnfServerSoftware conf) + , " at " + , T.unpack (cnfServerHost conf) + ] in ( eelem "/" += ( eelem "html" += sattr "xmlns" "http://www.w3.org/1999/xhtml" += ( eelem "head" += ( eelem "title" - += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg) + += txt sStr )) += ( eelem "body" += ( eelem "h1" - += txt (C8.unpack sMsg) + += txt sStr ) += ( eelem "p" += msgA ) += eelem "hr" += ( eelem "address" += txt sig )))) -{-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-} -getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree +getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree +{-# INLINEABLE getMsg #-} getMsg !req !res = case resStatus res of -- 1xx は body を持たない @@ -87,7 +90,7 @@ getMsg !req !res -- 3xx MovedPermanently - -> txt ("The resource at " ++ path ++ " has been moved to ") + → txt ("The resource at " ⧺ path ⧺ " has been moved to ") <+> eelem "a" += sattr "href" loc += txt loc @@ -95,7 +98,7 @@ getMsg !req !res txt " permanently." Found - -> txt ("The resource at " ++ path ++ " is currently located at ") + → txt ("The resource at " ⧺ path ⧺ " is currently located at ") <+> eelem "a" += sattr "href" loc += txt loc @@ -103,7 +106,7 @@ getMsg !req !res txt ". This is not a permanent relocation." SeeOther - -> txt ("The resource at " ++ path ++ " can be found at ") + → txt ("The resource at " ⧺ path ⧺ " can be found at ") <+> eelem "a" += sattr "href" loc += txt loc @@ -111,7 +114,7 @@ getMsg !req !res txt "." TemporaryRedirect - -> txt ("The resource at " ++ path ++ " is temporarily located at ") + → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ") <+> eelem "a" += sattr "href" loc += txt loc @@ -120,43 +123,40 @@ getMsg !req !res -- 4xx BadRequest - -> txt "The server could not understand the request you sent." + → txt "The server could not understand the request you sent." Unauthorized - -> txt ("You need a valid authentication to access " ++ path) + → txt ("You need a valid authentication to access " ⧺ path) Forbidden - -> txt ("You don't have permission to access " ++ path) + → txt ("You don't have permission to access " ⧺ path) NotFound - -> txt ("The requested URL " ++ path ++ " was not found on this server.") + → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.") Gone - -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.") + → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.") RequestEntityTooLarge - -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.") + → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.") RequestURITooLarge - -> txt "The request URI you sent was too big to accept." + → txt "The request URI you sent was too large to accept." -- 5xx InternalServerError - -> txt ("An internal server error has occured during the process of your request to " ++ path) + → txt ("An internal server error has occured during the process of your request to " ⧺ path) ServiceUnavailable - -> txt "The service is temporarily unavailable. Try later." + → txt "The service is temporarily unavailable. Try later." - _ -> none + _ → none - where - path :: String - path = let uri = reqURI $! fromJust req + path ∷ String + path = let uri = reqURI $ fromJust req in uriPath uri - loc :: String - loc = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res - -{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-} \ No newline at end of file + loc ∷ String + loc = A.toString $ fromJust $ getHeader "Location" res diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index d607ad1..acc496f 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -1,58 +1,69 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} {-# OPTIONS_HADDOCK prune #-} -- |Manipulation of entity tags. module Network.HTTP.Lucu.ETag ( ETag(..) + + , printETag + , strongETag , weakETag , eTagP , eTagListP ) where - -import Control.Monad -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http hiding (token) -import Network.HTTP.Lucu.Utils +import Control.Monad +import Control.Monad.Unicode +import Data.Ascii (Ascii) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 +import Data.Monoid.Unicode +import Network.HTTP.Lucu.Parser.Http hiding (token) +import Network.HTTP.Lucu.Utils -- |An entity tag is made of a weakness flag and a opaque string. data ETag = ETag { -- |The weakness flag. Weak tags looks like W\/\"blahblah\" and -- strong tags are like \"blahblah\". - etagIsWeak :: !Bool + etagIsWeak ∷ !Bool -- |An opaque string. Only characters from 0x20 (sp) to 0x7e (~) -- are allowed. - , etagToken :: !String - } deriving (Eq) + , etagToken ∷ !Ascii + } deriving (Eq, Show) -instance Show ETag where - show (ETag isWeak token) = (if isWeak then - "W/" - else - "") - ++ - quoteStr token +-- |Convert an 'ETag' to 'Ascii'. +printETag ∷ ETag → Ascii +printETag et + = A.fromAsciiBuilder $ + ( ( if etagIsWeak et then + A.toAsciiBuilder "W/" + else + (∅) + ) + ⊕ + quoteStr (etagToken et) ) -- |This is equivalent to @'ETag' 'Prelude.False'@. If you want to -- generate an ETag from a file, try using -- 'Network.HTTP.Lucu.StaticFile.generateETagFromFile'. -strongETag :: String -> ETag +strongETag ∷ Ascii → ETag strongETag = ETag False -- |This is equivalent to @'ETag' 'Prelude.True'@. -weakETag :: String -> ETag +weakETag ∷ Ascii → ETag weakETag = ETag True - -eTagP :: Parser ETag -eTagP = do isWeak <- option False (string "W/" >> return True) - str <- quotedStr +eTagP ∷ Parser ETag +eTagP = do isWeak ← option False (string "W/" ≫ return True) + str ← quotedStr return $ ETag isWeak str - -eTagListP :: Parser [ETag] -eTagListP = allowEOF - $! do xs <- listOf eTagP - when (null xs) - $ fail "" - return xs +eTagListP ∷ Parser [ETag] +eTagListP = do xs ← listOf eTagP + when (null xs) $ + fail "empty list of ETags" + return xs diff --git a/Network/HTTP/Lucu/Format.hs b/Network/HTTP/Lucu/Format.hs index 93c2cda..42508b9 100644 --- a/Network/HTTP/Lucu/Format.hs +++ b/Network/HTTP/Lucu/Format.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE + OverloadedStrings + , ScopedTypeVariables + , UnboxedTuples + , UnicodeSyntax + #-} -- 本當にこんなものを自分で書く必要があったのだらうか。Printf は重いの -- で駄目だが、それ以外のモジュールを探しても見付からなかった。 - module Network.HTTP.Lucu.Format ( fmtInt @@ -8,124 +13,108 @@ module Network.HTTP.Lucu.Format , fmtHex ) where - - -fmtInt :: Int -> Bool -> Int -> Char -> Bool -> Int -> String -fmtInt base upperCase minWidth pad forceSign n - = base `seq` minWidth `seq` pad `seq` forceSign `seq` n `seq` - let raw = reverse $! fmt' (abs n) - sign = if forceSign || n < 0 then - if n < 0 then "-" else "+" - else - "" - padded = padStr (minWidth - length sign) pad raw +import qualified Blaze.ByteString.Builder.Char8 as BC +import Data.Ascii (AsciiBuilder) +import qualified Data.ByteString.Char8 as BS +import qualified Data.Ascii as A +import Data.Char +import Data.Monoid.Unicode +import Prelude.Unicode + +fmtInt ∷ ∀n. Integral n ⇒ n → Int → n → AsciiBuilder +{-# INLINEABLE fmtInt #-} +fmtInt base minWidth n + = let (# raw, len #) = fmt' (abs n) (∅) 0 in - sign ++ padded + if n < 0 then + ( A.toAsciiBuilder "-" ⊕ + mkPad (minWidth - 1) len ⊕ + raw + ) + else + mkPad minWidth len ⊕ raw where - fmt' :: Int -> String - fmt' m - | m < base = [intToChar upperCase m] - | otherwise = (intToChar upperCase $! m `mod` base) : fmt' (m `div` base) - - -fmtDec :: Int -> Int -> String + fmt' ∷ n → AsciiBuilder → Int → (# AsciiBuilder, Int #) + {-# INLINEABLE fmt' #-} + fmt' x b len + | x < base + = let b' = b ⊕ fromDigit x + in + (# b', len + 1 #) + | otherwise + = let x' = x `div` base + y = x `mod` base + b' = b ⊕ fromDigit y + in + fmt' x' b' (len + 1) + +mkPad ∷ Int → Int → AsciiBuilder +{-# INLINEABLE mkPad #-} +mkPad minWidth len + = A.toAsciiBuilder $ + A.unsafeFromByteString $ + BS.replicate (minWidth - len) '0' + +fmtDec ∷ Integral n ⇒ Int → n → AsciiBuilder +{-# INLINE fmtDec #-} fmtDec minWidth n | minWidth == 2 = fmtDec2 n -- optimization | minWidth == 3 = fmtDec3 n -- optimization | minWidth == 4 = fmtDec4 n -- optimization - | otherwise = fmtInt 10 undefined minWidth '0' False n -{-# INLINE fmtDec #-} - + | otherwise = fmtInt 10 minWidth n -fmtDec2 :: Int -> String +fmtDec2 ∷ Integral n ⇒ n → AsciiBuilder +{-# INLINEABLE fmtDec2 #-} fmtDec2 n - | n < 0 || n >= 100 = fmtInt 10 undefined 2 '0' False n -- fallback - | n < 10 = [ '0' - , intToChar undefined n - ] - | otherwise = [ intToChar undefined (n `div` 10) - , intToChar undefined (n `mod` 10) - ] - - -fmtDec3 :: Int -> String + | n < 0 ∨ n ≥ 100 = fmtInt 10 2 n -- fallback + | n < 10 = A.toAsciiBuilder "0" ⊕ + fromDigit n + | otherwise = fromDigit (n `div` 10) ⊕ + fromDigit (n `mod` 10) + +fmtDec3 ∷ Integral n ⇒ n → AsciiBuilder +{-# INLINEABLE fmtDec3 #-} fmtDec3 n - | n < 0 || n >= 1000 = fmtInt 10 undefined 3 '0' False n -- fallback - | n < 10 = [ '0' - , '0' - , intToChar undefined n - ] - | n < 100 = [ '0' - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - | otherwise = [ intToChar undefined ((n `div` 100) `mod` 10) - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - - -fmtDec4 :: Int -> String + | n < 0 ∨ n ≥ 1000 = fmtInt 10 3 n -- fallback + | n < 10 = A.toAsciiBuilder "00" ⊕ + fromDigit n + | n < 100 = A.toAsciiBuilder "0" ⊕ + fromDigit ((n `div` 10) `mod` 10) ⊕ + fromDigit ( n `mod` 10) + | otherwise = fromDigit (n `div` 100) ⊕ + fromDigit ((n `div` 10) `mod` 10) ⊕ + fromDigit ( n `mod` 10) + +fmtDec4 ∷ Integral n ⇒ n → AsciiBuilder +{-# INLINEABLE fmtDec4 #-} fmtDec4 n - | n < 0 || n >= 10000 = fmtInt 10 undefined 4 '0' False n -- fallback - | n < 10 = [ '0' - , '0' - , '0' - , intToChar undefined n - ] - | n < 100 = [ '0' - , '0' - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - | n < 1000 = [ '0' - , intToChar undefined ((n `div` 100) `mod` 10) - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - | otherwise = [ intToChar undefined ((n `div` 1000) `mod` 10) - , intToChar undefined ((n `div` 100) `mod` 10) - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - - -fmtHex :: Bool -> Int -> Int -> String -fmtHex upperCase minWidth - = fmtInt 16 upperCase minWidth '0' False - - -padStr :: Int -> Char -> String -> String -padStr minWidth pad str - = let delta = minWidth - length str - in - if delta > 0 then - replicate delta pad ++ str - else - str - - -intToChar :: Bool -> Int -> Char -intToChar _ 0 = '0' -intToChar _ 1 = '1' -intToChar _ 2 = '2' -intToChar _ 3 = '3' -intToChar _ 4 = '4' -intToChar _ 5 = '5' -intToChar _ 6 = '6' -intToChar _ 7 = '7' -intToChar _ 8 = '8' -intToChar _ 9 = '9' -intToChar False 10 = 'a' -intToChar True 10 = 'A' -intToChar False 11 = 'b' -intToChar True 11 = 'B' -intToChar False 12 = 'c' -intToChar True 12 = 'C' -intToChar False 13 = 'd' -intToChar True 13 = 'D' -intToChar False 14 = 'e' -intToChar True 14 = 'E' -intToChar False 15 = 'f' -intToChar True 15 = 'F' -intToChar _ _ = undefined + | n < 0 ∨ n ≥ 10000 = fmtInt 10 4 n -- fallback + | n < 10 = A.toAsciiBuilder "000" ⊕ + fromDigit n + | n < 100 = A.toAsciiBuilder "00" ⊕ + fromDigit ((n `div` 10) `mod` 10) ⊕ + fromDigit ( n `mod` 10) + | n < 1000 = A.toAsciiBuilder "0" ⊕ + fromDigit ((n `div` 100) `mod` 10) ⊕ + fromDigit ((n `div` 10) `mod` 10) ⊕ + fromDigit ( n `mod` 10) + | otherwise = fromDigit (n `div` 1000) ⊕ + fromDigit ((n `div` 100) `mod` 10) ⊕ + fromDigit ((n `div` 10) `mod` 10) ⊕ + fromDigit ( n `mod` 10) + +fmtHex ∷ Integral n ⇒ Int → n → AsciiBuilder +{-# INLINE fmtHex #-} +fmtHex = fmtInt 16 + +digitToChar ∷ Integral n ⇒ n → Char +{-# INLINE digitToChar #-} +digitToChar n + | n < 0 = (⊥) + | n < 10 = chr (ord '0' + fromIntegral n ) + | n < 16 = chr (ord 'A' + fromIntegral (n-10)) + | otherwise = (⊥) + +fromDigit ∷ Integral n ⇒ n → AsciiBuilder +{-# INLINE fromDigit #-} +fromDigit = A.unsafeFromBuilder ∘ BC.fromChar ∘ digitToChar diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 87d858c..f87ae5c 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE + BangPatterns + , GeneralizedNewtypeDeriving + , OverloadedStrings + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Headers ( Headers , HasHeaders(..) - , noCaseCmp - , noCaseEq - - , emptyHeaders , toHeaders , fromHeaders @@ -13,153 +15,78 @@ module Network.HTTP.Lucu.Headers , hPutHeaders ) where - -import qualified Data.ByteString as Strict (ByteString) -import Data.ByteString.Internal (toForeignPtr, w2c, inlinePerformIO) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Data.Char -import Data.List -import Data.Map (Map) +import Control.Applicative +import Data.Ascii (Ascii, CIAscii) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P +import qualified Data.ByteString as BS +import Data.Map (Map) import qualified Data.Map as M -import Data.Ord -import Data.Word -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Storable -import Network.HTTP.Lucu.HandleLike -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Utils - -type Headers = Map NCBS Strict.ByteString -newtype NCBS = NCBS Strict.ByteString - -toNCBS :: Strict.ByteString -> NCBS -toNCBS = NCBS -{-# INLINE toNCBS #-} - -fromNCBS :: NCBS -> Strict.ByteString -fromNCBS (NCBS x) = x -{-# INLINE fromNCBS #-} - -instance Eq NCBS where - (NCBS a) == (NCBS b) = a == b - -instance Ord NCBS where - (NCBS a) `compare` (NCBS b) = a `noCaseCmp` b - -instance Show NCBS where - show (NCBS x) = show x - -noCaseCmp :: Strict.ByteString -> Strict.ByteString -> Ordering -noCaseCmp a b = a `seq` b `seq` - toForeignPtr a `cmp` toForeignPtr b - where - cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Ordering - cmp (x1, s1, l1) (x2, s2, l2) - | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined - | l1 == 0 && l2 == 0 = EQ - | x1 == x2 && s1 == s2 && l1 == l2 = EQ - | otherwise - = inlinePerformIO $ - withForeignPtr x1 $ \ p1 -> - withForeignPtr x2 $ \ p2 -> - noCaseCmp' (p1 `plusPtr` s1) l1 (p2 `plusPtr` s2) l2 - - --- もし先頭の文字列が等しければ、短い方が小さい。 -noCaseCmp' :: Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Ordering -noCaseCmp' p1 l1 p2 l2 - | p1 `seq` l1 `seq` p2 `seq` l2 `seq` False = undefined - | l1 == 0 && l2 == 0 = return EQ - | l1 == 0 = return LT - | l2 == 0 = return GT - | otherwise - = do c1 <- peek p1 - c2 <- peek p2 - case comparing (toLower . w2c) c1 c2 of - EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1) - x -> return x - - -noCaseEq :: Strict.ByteString -> Strict.ByteString -> Bool -noCaseEq a b = a `seq` b `seq` - toForeignPtr a `cmp` toForeignPtr b - where - cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Bool - cmp (x1, s1, l1) (x2, s2, l2) - | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined - | l1 /= l2 = False - | l1 == 0 && l2 == 0 = True - | x1 == x2 && s1 == s2 && l1 == l2 = True - | otherwise - = inlinePerformIO $ - withForeignPtr x1 $ \ p1 -> - withForeignPtr x2 $ \ p2 -> - noCaseEq' (p1 `plusPtr` s1) (p2 `plusPtr` s2) l1 - - -noCaseEq' :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool -noCaseEq' p1 p2 l - | p1 `seq` p2 `seq` l `seq` False = undefined - | l == 0 = return True - | otherwise - = do c1 <- peek p1 - c2 <- peek p2 - if toLower (w2c c1) == toLower (w2c c2) then - noCaseEq' (p1 `plusPtr` 1) (p2 `plusPtr` 1) (l - 1) - else - return False +import Data.Monoid +import Data.Monoid.Unicode +import Network.HTTP.Lucu.HandleLike +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.Utils +import Prelude.Unicode +newtype Headers + = Headers (Map CIAscii Ascii) + deriving (Eq, Show, Monoid) class HasHeaders a where - getHeaders :: a -> Headers - setHeaders :: a -> Headers -> a - - getHeader :: Strict.ByteString -> a -> Maybe Strict.ByteString - getHeader key a - = key `seq` a `seq` - M.lookup (toNCBS key) (getHeaders a) - - deleteHeader :: Strict.ByteString -> a -> a - deleteHeader key a - = key `seq` a `seq` - setHeaders a $ M.delete (toNCBS key) (getHeaders a) - - setHeader :: Strict.ByteString -> Strict.ByteString -> a -> a - setHeader key val a - = key `seq` val `seq` a `seq` - setHeaders a $ M.insert (toNCBS key) val (getHeaders a) - - -emptyHeaders :: Headers -emptyHeaders = M.empty - - -toHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers -toHeaders xs = mkHeaders xs M.empty - - -mkHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers -> Headers -mkHeaders [] m = m -mkHeaders ((key, val):xs) m = mkHeaders xs $ - case M.lookup (toNCBS key) m of - Nothing -> M.insert (toNCBS key) val m - Just old -> M.insert (toNCBS key) (merge old val) m + getHeaders ∷ a → Headers + setHeaders ∷ a → Headers → a + + getHeader ∷ CIAscii → a → Maybe Ascii + {-# INLINE getHeader #-} + getHeader !key !a + = case getHeaders a of + Headers m → M.lookup key m + + deleteHeader ∷ CIAscii → a → a + {-# INLINE deleteHeader #-} + 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 + = case getHeaders a of + Headers m + → setHeaders a $ Headers $ M.insert key val m + +instance HasHeaders Headers where + getHeaders = id + setHeaders _ = id + +toHeaders ∷ [(CIAscii, Ascii)] → Headers +{-# INLINE toHeaders #-} +toHeaders = flip mkHeaders (∅) + +mkHeaders ∷ [(CIAscii, Ascii)] → Headers → Headers +mkHeaders [] (Headers m) = Headers m +mkHeaders ((key, val):xs) (Headers m) + = mkHeaders xs $ Headers $ + case M.lookup key m of + Nothing → M.insert key val m + Just old → M.insert key (merge old val) m where - merge :: Strict.ByteString -> Strict.ByteString -> Strict.ByteString - -- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない - -- ヘッダは複數個あってはならない事になってゐる。 + merge ∷ Ascii → Ascii → Ascii + {-# INLINE merge #-} merge a b - | C8.null a && C8.null b = C8.empty - | C8.null a = b - | C8.null b = a - | otherwise = C8.concat [a, C8.pack ", ", b] - + | nullA a ∧ nullA b = (∅) + | nullA a = b + | nullA b = a + | otherwise = a ⊕ ", " ⊕ b -fromHeaders :: Headers -> [(Strict.ByteString, Strict.ByteString)] -fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs] + nullA ∷ Ascii → Bool + {-# INLINE nullA #-} + nullA = BS.null ∘ A.toByteString +fromHeaders ∷ Headers → [(CIAscii, Ascii)] +fromHeaders (Headers m) = M.toList m {- message-header = field-name ":" [ field-value ] @@ -172,49 +99,38 @@ fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs] field-value の先頭および末尾にある LWS は全て削除され、それ以外の LWS は單一の SP に變換される。 -} -headersP :: Parser Headers -headersP = do xs <- many header - _ <- crlf - return $! toHeaders xs +headersP ∷ Parser Headers +{-# INLINEABLE headersP #-} +headersP = do xs ← P.many header + crlf + return $ toHeaders xs where - header :: Parser (Strict.ByteString, Strict.ByteString) - header = do name <- token - _ <- char ':' - -- FIXME: これは多少インチキだが、RFC 2616 のこの部分 - -- の記述はひどく曖昧であり、この動作が本當に間違って - -- ゐるのかどうかも良く分からない。例へば - -- quoted-string の内部にある空白は纏めていいのか惡い - -- のか？直勸的には駄目さうに思へるが、そんな記述は見 - -- 付からない。 - contents <- many (lws <|> many1 text) - _ <- crlf - let value = foldr (++) "" contents - norm = normalize value - return (C8.pack name, C8.pack norm) - - normalize :: String -> String - normalize = trimBody . trim isWhiteSpace - - trimBody = concat - . map (\ s -> if head s == ' ' then - " " - else - s) - . group - . map (\ c -> if isWhiteSpace c - then ' ' - else c) - - -hPutHeaders :: HandleLike h => h -> Headers -> IO () -hPutHeaders h hds - = h `seq` hds `seq` - mapM_ putH (M.toList hds) >> hPutBS h (C8.pack "\r\n") + header ∷ Parser (CIAscii, Ascii) + header = do name ← A.toCIAscii <$> token + _ ← char ':' + skipMany lws + values ← sepBy content (try lws) + skipMany (try lws) + crlf + return (name, joinValues values) + + content ∷ Parser Ascii + {-# INLINE content #-} + content = A.unsafeFromByteString + <$> + takeWhile1 (\c → ((¬) (isSPHT c)) ∧ isText c) + + joinValues ∷ [Ascii] → Ascii + {-# INLINE joinValues #-} + joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" ∘ map A.toAsciiBuilder + +hPutHeaders ∷ HandleLike h => h → Headers → IO () +hPutHeaders !h !(Headers m) + = mapM_ putH (M.toList m) >> hPutBS h "\r\n" where - putH :: (NCBS, Strict.ByteString) -> IO () - putH (name, value) - = name `seq` value `seq` - do hPutBS h (fromNCBS name) - hPutBS h (C8.pack ": ") - hPutBS h value - hPutBS h (C8.pack "\r\n") + putH ∷ (CIAscii, Ascii) → IO () + putH (!name, !value) + = do hPutBS h (A.ciToByteString name) + hPutBS h ": " + hPutBS h (A.toByteString value) + hPutBS h "\r\n" diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index d48f6ec..4531c83 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns + , OverloadedStrings , UnicodeSyntax #-} {-# OPTIONS_HADDOCK prune #-} @@ -11,18 +12,15 @@ module Network.HTTP.Lucu.HttpVersion , hPutHttpVersion ) where - -import qualified Data.ByteString.Char8 as C8 -import Network.HTTP.Lucu.HandleLike -import Network.HTTP.Lucu.Parser -import Prelude hiding (min) +import Control.Monad.Unicode +import Data.Attoparsec.Char8 +import Network.HTTP.Lucu.HandleLike +import Prelude hiding (min) -- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\". -data HttpVersion = HttpVersion !Int !Int - deriving (Eq) - -instance Show HttpVersion where - show (HttpVersion maj min) = "HTTP/" ++ show maj ++ "." ++ show min +data HttpVersion + = HttpVersion !Int !Int + deriving (Eq, Show) instance Ord HttpVersion where (HttpVersion majA minA) `compare` (HttpVersion majB minB) @@ -32,30 +30,26 @@ instance Ord HttpVersion where | minA < minB = LT | otherwise = EQ - -httpVersionP :: Parser HttpVersion +httpVersionP ∷ Parser HttpVersion httpVersionP = string "HTTP/" - >> - -- 頻出するので高速化 - choice [ string "1.0" >> return (HttpVersion 1 0) - , string "1.1" >> return (HttpVersion 1 1) - -- 一般の場合 - , do major <- many1 digit - _ <- char '.' - minor <- many1 digit - return $ HttpVersion (read major) (read minor) + ≫ + choice [ string "1.1" ≫ return (HttpVersion 1 1) + , string "1.0" ≫ return (HttpVersion 1 0) + , do major ← decimal + _ ← char '.' + minor ← decimal + return $ HttpVersion major minor ] - -hPutHttpVersion :: HandleLike h => h -> HttpVersion -> IO () +hPutHttpVersion ∷ HandleLike h ⇒ h → HttpVersion → IO () hPutHttpVersion !h !v = case v of -- 頻出するので高速化 - HttpVersion 1 0 -> hPutBS h (C8.pack "HTTP/1.0") - HttpVersion 1 1 -> hPutBS h (C8.pack "HTTP/1.1") + HttpVersion 1 0 → hPutBS h "HTTP/1.0" + HttpVersion 1 1 → hPutBS h "HTTP/1.1" -- 一般の場合 HttpVersion !maj !min - -> do hPutBS h (C8.pack "HTTP/") - hPutStr h (show maj) - hPutChar h '.' - hPutStr h (show min) + → do hPutBS h "HTTP/" + hPutStr h (show maj) + hPutChar h '.' + hPutStr h (show min) 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 diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index a3f3fc5..dfaef11 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -1,5 +1,5 @@ {-# LANGUAGE - UnboxedTuples + OverloadedStrings , UnicodeSyntax #-} {-# OPTIONS_HADDOCK prune #-} @@ -8,71 +8,62 @@ module Network.HTTP.Lucu.MIMEType ( MIMEType(..) , parseMIMEType + , printMIMEType + , mimeTypeP , mimeTypeListP ) where - -import qualified Data.ByteString.Lazy as B -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Utils -import Prelude hiding (min) +import Control.Applicative +import Data.Ascii (Ascii, CIAscii) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P +import qualified Data.ByteString.Char8 as C8 +import Data.Map (Map) +import Data.Monoid.Unicode +import Data.Text (Text) +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.RFC2231 +import Prelude hiding (min) +import Prelude.Unicode -- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@ -- represents \"major\/minor; name=value\". data MIMEType = MIMEType { - mtMajor :: !String - , mtMinor :: !String - , mtParams :: ![ (String, String) ] - } deriving (Eq) - - -instance Show MIMEType where - show (MIMEType maj min params) - = maj ++ "/" ++ min ++ - if null params then - "" - else - "; " ++ joinWith "; " (map showPair params) - where - showPair :: (String, String) -> String - showPair (name, value) - = name ++ "=" ++ if any (not . isToken) value then - quoteStr value - else - value + mtMajor ∷ !CIAscii + , mtMinor ∷ !CIAscii + , mtParams ∷ !(Map CIAscii Text) + } deriving (Eq, Show) +-- |Convert a 'MIMEType' to 'Ascii'. +printMIMEType ∷ MIMEType → Ascii +printMIMEType (MIMEType maj min params) + = A.fromAsciiBuilder $ + ( A.toAsciiBuilder (A.fromCIAscii maj) ⊕ + A.toAsciiBuilder "/" ⊕ + A.toAsciiBuilder (A.fromCIAscii min) ⊕ + printParams params + ) -instance Read MIMEType where - readsPrec _ s = [(parseMIMEType s, "")] - --- |Parse 'MIMEType' from a 'Prelude.String'. This function throws an +-- |Parse 'MIMEType' from an 'Ascii'. This function throws an -- exception for parse error. -parseMIMEType :: String -> MIMEType -parseMIMEType str = case parseStr mimeTypeP str of - (# Success t, r #) -> if B.null r - then t - else error ("unparsable MIME Type: " ++ str) - (# _ , _ #) -> error ("unparsable MIME Type: " ++ str) - +parseMIMEType ∷ Ascii → MIMEType +parseMIMEType str + = let p = do t ← mimeTypeP + endOfInput + return t + bs = A.toByteString str + in + case parseOnly p bs of + Right t → t + Left err → error ("unparsable MIME Type: " ⧺ C8.unpack bs ⧺ ": " ⧺ err) -mimeTypeP :: Parser MIMEType -mimeTypeP = allowEOF $! - do maj <- token - _ <- char '/' - min <- token - params <- many paramP +mimeTypeP ∷ Parser MIMEType +mimeTypeP = do maj ← A.toCIAscii <$> token + _ ← char '/' + min ← A.toCIAscii <$> token + params ← paramsP return $ MIMEType maj min params - where - paramP :: Parser (String, String) - paramP = do _ <- many lws - _ <- char ';' - _ <- many lws - name <- token - _ <- char '=' - value <- token <|> quotedStr - return (name, value) -mimeTypeListP :: Parser [MIMEType] -mimeTypeListP = allowEOF $! listOf mimeTypeP +mimeTypeListP ∷ Parser [MIMEType] +mimeTypeListP = listOf mimeTypeP diff --git a/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs b/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs deleted file mode 100644 index d6add2b..0000000 --- a/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs +++ /dev/null @@ -1,182 +0,0 @@ --- |This module is automatically generated from data\/mime.types. --- 'defaultExtensionMap' contains every possible pairs of an extension --- and a MIME Type. - -{- !!! WARNING !!! - This file is automatically generated. - DO NOT EDIT BY HAND OR YOU WILL REGRET -} - -module Network.HTTP.Lucu.MIMEType.DefaultExtensionMap - (defaultExtensionMap) where -import Network.HTTP.Lucu.MIMEType () -import Network.HTTP.Lucu.MIMEType.Guess -import qualified Data.Map as M - -defaultExtensionMap :: ExtMap -defaultExtensionMap - = M.fromList - [("3gp", read "application/x-3gp"), ("669", read "audio/x-mod"), - ("Z", read "application/x-compress"), - ("a", read "application/x-ar"), ("ac3", read "audio/x-ac3"), - ("ai", read "application/postscript"), - ("aif", read "audio/x-aiff"), ("aifc", read "audio/x-aiff"), - ("aiff", read "audio/x-aiff"), ("amf", read "audio/x-mod"), - ("anx", read "application/ogg"), ("ape", read "application/x-ape"), - ("asc", read "text/plain"), ("asf", read "video/x-ms-asf"), - ("atom", read "application/atom+xml"), ("au", read "audio/x-au"), - ("avi", read "video/x-msvideo"), - ("bcpio", read "application/x-bcpio"), - ("bin", read "application/octet-stream"), - ("bmp", read "image/bmp"), ("bz2", read "application/x-bzip"), - ("cabal", read "text/x-cabal"), - ("cdf", read "application/x-netcdf"), ("cgm", read "image/cgm"), - ("class", read "application/octet-stream"), - ("cpio", read "application/x-cpio"), - ("cpt", read "application/mac-compactpro"), - ("csh", read "application/x-csh"), ("css", read "text/css"), - ("dcr", read "application/x-director"), ("dif", read "video/x-dv"), - ("dir", read "application/x-director"), - ("djv", read "image/vnd.djvu"), ("djvu", read "image/vnd.djvu"), - ("dll", read "application/octet-stream"), - ("dmg", read "application/octet-stream"), - ("dms", read "application/octet-stream"), - ("doc", read "application/msword"), ("dsm", read "audio/x-mod"), - ("dtd", read "application/xml-dtd"), ("dv", read "video/x-dv"), - ("dvi", read "application/x-dvi"), - ("dxr", read "application/x-director"), - ("eps", read "application/postscript"), - ("etx", read "text/x-setext"), - ("exe", read "application/octet-stream"), - ("ez", read "application/andrew-inset"), - ("far", read "audio/x-mod"), ("flac", read "audio/x-flac"), - ("flc", read "video/x-fli"), ("fli", read "video/x-fli"), - ("flv", read "video/x-flv"), ("gdm", read "audio/x-mod"), - ("gif", read "image/gif"), ("gram", read "application/srgs"), - ("grxml", read "application/srgs+xml"), - ("gtar", read "application/x-gtar"), - ("gz", read "application/x-gzip"), - ("hdf", read "application/x-hdf"), - ("hi", read "application/octet-stream"), - ("hqx", read "application/mac-binhex40"), - ("hs", read "text/x-haskell"), ("htm", read "text/html"), - ("html", read "text/html"), - ("ice", read "x-conference/x-cooltalk"), - ("ico", read "image/x-icon"), ("ics", read "text/calendar"), - ("ief", read "image/ief"), ("ifb", read "text/calendar"), - ("iff", read "audio/x-svx"), ("iges", read "model/iges"), - ("igs", read "model/iges"), ("ilbc", read "audio/iLBC-sh"), - ("imf", read "audio/x-mod"), ("it", read "audio/x-mod"), - ("jng", read "image/x-jng"), - ("jnlp", read "application/x-java-jnlp-file"), - ("jp2", read "image/jp2"), ("jpe", read "image/jpeg"), - ("jpeg", read "image/jpeg"), ("jpg", read "image/jpeg"), - ("js", read "application/x-javascript"), - ("kar", read "audio/midi"), ("latex", read "application/x-latex"), - ("lha", read "application/octet-stream"), - ("lzh", read "application/octet-stream"), - ("m3u", read "audio/x-mpegurl"), ("m4a", read "audio/mp4a-latm"), - ("m4p", read "audio/mp4a-latm"), ("m4u", read "video/vnd.mpegurl"), - ("m4v", read "video/mpeg4"), ("mac", read "image/x-macpaint"), - ("man", read "application/x-troff-man"), - ("mathml", read "application/mathml+xml"), - ("me", read "application/x-troff-me"), ("med", read "audio/x-mod"), - ("mesh", read "model/mesh"), ("mid", read "audio/midi"), - ("midi", read "audio/midi"), ("mif", read "application/vnd.mif"), - ("mka", read "video/x-matroska"), ("mkv", read "video/x-matroska"), - ("mng", read "video/x-mng"), ("mod", read "audio/x-mod"), - ("mov", read "video/quicktime"), - ("movie", read "video/x-sgi-movie"), ("mp2", read "audio/mpeg"), - ("mp3", read "audio/mpeg"), ("mp4", read "video/mp4"), - ("mpc", read "audio/x-musepack"), ("mpe", read "video/mpeg"), - ("mpeg", read "video/mpeg"), ("mpg", read "video/mpeg"), - ("mpga", read "audio/mpeg"), ("ms", read "application/x-troff-ms"), - ("msh", read "model/mesh"), ("mtm", read "audio/x-mod"), - ("mve", read "video/x-mve"), ("mxu", read "video/vnd.mpegurl"), - ("nar", read "application/x-nar"), - ("nc", read "application/x-netcdf"), ("nist", read "audio/x-nist"), - ("nuv", read "video/x-nuv"), - ("o", read "application/octet-stream"), - ("oda", read "application/oda"), ("ogg", read "application/ogg"), - ("ogm", read "application/ogg"), ("okt", read "audio/x-mod"), - ("paf", read "audio/x-paris"), - ("pbm", read "image/x-portable-bitmap"), - ("pct", read "image/pict"), ("pdb", read "chemical/x-pdb"), - ("pdf", read "application/pdf"), - ("pgm", read "image/x-portable-graymap"), - ("pgn", read "application/x-chess-pgn"), - ("pic", read "image/pict"), ("pict", read "image/pict"), - ("png", read "image/png"), ("pnm", read "image/x-portable-anymap"), - ("pnt", read "image/x-macpaint"), - ("pntg", read "image/x-macpaint"), - ("ppm", read "image/x-portable-pixmap"), - ("ppt", read "application/vnd.ms-powerpoint"), - ("ps", read "application/postscript"), - ("qif", read "image/x-quicktime"), ("qt", read "video/quicktime"), - ("qti", read "image/x-quicktime"), - ("qtif", read "image/x-quicktime"), - ("ra", read "audio/x-pn-realaudio"), ("ram", read "text/uri-list"), - ("rar", read "application/x-rar"), - ("ras", read "image/x-sun-raster"), - ("rdf", read "application/rdf+xml"), ("rgb", read "image/x-rgb"), - ("rm", read "application/vnd.rn-realmedia"), - ("roff", read "application/x-troff"), ("rtf", read "text/rtf"), - ("rtx", read "text/richtext"), ("s3m", read "audio/x-mod"), - ("sam", read "audio/x-mod"), ("sds", read "audio/x-sds"), - ("sf", read "audio/x-ircam"), ("sgm", read "text/sgml"), - ("sgml", read "text/sgml"), ("sh", read "application/x-sh"), - ("shar", read "application/x-shar"), - ("shn", read "audio/x-shorten"), ("sid", read "audio/x-sid"), - ("silo", read "model/mesh"), ("sit", read "application/x-stuffit"), - ("skd", read "application/x-koan"), - ("skm", read "application/x-koan"), - ("skp", read "application/x-koan"), - ("skt", read "application/x-koan"), - ("smi", read "application/smil"), - ("smil", read "application/smil"), ("snd", read "audio/x-au"), - ("so", read "application/octet-stream"), - ("spc", read "application/x-spc"), - ("spl", read "application/x-futuresplash"), - ("src", read "application/x-wais-source"), - ("stm", read "audio/x-mod"), ("stx", read "audio/x-mod"), - ("sv4cpio", read "application/x-sv4cpio"), - ("sv4crc", read "application/x-sv4crc"), - ("svg", read "image/svg+xml"), ("svx", read "audio/x-svx"), - ("swf", read "application/x-shockwave-flash"), - ("swfl", read "application/x-shockwave-flash"), - ("t", read "application/x-troff"), - ("tar", read "application/x-tar"), - ("tbz", read "application/x-bzip"), - ("tcl", read "application/x-tcl"), - ("tex", read "application/x-tex"), - ("texi", read "application/x-texinfo"), - ("texinfo", read "application/x-texinfo"), - ("tgz", read "application/x-gzip"), ("tif", read "image/tiff"), - ("tiff", read "image/tiff"), ("tr", read "application/x-troff"), - ("ts", read "video/mpegts"), - ("tsv", read "text/tab-separated-values"), - ("tta", read "audio/x-ttafile"), ("txt", read "text/plain"), - ("ult", read "audio/x-mod"), ("ustar", read "application/x-ustar"), - ("vcd", read "application/x-cdlink"), ("voc", read "audio/x-voc"), - ("vrml", read "model/vrml"), - ("vxml", read "application/voicexml+xml"), - ("w64", read "audio/x-w64"), ("wav", read "audio/x-wav"), - ("wbmp", read "image/vnd.wap.wbmp"), - ("wbxml", read "application/vnd.wap.wbxml"), - ("wm", read "video/x-ms-asf"), ("wma", read "video/x-ms-asf"), - ("wml", read "text/vnd.wap.wml"), - ("wmlc", read "application/vnd.wap.wmlc"), - ("wmls", read "text/vnd.wap.wmlscript"), - ("wmlsc", read "application/vnd.wap.wmlscriptc"), - ("wmv", read "video/x-ms-asf"), ("wrl", read "model/vrml"), - ("wv", read "audio/x-wavpack"), - ("wvc", read "audio/x-wavpack-correction"), - ("wvp", read "audio/x-wavpack"), ("xbm", read "image/x-xbitmap"), - ("xcf", read "image/x-xcf"), ("xht", read "application/xhtml+xml"), - ("xhtml", read "application/xhtml+xml"), - ("xls", read "application/vnd.ms-excel"), - ("xm", read "audio/x-mod"), ("xml", read "application/xml"), - ("xpm", read "image/x-xpixmap"), ("xsl", read "application/xml"), - ("xslt", read "application/xslt+xml"), - ("xul", read "application/vnd.mozilla.xul+xml"), - ("xwd", read "image/x-xwindowdump"), - ("xyz", read "chemical/x-xyz"), ("zip", read "application/zip")] diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 39de37e..3344f4b 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,5 +1,5 @@ {-# LANGUAGE - UnboxedTuples + BangPatterns , UnicodeSyntax #-} -- |MIME Type guessing by a file extension. This is a poor man's way @@ -14,94 +14,104 @@ module Network.HTTP.Lucu.MIMEType.Guess , serializeExtMap ) where - +import Control.Applicative +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P +import qualified Data.Attoparsec.Lazy as AL import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Map as M -import Data.Map (Map) -import Data.Maybe -import Language.Haskell.Pretty -import Language.Haskell.Syntax -import Network.HTTP.Lucu.MIMEType -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Utils +import Data.Map (Map) +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import Language.Haskell.Pretty +import Language.Haskell.Syntax +import Network.HTTP.Lucu.MIMEType +import Prelude.Unicode +import System.FilePath --- |'Data.Map.Map' from extension to MIME Type. -type ExtMap = Map String MIMEType +-- |'Map' from extension to 'MIMEType'. +type ExtMap = Map Text MIMEType -- |Guess the MIME Type of file. -guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType -guessTypeByFileName extMap fpath - = extMap `seq` fpath `seq` - let ext = last $ splitBy (== '.') fpath +guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType +guessTypeByFileName !extMap !fpath + = let ext = T.pack $ takeExtension fpath in - M.lookup ext extMap >>= return + M.lookup ext extMap -- |Read an Apache mime.types and parse it. -parseExtMapFile :: FilePath -> IO ExtMap +parseExtMapFile ∷ FilePath → IO ExtMap parseExtMapFile fpath - = fpath `seq` - do file <- B.readFile fpath - case parse (allowEOF extMapP) file of - (# Success xs, _ #) - -> return $ compile xs - - (# _, input' #) - -> let near = B.unpack $ B.take 100 input' - in - fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")") - + = do file ← B.readFile fpath + case AL.parse extMapP file of + AL.Done _ xs → return $ compile xs + AL.Fail _ _ e → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e) -extMapP :: Parser [ (MIMEType, [String]) ] -extMapP = do xs <- many (comment <|> validLine <|> emptyLine) - eof +extMapP ∷ Parser [ (MIMEType, [Text]) ] +extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine) + endOfInput return $ catMaybes xs where - spc = oneOf " \t" + isSpc ∷ Char → Bool + isSpc c = c ≡ '\x20' ∨ c ≡ '\x09' - comment = many spc >> - char '#' >> - ( many $ satisfy (/= '\n') ) >> - return Nothing + comment ∷ Parser (Maybe (MIMEType, [Text])) + comment = try $ + do skipWhile isSpc + _ ← char '#' + skipWhile (≢ '\x0A') + return Nothing - validLine = do _ <- many spc - mime <- mimeTypeP - _ <- many spc - exts <- sepBy token (many spc) + validLine ∷ Parser (Maybe (MIMEType, [Text])) + validLine = try $ + do skipWhile isSpc + mime ← mimeTypeP + skipWhile isSpc + exts ← sepBy extP (skipWhile isSpc) return $ Just (mime, exts) - emptyLine = oneOf " \t\n" >> return Nothing + extP ∷ Parser Text + extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A')) + emptyLine ∷ Parser (Maybe (MIMEType, [Text])) + emptyLine = try $ + do skipWhile isSpc + _ ← char '\x0A' + return Nothing -compile :: [ (MIMEType, [String]) ] -> Map String MIMEType -compile = M.fromList . foldr (++) [] . map tr +compile ∷ [ (MIMEType, [Text]) ] → Map Text MIMEType +compile = M.fromList ∘ concat ∘ map tr where - tr :: (MIMEType, [String]) -> [ (String, MIMEType) ] - tr (mime, exts) = [ (ext, mime) | ext <- exts ] + tr ∷ (MIMEType, [Text]) → [ (Text, MIMEType) ] + tr (mime, exts) = [ (ext, mime) | ext ← exts ] -- |@'serializeExtMap' extMap moduleName variableName@ generates a -- Haskell source code which contains the following things: -- -- * A definition of module named @moduleName@. -- --- * @variableName :: 'ExtMap'@ whose content is a serialization of +-- * @variableName ∷ 'ExtMap'@ whose content is a serialization of -- @extMap@. -- -- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is -- surely generated using this function. -serializeExtMap :: ExtMap -> String -> String -> String +serializeExtMap ∷ ExtMap → String → String → String serializeExtMap extMap moduleName variableName - = let hsModule = HsModule undefined modName (Just exports) imports decls + = let hsModule = HsModule (⊥) modName (Just exports) imports decls modName = Module moduleName exports = [HsEVar (UnQual (HsIdent variableName))] - imports = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing (Just (False, [])) - , HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing - , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing + imports = [ HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing + , HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing + , HsImportDecl (⊥) (Module "Data.Ascii") True (Just (Module "A")) Nothing + , HsImportDecl (⊥) (Module "Data.Map") True (Just (Module "M")) Nothing + , HsImportDecl (⊥) (Module "Data.Text") True (Just (Module "T")) Nothing ] - decls = [ HsTypeSig undefined [HsIdent variableName] + decls = [ HsTypeSig (⊥) [HsIdent variableName] (HsQualType [] (HsTyCon (UnQual (HsIdent "ExtMap")))) - , HsFunBind [HsMatch undefined (HsIdent variableName) + , HsFunBind [HsMatch (⊥) (HsIdent variableName) [] (HsUnGuardedRhs extMapExp) []] ] extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records) @@ -111,13 +121,20 @@ serializeExtMap extMap moduleName variableName in comment ++ prettyPrint hsModule ++ "\n" where - records :: [HsExp] + records ∷ [HsExp] records = map record $ M.assocs extMap - record :: (String, MIMEType) -> HsExp + record ∷ (Text, MIMEType) → HsExp record (ext, mime) - = HsTuple [HsLit (HsString ext), mimeToExp mime] + = HsTuple + [ HsApp (HsVar (Qual (Module "T") (HsIdent "pack"))) + (HsLit (HsString (T.unpack ext))) + , mimeToExp mime + ] - mimeToExp :: MIMEType -> HsExp + mimeToExp ∷ MIMEType → HsExp mimeToExp mt - = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show mt)) + = HsApp (HsVar (UnQual (HsIdent "parseMIMEType"))) + (HsParen + (HsApp (HsVar (Qual (Module "A") (HsIdent "unsafeFromString"))) + (HsLit (HsString $ A.toString $ printMIMEType mt)))) diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index c463130..8d09d70 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -1,5 +1,8 @@ {-# LANGUAGE - UnboxedTuples + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , ScopedTypeVariables , UnicodeSyntax #-} module Network.HTTP.Lucu.MultipartForm @@ -7,150 +10,134 @@ module Network.HTTP.Lucu.MultipartForm , multipartFormP ) where - -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy.Char8 as L8 -import Data.Char -import Data.List -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Utils - - -data Part = Part Headers L8.ByteString +import Control.Applicative hiding (many) +import Data.Ascii (Ascii, CIAscii) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LS +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid.Unicode +import Data.Text (Text) +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.RFC2231 +import Prelude.Unicode -- |This data type represents a form value and possibly an uploaded -- file name. data FormData = FormData { - fdFileName :: Maybe String - , fdContent :: L8.ByteString + fdFileName ∷ Maybe Text + , fdContent ∷ LS.ByteString } -instance HasHeaders Part where - getHeaders (Part hs _) = hs - setHeaders (Part _ b) hs = Part hs b - +data Part + = Part { + ptHeaders ∷ Headers + , ptContDispo ∷ ContDispo + , ptBody ∷ LS.ByteString + } -data ContDispo = ContDispo String [(String, String)] +instance HasHeaders Part where + getHeaders = ptHeaders + setHeaders pt hs = pt { ptHeaders = hs } -instance Show ContDispo where - show (ContDispo dType dParams) - = dType ++ - if null dParams then - "" - else - "; " ++ joinWith "; " (map showPair dParams) - where - showPair :: (String, String) -> String - showPair (name, value) - = name ++ "=" ++ if any (not . isToken) value then - quoteStr value - else - value +data ContDispo + = ContDispo { + dType ∷ !CIAscii + , dParams ∷ !(Map CIAscii Text) + } +printContDispo ∷ ContDispo → Ascii +printContDispo d + = A.fromAsciiBuilder $ + ( A.toAsciiBuilder (A.fromCIAscii $ dType d) + ⊕ + printParams (dParams d) ) -multipartFormP :: String -> Parser [(String, FormData)] +multipartFormP ∷ Ascii → Parser [(Text, FormData)] multipartFormP boundary - = do parts <- many (partP boundary) - _ <- string "--" - _ <- string boundary - _ <- string "--" - _ <- crlf - eof - return $ map partToFormPair parts - - -partP :: String -> Parser Part + = do parts ← many $ try $ partP boundary + _ ← string "--" + _ ← string $ A.toByteString boundary + _ ← string "--" + crlf + catMaybes <$> mapM partToFormPair parts + +partP ∷ Ascii → Parser Part partP boundary - = do _ <- string "--" - _ <- string boundary - _ <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。 - hs <- headersP - body <- bodyP boundary - return $ Part hs body - - -bodyP :: String -> Parser L8.ByteString + = do _ ← string "--" + _ ← string $ A.toByteString boundary + crlf + hs ← headersP + d ← getContDispo hs + body ← bodyP boundary + return $ Part hs d body + +bodyP ∷ Ascii → Parser LS.ByteString bodyP boundary - = do body <- manyChar $ - do notFollowedBy $ ( crlf >> - string "--" >> - string boundary ) - anyChar - _ <- crlf + = do body ← manyCharsTill anyChar $ + try $ + do crlf + _ ← string "--" + _ ← string $ A.toByteString boundary + return () + crlf return body - -partToFormPair :: Part -> (String, FormData) -partToFormPair part@(Part _ body) - = let name = partName part - fname = partFileName part - fd = FormData { - fdFileName = fname - , fdContent = body - } - in (name, fd) - -partName :: Part -> String -partName = getName' . getContDispoFormData - where - getName' :: ContDispo -> String - getName' dispo@(ContDispo _ dParams) - = case find ((== "name") . map toLower . fst) dParams of - Just (_, name) -> name - Nothing - -> abortPurely BadRequest [] - (Just $ "form-data without name: " ++ show dispo) - - -partFileName :: Part -> Maybe String -partFileName = getFileName' . getContDispoFormData - where - getFileName' :: ContDispo -> Maybe String - getFileName' (ContDispo _ dParams) - = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams - return fileName - -getContDispoFormData :: Part -> ContDispo -getContDispoFormData part - = let dispo@(ContDispo dType _) = getContDispo part - in - if map toLower dType == "form-data" then - dispo - else - abortPurely BadRequest [] - (Just $ "Content-Disposition type is not form-data: " ++ dType) - - -getContDispo :: Part -> ContDispo -getContDispo part - = case getHeader (C8.pack "Content-Disposition") part of - Nothing - -> abortPurely BadRequest [] - (Just "There is a part without Content-Disposition in the multipart/form-data.") - Just dispoStr - -> case parse contDispoP (L8.fromChunks [dispoStr]) of - (# Success dispo, _ #) - -> dispo - (# _, _ #) - -> abortPurely BadRequest [] - (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr) - - -contDispoP :: Parser ContDispo -contDispoP = do dispoType <- token - params <- allowEOF $ many paramP +partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData)) +{-# INLINEABLE partToFormPair #-} +partToFormPair pt + | dType (ptContDispo pt) ≡ "form-data" + = do name ← partName pt + let fname = partFileName pt + let fd = FormData { + fdFileName = fname + , fdContent = ptBody pt + } + return $ Just (name, fd) + | otherwise + = return Nothing + +partName ∷ Monad m ⇒ Part → m Text +{-# INLINEABLE partName #-} +partName (Part {..}) + = case M.lookup "name" $ dParams ptContDispo of + Just name + → return name + Nothing + → fail ("form-data without name: " ⧺ + A.toString (printContDispo ptContDispo)) + +partFileName ∷ Part → Maybe Text +{-# INLINEABLE partFileName #-} +partFileName (Part {..}) + = M.lookup "filename" $ dParams ptContDispo + +getContDispo ∷ Monad m ⇒ Headers → m ContDispo +{-# INLINEABLE getContDispo #-} +getContDispo hdr + = case getHeader "Content-Disposition" hdr of + Nothing + → fail ("There is a part without Content-Disposition in the multipart/form-data.") + Just str + → let p = do d ← contDispoP + endOfInput + return d + bs = A.toByteString str + in + case parseOnly p bs of + Right d → return d + Left err → fail (concat [ "Unparsable Content-Disposition: " + , BS.unpack bs + , ": " + , err + ]) + +contDispoP ∷ Parser ContDispo +contDispoP = do dispoType ← A.toCIAscii <$> token + params ← paramsP return $ ContDispo dispoType params - where - paramP :: Parser (String, String) - paramP = do _ <- many lws - _ <- char ';' - _ <- many lws - name <- token - _ <- char '=' - value <- token <|> quotedStr - return (name, value) diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs deleted file mode 100644 index 7809f53..0000000 --- a/Network/HTTP/Lucu/Parser.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-# LANGUAGE - BangPatterns - , ScopedTypeVariables - , UnboxedTuples - , UnicodeSyntax - #-} --- |Yet another parser combinator. This is mostly a subset of --- "Text.ParserCombinators.Parsec" but there are some differences: --- --- * This parser works on 'Data.ByteString.Base.LazyByteString' --- instead of 'Prelude.String'. --- --- * Backtracking is the only possible behavior so there is no \"try\" --- action. --- --- * On success, the remaining string is returned as well as the --- parser result. --- --- * You can choose whether to treat reaching EOF (trying to eat one --- more letter at the end of string) a fatal error or to treat it a --- normal failure. If a fatal error occurs, the entire parsing --- process immediately fails without trying any backtracks. The --- default behavior is to treat EOF fatal. --- --- In general, you don't have to use this module directly. -module Network.HTTP.Lucu.Parser - ( Parser - , ParserResult(..) - - , failP - - , parse - , parseStr - - , anyChar - , eof - , allowEOF - , satisfy - , char - , string - , (<|>) - , choice - , oneOf - , digit - , hexDigit - , notFollowedBy - , many - , manyChar - , many1 - , count - , option - , sepBy - , sepBy1 - - , sp - , ht - , crlf - ) - where - -import Control.Monad.State.Strict hiding (state) -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString) -import qualified Data.Foldable as Fold -import Data.Int -import qualified Data.Sequence as Seq -import Data.Sequence (Seq, (|>)) - --- |@'Parser' a@ is obviously a parser which parses and returns @a@. -newtype Parser a = Parser { - runParser :: State ParserState (ParserResult a) - } - - -data ParserState - = PST { - pstInput :: Lazy.ByteString - , pstIsEOFFatal :: !Bool - } - deriving (Eq, Show) - - -data ParserResult a = Success !a - | IllegalInput -- 受理出來ない入力があった - | ReachedEOF -- 限界を越えて讀まうとした - deriving (Eq, Show) - - --- (>>=) :: Parser a -> (a -> Parser b) -> Parser b -instance Monad Parser where - p >>= f = Parser $! do saved <- get -- 失敗した時の爲に状態を保存 - result <- runParser p - case result of - Success a -> runParser (f a) - IllegalInput -> do put saved -- 状態を復歸 - return IllegalInput - ReachedEOF -> do put saved -- 状態を復歸 - return ReachedEOF - return !x = Parser $! return $! Success x - fail _ = Parser $! return $! IllegalInput - -instance Functor Parser where - fmap f p = p >>= return . f - --- |@'failP'@ is just a synonym for @'Prelude.fail' --- 'Prelude.undefined'@. -failP :: Parser a -failP = fail undefined - --- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(# result, --- remaining #)@. -parse :: Parser a -> Lazy.ByteString -> (# ParserResult a, Lazy.ByteString #) -parse !p input -- input は lazy である必要有り。 - = let (!result, state') = runState (runParser p) (PST input True) - in - (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。 - --- |@'parseStr' p str@ packs @str@ and parses it. -parseStr :: Parser a -> String -> (# ParserResult a, Lazy.ByteString #) -parseStr !p input -- input は lazy である必要有り。 - = parse p (B.pack input) - - -anyChar :: Parser Char -anyChar = Parser $! - do state@(PST input _) <- get - if B.null input then - return ReachedEOF - else - do put $! state { pstInput = B.tail input } - return (Success $! B.head input) - - -eof :: Parser () -eof = Parser $! - do PST input _ <- get - if B.null input then - return $! Success () - else - return IllegalInput - --- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure. -allowEOF :: Parser a -> Parser a -allowEOF !f - = Parser $! do saved@(PST _ isEOFFatal) <- get - put $! saved { pstIsEOFFatal = False } - - result <- runParser f - - state <- get - put $! state { pstIsEOFFatal = isEOFFatal } - - return result - - -satisfy :: (Char -> Bool) -> Parser Char -satisfy !f - = do c <- anyChar - if f c then - return c - else - failP - - -char :: Char -> Parser Char -char !c = satisfy (== c) - - -string :: String -> Parser String -string !str - = let bs = B.pack str - len = B.length bs - in - Parser $! - do st <- get - let (bs', rest) = B.splitAt len $ pstInput st - st' = st { pstInput = rest } - if B.length bs' < len then - return ReachedEOF - else - if bs == bs' then - do put st' - return $ Success str - else - return IllegalInput - - -infixr 0 <|> - --- |This is the backtracking alternation. There is no non-backtracking --- equivalent. -(<|>) :: Parser a -> Parser a -> Parser a -(!f) <|> (!g) - = Parser $! do saved <- get -- 状態を保存 - result <- runParser f - case result of - Success a -> return $! Success a - IllegalInput -> do put saved -- 状態を復歸 - runParser g - ReachedEOF -> if pstIsEOFFatal saved then - do put saved - return ReachedEOF - else - do put saved - runParser g - - -choice :: [Parser a] -> Parser a -choice = foldl (<|>) failP - - -oneOf :: [Char] -> Parser Char -oneOf = foldl (<|>) failP . map char - - -notFollowedBy :: Parser a -> Parser () -notFollowedBy !p - = Parser $! do saved <- get -- 状態を保存 - result <- runParser p - case result of - Success _ -> do put saved -- 状態を復歸 - return IllegalInput - IllegalInput -> do put saved -- 状態を復歸 - return $! Success () - ReachedEOF -> do put saved -- 状態を復歸 - return $! Success () - - -digit :: Parser Char -digit = do c <- anyChar - if c >= '0' && c <= '9' then - return c - else - failP - - -hexDigit :: Parser Char -hexDigit = do c <- anyChar - if (c >= '0' && c <= '9') || - (c >= 'a' && c <= 'f') || - (c >= 'A' && c <= 'F') then - return c - else - failP - - -many :: forall a. Parser a -> Parser [a] -many !p = Parser $! - do state <- get - let (# result, state' #) = many' state Seq.empty - put state' - return result - where - many' :: ParserState -> Seq a -> (# ParserResult [a], ParserState #) - many' !st !soFar - = case runState (runParser p) st of - (Success a, st') -> many' st' (soFar |> a) - (IllegalInput, _) -> (# Success (Fold.toList soFar), st #) - (ReachedEOF , _) -> if pstIsEOFFatal st then - (# ReachedEOF, st #) - else - (# Success (Fold.toList soFar), st #) - -manyChar :: Parser Char -> Parser Lazy.ByteString -manyChar !p = Parser $! - do state <- get - case scan' state 0 of - Success len - -> do let (bs, rest) = B.splitAt len (pstInput state) - state' = state { pstInput = rest } - put state' - return $ Success bs - ReachedEOF - -> if pstIsEOFFatal state then - return ReachedEOF - else - error "internal error" - _ -> error "internal error" - where - scan' :: ParserState -> Int64 -> ParserResult Int64 - scan' !st !soFar - = case runState (runParser p) st of - (Success _ , st') -> scan' st' (soFar + 1) - (IllegalInput, _ ) -> Success soFar - (ReachedEOF , _ ) -> if pstIsEOFFatal st then - ReachedEOF - else - Success soFar - - -many1 :: Parser a -> Parser [a] -many1 !p = do x <- p - xs <- many p - return (x:xs) - - -count :: Int -> Parser a -> Parser [a] -count !n !p = Parser $! count' n p Seq.empty - --- This implementation is rather ugly but we need to make it --- tail-recursive to avoid stack overflow. -count' :: Int -> Parser a -> Seq a -> State ParserState (ParserResult [a]) -count' 0 _ !soFar = return $! Success $! Fold.toList soFar -count' !n !p !soFar = do saved <- get - result <- runParser p - case result of - Success a -> count' (n-1) p (soFar |> a) - IllegalInput -> do put saved - return IllegalInput - ReachedEOF -> do put saved - return ReachedEOF - - --- def may be a _|_ -option :: a -> Parser a -> Parser a -option def !p = p <|> return def - - -sepBy :: Parser a -> Parser sep -> Parser [a] -sepBy !p !sep = sepBy1 p sep <|> return [] - - -sepBy1 :: Parser a -> Parser sep -> Parser [a] -sepBy1 !p !sep - = do x <- p - xs <- many $! sep >> p - return (x:xs) - - -sp :: Parser Char -sp = char ' ' - - -ht :: Parser Char -ht = char '\t' - - -crlf :: Parser String -crlf = string "\x0d\x0a" diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index fe54bde..5200342 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns + , OverloadedStrings + , ScopedTypeVariables , UnicodeSyntax #-} -- |This is an auxiliary parser utilities for parsing things related @@ -8,120 +10,219 @@ -- In general you don't have to use this module directly. module Network.HTTP.Lucu.Parser.Http ( isCtl + , isText , isSeparator , isChar , isToken + , isSPHT + , listOf - , token + + , crlf + , sp , lws - , text - , separator + + , token + , separators , quotedStr , qvalue + + , atMost + , manyCharsTill ) where +import Control.Applicative +import Control.Applicative.Unicode hiding ((∅)) +import Control.Monad.Unicode +import Data.Ascii (Ascii) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P hiding (scan) +import qualified Data.Attoparsec.FastSet as FS +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LS +import qualified Data.ByteString.Lazy.Internal as LS +import Data.Foldable +import Data.Monoid +import Data.Monoid.Unicode +import qualified Data.Sequence as S +import Data.Sequence.Unicode hiding ((∅)) +import Prelude.Unicode -import Network.HTTP.Lucu.Parser - --- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@. -isCtl :: Char -> Bool +-- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= c < 0x7F@. +isCtl ∷ Char → Bool +{-# INLINE isCtl #-} isCtl c - | c < '\x1f' = True - | c >= '\x7f' = True - | otherwise = False + | c ≤ '\x1f' = True + | c > '\x7f' = True + | otherwise = False + +-- |@'isText'@ is equivalent to @'not' '.' 'isCtl'@ +isText ∷ Char → Bool +{-# INLINE isText #-} +isText = (¬) ∘ isCtl -- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP -- separators. -isSeparator :: Char -> Bool -isSeparator '(' = True -isSeparator ')' = True -isSeparator '<' = True -isSeparator '>' = True -isSeparator '@' = True -isSeparator ',' = True -isSeparator ';' = True -isSeparator ':' = True -isSeparator '\\' = True -isSeparator '"' = True -isSeparator '/' = True -isSeparator '[' = True -isSeparator ']' = True -isSeparator '?' = True -isSeparator '=' = True -isSeparator '{' = True -isSeparator '}' = True -isSeparator ' ' = True -isSeparator '\t' = True -isSeparator _ = False +isSeparator ∷ Char → Bool +{-# INLINE isSeparator #-} +isSeparator = flip FS.memberChar set + where + {-# NOINLINE set #-} + set = FS.charClass "()<>@,;:\\\"/[]?={}\x20\x09" -- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@. -isChar :: Char -> Bool -isChar c - | c <= '\x7f' = True - | otherwise = False +isChar ∷ Char → Bool +{-# INLINE isChar #-} +isChar = (≤ '\x7F') -- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator' -- c)@ -isToken :: Char -> Bool -isToken c = c `seq` - not (isCtl c || isSeparator c) - --- |@'listOf' p@ is similar to @'Network.HTTP.Lucu.Parser.sepBy' p --- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any --- occurrences of LWS before and after each tokens. -listOf :: Parser a -> Parser [a] -listOf !p = do _ <- many lws - sepBy p $! do _ <- many lws - _ <- char ',' - many lws - --- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $ --- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@ -token :: Parser String -token = many1 $! satisfy isToken - --- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'? --- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@ -lws :: Parser String -lws = do s <- option "" crlf - xs <- many1 (sp <|> ht) - return (s ++ xs) - --- |'text' accepts one character which doesn't satisfy 'isCtl'. -text :: Parser Char -text = satisfy (not . isCtl) - --- |'separator' accepts one character which satisfies 'isSeparator'. -separator :: Parser Char -separator = satisfy isSeparator +isToken ∷ Char → Bool +{-# INLINE isToken #-} +isToken !c + = (¬) (isCtl c ∨ isSeparator c) + +-- |@'listOf' p@ is similar to @'sepBy' p ('char' \',\')@ but it +-- allows any occurrences of 'lws' before and after each tokens. +listOf ∷ Parser a → Parser [a] +{-# INLINEABLE listOf #-} +listOf p + = do skipMany lws + sepBy p $ do skipMany lws + _ <- char ',' + skipMany lws + +-- |'token' is similar to @'takeWhile1' 'isToken'@ +token ∷ Parser Ascii +{-# INLINE token #-} +token = A.unsafeFromByteString <$> takeWhile1 isToken + +-- |The CRLF: 0x0D 0x0A. +crlf ∷ Parser () +{-# INLINE crlf #-} +crlf = string "\x0D\x0A" ≫ return () + +-- |The SP: 0x20. +sp ∷ Parser () +{-# INLINE sp #-} +sp = char '\x20' ≫ return () + +-- |HTTP LWS: crlf? (sp | ht)+ +lws ∷ Parser () +{-# INLINEABLE lws #-} +lws = do option () crlf + _ ← takeWhile1 isSPHT + return () + +-- |Returns 'True' for SP and HT. +isSPHT ∷ Char → Bool +{-# INLINE isSPHT #-} +isSPHT '\x20' = True +isSPHT '\x09' = True +isSPHT _ = False + +-- |@'separators'@ is similar to @'takeWhile1' 'isSeparator'@. +separators ∷ Parser Ascii +{-# INLINE separators #-} +separators = A.unsafeFromByteString <$> takeWhile1 isSeparator -- |'quotedStr' accepts a string surrounded by double quotation -- marks. Quotes can be escaped by backslashes. -quotedStr :: Parser String -quotedStr = do _ <- char '"' - xs <- many (qdtext <|> quotedPair) - _ <- char '"' - return $ foldr (++) "" xs +quotedStr ∷ Parser Ascii +{-# INLINEABLE quotedStr #-} +quotedStr = try $ + do _ ← char '"' + xs ← P.many (qdtext <|> quotedPair) + _ ← char '"' + return $ A.unsafeFromByteString $ BS.pack xs where - qdtext = do c <- satisfy (/= '"') - return [c] + qdtext ∷ Parser Char + {-# INLINE qdtext #-} + qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c)) - quotedPair = do _ <- char '\\' - c <- satisfy isChar - return [c] + quotedPair ∷ Parser Char + {-# INLINE quotedPair #-} + quotedPair = char '\\' ≫ satisfy isChar -- |'qvalue' accepts a so-called qvalue. -qvalue :: Parser Double -qvalue = do x <- char '0' - xs <- option "" - $ do y <- char '.' - ys <- many digit -- 本當は三文字までに制限 - return (y:ys) +qvalue ∷ Parser Double +{-# INLINEABLE qvalue #-} +qvalue = do x ← char '0' + xs ← option "" $ + do y ← char '.' + ys ← atMost 3 digit + return (y:ys) return $ read (x:xs) <|> - do x <- char '1' - xs <- option "" - $ do y <- char '.' - ys <- many (char '0') -- 本當は三文字までに制限 - return (y:ys) + do x ← char '1' + xs ← option "" $ + do y ← char '.' + ys ← atMost 3 (char '0') + return (y:ys) return $ read (x:xs) + +-- |@'atMost' n v@ is like @'P.many' v@ but applies the given action +-- at most @n@ times. +atMost ∷ Alternative f ⇒ Int → f a → f [a] +{-# INLINE atMost #-} +atMost 0 _ = pure [] +atMost n v = ( (:) <$> v ⊛ atMost (n-1) v ) + <|> + pure [] + + +data CharAccumState + = CharAccumState { + casChunks ∷ !(S.Seq BS.ByteString) + , casLastChunk ∷ !(S.Seq Char) + } + +instance Monoid CharAccumState where + mempty + = CharAccumState { + casChunks = (∅) + , casLastChunk = (∅) + } + mappend a b + = b { + casChunks = (casChunks a ⊳ lastChunk a) ⋈ casChunks b + } + +lastChunk ∷ CharAccumState → BS.ByteString +{-# INLINE lastChunk #-} +lastChunk = BS.pack ∘ toList ∘ casLastChunk + +snoc ∷ CharAccumState → Char → CharAccumState +{-# INLINEABLE snoc #-} +snoc cas c + | S.length (casLastChunk cas) ≥ LS.defaultChunkSize + = cas { + casChunks = casChunks cas ⊳ lastChunk cas + , casLastChunk = S.singleton c + } + | otherwise + = cas { + casLastChunk = casLastChunk cas ⊳ c + } + +finish ∷ CharAccumState → LS.ByteString +{-# INLINEABLE finish #-} +finish cas + = let chunks = toList $ casChunks cas ⊳ lastChunk cas + str = LS.fromChunks chunks + in + str + +manyCharsTill ∷ ∀m b. (Monad m, Alternative m) + ⇒ m Char + → m b + → m LS.ByteString +{-# INLINEABLE manyCharsTill #-} +manyCharsTill p end = scan (∅) + where + scan ∷ CharAccumState → m LS.ByteString + {-# INLINE scan #-} + scan s + = (end *> pure (finish s)) + <|> + (scan =≪ (snoc s <$> p)) diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 806ed1c..49c95e8 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns + , DoAndIfThenElse + , OverloadedStrings , UnicodeSyntax #-} module Network.HTTP.Lucu.Postprocess @@ -7,24 +9,29 @@ module Network.HTTP.Lucu.Postprocess , completeUnconditionalHeaders ) where - -import Control.Concurrent.STM -import Control.Monad +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Unicode +import Data.Ascii (Ascii, CIAscii) +import qualified Data.Ascii as A import qualified Data.ByteString as Strict (ByteString) import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Data.IORef -import Data.Maybe -import Data.Time +import Data.IORef +import Data.Maybe +import Data.Monoid.Unicode +import Data.Time 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.Headers -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import System.IO.Unsafe +import GHC.Conc (unsafeIOToSTM) +import Network.HTTP.Lucu.Abortion +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 Prelude.Unicode +import System.IO.Unsafe {- @@ -59,122 +66,107 @@ import System.IO.Unsafe -} -postprocess :: Interaction -> STM () +postprocess ∷ Interaction → STM () postprocess !itr - = do reqM <- readItr itr itrRequest id - res <- readItr itr itrResponse id + = do reqM ← readItr itr itrRequest id + res ← readItr itr itrResponse id let sc = resStatus res - unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError]) - $ abortSTM InternalServerError [] - $ Just ("The status code is not good for a final status: " - ++ show sc) - - when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing) - $ abortSTM InternalServerError [] - $ Just ("The status was " ++ show sc ++ " but no Allow header.") - - when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing) - $ abortSTM InternalServerError [] - $ Just ("The status code was " ++ show sc ++ " but no Location header.") + unless (any (\ p → p sc) [isSuccessful, isRedirection, isError]) + $ abortSTM InternalServerError [] + $ Just + $ A.toText ( "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 ( "The status was " + ⊕ printStatusCode sc + ⊕ " but no Allow header." ) + + when (sc /= NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing) + $ abortSTM InternalServerError [] + $ Just + $ A.toText ( "The status code was " + ⊕ printStatusCode sc + ⊕ " but no Location header." ) when (reqM /= Nothing) relyOnRequest -- itrResponse の内容は relyOnRequest によって變へられてゐる可 -- 能性が高い。 - do oldRes <- readItr itr itrResponse id - newRes <- unsafeIOToSTM - $ completeUnconditionalHeaders (itrConfig itr) oldRes + do oldRes ← readItr itr itrResponse id + newRes ← unsafeIOToSTM + $ completeUnconditionalHeaders (itrConfig itr) oldRes writeItr itr itrResponse newRes where - relyOnRequest :: STM () + relyOnRequest ∷ STM () relyOnRequest - = do status <- readItr itr itrResponse resStatus - req <- readItr itr itrRequest fromJust + = do status ← readItr itr itrResponse resStatus + req ← readItr itr itrRequest fromJust let reqVer = reqVersion req - canHaveBody = if reqMethod req == HEAD then + canHaveBody = if reqMethod req ≡ HEAD then False else - not (isInformational status || - status == NoContent || - status == ResetContent || - status == NotModified ) + not (isInformational status ∨ + status ≡ NoContent ∨ + status ≡ ResetContent ∨ + status ≡ NotModified ) - updateRes $! deleteHeader (C8.pack "Content-Length") - updateRes $! deleteHeader (C8.pack "Transfer-Encoding") + updateRes $ deleteHeader "Content-Length" + updateRes $ deleteHeader "Transfer-Encoding" - cType <- readHeader (C8.pack "Content-Type") - when (cType == Nothing) - $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType + cType ← readHeader "Content-Type" + when (cType ≡ Nothing) + $ updateRes $ setHeader "Content-Type" defaultPageContentType if canHaveBody then - when (reqVer == HttpVersion 1 1) - $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked") - writeItr itr itrWillChunkBody True - else + when (reqVer ≡ HttpVersion 1 1) + $ do updateRes $ setHeader "Transfer-Encoding" "chunked" + writeItr itr itrWillChunkBody True + else -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す when (reqMethod req /= HEAD) - $ do updateRes $! deleteHeader (C8.pack "Content-Type") - updateRes $! deleteHeader (C8.pack "Etag") - updateRes $! deleteHeader (C8.pack "Last-Modified") + $ do updateRes $ deleteHeader "Content-Type" + updateRes $ deleteHeader "Etag" + updateRes $ deleteHeader "Last-Modified" - conn <- readHeader (C8.pack "Connection") + conn ← readHeader "Connection" case conn of - Nothing -> return () - Just value -> when (value `noCaseEq` C8.pack "close") - $ writeItr itr itrWillClose True + Nothing → return () + Just value → when (A.toCIAscii value ≡ "close") + $ writeItr itr itrWillClose True - willClose <- readItr itr itrWillClose id + willClose ← readItr itr itrWillClose id when willClose - $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close") + $ updateRes $ setHeader "Connection" "close" - when (reqMethod req == HEAD || not canHaveBody) - $ writeTVar (itrWillDiscardBody itr) True + when (reqMethod req ≡ HEAD ∨ not canHaveBody) + $ writeTVar (itrWillDiscardBody itr) True - readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString) - readHeader !name - = readItr itr itrResponse $ getHeader name + readHeader ∷ CIAscii → STM (Maybe Ascii) + {-# INLINE readHeader #-} + readHeader = readItr itr itrResponse ∘ getHeader - updateRes :: (Response -> Response) -> STM () - updateRes !updator - = updateItr itr itrResponse updator + updateRes ∷ (Response → Response) → STM () + {-# INLINE updateRes #-} + updateRes = updateItr itr itrResponse - -completeUnconditionalHeaders :: Config -> Response -> IO Response -completeUnconditionalHeaders !conf !res - = compServer res >>= compDate +completeUnconditionalHeaders ∷ Config → Response → IO Response +completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer where compServer res' - = case getHeader (C8.pack "Server") res' of - Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res' - Just _ -> return res' + = case getHeader "Server" res' of + Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res' + Just _ → return res' compDate res' - = case getHeader (C8.pack "Date") res' of - Nothing -> do date <- getCurrentDate - return $ setHeader (C8.pack "Date") date res' - Just _ -> return res' - - -cache :: IORef (UTCTime, Strict.ByteString) -cache = unsafePerformIO $ - newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined) -{-# NOINLINE cache #-} - -getCurrentDate :: IO Strict.ByteString -getCurrentDate = do now <- getCurrentTime - (cachedTime, cachedStr) <- readIORef cache - - if now `mostlyEq` cachedTime then - return cachedStr - else - do let dateStr = C8.pack $ HTTP.format now - writeIORef cache (now, dateStr) - return dateStr - where - mostlyEq :: UTCTime -> UTCTime -> Bool - mostlyEq a b - = (utctDay a == utctDay b) - && - (fromEnum (utctDayTime a) == fromEnum (utctDayTime b)) + = case getHeader "Date" res' of + Nothing → do date ← getCurrentDate + return $ setHeader "Date" date res' + Just _ → return res' + +getCurrentDate ∷ IO Ascii +getCurrentDate = HTTP.format <$> getCurrentTime diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs new file mode 100644 index 0000000..0f2eb13 --- /dev/null +++ b/Network/HTTP/Lucu/RFC2231.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , ScopedTypeVariables + , UnicodeSyntax + #-} +-- |Provide facilities to encode/decode MIME parameter values in +-- character sets other than US-ASCII. See: +-- http://www.faqs.org/rfcs/rfc2231.html +module Network.HTTP.Lucu.RFC2231 + ( printParams + , paramsP + ) + where +import Control.Applicative +import qualified Control.Exception as E +import Control.Monad.Unicode +import Data.Ascii (Ascii, CIAscii, AsciiBuilder) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P +import Data.Bits +import qualified Data.ByteString.Char8 as BS +import Data.Char +import Data.Foldable +import Data.Map (Map) +import qualified Data.Map as M +import Data.Monoid.Unicode +import Data.Sequence (Seq, ViewL(..)) +import qualified Data.Sequence as S +import Data.Sequence.Unicode hiding ((∅)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.ICU.Convert as TC +import Data.Text.ICU.Error +import Data.Text.Encoding +import Data.Traversable +import Data.Word +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.Utils +import Prelude hiding (concat, mapM, takeWhile) +import Prelude.Unicode +import System.IO.Unsafe + +printParams ∷ Map CIAscii Text → AsciiBuilder +printParams params + | M.null params = (∅) + | otherwise = A.toAsciiBuilder "; " ⊕ + joinWith "; " (map printPair $ M.toList params) + +printPair ∷ (CIAscii, Text) → AsciiBuilder +printPair (name, value) + | T.any (> '\xFF') value + = printPairInUTF8 name value + | otherwise + = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value) + +printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder +printPairInUTF8 name value + = A.toAsciiBuilder (A.fromCIAscii name) ⊕ + A.toAsciiBuilder "*=utf-8''" ⊕ + escapeUnsafeChars (encodeUtf8 value) (∅) + +printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder +printPairInAscii name value + = A.toAsciiBuilder (A.fromCIAscii name) ⊕ + A.toAsciiBuilder "=" ⊕ + if BS.any ((¬) ∘ isToken) (A.toByteString value) then + quoteStr value + else + A.toAsciiBuilder value + +escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder +escapeUnsafeChars bs b + = case BS.uncons bs of + Nothing → b + Just (c, bs') + | isToken c → escapeUnsafeChars bs' $ + b ⊕ A.toAsciiBuilder (A.unsafeFromString [c]) + | otherwise → escapeUnsafeChars bs' $ + b ⊕ toHex (fromIntegral $ fromEnum c) + +toHex ∷ Word8 → AsciiBuilder +toHex o = A.toAsciiBuilder "%" ⊕ + A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8) + , toHex' (o .&. 0x0F) ]) + +toHex' ∷ Word8 → Char +toHex' o + | o ≤ 0x09 = toEnum $ fromIntegral $ fromEnum '0' + fromIntegral o + | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (o - 0x0A) + + +data ExtendedParam + = InitialEncodedParam { + epName ∷ !CIAscii + , epCharset ∷ !CIAscii + , epPayload ∷ !BS.ByteString + } + | ContinuedEncodedParam { + epName ∷ !CIAscii + , epSection ∷ !Integer + , epPayload ∷ !BS.ByteString + } + | AsciiParam { + epName ∷ !CIAscii + , epSection ∷ !Integer + , apPayload ∷ !Ascii + } + +section ∷ ExtendedParam → Integer +section (InitialEncodedParam {..}) = 0 +section ep = epSection ep + +paramsP ∷ Parser (Map CIAscii Text) +paramsP = decodeParams =≪ P.many (try paramP) + +paramP ∷ Parser ExtendedParam +paramP = do skipMany lws + _ ← char ';' + skipMany lws + epm ← nameP + _ ← char '=' + case epm of + (name, 0, True) + → do (charset, payload) ← initialEncodedValue + return $ InitialEncodedParam name charset payload + (name, sect, True) + → do payload ← encodedPayload + return $ ContinuedEncodedParam name sect payload + (name, sect, False) + → do payload ← token <|> quotedStr + return $ AsciiParam name sect payload + +nameP ∷ Parser (CIAscii, Integer, Bool) +nameP = do name ← (A.toCIAscii ∘ A.unsafeFromByteString) <$> + takeWhile1 (\c → isToken c ∧ c ≢ '*') + sect ← option 0 $ + try $ + do _ ← char '*' + n ← decimal + return n + isEncoded ← option False $ + do _ ← char '*' + return True + return (name, sect, isEncoded) + +initialEncodedValue ∷ Parser (CIAscii, BS.ByteString) +initialEncodedValue + = do charset ← metadata + _ ← char '\'' + _ ← metadata -- Ignore the language tag + _ ← char '\'' + payload ← encodedPayload + if charset ≡ "" then + -- NOTE: I'm not sure this is the right thing, but RFC + -- 2231 doesn't tell us what we should do when the + -- charset is omitted. + return ("US-ASCII", payload) + else + return (charset, payload) + where + metadata ∷ Parser CIAscii + metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$> + takeWhile (\c → isToken c ∧ c ≢ '\'') + +encodedPayload ∷ Parser BS.ByteString +encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars) + +hexChar ∷ Parser BS.ByteString +hexChar = do _ ← char '%' + h ← satisfy isHexChar + l ← satisfy isHexChar + return $ BS.singleton $ hexToChar h l + +isHexChar ∷ Char → Bool +isHexChar = inClass "0-9a-fA-F" + +hexToChar ∷ Char → Char → Char +hexToChar h l + = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l + +hexToInt ∷ Char → Int +hexToInt c + | c ≤ '9' = ord c - ord '0' + | c ≤ 'F' = ord c - ord 'A' + 10 + | otherwise = ord c - ord 'a' + 10 + +rawChars ∷ Parser BS.ByteString +rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%') + +decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text) +decodeParams = (mapM decodeSections =≪) ∘ sortBySection + +sortBySection ∷ ∀m. Monad m + ⇒ [ExtendedParam] + → m (Map CIAscii (Map Integer ExtendedParam)) +sortBySection = flip go (∅) + where + go ∷ [ExtendedParam] + → Map CIAscii (Map Integer ExtendedParam) + → m (Map CIAscii (Map Integer ExtendedParam)) + go [] m = return m + go (x:xs) m + = case M.lookup (epName x) m of + Nothing + → let s = M.singleton (section x) x + m' = M.insert (epName x) s m + in + go xs m' + Just s + → case M.insertLookupWithKey (\_ s' _ → s') (section x) x s of + (Nothing, s') + → let m' = M.insert (epName x) s' m + in + go xs m' + (Just _, _) + → fail (concat [ "Duplicate section " + , show $ section x + , " for parameter '" + , A.toString $ A.fromCIAscii $ epName x + , "'" + ]) + +decodeSections ∷ ∀m. Monad m ⇒ Map Integer ExtendedParam → m Text +decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) + where + toSeq ∷ Map Integer ExtendedParam + → Integer + → Seq ExtendedParam + → m (Seq ExtendedParam) + toSeq m expectedSect sects + = case M.minViewWithKey m of + Nothing + → return sects + Just ((sect, p), m') + | sect ≡ expectedSect + → toSeq m' (expectedSect + 1) (sects ⊳ p) + | otherwise + → fail (concat [ "Missing section " + , show $ section p + , " for parameter '" + , A.toString $ A.fromCIAscii $ epName p + , "'" + ]) + + decodeSeq ∷ Seq ExtendedParam → m Text + decodeSeq sects + = case S.viewl sects of + EmptyL + → fail "decodeSeq: internal error: empty seq" + InitialEncodedParam {..} :< xs + → do conv ← openConv epCharset + let t = TC.toUnicode conv epPayload + decodeSeq' (Just conv) xs $ S.singleton t + ContinuedEncodedParam {..} :< _ + → fail "decodeSeq: internal error: CEP at section 0" + AsciiParam {..} :< xs + → let t = A.toText apPayload + in + decodeSeq' Nothing xs $ S.singleton t + + decodeSeq' ∷ Maybe (TC.Converter) + → Seq ExtendedParam + → Seq Text + → m Text + decodeSeq' convM sects chunks + = case S.viewl sects of + EmptyL + → return $ T.concat $ toList chunks + InitialEncodedParam {..} :< _ + → fail "decodeSeq': internal error: IEP at section > 0" + ContinuedEncodedParam {..} :< xs + → case convM of + Just conv + → let t = TC.toUnicode conv epPayload + in + decodeSeq' convM xs $ chunks ⊳ t + Nothing + → fail (concat [ "Section " + , show epSection + , " for parameter '" + , A.toString $ A.fromCIAscii epName + , "' is encoded but its first section is not" + ]) + AsciiParam {..} :< xs + → let t = A.toText apPayload + in + decodeSeq' convM xs $ chunks ⊳ t + + openConv ∷ CIAscii → m TC.Converter + openConv charset + = let cs = A.toString $ A.fromCIAscii charset + open' = TC.open cs (Just True) + in + case unsafePerformIO $ E.try open' of + Right conv → return conv + Left err → fail $ show (err ∷ ICUError) diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index 712a610..b690c3e 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} {-# OPTIONS_HADDOCK prune #-} -- |Definition of things related on HTTP request. @@ -9,12 +13,16 @@ module Network.HTTP.Lucu.Request , requestP ) where - -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.URI +import Control.Applicative +import Control.Monad.Unicode +import Data.Ascii (Ascii) +import Data.Attoparsec.Char8 +import qualified Data.ByteString.Char8 as C8 +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Parser.Http +import Network.URI +import Prelude.Unicode -- |This is the definition of HTTP request methods, which shouldn't -- require any description. @@ -26,28 +34,27 @@ data Method = OPTIONS | DELETE | TRACE | CONNECT - | ExtensionMethod !String + | ExtensionMethod !Ascii deriving (Eq, Show) -- |This is the definition of HTTP reqest. data Request = Request { - reqMethod :: !Method - , reqURI :: !URI - , reqVersion :: !HttpVersion - , reqHeaders :: !Headers + reqMethod ∷ !Method + , reqURI ∷ !URI + , reqVersion ∷ !HttpVersion + , reqHeaders ∷ !Headers } - deriving (Show, Eq) + deriving (Eq, Show) instance HasHeaders Request where getHeaders = reqHeaders setHeaders req hdr = req { reqHeaders = hdr } - -requestP :: Parser Request -requestP = do _ <- many crlf - (method, uri, version) <- requestLineP - headers <- headersP +requestP ∷ Parser Request +requestP = do skipMany crlf + (method, uri, version) ← requestLineP + headers ← headersP return Request { reqMethod = method , reqURI = uri @@ -55,35 +62,31 @@ requestP = do _ <- many crlf , reqHeaders = headers } - -requestLineP :: Parser (Method, URI, HttpVersion) -requestLineP = do method <- methodP - _ <- sp - uri <- uriP - _ <- sp - ver <- httpVersionP - _ <- crlf +requestLineP ∷ Parser (Method, URI, HttpVersion) +requestLineP = do method ← methodP + sp + uri ← uriP + sp + ver ← httpVersionP + crlf return (method, uri, ver) +methodP ∷ Parser Method +methodP = choice + [ string "OPTIONS" ≫ return OPTIONS + , string "GET" ≫ return GET + , string "HEAD" ≫ return HEAD + , string "POST" ≫ return POST + , string "PUT" ≫ return PUT + , string "DELETE" ≫ return DELETE + , string "TRACE" ≫ return TRACE + , string "CONNECT" ≫ return CONNECT + , ExtensionMethod <$> token + ] -methodP :: Parser Method -methodP = ( let methods = [ ("OPTIONS", OPTIONS) - , ("GET" , GET ) - , ("HEAD" , HEAD ) - , ("POST" , POST ) - , ("PUT" , PUT ) - , ("DELETE" , DELETE ) - , ("TRACE" , TRACE ) - , ("CONNECT", CONNECT) - ] - in choice $ map (\ (str, mth) - -> string str >> return mth) methods ) - <|> - fmap ExtensionMethod token - - -uriP :: Parser URI -uriP = do str <- many1 $ satisfy (\ c -> not (isCtl c || c == ' ')) +uriP ∷ Parser URI +uriP = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20')) + let str = C8.unpack bs case parseURIReference str of - Nothing -> failP - Just uri -> return uri \ No newline at end of file + Nothing -> fail ("Unparsable URI: " ⧺ str) + Just uri -> return uri diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index d3b8daa..ab8e5c7 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -7,7 +7,6 @@ module Network.HTTP.Lucu.RequestReader ( requestReader ) where - import Control.Concurrent.STM import Control.Exception import Control.Monad @@ -23,7 +22,6 @@ import Network.HTTP.Lucu.Chunk import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.HandleLike import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Preprocess import Network.HTTP.Lucu.Request diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index fa08fa5..3bc7524 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -139,7 +139,6 @@ module Network.HTTP.Lucu.Resource , driftTo ) where - import Control.Concurrent.STM import Control.Monad.Reader import qualified Data.ByteString as Strict (ByteString) @@ -161,7 +160,6 @@ import qualified Network.HTTP.Lucu.Headers as H import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.MultipartForm -import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index adf8505..2791616 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,7 +1,10 @@ {-# LANGUAGE DeriveDataTypeable + , OverloadedStrings + , RecordWildCards , UnboxedTuples , UnicodeSyntax + , ViewPatterns #-} {-# OPTIONS_HADDOCK prune #-} @@ -9,6 +12,7 @@ module Network.HTTP.Lucu.Response ( StatusCode(..) , Response(..) + , printStatusCode , hPutResponse , isInformational , isSuccessful @@ -19,14 +23,15 @@ module Network.HTTP.Lucu.Response , statusCode ) where - -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Data.Typeable -import Network.HTTP.Lucu.Format -import Network.HTTP.Lucu.HandleLike -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion +import Data.Ascii (Ascii) +import qualified Data.Ascii as A +import Data.Monoid.Unicode +import Data.Typeable +import Network.HTTP.Lucu.Format +import Network.HTTP.Lucu.HandleLike +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Prelude.Unicode -- |This is the definition of HTTP status code. -- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named statuses @@ -82,126 +87,120 @@ data StatusCode = Continue | GatewayTimeout | HttpVersionNotSupported | InsufficientStorage - deriving (Typeable, Eq) - -instance Show StatusCode where - show sc = case statusCode sc of - (# num, msg #) - -> (fmtDec 3 num) ++ " " ++ C8.unpack msg + deriving (Eq, Show, Typeable) +-- |Convert a 'StatusCode' to 'Ascii'. +printStatusCode ∷ StatusCode → Ascii +printStatusCode (statusCode → (# num, msg #)) + = A.fromAsciiBuilder $ + ( fmtDec 3 num ⊕ + A.toAsciiBuilder " " ⊕ + A.toAsciiBuilder msg + ) data Response = Response { - resVersion :: !HttpVersion - , resStatus :: !StatusCode - , resHeaders :: !Headers + resVersion ∷ !HttpVersion + , resStatus ∷ !StatusCode + , resHeaders ∷ !Headers } deriving (Show, Eq) - instance HasHeaders Response where getHeaders = resHeaders setHeaders res hdr = res { resHeaders = hdr } - -hPutResponse :: HandleLike h => h -> Response -> IO () -hPutResponse h res - = h `seq` res `seq` - do hPutHttpVersion h (resVersion res) +hPutResponse ∷ HandleLike h ⇒ h → Response → IO () +hPutResponse h (Response {..}) + = do hPutHttpVersion h resVersion hPutChar h ' ' - hPutStatus h (resStatus res) - hPutBS h (C8.pack "\r\n") - hPutHeaders h (resHeaders res) - -hPutStatus :: HandleLike h => h -> StatusCode -> IO () -hPutStatus h sc - = h `seq` sc `seq` - case statusCode sc of - (# num, msg #) - -> do hPutStr h (fmtDec 3 num) - hPutChar h ' ' - hPutBS h msg + hPutStatus h resStatus + hPutBS h "\r\n" + hPutHeaders h resHeaders +hPutStatus ∷ HandleLike h ⇒ h → StatusCode → IO () +hPutStatus h (statusCode → (# num, msg #)) + = do hPutBS h (A.toByteString $ A.fromAsciiBuilder $ fmtDec 3 num) + hPutChar h ' ' + hPutBS h (A.toByteString msg) -- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@. -isInformational :: StatusCode -> Bool +isInformational ∷ StatusCode → Bool isInformational = doesMeet (< 200) -- |@'isSuccessful' sc@ is 'Prelude.True' iff @200 <= sc < 300@. -isSuccessful :: StatusCode -> Bool -isSuccessful = doesMeet (\ n -> n >= 200 && n < 300) +isSuccessful ∷ StatusCode → Bool +isSuccessful = doesMeet (\ n → n ≥ 200 ∧ n < 300) -- |@'isRedirection' sc@ is 'Prelude.True' iff @300 <= sc < 400@. -isRedirection :: StatusCode -> Bool -isRedirection = doesMeet (\ n -> n >= 300 && n < 400) +isRedirection ∷ StatusCode → Bool +isRedirection = doesMeet (\ n → n ≥ 300 ∧ n < 400) -- |@'isError' sc@ is 'Prelude.True' iff @400 <= sc@ -isError :: StatusCode -> Bool -isError = doesMeet (>= 400) +isError ∷ StatusCode → Bool +isError = doesMeet (≥ 400) -- |@'isClientError' sc@ is 'Prelude.True' iff @400 <= sc < 500@. -isClientError :: StatusCode -> Bool -isClientError = doesMeet (\ n -> n >= 400 && n < 500) +isClientError ∷ StatusCode → Bool +isClientError = doesMeet (\ n → n ≥ 400 ∧ n < 500) -- |@'isServerError' sc@ is 'Prelude.True' iff @500 <= sc@. -isServerError :: StatusCode -> Bool -isServerError = doesMeet (>= 500) - - -doesMeet :: (Int -> Bool) -> StatusCode -> Bool -doesMeet p sc = case statusCode sc of - (# num, _ #) -> p num +isServerError ∷ StatusCode → Bool +isServerError = doesMeet (≥ 500) +doesMeet ∷ (Int → Bool) → StatusCode → Bool +{-# INLINE doesMeet #-} +doesMeet p (statusCode → (# num, _ #)) = p num -- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual -- representation of @sc@. -statusCode :: StatusCode -> (# Int, Strict.ByteString #) - -statusCode Continue = (# 100, C8.pack "Continue" #) -statusCode SwitchingProtocols = (# 101, C8.pack "Switching Protocols" #) -statusCode Processing = (# 102, C8.pack "Processing" #) - -statusCode Ok = (# 200, C8.pack "OK" #) -statusCode Created = (# 201, C8.pack "Created" #) -statusCode Accepted = (# 202, C8.pack "Accepted" #) -statusCode NonAuthoritativeInformation = (# 203, C8.pack "Non Authoritative Information" #) -statusCode NoContent = (# 204, C8.pack "No Content" #) -statusCode ResetContent = (# 205, C8.pack "Reset Content" #) -statusCode PartialContent = (# 206, C8.pack "Partial Content" #) -statusCode MultiStatus = (# 207, C8.pack "Multi Status" #) - -statusCode MultipleChoices = (# 300, C8.pack "Multiple Choices" #) -statusCode MovedPermanently = (# 301, C8.pack "Moved Permanently" #) -statusCode Found = (# 302, C8.pack "Found" #) -statusCode SeeOther = (# 303, C8.pack "See Other" #) -statusCode NotModified = (# 304, C8.pack "Not Modified" #) -statusCode UseProxy = (# 305, C8.pack "Use Proxy" #) -statusCode TemporaryRedirect = (# 306, C8.pack "Temporary Redirect" #) - -statusCode BadRequest = (# 400, C8.pack "Bad Request" #) -statusCode Unauthorized = (# 401, C8.pack "Unauthorized" #) -statusCode PaymentRequired = (# 402, C8.pack "Payment Required" #) -statusCode Forbidden = (# 403, C8.pack "Forbidden" #) -statusCode NotFound = (# 404, C8.pack "Not Found" #) -statusCode MethodNotAllowed = (# 405, C8.pack "Method Not Allowed" #) -statusCode NotAcceptable = (# 406, C8.pack "Not Acceptable" #) -statusCode ProxyAuthenticationRequired = (# 407, C8.pack "Proxy Authentication Required" #) -statusCode RequestTimeout = (# 408, C8.pack "Request Timeout" #) -statusCode Conflict = (# 409, C8.pack "Conflict" #) -statusCode Gone = (# 410, C8.pack "Gone" #) -statusCode LengthRequired = (# 411, C8.pack "Length Required" #) -statusCode PreconditionFailed = (# 412, C8.pack "Precondition Failed" #) -statusCode RequestEntityTooLarge = (# 413, C8.pack "Request Entity Too Large" #) -statusCode RequestURITooLarge = (# 414, C8.pack "Request URI Too Large" #) -statusCode UnsupportedMediaType = (# 415, C8.pack "Unsupported Media Type" #) -statusCode RequestRangeNotSatisfiable = (# 416, C8.pack "Request Range Not Satisfiable" #) -statusCode ExpectationFailed = (# 417, C8.pack "Expectation Failed" #) -statusCode UnprocessableEntitiy = (# 422, C8.pack "Unprocessable Entity" #) -statusCode Locked = (# 423, C8.pack "Locked" #) -statusCode FailedDependency = (# 424, C8.pack "Failed Dependency" #) - -statusCode InternalServerError = (# 500, C8.pack "Internal Server Error" #) -statusCode NotImplemented = (# 501, C8.pack "Not Implemented" #) -statusCode BadGateway = (# 502, C8.pack "Bad Gateway" #) -statusCode ServiceUnavailable = (# 503, C8.pack "Service Unavailable" #) -statusCode GatewayTimeout = (# 504, C8.pack "Gateway Timeout" #) -statusCode HttpVersionNotSupported = (# 505, C8.pack "HTTP Version Not Supported" #) -statusCode InsufficientStorage = (# 507, C8.pack "Insufficient Storage" #) \ No newline at end of file +statusCode ∷ StatusCode → (# Int, Ascii #) + +statusCode Continue = (# 100, "Continue" #) +statusCode SwitchingProtocols = (# 101, "Switching Protocols" #) +statusCode Processing = (# 102, "Processing" #) + +statusCode Ok = (# 200, "OK" #) +statusCode Created = (# 201, "Created" #) +statusCode Accepted = (# 202, "Accepted" #) +statusCode NonAuthoritativeInformation = (# 203, "Non Authoritative Information" #) +statusCode NoContent = (# 204, "No Content" #) +statusCode ResetContent = (# 205, "Reset Content" #) +statusCode PartialContent = (# 206, "Partial Content" #) +statusCode MultiStatus = (# 207, "Multi Status" #) + +statusCode MultipleChoices = (# 300, "Multiple Choices" #) +statusCode MovedPermanently = (# 301, "Moved Permanently" #) +statusCode Found = (# 302, "Found" #) +statusCode SeeOther = (# 303, "See Other" #) +statusCode NotModified = (# 304, "Not Modified" #) +statusCode UseProxy = (# 305, "Use Proxy" #) +statusCode TemporaryRedirect = (# 306, "Temporary Redirect" #) + +statusCode BadRequest = (# 400, "Bad Request" #) +statusCode Unauthorized = (# 401, "Unauthorized" #) +statusCode PaymentRequired = (# 402, "Payment Required" #) +statusCode Forbidden = (# 403, "Forbidden" #) +statusCode NotFound = (# 404, "Not Found" #) +statusCode MethodNotAllowed = (# 405, "Method Not Allowed" #) +statusCode NotAcceptable = (# 406, "Not Acceptable" #) +statusCode ProxyAuthenticationRequired = (# 407, "Proxy Authentication Required" #) +statusCode RequestTimeout = (# 408, "Request Timeout" #) +statusCode Conflict = (# 409, "Conflict" #) +statusCode Gone = (# 410, "Gone" #) +statusCode LengthRequired = (# 411, "Length Required" #) +statusCode PreconditionFailed = (# 412, "Precondition Failed" #) +statusCode RequestEntityTooLarge = (# 413, "Request Entity Too Large" #) +statusCode RequestURITooLarge = (# 414, "Request URI Too Large" #) +statusCode UnsupportedMediaType = (# 415, "Unsupported Media Type" #) +statusCode RequestRangeNotSatisfiable = (# 416, "Request Range Not Satisfiable" #) +statusCode ExpectationFailed = (# 417, "Expectation Failed" #) +statusCode UnprocessableEntitiy = (# 422, "Unprocessable Entity" #) +statusCode Locked = (# 423, "Locked" #) +statusCode FailedDependency = (# 424, "Failed Dependency" #) + +statusCode InternalServerError = (# 500, "Internal Server Error" #) +statusCode NotImplemented = (# 501, "Not Implemented" #) +statusCode BadGateway = (# 502, "Bad Gateway" #) +statusCode ServiceUnavailable = (# 503, "Service Unavailable" #) +statusCode GatewayTimeout = (# 504, "Gateway Timeout" #) +statusCode HttpVersionNotSupported = (# 505, "HTTP Version Not Supported" #) +statusCode InsufficientStorage = (# 507, "Insufficient Storage" #) diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index dbc65ac..d254169 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns + , OverloadedStrings , UnicodeSyntax #-} -- |Utility functions used internally in the Lucu httpd. These @@ -7,61 +8,60 @@ module Network.HTTP.Lucu.Utils ( splitBy , joinWith - , trim - , isWhiteSpace , quoteStr , parseWWWFormURLEncoded ) where import Control.Monad -import Data.List hiding (last) +import Data.Ascii (Ascii, AsciiBuilder) +import qualified Data.Ascii as A +import qualified Data.ByteString.Char8 as BS +import Data.List hiding (last) +import Data.Monoid.Unicode import Network.URI -import Prelude hiding (last) +import Prelude hiding (last) import Prelude.Unicode -- |> splitBy (== ':') "ab:c:def" -- > ==> ["ab", "c", "def"] -splitBy :: (a -> Bool) -> [a] -> [[a]] +splitBy ∷ (a → Bool) → [a] → [[a]] splitBy isSep src = case break isSep src - of (last , [] ) -> [last] - (first, _sep:rest) -> first : splitBy isSep rest + of (last , [] ) → [last] + (first, _sep:rest) → first : splitBy isSep rest -- |> joinWith ":" ["ab", "c", "def"] -- > ==> "ab:c:def" -joinWith :: [a] -> [[a]] -> [a] -joinWith = (join .) . intersperse - --- |> trim (== '_') "__ab_c__def___" --- > ==> "ab_c__def" -trim :: (a -> Bool) -> [a] -> [a] -trim !p = trimTail . trimHead +joinWith ∷ Ascii → [AsciiBuilder] → AsciiBuilder +{-# INLINEABLE joinWith #-} +joinWith sep = flip go (∅) where - trimHead = dropWhile p - trimTail = reverse . trimHead . reverse - --- |@'isWhiteSpace' c@ is 'Prelude.True' iff c is one of SP, HT, CR --- and LF. -isWhiteSpace :: Char -> Bool -isWhiteSpace ' ' = True -isWhiteSpace '\t' = True -isWhiteSpace '\r' = True -isWhiteSpace '\n' = True -isWhiteSpace _ = False -{-# INLINE isWhiteSpace #-} + go ∷ [AsciiBuilder] → AsciiBuilder → AsciiBuilder + {-# INLINE go #-} + go [] ab = ab + go (x:[]) ab = ab ⊕ x + go (x:xs) ab = go xs (ab ⊕ A.toAsciiBuilder sep ⊕ x) -- |> quoteStr "abc" -- > ==> "\"abc\"" -- -- > quoteStr "ab\"c" -- > ==> "\"ab\\\"c\"" -quoteStr :: String -> String -quoteStr !str = concat (["\""] ++ map quote str ++ ["\""]) +quoteStr ∷ Ascii → AsciiBuilder +quoteStr str = A.toAsciiBuilder "\"" ⊕ + go (A.toByteString str) (∅) ⊕ + A.toAsciiBuilder "\"" where - quote :: Char -> String - quote '"' = "\\\"" - quote c = [c] + go ∷ BS.ByteString → AsciiBuilder → AsciiBuilder + go bs ab + = case BS.break (≡ '"') bs of + (x, y) + | BS.null y → ab ⊕ b2ab x + | otherwise → go (BS.tail y) (ab ⊕ b2ab x + ⊕ A.toAsciiBuilder "\\\"") + b2ab ∷ BS.ByteString → AsciiBuilder + b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString -- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd" -- > ==> [("aaa", "bbb"), ("ccc", "ddd")] diff --git a/bugs/issue-74e34d62deabaab386472d2949a46fea893f1ec1.yaml b/bugs/issue-74e34d62deabaab386472d2949a46fea893f1ec1.yaml index 717a930..d113d82 100644 --- a/bugs/issue-74e34d62deabaab386472d2949a46fea893f1ec1.yaml +++ b/bugs/issue-74e34d62deabaab386472d2949a46fea893f1ec1.yaml @@ -5,7 +5,7 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted +status: :in_progress disposition: creation_time: 2011-07-29 16:01:14.666629 Z references: [] @@ -20,4 +20,8 @@ log_events: - PHO - assigned to release Lucu-1.0 from unassigned - "" -git_branch: +- - 2011-07-30 11:17:25.622897 Z + - PHO + - changed status from unstarted to in_progress + - "" +git_branch: attoparsec diff --git a/bugs/issue-8959dadc07db1bd363283dee401073f6e48dc7fa.yaml b/bugs/issue-8959dadc07db1bd363283dee401073f6e48dc7fa.yaml index 76f9120..3e454e7 100644 --- a/bugs/issue-8959dadc07db1bd363283dee401073f6e48dc7fa.yaml +++ b/bugs/issue-8959dadc07db1bd363283dee401073f6e48dc7fa.yaml @@ -5,7 +5,7 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted +status: :in_progress disposition: creation_time: 2010-03-12 06:56:06.939283 Z references: [] @@ -20,4 +20,8 @@ log_events: - PHO - assigned to release Lucu-1.0 from unassigned - "" -git_branch: +- - 2011-07-30 11:17:19.173203 Z + - PHO + - changed status from unstarted to in_progress + - "" +git_branch: attoparsec diff --git a/bugs/issue-b3e2a5ee9307d4ba9b7a0346e6ca0d91ca287997.yaml b/bugs/issue-b3e2a5ee9307d4ba9b7a0346e6ca0d91ca287997.yaml index 661d612..8469a0a 100644 --- a/bugs/issue-b3e2a5ee9307d4ba9b7a0346e6ca0d91ca287997.yaml +++ b/bugs/issue-b3e2a5ee9307d4ba9b7a0346e6ca0d91ca287997.yaml @@ -5,7 +5,7 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted +status: :in_progress disposition: creation_time: 2011-07-30 04:39:53.073102 Z references: [] @@ -16,4 +16,8 @@ log_events: - PHO - created - "" -git_branch: +- - 2011-07-30 11:17:28.677836 Z + - PHO + - changed status from unstarted to in_progress + - "" +git_branch: attoparsec diff --git a/data/Makefile b/data/Makefile index 584c8d6..23c69ed 100644 --- a/data/Makefile +++ b/data/Makefile @@ -1,5 +1,10 @@ ../Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs: mime.types CompileMimeTypes ./CompileMimeTypes $< $@ -CompileMimeTypes: CompileMimeTypes.hs - ghc --make $@ +CompileMimeTypes: + ghc --make $@ -i.. + +clean: + rm -f *.hi *.o CompileMimeTypes + +.PHONY: clean