module Text.LogFormat where
import Data.Map
import Text.Parsec
type Parser a = Parsec String () a
data Rule = Literal String
| Keyword Char (Maybe String)
deriving Show
logFormatParser :: String -> Either ParseError (Parser (Map String String))
logFormatParser logFormat = parse rulesParser parserName logFormat
where rulesParser = do rules <- logFormatSpecParser
return $ buildLogRecordParser rules
parserName = "Parsing LogFormat [" ++ logFormat ++ "]"
logFormatSpecParser = do rules <- many1 (rule <|> literal)
return $ combineLiterals rules
combineLiterals [] = []
combineLiterals (Literal l1 : Literal l2 : rs) =
combineLiterals $ Literal (l1 ++ l2) : rs
combineLiterals (r:rs) = r : combineLiterals rs
rule = try simpleRule <|> try literalRule <|> try sRule <|> iRule
simpleRule = do char '%'
format <- oneOf "aABbCDefhHlmnopPqrtTuUvVXIO"
return $ Keyword format Nothing
literalRule = do string "%%"
return $ Literal "%"
sRule = do char '%'
mod <- optionMaybe $ string ">"
char 's'
return $ Keyword 's' mod
iRule = do char '%'
mod <- optionMaybe $ between (char '{') (char '}') (many $ alphaNum <|> char '-')
char 'i'
return $ Keyword 'i' mod
literal = do str <- many1 $ noneOf "%"
return $ Literal str
buildLogRecordParser :: [Rule] -> Parser (Map String String)
buildLogRecordParser rules = Prelude.foldr combiner eolParser rules
where eolParser = do newline
return empty
combiner (Keyword 'i' mod) followingParser = headerParser mod followingParser
combiner rule followingParser = do m1 <- parserFor rule
m2 <- followingParser
return $ union m1 m2
headerParser mod followingParser = do
value <- manyTill anyChar (lookAhead (try followingParser))
rest <- followingParser
return $ insert key value rest
where key = case mod of
Nothing -> "header"
Just m -> "header:" ++ m
keyValueParser :: a -> Parser b -> Parser (Map a b)
keyValueParser key parser = do value <- parser
return $ singleton key value
concatParser :: String -> Parser (String -> String -> String)
concatParser sepStr = do value <- string sepStr
return (\a b -> a ++ sepStr ++ b)
ipParser :: Parser String
ipParser = chainl1 (many1 digit) (concatParser ".")
hostnameParser :: Parser String
hostnameParser = chainl1 (many1 alphaNum) (concatParser ".")
digits = many1 digit
parserFor :: Rule -> Parser (Map String String)
parserFor (Literal lit) = do string lit
return empty
parserFor (Keyword 'U' Nothing) = keyValueParser "path" (many1 $ alphaNum <|> char '/')
parserFor (Keyword 'm' Nothing) = keyValueParser "method" $ (many1 $ oneOf ['A'..'Z'])
parserFor (Keyword 'P' Nothing) = keyValueParser "processId" digits
parserFor (Keyword 'T' Nothing) = keyValueParser "timeTakenSeconds" digits
parserFor (Keyword 'D' Nothing) = keyValueParser "timeTakenMicroseconds" digits
parserFor (Keyword 'B' Nothing) = keyValueParser "bytes" $ digits
parserFor (Keyword 'b' Nothing) = keyValueParser "bytesCLF" valueParser
where valueParser = digits <|> (string "-")
parserFor (Keyword 'a' Nothing) = keyValueParser "remoteIP" ipParser
parserFor (Keyword 'A' Nothing) = keyValueParser "localIP" ipParser
parserFor (Keyword 'q' Nothing) = do value <- (string "") <|> queryStringParser
return $ singleton "queryString" value
where queryStringParser = do char '?'
qs <- many1 $ alphaNum <|> char '&' <|> char '='
return $ "?" ++ qs
parserFor (Keyword 's' mod) = keyValueParser (format mod) (many1 alphaNum)
where format Nothing = "statusOriginal"
format (Just ">") = "statusLast"
parserFor (Keyword 'h' Nothing) = keyValueParser "remoteHost" hostnameParser
parserFor (Keyword 'v' Nothing) = keyValueParser "canonicalServerName" hostnameParser
parserFor (Keyword 'V' Nothing) = keyValueParser "serverName" hostnameParser