From 3d017dd65ddede9a11c5b7a34a91e04340e67bc4 Mon Sep 17 00:00:00 2001 From: pho Date: Mon, 5 Nov 2007 14:10:32 +0900 Subject: [PATCH] Exodus to GHC 6.8.1 darcs-hash:20071105051032-62b54-c7e219ec83a3c243c2ad3083abb9de133109d7ab.gz --- ImplantFile.hs | 95 ++++++++++++------------- Lucu.cabal | 15 ++-- Makefile | 10 +-- Network/HTTP/Lucu/Config.hs | 8 +-- Network/HTTP/Lucu/DefaultPage.hs | 8 +-- Network/HTTP/Lucu/ETag.hs | 2 +- Network/HTTP/Lucu/Format.hs | 9 +-- Network/HTTP/Lucu/Headers.hs | 35 ++++----- Network/HTTP/Lucu/HttpVersion.hs | 1 + Network/HTTP/Lucu/Interaction.hs | 21 +++--- Network/HTTP/Lucu/MIMEType.hs | 1 + Network/HTTP/Lucu/MultipartForm.hs | 8 +-- Network/HTTP/Lucu/Parser.hs | 13 ++-- Network/HTTP/Lucu/Parser/Http.hs | 14 ++-- Network/HTTP/Lucu/Postprocess.hs | 85 +++++++++++----------- Network/HTTP/Lucu/Preprocess.hs | 18 ++--- Network/HTTP/Lucu/RFC1123DateTime.hs | 96 ++++++++++++------------- Network/HTTP/Lucu/Resource.hs | 102 ++++++++++++++------------- Network/HTTP/Lucu/Resource/Tree.hs | 15 ++-- Network/HTTP/Lucu/Response.hs | 6 +- Network/HTTP/Lucu/ResponseWriter.hs | 9 ++- Network/HTTP/Lucu/StaticFile.hs | 44 ++++++------ Network/HTTP/Lucu/Utils.hs | 15 ++-- 23 files changed, 319 insertions(+), 311 deletions(-) diff --git a/ImplantFile.hs b/ImplantFile.hs index a16c76e..26be80e 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -2,12 +2,14 @@ import Codec.Binary.Base64 import Codec.Compression.GZip import Control.Monad import Data.Bits -import Data.ByteString.Base (LazyByteString) -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as L hiding (ByteString) import Data.Char import Data.Digest.SHA1 import Data.Int import Data.Maybe +import Data.Time +import Data.Time.Clock.POSIX import Data.Word import Language.Haskell.Pretty import Language.Haskell.Syntax @@ -15,11 +17,10 @@ import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap import Network.HTTP.Lucu.MIMEType.Guess import System.Console.GetOpt -import System.Directory import System.Environment import System.Exit +import System.Posix.Files import System.IO -import System.Time data CmdOpt = OptOutput FilePath @@ -111,19 +112,17 @@ generateHaskellSource opts srcFile rawB64 = encode $ L.unpack input gzippedB64 = encode $ L.unpack gzippedData - header = mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod + header <- mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod - hsModule = HsModule undefined (Module modName) (Just exports) imports decls + let hsModule = HsModule undefined (Module modName) (Just exports) imports decls exports = [HsEVar (UnQual (HsIdent symName))] imports = [ HsImportDecl undefined (Module "Codec.Binary.Base64") False Nothing Nothing - , HsImportDecl undefined (Module "Data.ByteString.Base") - False Nothing (Just (False, [HsIVar (HsIdent "LazyByteString")])) , HsImportDecl undefined (Module "Data.ByteString.Lazy") True (Just (Module "L")) Nothing - , HsImportDecl undefined (Module "Network.HTTP.Lucu") + , HsImportDecl undefined (Module "Data.Time") False Nothing Nothing - , HsImportDecl undefined (Module "System.Time") + , HsImportDecl undefined (Module "Network.HTTP.Lucu") False Nothing Nothing ] ++ @@ -263,18 +262,15 @@ generateHaskellSource opts srcFile declLastModified = [ HsTypeSig undefined [HsIdent "lastModified"] (HsQualType [] - (HsTyCon (UnQual (HsIdent "ClockTime")))) + (HsTyCon (UnQual (HsIdent "UTCTime")))) , HsFunBind [HsMatch undefined (HsIdent "lastModified") [] (HsUnGuardedRhs defLastModified) []] ] defLastModified :: HsExp defLastModified - = let TOD a b = lastMod - in - (HsApp (HsApp (HsCon (UnQual (HsIdent "TOD"))) - (HsLit (HsInt a))) - (HsLit (HsInt b))) + = HsApp (HsVar (UnQual (HsIdent "read"))) + (HsLit (HsString $ show lastMod)) declContentType :: [HsDecl] @@ -295,7 +291,7 @@ generateHaskellSource opts srcFile declGZippedData = [ HsTypeSig undefined [HsIdent "gzippedData"] (HsQualType [] - (HsTyCon (UnQual (HsIdent "LazyByteString")))) + (HsTyCon (Qual (Module "L") (HsIdent "ByteString")))) , HsFunBind [HsMatch undefined (HsIdent "gzippedData") [] (HsUnGuardedRhs defGZippedData) []] ] @@ -311,7 +307,7 @@ generateHaskellSource opts srcFile declRawData = [ HsTypeSig undefined [HsIdent "rawData"] (HsQualType [] - (HsTyCon (UnQual (HsIdent "LazyByteString")))) + (HsTyCon (Qual (Module "L") (HsIdent "ByteString")))) , HsFunBind [HsMatch undefined (HsIdent "rawData") [] (HsUnGuardedRhs defRawData) []] ] @@ -328,23 +324,24 @@ generateHaskellSource opts srcFile hClose output -mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> ClockTime -> String +mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> UTCTime -> IO String mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod - = "{- DO NOT EDIT THIS FILE.\n" ++ - " This file is automatically generated by the lucu-implant-file program.\n" ++ - "\n" ++ - " Source: " ++ (if srcFile == "-" - then "(stdin)" - else srcFile) ++ "\n" ++ - " Original Length: " ++ show originalLen ++ " bytes\n" ++ - (if useGZip - then " Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++ - " Compression: gzip\n" - else " Compression: disabled\n") ++ - " MIME Type: " ++ show mimeType ++ "\n" ++ - " ETag: " ++ eTag ++ "\n" ++ - " Last Modified: " ++ show lastMod ++ "\n" ++ - " -}" + = do localLastMod <- utcToLocalZonedTime lastMod + return ("{- DO NOT EDIT THIS FILE.\n" ++ + " This file is automatically generated by the lucu-implant-file program.\n" ++ + "\n" ++ + " Source: " ++ (if srcFile == "-" + then "(stdin)" + else srcFile) ++ "\n" ++ + " Original Length: " ++ show originalLen ++ " bytes\n" ++ + (if useGZip + then " Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++ + " Compression: gzip\n" + else " Compression: disabled\n") ++ + " MIME Type: " ++ show mimeType ++ "\n" ++ + " ETag: " ++ eTag ++ "\n" ++ + " Last Modified: " ++ show localLastMod ++ "\n" ++ + " -}") getModuleName :: [CmdOpt] -> IO String @@ -369,6 +366,7 @@ getSymbolName opts modName defaultSymName = mkDefault modName mkDefault = headToLower . getLastComp headToLower = \ str -> case str of + [] -> error "module name must not be empty" (x:xs) -> toLower x : xs getLastComp = reverse . fst . break (== '.') . reverse in @@ -392,12 +390,13 @@ getMIMEType opts srcFile _ -> error "too many --mime-type options." -getLastModified :: FilePath -> IO ClockTime -getLastModified "-" = getClockTime -getLastModified fpath = getModificationTime fpath +getLastModified :: FilePath -> IO UTCTime +getLastModified "-" = getCurrentTime +getLastModified fpath = getFileStatus fpath + >>= return . posixSecondsToUTCTime . toEnum . fromEnum . modificationTime -getETag :: [CmdOpt] -> LazyByteString -> IO String +getETag :: [CmdOpt] -> Lazy.ByteString -> IO String getETag opts input = let eTagOpts = filter (\ x -> case x of OptETag _ -> True @@ -421,11 +420,12 @@ getETag opts input hex4bit :: Int -> Char hex4bit n - | n < 10 = (chr $ ord '0' + n ) - | n < 16 = (chr $ ord 'a' + n - 10) + | n < 10 = (chr $ ord '0' + n ) + | n < 16 = (chr $ ord 'a' + n - 10) + | otherwise = undefined -openInput :: FilePath -> IO LazyByteString +openInput :: FilePath -> IO Lazy.ByteString openInput "-" = L.getContents openInput fpath = L.readFile fpath @@ -454,14 +454,13 @@ openOutput opts Compression: disabled MIME Type: image/png ETag: d41d8cd98f00b204e9800998ecf8427e - Last Modified: Wed, 03 Oct 2007 00:55:45 JST + Last Modified: 2007-11-05 13:53:42.231882 JST -} module Foo.Bar.Baz (baz) where import Codec.Binary.Base64 - import Data.ByteString.Base (LazyByteString) import qualified Data.ByteString.Lazy as L + import Data.Time import Network.HTTP.Lucu - import System.Time baz :: ResourceDef baz = ResourceDef { @@ -480,13 +479,13 @@ openOutput opts entityTag :: ETag entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e" - lastModified :: ClockTime - lastModified = TOD 1191340545 0 + lastModified :: UTCTime + lastModified = read "2007-11-05 04:47:56.008366 UTC" contentType :: MIMEType contentType = read "image/png" - rawData :: LazyByteString + rawData :: L.ByteString rawData = L.pack (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...") ------------------------------------------------------------------------------ @@ -518,7 +517,7 @@ openOutput opts } -- rawData の代はりに gzippedData - gzippedData :: LazyByteString + gzippedData :: L.ByteString gzippedData = L.pack (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...") ------------------------------------------------------------------------------ -} diff --git a/Lucu.cabal b/Lucu.cabal index 4a1b9ea..ae858fb 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -15,9 +15,10 @@ Maintainer: PHO Stability: experimental Homepage: http://ccm.sherry.jp/Lucu/ Category: Network -Tested-With: GHC == 6.6.1 +Tested-With: GHC == 6.8.1 Build-Depends: - base, mtl, network, stm, hxt, haskell-src, unix, zlib, Crypto + Crypto, base, bytestring, containers, directory, haskell-src, + hxt, mtl, network, stm, time, unix, zlib Exposed-Modules: Network.HTTP.Lucu Network.HTTP.Lucu.Abortion @@ -56,19 +57,17 @@ Extra-Source-Files: examples/Makefile ghc-options: -fglasgow-exts - -fwarn-missing-signatures - -fwarn-unused-imports + -Wall -funbox-strict-fields - -O3 + Executable: lucu-implant-file Main-Is: ImplantFile.hs ghc-options: -fglasgow-exts - -fwarn-missing-signatures - -fwarn-unused-imports + -Wall -funbox-strict-fields - -O3 + --Executable: HelloWorld --Main-Is: HelloWorld.hs diff --git a/Makefile b/Makefile index 6b4ad4d..7e30a9f 100644 --- a/Makefile +++ b/Makefile @@ -9,8 +9,8 @@ run: build $(MAKE) -C examples run .setup-config: $(CABAL_FILE) Setup -# ./Setup configure - ./Setup configure -p +# ./Setup configure --disable-optimization + ./Setup configure -p --enable-split-objs Setup: Setup.hs $(GHC) --make Setup @@ -21,12 +21,12 @@ clean: $(MAKE) -C examples clean doc: .setup-config Setup - ./Setup haddock + ./Setup haddock --hyperlink-source --haddock-css=../hscolour/hscolour.css install: build - ./Setup install + sudo ./Setup install sdist: Setup ./Setup sdist -.PHONY: build run clean install doc sdist \ No newline at end of file +.PHONY: build run clean install doc sdist diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 0784384..8b1fcf0 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -5,8 +5,8 @@ module Network.HTTP.Lucu.Config ) where -import Data.ByteString.Base (ByteString) -import qualified Data.ByteString.Char8 as C8 +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 @@ -17,10 +17,10 @@ import System.IO.Unsafe -- '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 :: !ByteString + cnfServerSoftware :: !Strict.ByteString -- |The host name of the server. This value will be used in -- built-in pages like \"404 Not Found\". - , cnfServerHost :: !ByteString + , cnfServerHost :: !Strict.ByteString -- |A port ID to listen to HTTP clients. , cnfServerPort :: !PortID -- |The maximum number of requests to accept in one connection diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index be369cc..6a98010 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -19,7 +19,7 @@ import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response -import Network.URI +import Network.URI hiding (path) import System.IO.Unsafe import Text.XML.HXT.Arrow.WriteDocument import Text.XML.HXT.Arrow.XmlArrow @@ -44,10 +44,8 @@ getDefaultPage conf req res writeDefaultPage :: Interaction -> STM () writeDefaultPage itr = itr `seq` - do wroteHeader <- readTVar (itrWroteHeader itr) - - -- Content-Type が正しくなければ補完できない。 - res <- readItr itr itrResponse id + -- Content-Type が正しくなければ補完できない。 + do res <- readItr itr itrResponse id when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType) $ do reqM <- readItr itr itrRequest id diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index 20fa047..158144c 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -12,7 +12,7 @@ module Network.HTTP.Lucu.ETag import Control.Monad import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http +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. diff --git a/Network/HTTP/Lucu/Format.hs b/Network/HTTP/Lucu/Format.hs index 042b4fe..f017f5e 100644 --- a/Network/HTTP/Lucu/Format.hs +++ b/Network/HTTP/Lucu/Format.hs @@ -23,9 +23,9 @@ fmtInt base upperCase minWidth pad forceSign n sign ++ padded where fmt' :: Int -> String - fmt' n - | n < base = (intToChar upperCase n) : [] - | otherwise = (intToChar upperCase $! n `mod` base) : fmt' (n `div` base) + fmt' m + | m < base = (intToChar upperCase m) : [] + | otherwise = (intToChar upperCase $! m `mod` base) : fmt' (m `div` base) fmtDec :: Int -> Int -> String @@ -123,4 +123,5 @@ intToChar True 13 = 'D' intToChar False 14 = 'e' intToChar True 14 = 'E' intToChar False 15 = 'f' -intToChar True 15 = 'F' \ No newline at end of file +intToChar True 15 = 'F' +intToChar _ _ = undefined diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 4ad6043..5eeab6f 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -14,8 +14,9 @@ module Network.HTTP.Lucu.Headers ) where -import Data.ByteString.Base (ByteString, toForeignPtr, w2c, inlinePerformIO) -import qualified Data.ByteString.Char8 as C8 +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) @@ -29,14 +30,14 @@ import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils import System.IO -type Headers = Map NCBS ByteString -newtype NCBS = NCBS ByteString +type Headers = Map NCBS Strict.ByteString +newtype NCBS = NCBS Strict.ByteString -toNCBS :: ByteString -> NCBS +toNCBS :: Strict.ByteString -> NCBS toNCBS = NCBS {-# INLINE toNCBS #-} -fromNCBS :: NCBS -> ByteString +fromNCBS :: NCBS -> Strict.ByteString fromNCBS (NCBS x) = x {-# INLINE fromNCBS #-} @@ -49,7 +50,7 @@ instance Ord NCBS where instance Show NCBS where show (NCBS x) = show x -noCaseCmp :: ByteString -> ByteString -> Ordering +noCaseCmp :: Strict.ByteString -> Strict.ByteString -> Ordering noCaseCmp a b = a `seq` b `seq` toForeignPtr a `cmp` toForeignPtr b where @@ -80,7 +81,7 @@ noCaseCmp' p1 l1 p2 l2 x -> return x -noCaseEq :: ByteString -> ByteString -> Bool +noCaseEq :: Strict.ByteString -> Strict.ByteString -> Bool noCaseEq a b = a `seq` b `seq` toForeignPtr a `cmp` toForeignPtr b where @@ -114,17 +115,17 @@ class HasHeaders a where getHeaders :: a -> Headers setHeaders :: a -> Headers -> a - getHeader :: ByteString -> a -> Maybe ByteString + getHeader :: Strict.ByteString -> a -> Maybe Strict.ByteString getHeader key a = key `seq` a `seq` M.lookup (toNCBS key) (getHeaders a) - deleteHeader :: ByteString -> a -> a + deleteHeader :: Strict.ByteString -> a -> a deleteHeader key a = key `seq` a `seq` setHeaders a $ M.delete (toNCBS key) (getHeaders a) - setHeader :: ByteString -> ByteString -> a -> 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) @@ -134,18 +135,18 @@ emptyHeaders :: Headers emptyHeaders = M.empty -toHeaders :: [(ByteString, ByteString)] -> Headers +toHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers toHeaders xs = mkHeaders xs M.empty -mkHeaders :: [(ByteString, ByteString)] -> Headers -> Headers +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 where - merge :: ByteString -> ByteString -> ByteString + merge :: Strict.ByteString -> Strict.ByteString -> Strict.ByteString -- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない -- ヘッダは複數個あってはならない事になってゐる。 merge a b @@ -155,7 +156,7 @@ mkHeaders ((key, val):xs) m = mkHeaders xs $ | otherwise = C8.concat [a, C8.pack ", ", b] -fromHeaders :: Headers -> [(ByteString, ByteString)] +fromHeaders :: Headers -> [(Strict.ByteString, Strict.ByteString)] fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs] @@ -175,7 +176,7 @@ headersP = do xs <- many header crlf return $! toHeaders xs where - header :: Parser (ByteString, ByteString) + header :: Parser (Strict.ByteString, Strict.ByteString) header = do name <- token char ':' -- FIXME: これは多少インチキだが、RFC 2616 のこの部分 @@ -209,7 +210,7 @@ hPutHeaders h hds = h `seq` hds `seq` mapM_ putH (M.toList hds) >> C8.hPut h (C8.pack "\r\n") where - putH :: (NCBS, ByteString) -> IO () + putH :: (NCBS, Strict.ByteString) -> IO () putH (name, value) = name `seq` value `seq` do C8.hPut h (fromNCBS name) diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index 9bc1b81..e0694f1 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -10,6 +10,7 @@ module Network.HTTP.Lucu.HttpVersion import qualified Data.ByteString.Char8 as C8 import Network.HTTP.Lucu.Parser +import Prelude hiding (min) import System.IO -- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\". diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 4c0735a..a81320b 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -15,9 +15,10 @@ module Network.HTTP.Lucu.Interaction where import Control.Concurrent.STM -import Data.ByteString.Base (ByteString, LazyByteString) -import Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import Data.ByteString.Char8 as C8 hiding (ByteString) +import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) import qualified Data.Sequence as S import Data.Sequence (Seq) import Network.Socket @@ -31,26 +32,26 @@ data Interaction = Interaction { itrConfig :: !Config , itrRemoteAddr :: !SockAddr , itrResourcePath :: !(Maybe [String]) - , itrRequest :: !(TVar (Maybe Request)) + , itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し , itrResponse :: !(TVar Response) - , itrRequestHasBody :: !(TVar Bool) - , itrRequestIsChunked :: !(TVar Bool) - , itrExpectedContinue :: !(TVar Bool) + , itrRequestHasBody :: !(TVar Bool) -- FIXME: TVar である必要無し + , itrRequestIsChunked :: !(TVar Bool) -- FIXME: TVar である必要無し + , itrExpectedContinue :: !(TVar Bool) -- FIXME: TVar である必要無し , itrReqChunkLength :: !(TVar (Maybe Int)) , itrReqChunkRemaining :: !(TVar (Maybe Int)) , itrReqChunkIsOver :: !(TVar Bool) , itrReqBodyWanted :: !(TVar (Maybe Int)) , itrReqBodyWasteAll :: !(TVar Bool) - , itrReceivedBody :: !(TVar LazyByteString) -- Resource が受領した部分は削除される + , itrReceivedBody :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される , itrWillReceiveBody :: !(TVar Bool) , itrWillChunkBody :: !(TVar Bool) , itrWillDiscardBody :: !(TVar Bool) , itrWillClose :: !(TVar Bool) - , itrBodyToSend :: !(TVar LazyByteString) + , itrBodyToSend :: !(TVar Lazy.ByteString) , itrBodyIsNull :: !(TVar Bool) , itrState :: !(TVar InteractionState) @@ -75,7 +76,7 @@ newInteractionQueue :: IO InteractionQueue newInteractionQueue = newTVarIO S.empty -defaultPageContentType :: ByteString +defaultPageContentType :: Strict.ByteString defaultPageContentType = C8.pack "application/xhtml+xml" diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index da4f503..a8f0437 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -13,6 +13,7 @@ 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) -- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@ -- represents \"major\/minor; name=value\". diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 21fca67..8903d7f 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -3,8 +3,8 @@ module Network.HTTP.Lucu.MultipartForm ) where -import Data.ByteString.Base (LazyByteString(..)) 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 @@ -78,13 +78,13 @@ partToPair part@(Part _ body) Nothing -> abortPurely BadRequest [] (Just "There is a part without Content-Disposition in the multipart/form-data.") - Just dispo - -> case parse contDispoP (LPS [dispo]) of + Just dispoStr + -> case parse contDispoP (L8.fromChunks [dispoStr]) of (# Success dispo, _ #) -> (getName dispo, body) (# _, _ #) -> abortPurely BadRequest [] - (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispo) + (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr) where getName :: ContDispo -> String getName dispo@(ContDispo dType dParams) diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index bbe16a3..4bb8fa0 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -51,9 +51,8 @@ module Network.HTTP.Lucu.Parser where import Control.Monad.State.Strict -import Data.ByteString.Base (LazyByteString) -import Data.ByteString.Lazy () -import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString) -- |@'Parser' a@ is obviously a parser which parses and returns @a@. newtype Parser a = Parser { @@ -63,7 +62,7 @@ newtype Parser a = Parser { data ParserState = PST { - pstInput :: LazyByteString + pstInput :: Lazy.ByteString , pstIsEOFFatal :: !Bool } deriving (Eq, Show) @@ -95,7 +94,7 @@ failP = fail undefined -- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(# result, -- remaining #)@. -parse :: Parser a -> LazyByteString -> (# ParserResult a, LazyByteString #) +parse :: Parser a -> Lazy.ByteString -> (# ParserResult a, Lazy.ByteString #) parse p input -- input は lazy である必要有り。 = p `seq` let (result, state') = runState (runParser p) (PST input True) @@ -103,7 +102,7 @@ parse p input -- input は lazy である必要有り。 result `seq` (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。 -- |@'parseStr' p str@ packs @str@ and parses it. -parseStr :: Parser a -> String -> (# ParserResult a, LazyByteString #) +parseStr :: Parser a -> String -> (# ParserResult a, Lazy.ByteString #) parseStr p input = p `seq` -- input は lazy である必要有り。 parse p (B.pack input) @@ -190,7 +189,7 @@ notFollowedBy p Parser $! do saved <- get -- 状態を保存 result <- runParser p case result of - Success a -> do put saved -- 状態を復歸 + Success _ -> do put saved -- 状態を復歸 return IllegalInput IllegalInput -> do put saved -- 状態を復歸 return $! Success () diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index a5dfbd9..adbda7b 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -104,7 +104,7 @@ quotedStr = do char '"' qdtext = do c <- satisfy (/= '"') return [c] - quotedPair = do q <- char '\\' + quotedPair = do char '\\' c <- satisfy isChar return [c] @@ -112,14 +112,14 @@ quotedStr = do char '"' qvalue :: Parser Double qvalue = do x <- char '0' xs <- option "" - $ do x <- char '.' - xs <- many digit -- 本當は三文字までに制限 - return (x:xs) + $ do y <- char '.' + ys <- many digit -- 本當は三文字までに制限 + return (y:ys) return $ read (x:xs) <|> do x <- char '1' xs <- option "" - $ do x <- char '.' - xs <- many (char '0') -- 本當は三文字までに制限 - return (x:xs) + $ do y <- char '.' + ys <- many (char '0') -- 本當は三文字までに制限 + return (y:ys) return $ read (x:xs) diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 6e8a5e6..d3659cc 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -6,10 +6,11 @@ module Network.HTTP.Lucu.Postprocess import Control.Concurrent.STM import Control.Monad -import Data.ByteString.Base (ByteString) -import qualified Data.ByteString.Char8 as C8 +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 GHC.Conc (unsafeIOToSTM) import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config @@ -19,7 +20,6 @@ import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.RFC1123DateTime import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response -import System.Time import System.IO.Unsafe {- @@ -75,8 +75,7 @@ postprocess itr $ abortSTM InternalServerError [] $ Just ("The status code was " ++ show sc ++ " but no Location header.") - when (reqM /= Nothing) - $ relyOnRequest itr + when (reqM /= Nothing) relyOnRequest -- itrResponse の内容は relyOnRequest によって變へられてゐる可 -- 能性が高い。 @@ -85,10 +84,9 @@ postprocess itr $ completeUnconditionalHeaders (itrConfig itr) oldRes writeItr itr itrResponse newRes where - relyOnRequest :: Interaction -> STM () - relyOnRequest itr - = itr `seq` - do status <- readItr itr itrResponse resStatus + relyOnRequest :: STM () + relyOnRequest + = do status <- readItr itr itrResponse resStatus req <- readItr itr itrRequest fromJust let reqVer = reqVersion req @@ -100,25 +98,25 @@ postprocess itr status == ResetContent || status == NotModified ) - updateRes itr $! deleteHeader (C8.pack "Content-Length") - updateRes itr $! deleteHeader (C8.pack "Transfer-Encoding") + updateRes $! deleteHeader (C8.pack "Content-Length") + updateRes $! deleteHeader (C8.pack "Transfer-Encoding") - cType <- readHeader itr (C8.pack "Content-Type") + cType <- readHeader (C8.pack "Content-Type") when (cType == Nothing) - $ updateRes itr $ setHeader (C8.pack "Content-Type") defaultPageContentType + $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType if canHaveBody then when (reqVer == HttpVersion 1 1) - $ do updateRes itr $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked") + $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked") writeItr itr itrWillChunkBody True else -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す when (reqMethod req /= HEAD) - $ do updateRes itr $! deleteHeader (C8.pack "Content-Type") - updateRes itr $! deleteHeader (C8.pack "Etag") - updateRes itr $! deleteHeader (C8.pack "Last-Modified") + $ do updateRes $! deleteHeader (C8.pack "Content-Type") + updateRes $! deleteHeader (C8.pack "Etag") + updateRes $! deleteHeader (C8.pack "Last-Modified") - conn <- readHeader itr (C8.pack "Connection") + conn <- readHeader (C8.pack "Connection") case conn of Nothing -> return () Just value -> if value `noCaseEq` C8.pack "close" then @@ -128,19 +126,19 @@ postprocess itr willClose <- readItr itr itrWillClose id when willClose - $ updateRes itr $! setHeader (C8.pack "Connection") (C8.pack "close") + $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close") when (reqMethod req == HEAD || not canHaveBody) $ writeTVar (itrWillDiscardBody itr) True - readHeader :: Interaction -> ByteString -> STM (Maybe ByteString) - readHeader itr name - = itr `seq` name `seq` + readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString) + readHeader name + = name `seq` readItr itr itrResponse $ getHeader name - updateRes :: Interaction -> (Response -> Response) -> STM () - updateRes itr updator - = itr `seq` updator `seq` + updateRes :: (Response -> Response) -> STM () + updateRes updator + = updator `seq` updateItr itr itrResponse updator @@ -149,30 +147,37 @@ completeUnconditionalHeaders conf res = conf `seq` res `seq` return res >>= compServer >>= compDate >>= return where - compServer res - = case getHeader (C8.pack "Server") res of - Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res - Just _ -> return res + compServer res' + = case getHeader (C8.pack "Server") res' of + Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res' + Just _ -> return res' - compDate res - = case getHeader (C8.pack "Date") res of + compDate res' + = case getHeader (C8.pack "Date") res' of Nothing -> do date <- getCurrentDate - return $ setHeader (C8.pack "Date") date res - Just _ -> return res + return $ setHeader (C8.pack "Date") date res' + Just _ -> return res' -cache :: IORef (ClockTime, ByteString) +cache :: IORef (UTCTime, Strict.ByteString) cache = unsafePerformIO $ - newIORef (TOD 0 0, undefined) + newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined) {-# NOINLINE cache #-} -getCurrentDate :: IO ByteString -getCurrentDate = do now@(TOD curSec _) <- getClockTime - (TOD cachedSec _, cachedStr) <- readIORef cache +getCurrentDate :: IO Strict.ByteString +getCurrentDate = do now <- getCurrentTime + (cachedTime, cachedStr) <- readIORef cache - if curSec == cachedSec then + if now `mostlyEq` cachedTime then return cachedStr else do let dateStr = C8.pack $ formatHTTPDateTime now writeIORef cache (now, dateStr) - return dateStr \ No newline at end of file + return dateStr + where + mostlyEq :: UTCTime -> UTCTime -> Bool + mostlyEq a b + = if utctDay a == utctDay b then + fromEnum (utctDayTime a) == fromEnum (utctDayTime b) + else + False diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index ef66898..7f386a7 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -5,8 +5,8 @@ module Network.HTTP.Lucu.Preprocess import Control.Concurrent.STM import Control.Monad -import Data.ByteString.Base (ByteString) -import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.ByteString.Char8 as C8 hiding (ByteString) import Data.Char import Data.Maybe import Network.HTTP.Lucu.Config @@ -75,7 +75,7 @@ preprocess itr PUT -> writeItr itr itrRequestHasBody True _ -> setStatus NotImplemented - preprocessHeader itr req + preprocessHeader req where setStatus :: StatusCode -> STM () setStatus status @@ -94,7 +94,7 @@ preprocess itr do let conf = itrConfig itr host = cnfServerHost conf port = case cnfServerPort conf of - PortNumber n -> Just $ fromIntegral n + PortNumber n -> Just (fromIntegral n :: Int) _ -> Nothing portStr = case port of @@ -115,11 +115,11 @@ preprocess itr Nothing -> setStatus BadRequest - parseHost :: ByteString -> (ByteString, ByteString) + parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString) parseHost = C8.break (== ':') - updateAuthority :: ByteString -> ByteString -> STM () + updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM () updateAuthority host portStr = host `seq` portStr `seq` updateItr itr itrRequest @@ -135,9 +135,9 @@ preprocess itr } - preprocessHeader :: Interaction -> Request -> STM () - preprocessHeader itr req - = itr `seq` req `seq` + preprocessHeader :: Request -> STM () + preprocessHeader req + = req `seq` do case getHeader (C8.pack "Expect") req of Nothing -> return () Just value -> if value `noCaseEq` C8.pack "100-continue" then diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs index 4606baf..f86b2b1 100644 --- a/Network/HTTP/Lucu/RFC1123DateTime.hs +++ b/Network/HTTP/Lucu/RFC1123DateTime.hs @@ -9,46 +9,56 @@ module Network.HTTP.Lucu.RFC1123DateTime where import Control.Monad -import Data.ByteString.Base (LazyByteString) +import Data.Time +import Data.Time.Calendar.WeekDate +import qualified Data.ByteString.Lazy as Lazy (ByteString) import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.Parser -import System.Time +import Prelude hiding (min) -month :: [String] -month = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"] -week :: [String] -week = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"] +monthStr :: [String] +monthStr = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"] + +weekStr :: [String] +weekStr = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"] -- |Format a 'System.Time.CalendarTime' to RFC 1123 Date and Time -- string. -formatRFC1123DateTime :: CalendarTime -> String -formatRFC1123DateTime time - = time `seq` - - id (week !! fromEnum (ctWDay time)) - ++ ", " ++ - fmtDec 2 (ctDay time) - ++ " " ++ - id (month !! fromEnum (ctMonth time)) - ++ " " ++ - fmtDec 4 (ctYear time) - ++ " " ++ - fmtDec 2 (ctHour time) - ++ ":" ++ - fmtDec 2 (ctMin time) - ++ ":" ++ - fmtDec 2 (ctSec time) - ++ " " ++ - id (ctTZName time) +formatRFC1123DateTime :: ZonedTime -> String +formatRFC1123DateTime zonedTime + = let localTime = zonedTimeToLocalTime zonedTime + timeZone = zonedTimeZone zonedTime + (year, month, day) = toGregorian (localDay localTime) + (_, _, week) = toWeekDate (localDay localTime) + timeOfDay = localTimeOfDay localTime + in + id (weekStr !! (week - 1)) + ++ ", " ++ + fmtDec 2 day + ++ " " ++ + id (monthStr !! (month - 1)) + ++ " " ++ + fmtDec 4 (fromInteger year) + ++ " " ++ + fmtDec 2 (todHour timeOfDay) + ++ ":" ++ + fmtDec 2 (todMin timeOfDay) + ++ ":" ++ + fmtDec 2 (floor (todSec timeOfDay)) + ++ " " ++ + id (timeZoneName timeZone) -- |Format a 'System.Time.ClockTime' to HTTP Date and Time. Time zone -- will be always UTC but prints as GMT. -formatHTTPDateTime :: ClockTime -> String -formatHTTPDateTime time - = time `seq` - formatRFC1123DateTime $! (\cal -> cal { ctTZName = "GMT" }) $! toUTCTime time +formatHTTPDateTime :: UTCTime -> String +formatHTTPDateTime utcTime + = let timeZone = TimeZone 0 False "GMT" + zonedTime = utcToZonedTime timeZone utcTime + in + formatRFC1123DateTime zonedTime + -- |Parse an HTTP Date and Time. -- @@ -64,20 +74,20 @@ formatHTTPDateTime time -- ...but currently this function only supports the RFC 1123 -- format. This is a violation of RFC 2616 so this should be fixed -- later. What a bother! -parseHTTPDateTime :: LazyByteString -> Maybe ClockTime +parseHTTPDateTime :: Lazy.ByteString -> Maybe UTCTime parseHTTPDateTime src = case parse httpDateTime src of (# Success ct, _ #) -> Just ct (# _ , _ #) -> Nothing -httpDateTime :: Parser ClockTime -httpDateTime = do foldl (<|>) failP (map string week) +httpDateTime :: Parser UTCTime +httpDateTime = do foldl (<|>) failP (map string weekStr) char ',' char ' ' day <- liftM read (count 2 digit) char ' ' - mon <- foldl (<|>) failP (map tryEqToFst (zip month [1..])) + mon <- foldl (<|>) failP (map tryEqToFst (zip monthStr [1..])) char ' ' year <- liftM read (count 4 digit) char ' ' @@ -85,24 +95,14 @@ httpDateTime = do foldl (<|>) failP (map string week) char ':' min <- liftM read (count 2 digit) char ':' - sec <- liftM read (count 2 digit) + sec <- liftM read (count 2 digit) :: Parser Int char ' ' string "GMT" eof - return $ toClockTime $ CalendarTime { - ctYear = year - , ctMonth = toEnum (mon - 1) - , ctDay = day - , ctHour = hour - , ctMin = min - , ctSec = sec - , ctPicosec = 0 - , ctTZ = 0 - , ctWDay = undefined - , ctYDay = undefined - , ctTZName = undefined - , ctIsDST = undefined - } + let julianDay = fromGregorian year mon day + timeOfDay = TimeOfDay hour min (fromIntegral sec) + utcTime = UTCTime julianDay (timeOfDayToTime timeOfDay) + return utcTime where tryEqToFst :: (String, a) -> Parser a tryEqToFst (str, a) = string str >> return a diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 33eaa62..a8d8011 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -134,12 +134,14 @@ module Network.HTTP.Lucu.Resource import Control.Concurrent.STM import Control.Monad.Reader import Data.Bits -import Data.ByteString.Base (ByteString, LazyByteString(..)) -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Char8 as C8 hiding (ByteString) +import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) import Data.Char import Data.List import Data.Maybe +import Data.Time import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.ContentCoding @@ -156,9 +158,8 @@ import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils -import Network.Socket -import Network.URI -import System.Time +import Network.Socket hiding (accept) +import Network.URI hiding (path) -- |The 'Resource' monad. This monad implements -- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO' @@ -208,15 +209,17 @@ getRemoteAddr' :: Resource String getRemoteAddr' = do addr <- getRemoteAddr case addr of -- Network.Socket は IPv6 を考慮してゐないやうだ… - (SockAddrInet _ v4addr) + SockAddrInet _ v4addr -> let b1 = (v4addr `shiftR` 24) .&. 0xFF b2 = (v4addr `shiftR` 16) .&. 0xFF b3 = (v4addr `shiftR` 8) .&. 0xFF b4 = v4addr .&. 0xFF in return $ concat $ intersperse "." $ map show [b1, b2, b3, b4] - (SockAddrUnix path) + SockAddrUnix path -> return path + _ + -> undefined -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents @@ -273,8 +276,8 @@ getResourcePath = do itr <- getInteraction -- greedy. See 'getResourcePath'. getPathInfo :: Resource [String] getPathInfo = do rsrcPath <- getResourcePath - reqURI <- getRequestURI - let reqPathStr = uriPath reqURI + uri <- getRequestURI + let reqPathStr = uriPath uri reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""] -- rsrcPath と reqPath の共通する先頭部分を reqPath か -- ら全部取り除くと、それは PATH_INFO のやうなものにな @@ -287,14 +290,14 @@ getPathInfo = do rsrcPath <- getResourcePath -- application\/x-www-form-urlencoded, and parse it. This action -- doesn't parse the request body. See 'inputForm'. getQueryForm :: Resource [(String, String)] -getQueryForm = do reqURI <- getRequestURI - return $! parseWWWFormURLEncoded $ uriQuery reqURI +getQueryForm = do uri <- getRequestURI + return $! parseWWWFormURLEncoded $ uriQuery uri -- |Get a value of given request header. Comparison of header name is -- case-insensitive. Note that this action is not intended to be used -- so frequently: there should be actions like 'getContentType' for -- every common headers. -getHeader :: ByteString -> Resource (Maybe ByteString) +getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString) getHeader name = name `seq` do req <- getRequest return $! H.getHeader name req @@ -307,7 +310,7 @@ getAccept = do acceptM <- getHeader (C8.pack "Accept") Nothing -> return [] Just accept - -> case parse mimeTypeListP (LPS [accept]) of + -> case parse mimeTypeListP (L8.fromChunks [accept]) of (# Success xs, _ #) -> return xs (# _ , _ #) -> abort BadRequest [] (Just $ "Unparsable Accept: " ++ C8.unpack accept) @@ -328,12 +331,13 @@ getAcceptEncoding case ver of HttpVersion 1 0 -> return [("identity", Nothing)] HttpVersion 1 1 -> return [("*" , Nothing)] + _ -> undefined Just value -> if C8.null value then -- identity のみが許される。 return [("identity", Nothing)] else - case parse acceptEncodingListP (LPS [value]) of + case parse acceptEncodingListP (L8.fromChunks [value]) of (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x (# _ , _ #) -> abort BadRequest [] (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value) @@ -355,7 +359,7 @@ getContentType Nothing -> return Nothing Just cType - -> case parse mimeTypeP (LPS [cType]) of + -> case parse mimeTypeP (L8.fromChunks [cType]) of (# Success t, _ #) -> return $ Just t (# _ , _ #) -> abort BadRequest [] (Just $ "Unparsable Content-Type: " ++ C8.unpack cType) @@ -377,7 +381,7 @@ getContentType -- -- If this is a GET or HEAD request, 'foundEntity' automatically puts -- \"ETag\" and \"Last-Modified\" headers into the response. -foundEntity :: ETag -> ClockTime -> Resource () +foundEntity :: ETag -> UTCTime -> Resource () foundEntity tag timeStamp = tag `seq` timeStamp `seq` do driftTo ExaminingRequest @@ -418,7 +422,7 @@ foundETag tag Just value -> if value == C8.pack "*" then return () else - case parse eTagListP (LPS [value]) of + case parse eTagListP (L8.fromChunks [value]) of (# Success tags, _ #) -- tags の中に一致するものが無ければ -- PreconditionFailed で終了。 @@ -440,7 +444,7 @@ foundETag tag Just value -> if value == C8.pack "*" then abort statusForNoneMatch [] $! Just ("The entity tag matches: *") else - case parse eTagListP (LPS [value]) of + case parse eTagListP (L8.fromChunks [value]) of (# Success tags, _ #) -> when (any (== tag) tags) $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value) @@ -459,7 +463,7 @@ foundETag tag -- -- This action is not preferred. You should use 'foundEntity' whenever -- possible. -foundTimeStamp :: ClockTime -> Resource () +foundTimeStamp :: UTCTime -> Resource () foundTimeStamp timeStamp = timeStamp `seq` do driftTo ExaminingRequest @@ -479,7 +483,7 @@ foundTimeStamp timeStamp -- If-Modified-Since があればそれを見る。 ifModSince <- getHeader (C8.pack "If-Modified-Since") case ifModSince of - Just str -> case parseHTTPDateTime (LPS [str]) of + Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of Just lastTime -> when (timeStamp <= lastTime) $ abort statusForIfModSince [] @@ -491,7 +495,7 @@ foundTimeStamp timeStamp -- If-Unmodified-Since があればそれを見る。 ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since") case ifUnmodSince of - Just str -> case parseHTTPDateTime (LPS [str]) of + Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of Just lastTime -> when (timeStamp > lastTime) $ abort PreconditionFailed [] @@ -550,13 +554,12 @@ input limit = limit `seq` -- | This is mostly the same as 'input' but is more --- efficient. 'inputLBS' returns a --- 'Data.ByteString.Base.LazyByteString' but it's not really lazy: --- reading from the socket just happens at the computation of --- 'inputLBS', not at the evaluation of the --- 'Data.ByteString.Base.LazyByteString'. The same goes for +-- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString' +-- but it's not really lazy: reading from the socket just happens at +-- the computation of 'inputLBS', not at the evaluation of the +-- 'Data.ByteString.Lazy.ByteString'. The same goes for -- 'inputChunkLBS'. -inputLBS :: Int -> Resource LazyByteString +inputLBS :: Int -> Resource Lazy.ByteString inputLBS limit = limit `seq` do driftTo GettingBody @@ -569,14 +572,14 @@ inputLBS limit return L8.empty return chunk where - askForInput :: Interaction -> Resource LazyByteString + askForInput :: Interaction -> Resource Lazy.ByteString askForInput itr = itr `seq` - do let defaultLimit = cnfMaxEntityLength $ itrConfig itr - actualLimit = if limit <= 0 then - defaultLimit - else - limit + do let confLimit = cnfMaxEntityLength $ itrConfig itr + actualLimit = if limit <= 0 then + confLimit + else + limit when (actualLimit <= 0) $ fail ("inputLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト @@ -636,7 +639,7 @@ inputChunk limit = limit `seq` -- | This is mostly the same as 'inputChunk' but is more -- efficient. See 'inputLBS'. -inputChunkLBS :: Int -> Resource LazyByteString +inputChunkLBS :: Int -> Resource Lazy.ByteString inputChunkLBS limit = limit `seq` do driftTo GettingBody @@ -649,12 +652,12 @@ inputChunkLBS limit return L8.empty return chunk where - askForInput :: Interaction -> Resource LazyByteString + askForInput :: Interaction -> Resource Lazy.ByteString askForInput itr = itr `seq` - do let defaultLimit = cnfMaxEntityLength $! itrConfig itr - actualLimit = if limit < 0 then - defaultLimit + do let confLimit = cnfMaxEntityLength $! itrConfig itr + actualLimit = if limit < 0 then + confLimit else limit when (actualLimit <= 0) @@ -752,13 +755,13 @@ setStatus code -- 20 bytes long. In this case the client shall only accept the first -- 10 bytes of response body and thinks that the residual 10 bytes is -- a part of header of the next response. -setHeader :: ByteString -> ByteString -> Resource () +setHeader :: Strict.ByteString -> Strict.ByteString -> Resource () setHeader name value = name `seq` value `seq` driftTo DecidingHeader >> setHeader' name value -setHeader' :: ByteString -> ByteString -> Resource () +setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource () setHeader' name value = name `seq` value `seq` do itr <- getInteraction @@ -800,6 +803,7 @@ setContentEncoding codings let tr = case ver of HttpVersion 1 0 -> unnormalizeCoding HttpVersion 1 1 -> id + _ -> undefined setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings) @@ -817,7 +821,7 @@ output str = outputLBS $! L8.pack str {-# INLINE output #-} -- | This is mostly the same as 'output' but is more efficient. -outputLBS :: LazyByteString -> Resource () +outputLBS :: Lazy.ByteString -> Resource () outputLBS str = do outputChunkLBS str driftTo Done {-# INLINE outputLBS #-} @@ -834,9 +838,9 @@ outputChunk str = outputChunkLBS $! L8.pack str {-# INLINE outputChunk #-} -- | This is mostly the same as 'outputChunk' but is more efficient. -outputChunkLBS :: LazyByteString -> Resource () -outputChunkLBS str - = str `seq` +outputChunkLBS :: Lazy.ByteString -> Resource () +outputChunkLBS wholeChunk + = wholeChunk `seq` do driftTo DecidingBody itr <- getInteraction @@ -849,18 +853,18 @@ outputChunkLBS str readItr itr itrWillDiscardBody id unless (discardBody) - $ sendChunks str limit + $ sendChunks wholeChunk limit - unless (L8.null str) + unless (L8.null wholeChunk) $ liftIO $ atomically $ writeItr itr itrBodyIsNull False where -- チャンクの大きさは Config で制限されてゐる。もし例へば - -- "/dev/zero" を L8.readFile して作った LazyByteString をそのまま + -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま -- ResponseWriter に渡したりすると大變な事が起こる。何故なら -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書 -- く爲にチャンクの大きさを測る。 - sendChunks :: LazyByteString -> Int -> Resource () + sendChunks :: Lazy.ByteString -> Int -> Resource () sendChunks str limit | L8.null str = return () | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 2cd498f..cef168c 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -31,7 +31,7 @@ import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Utils -import Network.URI +import Network.URI hiding (path) import System.IO import System.IO.Error hiding (catch) import Prelude hiding (catch) @@ -114,7 +114,7 @@ data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree -- ] -- @ mkResTree :: [ ([String], ResourceDef) ] -> ResTree -mkResTree list = list `seq` processRoot list +mkResTree xs = xs `seq` processRoot xs where processRoot :: [ ([String], ResourceDef) ] -> ResTree processRoot list @@ -166,14 +166,14 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri where walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef) - walkTree subtree (name:[]) soFar - = case M.lookup name subtree of + walkTree tree (name:[]) soFar + = case M.lookup name tree of Nothing -> Nothing Just (ResNode defM _) -> do def <- defM return (soFar ++ [name], def) - walkTree subtree (x:xs) soFar - = case M.lookup x subtree of + walkTree tree (x:xs) soFar + = case M.lookup x tree of Nothing -> Nothing Just (ResNode defM children) -> case defM of Just (ResourceDef { resIsGreedy = True }) @@ -215,6 +215,7 @@ runResource def itr POST -> resPost def PUT -> resPut def DELETE -> resDelete def + _ -> undefined notAllowed :: Resource () notAllowed = do setStatus MethodNotAllowed @@ -239,7 +240,7 @@ runResource def itr ErrorCall msg -> Abortion InternalServerError emptyHeaders $ Just msg IOException ioE -> Abortion InternalServerError emptyHeaders $ Just $ formatIOE ioE DynException dynE -> case fromDynamic dynE of - Just (abo :: Abortion) -> abo + Just (a :: Abortion) -> a Nothing -> Abortion InternalServerError emptyHeaders $ Just $ show exc diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index fd949fe..8adf88a 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -15,8 +15,8 @@ module Network.HTTP.Lucu.Response ) where -import Data.ByteString.Base (ByteString) -import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.ByteString.Char8 as C8 hiding (ByteString) import Data.Dynamic import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.Headers @@ -148,7 +148,7 @@ doesMeet p sc = case statusCode sc of -- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual -- representation of @sc@. -statusCode :: StatusCode -> (# Int, ByteString #) +statusCode :: StatusCode -> (# Int, Strict.ByteString #) statusCode Continue = (# 100, C8.pack "Continue" #) statusCode SwitchingProtocols = (# 101, C8.pack "Switching Protocols" #) diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 52f6cf3..830baa6 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -36,15 +36,13 @@ responseWriter cnf h tQueue readerTID = {-# SCC "awaitSomethingToWrite" #-} do action <- atomically $! - do -- キューが空でなくなるまで待つ - queue <- readTVar tQueue - when (S.null queue) - retry - + -- キューが空でなくなるまで待つ + do queue <- readTVar tQueue -- GettingBody 状態にあり、Continue が期待され -- てゐて、それがまだ送信前なのであれば、 -- Continue を送信する。 case S.viewr queue of + EmptyR -> retry _ :> itr -> do state <- readItr itr itrState id if state == GettingBody then @@ -163,6 +161,7 @@ responseWriter cnf h tQueue readerTID do queue <- readTVar tQueue case S.viewr queue of + EmptyR -> return () -- this should never happen remaining :> _ -> writeTVar tQueue remaining readItr itr itrWillClose id diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 12cf78b..7c2ce5c 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -13,6 +13,7 @@ module Network.HTTP.Lucu.StaticFile import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Lazy.Char8 as B +import Data.Time.Clock.POSIX import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.ETag @@ -22,7 +23,6 @@ import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Utils -import System.Directory import System.Posix.Files @@ -53,33 +53,33 @@ staticFile path handleStaticFile :: FilePath -> Resource () handleStaticFile path = path `seq` - do isFile <- liftIO $ doesFileExist path - if isFile then + do exists <- liftIO $ fileExist path + if exists then -- 存在はした。讀めるかどうかは知らない。 - do readable <- liftIO $ fileAccess path True False False - unless readable + do stat <- liftIO $ getFileStatus path + if isRegularFile stat then + do readable <- liftIO $ fileAccess path True False False + unless readable -- 讀めない $ abort Forbidden [] Nothing + -- 讀める + tag <- liftIO $ generateETagFromFile path + lastMod <- return $ posixSecondsToUTCTime $ toEnum $ fromEnum $ modificationTime stat + foundEntity tag lastMod - -- 讀める - tag <- liftIO $ generateETagFromFile path - lastMod <- liftIO $ getModificationTime path - foundEntity tag lastMod + -- MIME Type を推定 + conf <- getConfig + case guessTypeByFileName (cnfExtToMIMEType conf) path of + Nothing -> return () + Just mime -> setContentType mime - -- MIME Type を推定 - conf <- getConfig - case guessTypeByFileName (cnfExtToMIMEType conf) path of - Nothing -> return () - Just mime -> setContentType mime - - -- 實際にファイルを讀んで送る - (liftIO $ B.readFile path) >>= outputLBS - else - do isDir <- liftIO $ doesDirectoryExist path - if isDir then - abort Forbidden [] Nothing + -- 實際にファイルを讀んで送る + (liftIO $ B.readFile path) >>= outputLBS else - foundNoEntity Nothing + abort Forbidden [] Nothing + else + foundNoEntity Nothing + -- |Computation of @'generateETagFromFile' fpath@ generates a strong -- entity tag from a file. The file doesn't necessarily have to be a diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index b679a93..6b749a8 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -10,18 +10,17 @@ module Network.HTTP.Lucu.Utils ) where -import Data.Char -import Data.List +import Data.List hiding (last) import Network.URI +import Prelude hiding (last) -- |> splitBy (== ':') "ab:c:def" -- > ==> ["ab", "c", "def"] splitBy :: (a -> Bool) -> [a] -> [[a]] -splitBy isSeparator src - = isSeparator `seq` - case break isSeparator src - of (last , [] ) -> last : [] - (first, sep:rest) -> first : splitBy isSeparator rest +splitBy isSep src + = case break isSep src + of (last , [] ) -> last : [] + (first, _sep:rest) -> first : splitBy isSep rest -- |> joinWith ":" ["ab", "c", "def"] -- > ==> "ab:c:def" @@ -72,5 +71,5 @@ parseWWWFormURLEncoded src return ( unEscapeString key , unEscapeString $ case value of ('=':val) -> val - "" -> "" + val -> val ) -- 2.40.0