{- DisTract ------------------------------------------------------\
 |                                                                 |
 | Copyright (c) 2007, Matthew Sackman (matthew@wellquite.org)     |
 |                                                                 |
 | DisTract is freely distributable under the terms of a 3-Clause  |
 | BSD-style license. For details, see the DisTract web site:      |
 |   http://distract.wellquite.org/                                |
 |                                                                 |
 \-----------------------------------------------------------------}

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)