{-# 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."