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') ||
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 #-}
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)
-}
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 のこの部分
-- の記述はひどく曖昧であり、この動作が本當に間違って
-- ゐるのかどうかも良く分からない。例へば
-- のか？直勸的には駄目さうに思へるが、そんな記述は見
-- 付からない。
contents <- many (lws <|> many1 text)
- crlf
+ _ <- crlf
let value = foldr (++) "" contents
norm = normalize value
return (C8.pack name, C8.pack norm)
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)
]
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
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)
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
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)
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
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
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)
)
where
-import Data.List
import Network.HTTP.Lucu.Parser
-- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@.
-- ('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'@
-- |'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]
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)
requestP :: Parser Request
-requestP = do many crlf
+requestP = do _ <- many crlf
(method, uri, version) <- requestLineP
headers <- headersP
return Request {
requestLineP :: Parser (Method, URI, HttpVersion)
requestLineP = do method <- methodP
- sp
+ _ <- sp
uri <- uriP
- sp
+ _ <- sp
ver <- httpVersionP
- crlf
+ _ <- crlf
return (method, uri, ver)
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
projects / Lucu.git / commitdiff