haskell-tor-0.1.0.0: src/Tor/DataFormat/RelayCell.hs
-- |Parsing and rendering routines for relay cells.
{-# LANGUAGE DeriveDataTypeable #-}
module Tor.DataFormat.RelayCell(
RelayCell(..), putRelayCell, getRelayCell
, parseRelayCell, renderRelayCell
, ExtendSpec(..), putExtendSpec, getExtendSpec
, RelayEndReason(..), putRelayEndReason, getRelayEndReason
, putRelayCellGuts
, RelayIntro1Data(..)
)
where
import Control.Applicative
import Control.Exception
import Control.Monad
import Crypto.Hash hiding (hash)
import Data.Attoparsec.ByteString
import Data.Binary.Get
import Data.Binary.Put
import Data.Bits
import Data.ByteArray(convert)
import Data.ByteString(ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Char8(pack,unpack)
import Data.ByteString.Lazy(toStrict,fromStrict)
import Data.Typeable
import Data.Word
import Tor.DataFormat.Helpers(toString, ip4, ip6, char8, decimalNum)
import Tor.DataFormat.TorAddress
import Tor.DataFormat.TorCell
-- FIXME: the stream id is only relevant for some of these items, and should
-- probably be removed from the rest.
-- |The format of a Relay cell in a Tor stream.
data RelayCell =
RelayBegin { relayStreamId :: Word16
, relayBeginAddress :: TorAddress
, relayBeginPort :: Word16
, relayBeginIPv4OK :: Bool
, relayBeginIPv6OK :: Bool
, relayBeginIPv6Pref :: Bool }
| RelayData { relayStreamId :: Word16
, relayData :: ByteString }
| RelayEnd { relayStreamId :: Word16
, relayEndReason :: RelayEndReason }
| RelayConnected { relayStreamId :: Word16
, relayConnectedAddr :: TorAddress
, relayConnectedTTL :: Word32 }
| RelaySendMe { relayStreamId :: Word16 }
| RelayExtend { relayStreamId :: Word16
, relayExtendAddress :: String -- ^ IPv4
, relayExtendPort :: Word16
, relayExtendSkin :: ByteString
, relayExtendIdent :: ByteString }
| RelayExtended { relayStreamId :: Word16
, relayExtendedData :: ByteString }
| RelayTruncate { relayStreamId :: Word16 }
| RelayTruncated { relayStreamId :: Word16
, relayTruncatedRsn :: DestroyReason }
| RelayDrop { relayStreamId :: Word16 }
| RelayResolve { relayStreamId :: Word16
, relayResolveName :: String }
| RelayResolved { relayStreamId :: Word16
, relayResolvedAddrs :: [(TorAddress,Word32)]}
| RelayBeginDir { relayStreamId :: Word16 }
| RelayExtend2 { relayStreamId :: Word16
, relayExtendTarget :: [ExtendSpec]
, relayExtendType :: HandshakeType
, relayExtendData :: ByteString }
| RelayExtended2 { relayStreamId :: Word16
, relayExtendedData :: ByteString }
| RelayEstablishIntro { relayStreamId :: Word16
, relayEstIntKey :: ByteString
, relayEstIntSessHash :: ByteString
, relayEstIntSig :: ByteString }
| RelayEstablishRendezvous { relayStreamId :: Word16
, relayEstRendCookie :: ByteString }
| RelayIntroduce1 { relayStreamId :: Word16
, relayIntro1KeyId :: ByteString
, relayIntro1Data :: ByteString }
| RelayIntroduce2 { relayStreamId :: Word16
, relayIntro2Data :: ByteString }
| RelayRendezvous1 { relayStreamId :: Word16
, relayRendCookie :: ByteString
, relayRendGY :: ByteString
, relayRendKH :: ByteString}
| RelayRendezvous2 { relayStreamId :: Word16
, relayRendGY :: ByteString
, relayRendKH :: ByteString }
| RelayIntroEstablished { relayStreamId :: Word16 }
| RelayRendezvousEstablished { relayStreamId :: Word16 }
| RelayIntroduceAck { relayStreamId :: Word16 }
deriving (Eq, Show)
-- |Various bits of information for dealing with hidden services. Currently not
-- implemented.
data RelayIntro1Data =
RelayIntro1v0 { intRendPoint :: ByteString
, intRendCookie :: ByteString
, intRendgx1 :: ByteString }
| RelayIntro1v1 { intRendPoint :: ByteString
, intRendCookie :: ByteString
, intRendgx1 :: ByteString }
| RelayIntro1v2 { intRendPointIP :: String
, intRendPointPort :: Word16
, intRendPointId :: ByteString
, intRendOnionKey :: ByteString
, intRendCookie :: ByteString
, intRendgx1 :: ByteString }
| RelayIntro1v3 { intAuthType :: Word8
, intAuthData :: ByteString
, intRendPointIP :: String
, intRendPointPort :: Word16
, intRendPointId :: ByteString
, intRendOnionKey :: ByteString
, intRendCookie :: ByteString
, intRendgx1 :: ByteString }
-- |Parse a relay cell off the wire, returning the shortened digest and the
-- parsed relay cell.
getRelayCell :: Get (ByteString, RelayCell)
getRelayCell =
do cmd <- getWord8
recog <- getWord16be
unless (recog == 0) $ fail "Recognized != 0"
strmId <- getWord16be
digest <- getByteString 4
len <- getWord16be
unless (len <= (514 - 11)) $ fail "Length too long"
case cmd of
1 -> do addrport <- toStrict <$> getLazyByteStringNul
(ok4, ok6, pref6) <- parseFlags <$> getWord32be
(addr, port) <- parseAddrPort addrport
return (digest, RelayBegin strmId addr port ok4 ok6 pref6)
2 -> do bstr <- getByteString (fromIntegral len)
return (digest, RelayData strmId bstr)
3 -> do rsn <- getRelayEndReason len
return (digest, RelayEnd strmId rsn)
4 -> do ip4addr <- getByteString 4
if BS.any (/= 0) ip4addr
then do ttl <- getWord32be
let addr = IP4 (ip4ToString ip4addr)
return (digest, RelayConnected strmId addr ttl)
else do atype <- getWord8
unless (atype == 1) $
fail ("Bad address type: " ++ show atype)
ip6ad <- ip6ToString <$> getByteString 16
ttl <- getWord32be
return (digest, RelayConnected strmId (IP6 ip6ad) ttl)
5 -> return (digest, RelaySendMe strmId)
6 -> do addr <- ip4ToString <$> getByteString 4
port <- getWord16be
skin <- getByteString (128 + 16 + 42) -- TAP_C_HANDSHAKE_LEN
idfp <- getByteString 20 -- HASH_LEN
return (digest, RelayExtend strmId addr port skin idfp)
7 -> do edata <- getByteString (128 + 20)
return (digest, RelayExtended strmId edata)
8 -> return (digest, RelayTruncate strmId)
9 -> do rsn <- getDestroyReason
return (digest, RelayTruncated strmId rsn)
10 -> return (digest, RelayDrop strmId)
11 -> do bstr <- toStrict <$> getLazyByteStringNul
return (digest, RelayResolve strmId (unpack bstr))
12 -> do bstr <- getByteString (fromIntegral len)
case runGetOrFail getResolved (fromStrict bstr) of
Left (_, _, str) -> fail str
Right (_, _, x) ->
return (digest, RelayResolved strmId x)
13 -> return (digest, RelayBeginDir strmId)
14 -> do nspec <- getWord8
specs <- replicateM (fromIntegral nspec) getExtendSpec
htype <- getHandshakeType
hlen <- getWord16be
hdata <- getByteString (fromIntegral hlen)
return (digest, RelayExtend2 strmId specs htype hdata)
15 -> do hlen <- getWord16be
hdata <- getByteString (fromIntegral hlen)
return (digest, RelayExtended2 strmId hdata)
32 -> do kl <- getWord16be
pk <- getByteString (fromIntegral kl)
hs <- getByteString 20
sig <- getByteString (fromIntegral kl) -- FIXME: correct?
return (digest, RelayEstablishIntro strmId pk hs sig)
33 -> do rc <- getByteString 20
return (digest, RelayEstablishRendezvous strmId rc)
34 -> do pkId <- getByteString 20
bs <- getByteString (fromIntegral len - 20)
return (digest, RelayIntroduce1 strmId pkId bs)
35 -> do bs <- getByteString (fromIntegral len)
return (digest, RelayIntroduce2 strmId bs)
36 -> do rc <- getByteString 20
gy <- getByteString 128
kh <- getByteString 20
return (digest, RelayRendezvous1 strmId rc gy kh)
37 -> do gy <- getByteString 128
kh <- getByteString 20
return (digest, RelayRendezvous2 strmId gy kh)
38 -> return (digest, RelayIntroEstablished strmId)
39 -> return (digest, RelayRendezvousEstablished strmId)
40 -> return (digest, RelayIntroduceAck strmId)
_ -> fail ("Unknown command: " ++ show cmd)
where
getResolved =
do done <- isEmpty
if done
then return []
else do addr <- getTorAddress
ttl <- getWord32be
((addr, ttl) :) <$> getResolved
-- -----------------------------------------------------------------------------
-- |Render a relay cell using the given hash context, returning the rendered
-- cell and the new hash context.
renderRelayCell :: Context SHA1 -> RelayCell ->
(ByteString, Context SHA1)
renderRelayCell state cell = (result, state')
where
emptyDigest = BS.pack [0,0,0,0]
base = toStrict (runPut (putRelayCell emptyDigest cell))
state' = hashUpdate state base
digest = hashFinalize state'
result = injectRelayHash (BS.take 4 (convert digest)) base
-- |Parse a relay cell, verifying that the digest matches appropriately,
-- returning the parsed cell and new hash context.
parseRelayCell :: Context SHA1 -> Get (RelayCell, Context SHA1)
parseRelayCell state =
do chunk <- getByteString 509 -- PAYLOAD_LEN
case runGetOrFail getRelayCell (fromStrict chunk) of
Left (_, _, err) -> fail err
Right (_, _, (digestStart, c)) ->
do let noDigestBody = injectRelayHash (BS.replicate 4 0) chunk
state' = hashUpdate state noDigestBody
fullDigest = convert (hashFinalize state')
unless (BS.take 4 fullDigest == digestStart) $
fail "Relay cell digest mismatch."
return (c, state')
injectRelayHash :: ByteString -> ByteString -> ByteString
injectRelayHash digest base =
BS.take 5 base `BS.append`
BS.take 4 digest `BS.append`
BS.drop 9 base
-- -----------------------------------------------------------------------------
-- |Perform a raw relay cell render, with 0 for the hash mark.
putRelayCell :: ByteString -> RelayCell -> Put
putRelayCell dgst x =
do let (cmd, bstr) = runPutM (putRelayCellGuts x)
let bstr' = toStrict bstr
putWord8 cmd
putWord16be 0
putWord16be (relayStreamId x)
putByteString dgst
putWord16be (fromIntegral (BS.length bstr'))
unless (BS.length bstr' <= (509 - 11)) $
fail "RelayCell payload is too large!"
putLazyByteString bstr
putByteString (BS.replicate ((509 - 11) - BS.length bstr') 0)
-- |Render the internals of a relay cell (basically everything but the header).
putRelayCellGuts :: RelayCell -> PutM Word8
putRelayCellGuts x@RelayBegin{} =
do let str = unTorAddress (relayBeginAddress x) ++ ":" ++
show (relayBeginPort x)
putByteString (pack str)
putWord8 0
putWord32be (renderFlags (relayBeginIPv4OK x) (relayBeginIPv6OK x)
(relayBeginIPv6Pref x))
return 1
putRelayCellGuts x@RelayData{} =
do putByteString (relayData x)
return 2
putRelayCellGuts x@RelayEnd{} =
do putRelayEndReason (relayEndReason x)
return 3
putRelayCellGuts x@RelayConnected{} =
do case relayConnectedAddr x of
IP6 _ -> do putWord32be 0
putWord8 1
_ -> return ()
putByteString (torAddressByteString (relayConnectedAddr x))
putWord32be (relayConnectedTTL x)
return 4
putRelayCellGuts RelaySendMe{} =
return 5
putRelayCellGuts x@RelayExtend{} =
do putIP4String (relayExtendAddress x)
putWord16be (relayExtendPort x)
putByteString (relayExtendSkin x)
putByteString (relayExtendIdent x)
return 6
putRelayCellGuts x@RelayExtended{} =
do putByteString (relayExtendedData x)
return 7
putRelayCellGuts RelayTruncate{} =
return 8
putRelayCellGuts x@RelayTruncated{} =
do putDestroyReason (relayTruncatedRsn x)
return 9
putRelayCellGuts RelayDrop{} =
return 10
putRelayCellGuts x@RelayResolve{} =
do putByteString (pack (relayResolveName x))
putWord8 0
return 11
putRelayCellGuts x@RelayResolved{} =
do forM_ (relayResolvedAddrs x) $ \ (addr, ttl) ->
do putTorAddress addr
putWord32be ttl
return 12
putRelayCellGuts RelayBeginDir{} =
return 13
putRelayCellGuts x@RelayExtend2{} =
do putWord8 (fromIntegral (length (relayExtendTarget x)))
forM_ (relayExtendTarget x) putExtendSpec
putHandshakeType (relayExtendType x)
putWord16be (fromIntegral (BS.length (relayExtendData x)))
putByteString (relayExtendData x)
return 14
putRelayCellGuts x@RelayExtended2{} =
do putWord16be (fromIntegral (BS.length (relayExtendedData x)))
putByteString (relayExtendedData x)
return 15
putRelayCellGuts x@RelayEstablishIntro{} =
do putWord16be (fromIntegral (BS.length (relayEstIntKey x)))
-- FIXME: Put guards on these sizes
putByteString (relayEstIntKey x)
putByteString (relayEstIntSessHash x)
putByteString (relayEstIntSig x)
return 32
putRelayCellGuts x@RelayEstablishRendezvous{} =
-- FIXME: Put guards on these sizes
do putByteString (relayEstRendCookie x)
return 33
putRelayCellGuts x@RelayIntroduce1{} =
-- FIXME: Put guards on these sizes
do putByteString (relayIntro1KeyId x)
putByteString (relayIntro1Data x)
return 34
putRelayCellGuts x@RelayIntroduce2{} =
-- FIXME: Put guards on these sizes
do putByteString (relayIntro2Data x)
return 35
putRelayCellGuts x@RelayRendezvous1{} =
-- FIXME: Put guards on these sizes
do putByteString (relayRendCookie x)
putByteString (relayRendGY x)
putByteString (relayRendKH x)
return 36
putRelayCellGuts x@RelayRendezvous2{} =
-- FIXME: Put guards on these sizes
do putByteString (relayRendGY x)
putByteString (relayRendKH x)
return 37
putRelayCellGuts RelayIntroEstablished{} =
return 38
putRelayCellGuts RelayRendezvousEstablished{} =
return 39
putRelayCellGuts RelayIntroduceAck{} =
return 40
-- -----------------------------------------------------------------------------
parseFlags :: Word32 -> (Bool, Bool, Bool)
parseFlags x = (not (testBit x 1), testBit x 0, testBit x 2)
renderFlags :: Bool -> Bool -> Bool -> Word32
renderFlags ip4ok ip6ok ip6pref = ip4bit .|. ip6bit .|. ip6prefbit
where
ip4bit = if ip4ok then 0 else bit 1
ip6bit = if ip6ok then bit 0 else 0
ip6prefbit = if ip6pref then bit 2 else 0
parseAddrPort :: ByteString -> Get (TorAddress, Word16)
parseAddrPort bstr =
case parse addrPort bstr of
Data.Attoparsec.ByteString.Fail _ _ err -> fail err
Data.Attoparsec.ByteString.Partial f ->
case f BS.empty of
Data.Attoparsec.ByteString.Fail _ _ err -> fail err
Data.Attoparsec.ByteString.Partial _ -> fail "Not enough input"
Data.Attoparsec.ByteString.Done _ res -> return res
Data.Attoparsec.ByteString.Done _ res -> return res
where
addrPort =
do addr <- addrPart
_ <- char8 ':'
port <- decimalNum (const True)
return (addr, port)
addrPart = ip4Addr <|> ip6Addr <|> hostnameAddr
ip4Addr = IP4 <$> ip4
ip6Addr = do x <- ip6
return (IP6 ("[" ++ x ++ "]"))
hostnameAddr = (Hostname . toString) <$> many1 (notWord8 58)
-- -----------------------------------------------------------------------------
-- |A reason that someone might want to end a relay.
data RelayEndReason = ReasonMisc
| ReasonResolveFailed
| ReasonConnectionRefused
| ReasonExitPolicy TorAddress Word32
| ReasonDestroyed
| ReasonDone
| ReasonTimeout
| ReasonNoRoute
| ReasonHibernating
| ReasonInternal
| ReasonResourceLimit
| ReasonConnectionReset
| ReasonTorProtocol
| ReasonNotDirectory
deriving (Eq, Show, Typeable)
instance Exception RelayEndReason
-- |Parse a RelayEndReason.
getRelayEndReason :: Word16 -> Get RelayEndReason
getRelayEndReason len =
do b <- getWord8
case b of
1 -> return ReasonMisc
2 -> return ReasonResolveFailed
3 -> return ReasonConnectionRefused
-- FIXME: Turn these into better data structures.
4 | len == 9 -> do addr <- (IP4 . ip4ToString) <$> getByteString 4
ttl <- getWord32be
return (ReasonExitPolicy addr ttl)
| len == 21 -> do addr <- (IP6 . ip6ToString) <$> getByteString 16
ttl <- getWord32be
return (ReasonExitPolicy addr ttl)
| otherwise -> fail ("Bad length for REASON_EXITPOLICY: " ++ show len)
5 -> return ReasonDestroyed
6 -> return ReasonDone
7 -> return ReasonTimeout
8 -> return ReasonNoRoute
9 -> return ReasonHibernating
10 -> return ReasonInternal
11 -> return ReasonResourceLimit
12 -> return ReasonConnectionReset
13 -> return ReasonTorProtocol
14 -> return ReasonNotDirectory
_ -> fail ("Unknown destroy reason: " ++ show b)
-- |Render a RelayEndReason.
putRelayEndReason :: RelayEndReason -> Put
putRelayEndReason ReasonMisc = putWord8 1
putRelayEndReason ReasonResolveFailed = putWord8 2
putRelayEndReason ReasonConnectionRefused = putWord8 3
putRelayEndReason (ReasonExitPolicy a t) =
do putWord8 4
putByteString (torAddressByteString a)
putWord32be t
putRelayEndReason ReasonDestroyed = putWord8 5
putRelayEndReason ReasonDone = putWord8 6
putRelayEndReason ReasonTimeout = putWord8 7
putRelayEndReason ReasonNoRoute = putWord8 8
putRelayEndReason ReasonHibernating = putWord8 9
putRelayEndReason ReasonInternal = putWord8 10
putRelayEndReason ReasonResourceLimit = putWord8 11
putRelayEndReason ReasonConnectionReset = putWord8 12
putRelayEndReason ReasonTorProtocol = putWord8 13
putRelayEndReason ReasonNotDirectory = putWord8 14
-- -----------------------------------------------------------------------------
-- |The format for extension request.
data ExtendSpec = ExtendIP4 String Word16
| ExtendIP6 String Word16
| ExtendDigest ByteString
deriving (Eq, Show)
-- |Render an ExtendSpec.
putExtendSpec :: ExtendSpec -> Put
putExtendSpec (ExtendIP4 addr port) =
do putWord8 0x00
putWord8 (4 + 2)
putIP4String addr
putWord16be port
putExtendSpec (ExtendIP6 addr port) =
do putWord8 0x01
putWord8 (16 + 2)
putIP6String addr
putWord16be port
putExtendSpec (ExtendDigest hash) =
do putWord8 0x02
putWord8 20
putByteString hash
-- |Parse an ExtendSpec
getExtendSpec :: Get ExtendSpec
getExtendSpec =
do lstype <- getWord8
lslen <- getWord8
case (lstype, lslen) of
(0x00, 6) -> do addr <- getByteString 4
port <- getWord16be
return (ExtendIP4 (ip4ToString addr) port)
(0x01, 18) -> do addr <- getByteString 16
port <- getWord16be
return (ExtendIP6 (ip6ToString addr) port)
(0x02, 20) -> do hash <- getByteString 20
return (ExtendDigest hash)
(_, _) -> fail "Invalid LSTYPE / LSLEN combination."