Lucu 0.4.1 → 0.4.2

raw patch · 17 files changed

+85/−85 lines, 17 files

Files

• Lucu.cabal +1/−1
• NEWS +5/−0
• Network/HTTP/Lucu/Authorization.hs +2/−2
• Network/HTTP/Lucu/Chunk.hs +9/−7
• Network/HTTP/Lucu/ContentCoding.hs +1/−1
• Network/HTTP/Lucu/Headers.hs +3/−3
• Network/HTTP/Lucu/HttpVersion.hs +3/−5
• Network/HTTP/Lucu/Httpd.hs +1/−1
• Network/HTTP/Lucu/MIMEType.hs +8/−8
• Network/HTTP/Lucu/MIMEType/Guess.hs +6/−7
• Network/HTTP/Lucu/MultipartForm.hs +16/−16
• Network/HTTP/Lucu/Parser/Http.hs +7/−9
• Network/HTTP/Lucu/RFC1123DateTime.hs +10/−10
• Network/HTTP/Lucu/Request.hs +4/−4
• Network/HTTP/Lucu/RequestReader.hs +2/−2
• Network/HTTP/Lucu/ResponseWriter.hs +1/−1
• Network/HTTP/Lucu/Utils.hs +6/−8

@@ -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 <pho at cielonegro dot org>

@@ -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)

@@ -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') ||

@@ -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 #-}  

@@ -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)

@@ -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)

@@ -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)                       ]

@@ -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

@@ -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) 

@@ -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) 

@@ -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)

@@ -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] 

@@ -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)

@@ -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)  

@@ -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

@@ -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

@@ -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 '"' = "\\\""