content: {-# LANGUAGE MultiWayIf        #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards   #-}
  -- |Routines for parsing a consensus document.
  module Tor.DataFormat.Consensus(
           Consensus(..)
         , Authority(..)
         , Router(..)
         , parseConsensusDocument
         )
   where
  
  import Control.Applicative
  import Crypto.Hash.Easy
  import Data.Attoparsec.ByteString
  import Data.ByteString(ByteString)
  import Data.ByteString.Char8(unpack)
  import qualified Data.ByteString as BS
  import Data.Hourglass
  import Data.Int
  import Data.Map(Map)
  import qualified Data.Map as Map
  import Data.Version
  import Data.Word
  import Tor.DataFormat.Helpers
  
  -- |A current consensus from a directory server.
  data Consensus = Consensus {
         conMethods             :: Maybe [Int]
       , conMethod              :: Int
       , conValidAfter          :: DateTime
       , conFreshUntil          :: DateTime
       , conValidUntil          :: DateTime
       , conVotingDelay         :: (Integer, Integer)
       , conSuggestedClientVers :: Maybe [Version]
       , conSuggestedServerVers :: Maybe [Version]
       , conKnownFlags          :: [String]
       , conParameters          :: [(String, Int32)]
       , conAuthorities         :: [Authority]
       , conRouters             :: [Router]
       , conBandwidthWeights    :: Map String Int32
       , conSignatures          :: [(Bool, ByteString, ByteString, ByteString)]
       }
   deriving (Show)
  
  -- |An authority that might sign a consensus document.
  data Authority = Authority {
         authName       :: String
       , authIdent      :: ByteString
       , authAddress    :: String
       , authIP         :: String
       , authDirPort    :: Word16
       , authOnionPort  :: Word16
       , authContact    :: String
       , authVoteDigest :: ByteString
       }
   deriving (Show)
  
  -- |A router within the consensus document.
  data Router = Router {
         rtrNickName       :: String
       , rtrIdentity       :: ByteString
       , rtrDigest         :: ByteString
       , rtrPubTime        :: DateTime
       , rtrIP             :: String
       , rtrOnionPort      :: Word16
       , rtrDirPort        :: Maybe Word16
       , rtrIP6Addrs       :: [(String, Word16)]
       , rtrStatus         :: [String]
       , rtrVersion        :: Maybe Version
       , rtrBandwidth      :: Maybe (Integer, [(String, String)])
       , rtrPortList       :: Maybe (Bool, [PortSpec])
       }
   deriving (Show)
  
  -- |Parse a consensus document, returning either an error or the parsed
  -- consensus and the SHA1 and SHA256 hashes of that consensus, for later
  -- validation.
  parseConsensusDocument :: ByteString ->
                            Either String (Consensus, ByteString, ByteString)
  parseConsensusDocument bstr =
    case parse consensusDocument bstr of
      Partial f -> processParse (f BS.empty)
      x         -> processParse x
   where
    (digest1, digest256) = generateHashes bstr
    processParse (Fail x _ err) = Left (err ++ " (around |" ++ show (BS.take 10 x) ++ "|)")
    processParse (Partial _ )   = Left "Incomplete consensus document!"
    processParse (Done _ res)   = Right (res, digest1, digest256)
  
  generateHashes :: ByteString -> (ByteString, ByteString)
  generateHashes infile = (sha1 message, sha256 message)
   where
    message  = run infile
    run bstr =
      case BS.span (/= 10) bstr of
        (start, finale) | "\ndirectory-signature " `BS.isPrefixOf` finale ->
          start `BS.append` "\ndirectory-signature "
        (start, rest) ->
          start `BS.append` (BS.singleton 10) `BS.append` run (BS.drop 1 rest)
  
  consensusDocument :: Parser Consensus
  consensusDocument =
    do _                      <- string "network-status-version 3\n"
       _                      <- string "vote-status consensus\n"
       conMethods             <- option Nothing $
                                   do _   <- string "consensus-methods" >> sp
                                      res <- sepBy1 consensusMethod sp
                                      _   <- nl
                                      return (Just res)
       conMethod              <- standardLine "consensus-method" consensusMethod
       conValidAfter          <- standardLine "valid-after" utcTime
       conFreshUntil          <- standardLine "fresh-until" utcTime
       conValidUntil          <- standardLine "valid-until" utcTime
       conVotingDelay         <- standardLine "voting-delay" $
                                   do vsec <- decimalNum (const True)
                                      _    <- sp
                                      dsec <- decimalNum (const True)
                                      return (vsec, dsec)
       conSuggestedClientVers <- option Nothing $
                                   standardLine "client-versions"
                                     (Just <$> sepBy1 torVersion (char8 ','))
       conSuggestedServerVers <- option Nothing $
                                   standardLine "server-versions"
                                     (Just <$> sepBy1 torVersion (char8 ','))
       conKnownFlags          <- standardLine "known-flags"
                                     (sepBy1 (unpack <$> flag) (char8 ' '))
       conParameters          <- standardLine "params" torParams --option [] $  
       conAuthorities         <- many1 authority
       conRouters             <- many1 router
       _                      <- string "directory-footer\n"
       conBandwidthWeights    <- option Map.empty $
                                   do _ <- string "bandwidth-weights "
                                      x <- bandwidthWeights
                                      _ <- nl
                                      return x
       conSignatures          <- many1 consensusSignature
       return Consensus{..}
  
  consensusMethod :: Parser Int
  consensusMethod = decimalNum (\ x -> (x >= 1) && (x <= 20))
  
  torVersion :: Parser Version
  torVersion =
    do versionBranch <- sepBy1 (decimalNum (const True)) (char8 '.')
       versionTags   <- option [] $ do _ <- char8 '-'
                                       tags <- sepBy1 (many1 alphaNum) (char8 '-')
                                       return (map toString tags)
       return Version{..}
  
  flag :: Parser ByteString
  flag = string "Authority"
     <|> string "BadExit"
     <|> string "BadDirectory"
     <|> string "Exit"
     <|> string "Fast"
     <|> string "Guard"
     <|> string "HSDir"
     <|> string "Named"
     <|> string "Stable"
     <|> string "Running"
     <|> string "Unnamed"
     <|> string "Valid"
     <|> string "V2Dir"
  
  torParams :: Parser [(String, Int32)]
  torParams = sepBy1 parameter (char8 ' ')
   where
    parameter =
      do x <- keyword
         _ <- char8 '='
         v <- decimalNum (const True)
         return (x, v)
    keyword = toString <$> many1 keywordChar
    keywordChar = satisfy (inClass "A-Za-z0-9_-")
  
  authority :: Parser Authority
  authority =
    do _              <- string "dir-source"
       _              <- sp
       authName       <- nickname
       _              <- sp
       authIdent      <- hexDigest
       _              <- sp
       authAddress    <- toString <$> many1 (notWord8 32)
       _              <- sp
       authIP         <- ip4
       _              <- sp
       authDirPort    <- decimalNum (const True)
       _              <- sp
       authOnionPort  <- decimalNum (const True)
       _              <- nl
       _              <- string "contact"
       _              <- sp
       authContact    <- toString <$> many1 (notWord8 10)
       _              <- nl
       _              <- string "vote-digest"
       _              <- sp
       authVoteDigest <- hexDigest
       _              <- nl
       return Authority{ .. }
  
  router :: Parser Router
  router =
    do _              <- string "r "
       rtrNickName    <- nickname
       _              <- sp
       rtrIdentity    <- decodeBase64' =<< many1 base64Char
       _              <- sp
       rtrDigest      <- decodeBase64' =<< many1 base64Char
       _              <- sp
       rtrPubTime     <- utcTime
       _              <- sp
       rtrIP          <- ip4
       _              <- sp
       rtrOnionPort   <- decimalNum (const True)
       _              <- sp
       rtrDirPort     <- maybe0 <$> decimalNum (const True)
       _              <- nl
       rtrIP6Addrs    <- many $ do _ <- string "a "
                                   a <- ip6
                                   _ <- char8 ':'
                                   p <- decimalNum (const True)
                                   _ <- nl
                                   return (a, p)
       _              <- string "s "
       rtrStatus      <- map unpack <$> sepBy1 flag (char8 ' ')
       _              <- nl
       rtrVersion     <- option Nothing $
                           do _ <- string "v Tor "
                              v <- torVersion
                              _ <- nl
                              return (Just v)
       rtrBandwidth   <- option Nothing $
                           do _ <- string "w Bandwidth="
                              b <- decimalNum (const True)
                              f <- many $ do _ <- sp
                                             x <- many1 alphaNum
                                             _ <- char8 '='
                                             v <- many1 alphaNum
                                             return (toString x, toString v)
                              _ <- nl
                              return (Just (b, f))
       rtrPortList    <- option Nothing $
                           do _ <- string "p "
                              a <-  (string "accept" >> return True)
                                <|> (string "reject" >> return False)
                              _ <- sp
                              p <- sepBy1 portSpec (char8 ',')
                              _ <- nl
                              return (Just (a, p))
       return Router{..}
   where
    maybe0 0 = Nothing
    maybe0 x = Just x
  
  bandwidthWeights :: Parser (Map String Int32)
  bandwidthWeights = Map.fromList <$> sepBy1 bweight (char8 ' ')
   where
    bweight =
      do weight <- toString <$> many1 alphaNum
         _      <- char8 '='
         value  <- decimalNum (const True)
         return (weight, value)
  
  consensusSignature :: Parser (Bool, ByteString, ByteString, ByteString)
  consensusSignature =
    do _     <- string "directory-signature"
       sha1p <- option True $ (string "sha1"   >> return True)
                          <|> (string "sha256" >> return False)
       _     <- sp
       ident <- hexDigest
       _     <- sp
       skdig <- hexDigest
       _     <- nl
       _     <- string "-----BEGIN SIGNATURE-----\n"
       let end = string "-----END SIGNATURE-----\n"
       sig   <- decodeBase64 =<< manyTill base64Char end
       return (sha1p, ident, skdig, sig)
  
  -- -----------------------------------------------------------------------------
  
  decodeBase64' :: [Word8] -> Parser ByteString
  decodeBase64' bytes =
    case length bytes `mod` 4 of
      0 -> decodeBase64 bytes
      1 -> error "Does this happen?"
      2 -> decodeBase64 (bytes ++ [61,61])
      3 -> decodeBase64 (bytes ++ [61])
      _ -> error "The universe appears to be broken."
  