haskell-tor-0.1.0.0: src/Tor/DataFormat/TorCell.hs
{-# 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)