From: pho Date: Tue, 10 Nov 2009 05:49:04 +0000 (+0900) Subject: Cosmetic changes suggested by hlint X-Git-Tag: RELEASE-0_4_1~2 X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=f62b6f07bbf1eefcf552163d8f7daa6e0862ed5d Cosmetic changes suggested by hlint Ignore-this: 28bf8a64b9fcc04a983b14d4893ca14f darcs-hash:20091110054904-62b54-30cdb8d478c8a477e4b38cff03d296e71791bacf.gz --- diff --git a/.boring b/.boring index e8b77c9..408e6f4 100644 --- a/.boring +++ b/.boring @@ -53,6 +53,7 @@ ^Setup$ ^\.setup-config$ ^.installed-pkg-config$ +^report\.html$ ^data/CompileMimeTypes$ ^examples/HelloWorld$ diff --git a/ImplantFile.hs b/ImplantFile.hs index ae749b9..1d7d43d 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -78,11 +78,11 @@ main :: IO () main = withOpenSSL $ do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs - when (not $ null errors) + unless (null errors) $ do mapM_ putStr errors exitWith $ ExitFailure 1 - when (any (\ x -> x == OptHelp) opts) + when (any (== OptHelp) opts) $ do printUsage exitWith ExitSuccess @@ -106,7 +106,7 @@ generateHaskellSource opts srcFile output <- openOutput opts eTag <- getETag opts input - let compParams = defaultCompressParams { compressLevel = BestCompression } + let compParams = defaultCompressParams { compressLevel = bestCompression } gzippedData = compressWith compParams input originalLen = L.length input gzippedLen = L.length gzippedData @@ -371,12 +371,12 @@ getSymbolName opts modName _ -> False) opts -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を -- 小文字にしたものを使ふ。 - 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 + 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 case symNameOpts of [] -> return defaultSymName @@ -400,8 +400,8 @@ getMIMEType opts srcFile getLastModified :: FilePath -> IO UTCTime getLastModified "-" = getCurrentTime -getLastModified fpath = getFileStatus fpath - >>= return . posixSecondsToUTCTime . fromRational . toRational . modificationTime +getLastModified fpath = fmap (posixSecondsToUTCTime . fromRational . toRational . modificationTime) + $ getFileStatus fpath getETag :: [CmdOpt] -> Lazy.ByteString -> IO String @@ -411,25 +411,26 @@ getETag opts input _ -> False) opts in case eTagOpts of - [] -> getDigestByName "SHA1" >>= return . mkETagFromInput . fromJust + [] -> fmap (mkETagFromInput . fromJust) (getDigestByName "SHA1") (OptETag str):[] -> return str _ -> error "too many --etag options." where mkETagFromInput :: Digest -> String - mkETagFromInput sha1 = "SHA-1:" ++ (toHex $ digestLBS sha1 input) + mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input) - toHex :: [Char] -> String - toHex [] = "" - toHex (x:xs) = hexByte (fromEnum x) ++ toHex xs + toHex :: String -> String + toHex = foldr ((++) . hexByte . fromEnum) "" hexByte :: Int -> String hexByte n - = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : [] + = [ hex4bit ((n `shiftR` 4) .&. 0x0F) + , hex4bit ( n .&. 0x0F) + ] 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 diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 33f22ab..6d36ea8 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -109,7 +109,6 @@ abortPage conf reqM res abo Nothing -> let res' = res { resStatus = aboStatus abo } res'' = foldl (.) id [setHeader name value - | (name, value) <- fromHeaders $ aboHeaders abo] - $ res' + | (name, value) <- fromHeaders $ aboHeaders abo] res' in getDefaultPage conf reqM res'' diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs index 37adda3..0771efa 100644 --- a/Network/HTTP/Lucu/ContentCoding.hs +++ b/Network/HTTP/Lucu/ContentCoding.hs @@ -7,6 +7,7 @@ module Network.HTTP.Lucu.ContentCoding where import Data.Char +import Data.Ord import Data.Maybe import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http @@ -43,4 +44,5 @@ unnormalizeCoding coding orderAcceptEncodings :: (String, Maybe Double) -> (String, Maybe Double) -> Ordering orderAcceptEncodings (_, q1) (_, q2) - = fromMaybe 0 q1 `compare` fromMaybe 0 q2 + = comparing (fromMaybe 0) q1 q2 + diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 6a98010..cbbf674 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -29,9 +29,8 @@ import Text.XML.HXT.DOM.XmlKeywords getDefaultPage :: Config -> Maybe Request -> Response -> String -getDefaultPage conf req res - = conf `seq` req `seq` res `seq` - let msgA = getMsg req res +getDefaultPage !conf !req !res + = let msgA = getMsg req res in unsafePerformIO $ do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA @@ -42,10 +41,9 @@ getDefaultPage conf req res writeDefaultPage :: Interaction -> STM () -writeDefaultPage itr - = itr `seq` - -- Content-Type が正しくなければ補完できない。 - do res <- readItr itr itrResponse id +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 @@ -57,9 +55,8 @@ writeDefaultPage itr mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree -mkDefaultPage conf status msgA - = conf `seq` status `seq` msgA `seq` - let (# sCode, sMsg #) = statusCode status +mkDefaultPage !conf !status !msgA + = let (# sCode, sMsg #) = statusCode status sig = C8.unpack (cnfServerSoftware conf) ++ " at " ++ C8.unpack (cnfServerHost conf) @@ -85,9 +82,8 @@ mkDefaultPage conf status msgA {-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-} getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree -getMsg req res - = req `seq` res `seq` - case resStatus res of +getMsg !req !res + = case resStatus res of -- 1xx は body を持たない -- 2xx の body は補完しない diff --git a/Network/HTTP/Lucu/Format.hs b/Network/HTTP/Lucu/Format.hs index f017f5e..93c2cda 100644 --- a/Network/HTTP/Lucu/Format.hs +++ b/Network/HTTP/Lucu/Format.hs @@ -24,7 +24,7 @@ fmtInt base upperCase minWidth pad forceSign n where fmt' :: Int -> String fmt' m - | m < base = (intToChar upperCase m) : [] + | m < base = [intToChar upperCase m] | otherwise = (intToChar upperCase $! m `mod` base) : fmt' (m `div` base) @@ -40,50 +40,54 @@ fmtDec minWidth n fmtDec2 :: Int -> String 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) - : [] + | n < 10 = [ '0' + , intToChar undefined n + ] + | otherwise = [ intToChar undefined (n `div` 10) + , intToChar undefined (n `mod` 10) + ] fmtDec3 :: Int -> String 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) - : [] + | 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 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) - : [] + | 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 diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index febbdb6..163f6bc 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -21,6 +21,7 @@ import Data.Char import Data.List import Data.Map (Map) import qualified Data.Map as M +import Data.Ord import Data.Word import Foreign.ForeignPtr import Foreign.Ptr @@ -76,7 +77,7 @@ noCaseCmp' p1 l1 p2 l2 | otherwise = do c1 <- peek p1 c2 <- peek p2 - case toLower (w2c c1) `compare` toLower (w2c c2) of + case comparing (toLower . w2c) c1 c2 of EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1) x -> return x @@ -194,7 +195,7 @@ headersP = do xs <- many header normalize :: String -> String normalize = trimBody . trim isWhiteSpace - trimBody = foldr (++) [] + trimBody = concat . map (\ s -> if head s == ' ' then " " else diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 6b5cdae..5da428d 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -84,8 +84,8 @@ defaultPageContentType = C8.pack "application/xhtml+xml" newInteraction :: Config -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction newInteraction !conf !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)] @@ -115,7 +115,7 @@ newInteraction !conf !addr !cert !req wroteContinue <- newTVarIO False wroteHeader <- newTVarIO False - return $ Interaction { + return Interaction { itrConfig = conf , itrRemoteAddr = addr , itrRemoteCert = cert @@ -150,33 +150,28 @@ newInteraction !conf !addr !cert !req writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM () -writeItr itr accessor value - = itr `seq` accessor `seq` value `seq` - writeTVar (accessor itr) value +writeItr !itr !accessor !value + = writeTVar (accessor itr) value readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b -readItr itr accessor reader - = itr `seq` accessor `seq` reader `seq` - readTVar (accessor itr) >>= return . reader +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 - = itr `seq` accessor `seq` reader `seq` - readItr itr accessor (fmap reader) +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 - = itr `seq` accessor `seq` updator `seq` - do old <- readItr itr accessor id +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 - = itr `seq` accessor `seq` updator `seq` - updateItr itr accessor (fmap updator) +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 diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 9a36ad5..d08a145 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -93,6 +93,9 @@ instance Monad Parser where 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 diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index adbda7b..f6c80dc 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -87,7 +87,7 @@ lws = do s <- option "" crlf -- |'text' accepts one character which doesn't satisfy 'isCtl'. text :: Parser Char -text = satisfy (\ c -> not (isCtl c)) +text = satisfy (not . isCtl) -- |'separator' accepts one character which satisfies 'isSeparator'. separator :: Parser Char diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index d3659cc..489a4f9 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -56,13 +56,12 @@ import System.IO.Unsafe -} postprocess :: Interaction -> STM () -postprocess itr - = itr `seq` - do reqM <- readItr itr itrRequest id +postprocess !itr + = do reqM <- readItr itr itrRequest id res <- readItr itr itrResponse id let sc = resStatus res - when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError]) + unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError]) $ abortSTM InternalServerError [] $ Just ("The status code is not good for a final status: " ++ show sc) @@ -119,10 +118,8 @@ postprocess itr conn <- readHeader (C8.pack "Connection") case conn of Nothing -> return () - Just value -> if value `noCaseEq` C8.pack "close" then - writeItr itr itrWillClose True - else - return () + Just value -> when (value `noCaseEq` C8.pack "close") + $ writeItr itr itrWillClose True willClose <- readItr itr itrWillClose id when willClose @@ -132,20 +129,17 @@ postprocess itr $ writeTVar (itrWillDiscardBody itr) True readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString) - readHeader name - = name `seq` - readItr itr itrResponse $ getHeader name + readHeader !name + = readItr itr itrResponse $ getHeader name updateRes :: (Response -> Response) -> STM () - updateRes updator - = updator `seq` - updateItr itr itrResponse updator + updateRes !updator + = updateItr itr itrResponse updator completeUnconditionalHeaders :: Config -> Response -> IO Response -completeUnconditionalHeaders conf res - = conf `seq` res `seq` - return res >>= compServer >>= compDate >>= return +completeUnconditionalHeaders !conf !res + = compServer res >>= compDate where compServer res' = case getHeader (C8.pack "Server") res' of @@ -177,7 +171,6 @@ getCurrentDate = do now <- getCurrentTime where mostlyEq :: UTCTime -> UTCTime -> Bool mostlyEq a b - = if utctDay a == utctDay b then - fromEnum (utctDayTime a) == fromEnum (utctDayTime b) - else - False + = (utctDay a == utctDay b) + && + (fromEnum (utctDayTime a) == fromEnum (utctDayTime b)) diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 6191273..de5efaa 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -100,7 +100,7 @@ preprocess itr portStr = case port of Just 80 -> Just "" - Just n -> Just $ ":" ++ show n + Just n -> Just $ ':' : show n Nothing -> Nothing case portStr of Just str -> updateAuthority host (C8.pack str) @@ -110,10 +110,10 @@ preprocess itr -- いと思ふ。stderr？ Nothing -> setStatus InternalServerError else - do case getHeader (C8.pack "Host") req of - Just str -> let (host, portStr) = parseHost str - in updateAuthority host portStr - Nothing -> setStatus BadRequest + case getHeader (C8.pack "Host") req of + Just str -> let (host, portStr) = parseHost str + in updateAuthority host portStr + Nothing -> setStatus BadRequest parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString) @@ -148,13 +148,11 @@ preprocess itr case getHeader (C8.pack "Transfer-Encoding") req of Nothing -> return () - Just value -> if value `noCaseEq` C8.pack "identity" then - return () - else - if value `noCaseEq` C8.pack "chunked" then - writeItr itr itrRequestIsChunked True - else - setStatus NotImplemented + Just value -> unless (value `noCaseEq` C8.pack "identity") + $ if value `noCaseEq` C8.pack "chunked" then + writeItr itr itrRequestIsChunked True + else + setStatus NotImplemented case getHeader (C8.pack "Content-Length") req of Nothing -> return () @@ -167,7 +165,5 @@ preprocess itr case getHeader (C8.pack "Connection") req of Nothing -> return () - Just value -> if value `noCaseEq` C8.pack "close" then - writeItr itr itrWillClose True - else - return () + Just value -> when (value `noCaseEq` C8.pack "close") + $ writeItr itr itrWillClose True diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index c98a400..044ba22 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -67,19 +67,19 @@ requestLineP = do method <- methodP methodP :: Parser Method -methodP = (let methods = [ ("OPTIONS", OPTIONS) - , ("GET" , GET ) - , ("HEAD" , HEAD ) - , ("POST" , POST ) - , ("PUT" , PUT ) - , ("DELETE" , DELETE ) - , ("TRACE" , TRACE ) - , ("CONNECT", CONNECT) - ] - in foldl (<|>) failP $ map (\ (str, mth) - -> string str >> return mth) methods) +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 ) <|> - token >>= return . ExtensionMethod + fmap ExtensionMethod token uriP :: Parser URI diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index de19e04..06fed17 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -199,10 +199,10 @@ runResource def itr driftTo Done ) itr ) - $ \ exc -> processException exc + processException where fork :: IO () -> IO ThreadId - fork = if (resUsesNativeThread def) + fork = if resUsesNativeThread def then forkOS else forkIO @@ -223,12 +223,12 @@ runResource def itr setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods) allowedMethods :: [String] - allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"] - , methods resHead ["GET", "HEAD"] - , methods resPost ["POST"] - , methods resPut ["PUT"] - , methods resDelete ["DELETE"] - ] + allowedMethods = nub $ concat [ methods resGet ["GET"] + , methods resHead ["GET", "HEAD"] + , methods resPost ["POST"] + , methods resPut ["PUT"] + , methods resDelete ["DELETE"] + ] methods :: (ResourceDef -> Maybe a) -> [String] -> [String] methods f xs = case f def of @@ -253,7 +253,7 @@ runResource def itr if state <= DecidingHeader then flip runRes itr $ do setStatus $ aboStatus abo - mapM_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo + mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo output $ abortPage conf reqM res abo else when (cnfDumpTooLateAbortionToStderr $ itrConfig itr) diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 63174b7..6ad15e8 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -35,30 +35,28 @@ responseWriter !cnf !h !tQueue !readerTID awaitSomethingToWrite :: IO () awaitSomethingToWrite = {-# SCC "awaitSomethingToWrite" #-} - do action - <- atomically $! - -- キューが空でなくなるまで待つ - do queue <- readTVar tQueue - -- GettingBody 状態にあり、Continue が期待され - -- てゐて、それがまだ送信前なのであれば、 - -- Continue を送信する。 - case S.viewr queue of - EmptyR -> retry - _ :> itr -> do state <- readItr itr itrState id + join $! + atomically $! + -- キューが空でなくなるまで待つ + 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 - writeContinueIfNecessary itr - else - if state >= DecidingBody then - writeHeaderOrBodyIfNecessary itr - else - retry - action + if state == GettingBody then + writeContinueIfNecessary itr + else + if state >= DecidingBody then + writeHeaderOrBodyIfNecessary itr + else + retry writeContinueIfNecessary :: Interaction -> STM (IO ()) - writeContinueIfNecessary itr + writeContinueIfNecessary !itr = {-# SCC "writeContinueIfNecessary" #-} - itr `seq` do expectedContinue <- readItr itr itrExpectedContinue id if expectedContinue then do wroteContinue <- readItr itr itrWroteContinue id @@ -75,13 +73,12 @@ responseWriter !cnf !h !tQueue !readerTID retry writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ()) - writeHeaderOrBodyIfNecessary itr + writeHeaderOrBodyIfNecessary !itr -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が -- 空でなければ、それを出力する。空である時は、もし状態が -- Done であれば後処理をする。 = {-# SCC "writeHeaderOrBodyIfNecessary" #-} - itr `seq` do wroteHeader <- readItr itr itrWroteHeader id if not wroteHeader then @@ -100,9 +97,8 @@ responseWriter !cnf !h !tQueue !readerTID return $! writeBodyChunk itr writeContinue :: Interaction -> IO () - writeContinue itr + writeContinue !itr = {-# SCC "writeContinue" #-} - itr `seq` do let cont = Response { resVersion = HttpVersion 1 1 , resStatus = Continue @@ -115,9 +111,8 @@ responseWriter !cnf !h !tQueue !readerTID awaitSomethingToWrite writeHeader :: Interaction -> IO () - writeHeader itr + writeHeader !itr = {-# SCC "writeHeader" #-} - itr `seq` do res <- atomically $! do writeItr itr itrWroteHeader True readItr itr itrResponse id hPutResponse h res @@ -125,9 +120,8 @@ responseWriter !cnf !h !tQueue !readerTID awaitSomethingToWrite writeBodyChunk :: Interaction -> IO () - writeBodyChunk itr + writeBodyChunk !itr = {-# SCC "writeBodyChunk" #-} - itr `seq` do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id willChunkBody <- atomically $! readItr itr itrWillChunkBody id chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id @@ -145,18 +139,16 @@ responseWriter !cnf !h !tQueue !readerTID awaitSomethingToWrite finishBodyChunk :: Interaction -> IO () - finishBodyChunk itr + finishBodyChunk !itr = {-# SCC "finishBodyChunk" #-} - itr `seq` do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id willChunkBody <- atomically $! readItr itr itrWillChunkBody id when (not willDiscardBody && willChunkBody) $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h finalize :: Interaction -> IO () - finalize itr + finalize !itr = {-# SCC "finalize" #-} - itr `seq` do finishBodyChunk itr willClose <- atomically $! do queue <- readTVar tQueue diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 608d608..5b0ce57 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -64,7 +64,7 @@ handleStaticFile path $ abort Forbidden [] Nothing -- 讀める tag <- liftIO $ generateETagFromFile path - lastMod <- return $ posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat + let lastMod = posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat foundEntity tag lastMod -- MIME Type を推定 @@ -74,7 +74,7 @@ handleStaticFile path Just mime -> setContentType mime -- 實際にファイルを讀んで送る - (liftIO $ B.readFile path) >>= outputLBS + liftIO (B.readFile path) >>= outputLBS else abort Forbidden [] Nothing else diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 6b749a8..9212747 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -19,7 +19,7 @@ import Prelude hiding (last) splitBy :: (a -> Bool) -> [a] -> [[a]] splitBy isSep src = case break isSep src - of (last , [] ) -> last : [] + of (last , [] ) -> [last] (first, _sep:rest) -> first : splitBy isSep rest -- |> joinWith ":" ["ab", "c", "def"] diff --git a/cabal-package.mk b/cabal-package.mk index ca291ff..d8bbaad 100644 --- a/cabal-package.mk +++ b/cabal-package.mk @@ -13,6 +13,7 @@ FIND ?= find RM_RF ?= rm -rf SUDO ?= sudo AUTOCONF ?= autoconf +HLINT ?= hlint CONFIGURE_ARGS ?= --disable-optimization @@ -86,4 +87,9 @@ sdist: setup-config test: build ./Setup test -.PHONY: build build-hook setup-config setup-config-hook run clean clean-hook install doc sdist test +lint: + $(HLINT) . --report \ + --ignore="Use string literal" \ + --ignore="Use concatMap" + +.PHONY: build build-hook setup-config setup-config-hook run clean clean-hook install doc sdist test lint