module DisTract.Monotone.Parser
(findHash,
findHashes,
findKeys,
findCerts,
findLogBriefs,
findHashInCommitMessage,
findVersionHash,
handleParseError
)
where
import DisTract.Utils
import DisTract.Monotone.Types
import Text.ParserCombinators.Parsec
import Data.Either
import Data.Word
import Data.Time
import Control.Monad
import System.Locale
handleParseError :: Either ParseError a -> a
handleParseError result = case result of
(Left e) -> error (show e)
(Right r) -> r
findVersionHash :: String -> Hash
findVersionHash = handleParseError . runParser grabAnyHashParser () "DisTract.Monotone.Parser versionHash"
grabAnyHashParser :: Parser Hash
grabAnyHashParser = (try hashParser)
<|> (anyChar >> grabAnyHashParser)
findHash :: String -> Hash
findHash = handleParseError . runParser hashParser () "DisTract.Monotone.Parser hash"
findHashes :: String -> [Hash]
findHashes = handleParseError . runParser hashesParser () "DisTract.Monotone.Parser hashes"
hashesParser :: Parser [Hash]
hashesParser = do { hash <- hashParser
; many space
; rest <- hashesParser
; return (hash:rest)
}
<|> return []
hashParser :: Parser Hash
hashParser = do { [w1,w2,w3,w4,w5] <- sequence (replicate 5 word64Parser)
; return (Hash w1 w2 w3 w4 w5)
}
word64Parser :: Parser Word64
word64Parser = sequence (replicate 8 hexDigit) >>= return . read . ("0x"++)
findKeys :: String -> ([Key],[Key])
findKeys = handleParseError . runParser keysParser () "DisTract.Monotone.Parser keys"
keysParser :: Parser ([Key], [Key])
keysParser = do { many space
; string "[public keys]"
; many1 space
; public <- many (keyEntry PublicKey)
; manyTill anyChar (try (string "[private keys]"))
; many1 space
; private <- many (keyEntry PrivateKey)
; return (public, private)
}
keyEntry :: (String -> Hash -> Key) -> Parser Key
keyEntry con = do { hash <- hashParser
; many1 space
; address <- manyTill anyChar (try space)
; many space
; return (con address hash)
}
findCerts :: String -> [Cert]
findCerts = handleParseError . runParser certsParser () "DisTract.Monotone.Parser certs"
certsParser :: Parser [Cert]
certsParser = do { cert <- certParser
; rest <- certsParser
; return (cert:rest)
}
<|> return []
certParser :: Parser Cert
certParser = do { key <- certKeyValuePair "key"
; signature <- certKeyValuePair "signature"
; name <- certKeyValuePair "name"
; value <- certKeyValuePair "value"
; trust <- certKeyValuePair "trust"
; let trust' = case trust of
"trusted" -> Trusted
_ -> Untrusted
; let signature' = case signature of
"ok" -> SigOk
"unknown" -> SigUnknown
_ -> SigBad
; return (Cert { certName = name,
certValue = value,
certKey = key,
certTrust = trust',
certSignature = signature'
})
}
certKeyValuePair :: String -> Parser String
certKeyValuePair key
= do { many space
; string key
; many1 space
; char '"'
; value <- manyTill anyChar' (try (char '"' >> newline))
; many space
; return $ concat value
}
where
anyChar' :: Parser String
anyChar' = (try quotedPair)
<|> (anyChar >>= return . (:[]))
quotedPair :: Parser String
quotedPair = char '\\' >> anyChar >>= return . ('\\':) . (:[])
findLogBriefs :: String -> [LogBrief]
findLogBriefs = handleParseError . runParser logBriefParser () "DisTract.Monotone.Parser logBrief"
logBriefParser :: Parser [LogBrief]
logBriefParser = do { hash <- hashParser
; many1 space
; author <- manyTill anyChar (try space)
; many space
; dateStr <- count monotoneDateFormatLength anyChar
; let dateM = parseTime defaultTimeLocale monotoneDateFormat dateStr
; when (dateM == Nothing) $
fail $ "Unable to parse date: '" ++ dateStr ++ "'"
; let (Just date) = dateM
; many1 space
; branch <- manyTill anyChar ((try space >> return ()) <|> eof)
; many space
; rest <- logBriefParser
; return $ (LogBrief hash author date branch):rest
}
<|> return []
findHashInCommitMessage :: String -> (Maybe Hash)
findHashInCommitMessage = handleParseError . runParser hashInCommitParser () "DisTract.Monotone.Parser hashInCommit"
hashInCommitParser :: Parser (Maybe Hash)
hashInCommitParser = (try (grabAnyHashParser >>= return . Just))
<|> (return Nothing)