diff --git a/Lucu.cabal b/Lucu.cabal --- a/Lucu.cabal +++ b/Lucu.cabal @@ -8,7 +8,7 @@ messing around FastCGI. It is also intended to be run behind a reverse-proxy so it doesn't have some facilities like logging, client filtering or such like. -Version: 0.4.1 +Version: 0.4.2 License: PublicDomain License-File: COPYING Author: PHO diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,8 @@ +Changes from 0.4.1 to 0.4.2 +--------------------------- +* Fixed build failure on GHC 6.12.1. (Thanks: Voker57) + + Changes from 0.4 to 0.4.1 ------------------------- * Network.HTTP.Lucu.Resource: (Thanks: Voker57) diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs --- a/Network/HTTP/Lucu/Authorization.hs +++ b/Network/HTTP/Lucu/Authorization.hs @@ -51,8 +51,8 @@ authCredentialP :: Parser AuthCredential authCredentialP = allowEOF $! - do string "Basic" - many1 lws + do _ <- string "Basic" + _ <- many1 lws b64 <- many1 $ satisfy (\ c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs --- a/Network/HTTP/Lucu/Chunk.hs +++ b/Network/HTTP/Lucu/Chunk.hs @@ -13,18 +13,20 @@ chunkHeaderP :: Num a => Parser a chunkHeaderP = do hexLen <- many1 hexDigit - extension - crlf + _ <- extension + _ <- crlf let [(len, _)] = readHex hexLen return len where extension :: Parser () - extension = do many $ do char ';' - token - char '=' - token <|> quotedStr - return () + extension = many ( char ';' >> + token >> + char '=' >> + ( token <|> quotedStr ) + ) + >> + return () {-# SPECIALIZE chunkHeaderP :: Parser Int #-} diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs --- a/Network/HTTP/Lucu/ContentCoding.hs +++ b/Network/HTTP/Lucu/ContentCoding.hs @@ -20,7 +20,7 @@ accEncP :: Parser (String, Maybe Double) accEncP = do coding <- token qVal <- option Nothing - $ do string ";q=" + $ do _ <- string ";q=" q <- qvalue return $ Just q return (normalizeCoding coding, qVal) diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -174,12 +174,12 @@ -} headersP :: Parser Headers headersP = do xs <- many header - crlf + _ <- crlf return $! toHeaders xs where header :: Parser (Strict.ByteString, Strict.ByteString) header = do name <- token - char ':' + _ <- char ':' -- FIXME: これは多少インチキだが、RFC 2616 のこの部分 -- の記述はひどく曖昧であり、この動作が本當に間違って -- ゐるのかどうかも良く分からない。例へば @@ -187,7 +187,7 @@ -- のか？直勸的には駄目さうに思へるが、そんな記述は見 -- 付からない。 contents <- many (lws <|> many1 text) - crlf + _ <- crlf let value = foldr (++) "" contents norm = normalize value return (C8.pack name, C8.pack norm) diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -33,13 +33,11 @@ httpVersionP = string "HTTP/" >> -- 頻出するので高速化 - choice [ do string "1.0" - return $ HttpVersion 1 0 - , do string "1.1" - return $ HttpVersion 1 1 + choice [ string "1.0" >> return (HttpVersion 1 0) + , string "1.1" >> return (HttpVersion 1 1) -- 一般の場合 , do major <- many1 digit - char '.' + _ <- char '.' minor <- many1 digit return $ HttpVersion (read major) (read minor) ] diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -53,7 +53,7 @@ runHttpd :: Config -> ResTree -> [FallbackHandler] -> IO () runHttpd cnf tree fbs = withSocketsDo $ - do installHandler sigPIPE Ignore Nothing + do _ <- installHandler sigPIPE Ignore Nothing case cnfSSLConfig cnf of Nothing diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -55,18 +55,18 @@ mimeTypeP :: Parser MIMEType mimeTypeP = allowEOF $! - do maj <- token - char '/' - min <- token + do maj <- token + _ <- char '/' + min <- token params <- many paramP return $ MIMEType maj min params where paramP :: Parser (String, String) - paramP = do many lws - char ';' - many lws - name <- token - char '=' + paramP = do _ <- many lws + _ <- char ';' + _ <- many lws + name <- token + _ <- char '=' value <- token <|> quotedStr return (name, value) diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -21,7 +21,6 @@ import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils -import System.IO -- |'Data.Map.Map' from extension to MIME Type. type ExtMap = Map String MIMEType @@ -56,14 +55,14 @@ where spc = oneOf " \t" - comment = do many spc - char '#' - many $ satisfy (/= '\n') - return Nothing + comment = many spc >> + char '#' >> + ( many $ satisfy (/= '\n') ) >> + return Nothing - validLine = do many spc + validLine = do _ <- many spc mime <- mimeTypeP - many spc + _ <- many spc exts <- sepBy token (many spc) return $ Just (mime, exts) diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -53,19 +53,19 @@ multipartFormP :: String -> Parser [FormData] multipartFormP boundary = do parts <- many (partP boundary) - string "--" - string boundary - string "--" - crlf + _ <- string "--" + _ <- string boundary + _ <- string "--" + _ <- crlf eof return $ map partToFormData parts partP :: String -> Parser Part partP boundary - = do string "--" - string boundary - crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。 + = do _ <- string "--" + _ <- string boundary + _ <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。 hs <- headersP body <- bodyP boundary return $ Part hs body @@ -74,11 +74,11 @@ bodyP :: String -> Parser L8.ByteString bodyP boundary = do body <- manyChar $ - do notFollowedBy $ do crlf - string "--" - string boundary + do notFollowedBy $ ( crlf >> + string "--" >> + string boundary ) anyChar - crlf + _ <- crlf return body @@ -146,10 +146,10 @@ return $ ContDispo dispoType params where paramP :: Parser (String, String) - paramP = do many lws - char ';' - many lws - name <- token - char '=' + paramP = do _ <- many lws + _ <- char ';' + _ <- many lws + name <- token + _ <- char '=' value <- token <|> quotedStr return (name, value) diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -17,7 +17,6 @@ ) where -import Data.List import Network.HTTP.Lucu.Parser -- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@. @@ -67,11 +66,10 @@ -- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any -- occurrences of LWS before and after each tokens. listOf :: Parser a -> Parser [a] -listOf p = p `seq` - do many lws - sepBy p $! do many lws - char ',' - many lws +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'@ @@ -96,15 +94,15 @@ -- |'quotedStr' accepts a string surrounded by double quotation -- marks. Quotes can be escaped by backslashes. quotedStr :: Parser String -quotedStr = do char '"' +quotedStr = do _ <- char '"' xs <- many (qdtext <|> quotedPair) - char '"' + _ <- char '"' return $ foldr (++) "" xs where qdtext = do c <- satisfy (/= '"') return [c] - quotedPair = do char '\\' + quotedPair = do _ <- char '\\' c <- satisfy isChar return [c] diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs --- a/Network/HTTP/Lucu/RFC1123DateTime.hs +++ b/Network/HTTP/Lucu/RFC1123DateTime.hs @@ -82,22 +82,22 @@ httpDateTime :: Parser UTCTime -httpDateTime = do foldl (<|>) failP (map string weekStr) - char ',' - char ' ' +httpDateTime = do _ <- foldl (<|>) failP (map string weekStr) + _ <- char ',' + _ <- char ' ' day <- liftM read (count 2 digit) - char ' ' + _ <- char ' ' mon <- foldl (<|>) failP (map tryEqToFst (zip monthStr [1..])) - char ' ' + _ <- char ' ' year <- liftM read (count 4 digit) - char ' ' + _ <- char ' ' hour <- liftM read (count 2 digit) - char ':' + _ <- char ':' min <- liftM read (count 2 digit) - char ':' + _ <- char ':' sec <- liftM read (count 2 digit) :: Parser Int - char ' ' - string "GMT" + _ <- char ' ' + _ <- string "GMT" eof let julianDay = fromGregorian year mon day timeOfDay = TimeOfDay hour min (fromIntegral sec) diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -45,7 +45,7 @@ requestP :: Parser Request -requestP = do many crlf +requestP = do _ <- many crlf (method, uri, version) <- requestLineP headers <- headersP return Request { @@ -58,11 +58,11 @@ requestLineP :: Parser (Method, URI, HttpVersion) requestLineP = do method <- methodP - sp + _ <- sp uri <- uriP - sp + _ <- sp ver <- httpVersionP - crlf + _ <- crlf return (method, uri, ver) diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -35,7 +35,7 @@ `catches` [ Handler (( \ _ -> return () ) :: IOException -> IO ()) , Handler ( \ ThreadKilled -> return () ) - , Handler ( \ BlockedIndefinitely -> hPutStrLn stderr "requestReader: blocked indefinitely" ) + , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestReader: blocked indefinitely" ) , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ()) ] where @@ -119,7 +119,7 @@ do let itr = oldItr { itrResourcePath = Just rsrcPath } requestHasBody <- readItr itr itrRequestHasBody id enqueue itr - return $ do runResource rsrcDef itr + return $ do _ <- runResource rsrcDef itr if requestHasBody then observeRequest itr input else diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -28,7 +28,7 @@ `catches` [ Handler (( \ _ -> return () ) :: IOException -> IO ()) , Handler ( \ ThreadKilled -> return () ) - , Handler ( \ BlockedIndefinitely -> hPutStrLn stderr "requestWriter: blocked indefinitely" ) + , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestWriter: blocked indefinitely" ) , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ()) ] where diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -10,9 +10,10 @@ ) where -import Data.List hiding (last) +import Control.Monad +import Data.List hiding (last) import Network.URI -import Prelude hiding (last) +import Prelude hiding (last) -- |> splitBy (== ':') "ab:c:def" -- > ==> ["ab", "c", "def"] @@ -25,14 +26,12 @@ -- |> joinWith ":" ["ab", "c", "def"] -- > ==> "ab:c:def" joinWith :: [a] -> [[a]] -> [a] -joinWith separator xs - = separator `seq` xs `seq` - foldr (++) [] $! intersperse separator xs +joinWith = (join .) . intersperse -- |> trim (== '_') "__ab_c__def___" -- > ==> "ab_c__def" trim :: (a -> Bool) -> [a] -> [a] -trim p = p `seq` trimTail . trimHead +trim !p = trimTail . trimHead where trimHead = dropWhile p trimTail = reverse . trimHead . reverse @@ -53,8 +52,7 @@ -- > quoteStr "ab\"c" -- > ==> "\"ab\\\"c\"" quoteStr :: String -> String -quoteStr str = str `seq` - foldr (++) "" (["\""] ++ map quote str ++ ["\""]) +quoteStr !str = concat (["\""] ++ map quote str ++ ["\""]) where quote :: Char -> String quote '"' = "\\\""