{-# LANGUAGE DeriveDataTypeable #-} -- |Low-level rendering and parsing routines for raw Tor cells. module Tor.DataFormat.TorCell( TorCell(..), putTorCell, getTorCell , DestroyReason(..), putDestroyReason, getDestroyReason , HandshakeType(..), putHandshakeType, getHandshakeType , TorCert(..), putTorCert, getTorCert , getCircuit , isPadding ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Control.Exception import Control.Monad import Data.Binary.Get import Data.Binary.Put import Data.ByteString(ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Typeable import Data.X509 import Data.Word import Tor.DataFormat.TorAddress -- |A raw tor cell. data TorCell = Padding | Create Word32 ByteString | Created Word32 ByteString | Relay Word32 ByteString | Destroy Word32 DestroyReason | CreateFast Word32 ByteString | CreatedFast Word32 ByteString ByteString | NetInfo Word32 TorAddress [TorAddress] | RelayEarly Word32 ByteString | Create2 Word32 HandshakeType ByteString | Created2 Word32 ByteString | Versions | VPadding ByteString | Certs [TorCert] | AuthChallenge ByteString [Word16] | Authenticate ByteString | Authorize deriving (Eq, Show) -- |Given a tor cell, return the circuit it's associated with, if it is. getCircuit :: TorCell -> Maybe Word32 getCircuit x = case x of Create circId _ -> Just circId Created circId _ -> Just circId Relay circId _ -> Just circId Destroy circId _ -> Just circId CreateFast circId _ -> Just circId CreatedFast circId _ _ -> Just circId RelayEarly circId _ -> Just circId Create2 circId _ _ -> Just circId Created2 circId _ -> Just circId _ -> Nothing -- |Return True iff this is a padding cell of some sort. isPadding :: TorCell -> Bool isPadding x = case x of Padding -> True VPadding _ -> True _ -> False -- |Parse a TorCell getTorCell :: Get TorCell getTorCell = do circuit <- getWord32be command <- getWord8 case command of 0 -> getStandardCell $ return Padding 1 -> getStandardCell $ Create circuit <$> getByteString (128 + 16 + 42) 2 -> getStandardCell $ Created circuit <$> getByteString (128 + 20) 3 -> getStandardCell $ Relay circuit <$> getByteString 509 4 -> getStandardCell $ Destroy circuit <$> getDestroyReason 5 -> getStandardCell $ CreateFast circuit <$> getByteString 20 6 -> getStandardCell $ CreatedFast circuit <$> getByteString 20 <*> getByteString 20 8 -> getStandardCell $ do tstamp <- getWord32be otherOR <- getTorAddress numAddrs <- getWord8 thisOR <- replicateM (fromIntegral numAddrs) getTorAddress return (NetInfo tstamp otherOR thisOR) 9 -> getStandardCell $ RelayEarly circuit <$> getByteString 509 10 -> getStandardCell $ do htype <- getHandshakeType hlen <- getWord16be hdata <- getByteString (fromIntegral hlen) return (Create2 circuit htype hdata) 11 -> getStandardCell $ do hlen <- getWord16be hdata <- getByteString (fromIntegral hlen) return (Created2 circuit hdata) 7 -> fail "Should not be getting versions through this interface." 128 -> getVariableLength "VPadding" getVPadding 129 -> getVariableLength "Certs" getCerts 130 -> getVariableLength "AuthChallenge" getAuthChallenge 131 -> getVariableLength "Authenticate" getAuthenticate 132 -> getVariableLength "Authorize" (\ _ -> return Authorize) _ -> fail "Improper Tor cell command." where getStandardCell getter = do bstr <- getByteString 509 -- PAYLOAD_LEN case runGetOrFail getter (BSL.fromStrict bstr) of Left (_, _, err) -> fail err Right (_, _, x) -> return x getVariableLength name getter = do len <- getWord16be body <- getByteString (fromIntegral len) case runGetOrFail (getter len) (BSL.fromStrict body) of Left (_, _, s) -> fail ("Couldn't read " ++ name ++ " body: " ++ s) Right (_, _, x) -> return x -- getVPadding len = VPadding <$> getByteString (fromIntegral len) -- getAuthChallenge _ = do challenge <- getByteString 32 n_methods <- getWord16be methods <- replicateM (fromIntegral n_methods) getWord16be return (AuthChallenge challenge methods) -- getAuthenticate _ = do _ <- getWord16be -- AuthType l <- getWord16be s <- getByteString (fromIntegral l) return (Authenticate s) -- |Render a TorCell putTorCell :: TorCell -> Put putTorCell Padding = putStandardCell $ putWord32be 0 -- Circuit ID putTorCell (Create circ bstr) = putStandardCell $ do putWord32be circ putWord8 1 putByteString bstr putTorCell (Created circ bstr) = putStandardCell $ do putWord32be circ putWord8 2 putByteString bstr putTorCell (Relay circ bstr) = putStandardCell $ do putWord32be circ putWord8 3 putByteString bstr putTorCell (Destroy circ dreason) = putStandardCell $ do putWord32be circ putWord8 4 putDestroyReason dreason putTorCell (CreateFast circ keymat) = putStandardCell $ do putWord32be circ putWord8 5 putByteString keymat putTorCell (CreatedFast circ keymat deriv) = putStandardCell $ do putWord32be circ putWord8 6 putByteString keymat putByteString deriv putTorCell (NetInfo ttl oneside others) = putStandardCell $ do putWord32be 0 putWord8 8 putWord32be ttl putTorAddress oneside putWord8 (fromIntegral (length others)) forM_ others putTorAddress putTorCell (RelayEarly circ bstr) = putStandardCell $ do putWord32be circ putWord8 9 putByteString bstr putTorCell (Create2 circ htype cdata) = putStandardCell $ do putWord32be circ putWord8 10 putHandshakeType htype putWord16be (fromIntegral (BS.length cdata)) putByteString cdata putTorCell (Created2 circ cdata) = putStandardCell $ do putWord32be circ putWord8 11 putWord16be (fromIntegral (BS.length cdata)) putByteString cdata putTorCell (VPadding bstr) = do putWord32be 0 putWord8 128 putWord16be (fromIntegral (BS.length bstr)) putByteString bstr putTorCell (Certs cs) = do putWord32be 0 putWord8 129 putLenByteString $ do putWord8 (fromIntegral (length cs)) forM_ cs putTorCert putTorCell (AuthChallenge challenge methods) = do putWord32be 0 putWord8 130 putLenByteString $ do putByteString challenge putWord16be (fromIntegral (length methods)) forM_ methods putWord16be putTorCell (Authenticate authent) = do putWord32be 0 putWord8 131 putLenByteString $ do putWord16be 1 putWord16be (fromIntegral (BS.length authent)) putByteString authent putTorCell (Authorize) = do putWord32be 0 putWord8 132 putWord16be 0 putTorCell (Versions) = do putWord16be 0 putWord8 7 putWord16be 2 putWord16be 4 putLenByteString :: Put -> Put putLenByteString m = do let bstr = runPut m putWord16be (fromIntegral (BSL.length bstr)) putLazyByteString bstr putStandardCell :: Put -> Put putStandardCell m = do let bstr = runPut m infstr = bstr `BSL.append` BSL.repeat 0 putLazyByteString (BSL.take 514 infstr) -- ----------------------------------------------------------------------------- -- |A reason that a Circuit could or has been destroyed. data DestroyReason = NoReason | TorProtocolViolation | InternalError | RequestedDestroy | NodeHibernating | HitResourceLimit | ConnectionFailed | ORIdentityIssue | ORConnectionClosed | Finished | CircuitConstructionTimeout | CircuitDestroyed | NoSuchService | UnknownDestroyReason Word8 deriving (Eq, Show, Typeable) instance Exception DestroyReason -- |Parse a DestroyReason. getDestroyReason :: Get DestroyReason getDestroyReason = do b <- getWord8 case b of 0 -> return NoReason 1 -> return TorProtocolViolation 2 -> return InternalError 3 -> return RequestedDestroy 4 -> return NodeHibernating 5 -> return HitResourceLimit 6 -> return ConnectionFailed 7 -> return ORIdentityIssue 8 -> return ORConnectionClosed 9 -> return Finished 10 -> return CircuitConstructionTimeout 11 -> return CircuitDestroyed 12 -> return NoSuchService _ -> return (UnknownDestroyReason b) -- |Render a DestroyReason putDestroyReason :: DestroyReason -> Put putDestroyReason NoReason = putWord8 0 putDestroyReason TorProtocolViolation = putWord8 1 putDestroyReason InternalError = putWord8 2 putDestroyReason RequestedDestroy = putWord8 3 putDestroyReason NodeHibernating = putWord8 4 putDestroyReason HitResourceLimit = putWord8 5 putDestroyReason ConnectionFailed = putWord8 6 putDestroyReason ORIdentityIssue = putWord8 7 putDestroyReason ORConnectionClosed = putWord8 8 putDestroyReason Finished = putWord8 9 putDestroyReason CircuitConstructionTimeout = putWord8 10 putDestroyReason CircuitDestroyed = putWord8 11 putDestroyReason NoSuchService = putWord8 12 putDestroyReason (UnknownDestroyReason x) = putWord8 x -- ----------------------------------------------------------------------------- -- |The two supported handshake types for Tor. data HandshakeType = TAP | Reserved | NTor | Unknown Word16 deriving (Eq, Show) -- |Parse a handshake identifier. getHandshakeType :: Get HandshakeType getHandshakeType = do t <- getWord16be case t of 0x0000 -> return TAP 0x0001 -> return Reserved 0x0002 -> return NTor _ -> return (Unknown t) -- |Render a handshake identifier. putHandshakeType :: HandshakeType -> Put putHandshakeType TAP = putWord16be 0x0000 putHandshakeType Reserved = putWord16be 0x0001 putHandshakeType NTor = putWord16be 0x0002 putHandshakeType (Unknown x) = putWord16be x -- ----------------------------------------------------------------------------- -- |The kinds of certificates used within the initial Tor handshake. data TorCert = LinkKeyCert SignedCertificate | RSA1024Identity SignedCertificate | RSA1024Auth SignedCertificate | UnknownCertType Word8 ByteString deriving (Eq, Show) -- |Parse a certificate. getTorCert :: Get TorCert getTorCert = do t <- getWord8 l <- getWord16be c <- getByteString (fromIntegral l) case t of 1 -> return (maybeBuild LinkKeyCert t c) 2 -> return (maybeBuild RSA1024Identity t c) 3 -> return (maybeBuild RSA1024Auth t c) _ -> return (UnknownCertType t c) where maybeBuild builder t bstr = case decodeSignedObject bstr of Left _ -> UnknownCertType t bstr Right res -> builder res -- |Render a certificate. putTorCert :: TorCert -> Put putTorCert tc = do let (t, bstr) = case tc of LinkKeyCert sc -> (1, encodeSignedObject sc) RSA1024Identity sc -> (2, encodeSignedObject sc) RSA1024Auth sc -> (3, encodeSignedObject sc) UnknownCertType ct bs -> (ct, bs) putWord8 t putWord16be (fromIntegral (BS.length bstr)) putByteString bstr -- ----------------------------------------------------------------------------- getCerts :: Word16 -> Get TorCell getCerts _ = do num <- getWord8 certs <- replicateM (fromIntegral num) getTorCert return (Certs certs)