diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2010 Galois Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of Galois, Inc. nor the names of its contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,61 @@ +# A Tor Implementation in Haskell + + This version of haskell-tor is (C) 2015 Galois, Inc., and distributed under + a standard, three-clause BSD license. Please see the file LICENSE, + distributed with this software, for specific terms and conditions. + +## What is Tor? + +Tor is a secure onion routing network for providing anonymized access to both +the public Internet as well as a series of Tor-internal hidden services. Much +more information about Tor can be found at http://torproject.org. + +Many thanks to all the hard work that project has put into developing and +evangelizing Tor. + +## What is in this repository? + +This repository contains a Tor implementation in Haskell. It is eventually +designed to be a fully-compliant Tor implementation, but at the moment lacks +some features: + + * Support for finding or implementing hidden services. + * Proper flow-control support. + * Statistics updating. + * Directory server support. + +Using this library as an entrance node (i.e., to create anonymized connections +to hosts on the Internet) is fairly well tested and should be functional. Relay +and exit node support is implemented but much less well tested. For whichever +use case you have, please report any problems you find to the GitHub issue +tracker. + +## Building haskell-tor + +This library uses cabal as its build system, and should work for Mac, Unix, and +HaLVM-based installations. Windows support may work ... we just haven't tested +it. + +If you're building with the HaLVM, please add the constraints `--constraint "tls ++hans"`, `--constraint "tls -network"`, and `-f-network` to your build flags, +and if you're using the `integer-simple` library (for example, to avoid GPL +entanglements with unikernels), you should add the constraints `--constraint +"cryptonite -integer-gmp"`, `--constraint "scientific +integer-simple"` and +`--constraint "scientific < 0.3.4.1"`. + +In either case, we strongly suggest using sandboxes to keep everything nice and +tidy. + +## Important Note + +This is an early implementation of Tor that has not been peer-reviewed. Those +with a true, deep need for anonymity should strongly consider using the mainline +Tor client until and unless this version receives appropriate extensions, +testing, and review. + +## Usage + +As with most Haskell packages, this package can either be used as a library or +as a binary package. Currently, the executable binary will simply perform an +example get from whatismyip.com. Extending this to support a wider range of +features is an open issue. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +import Data.ByteString.Char8(ByteString,pack) +import qualified Data.ByteString.Lazy as L +import Tor +import Tor.Flags +import Tor.NetworkStack + +#ifdef HaLVM_HOST_OS +import Hans.Device.Xen +import Hans.DhcpClient +import Hans.NetworkStack hiding (listen, accept) +import Hypervisor.Console +import Hypervisor.XenStore +import Tor.NetworkStack.Hans +import XenDevice.NIC +#else +import Hans.Device.Tap +import Hans.DhcpClient +import Hans.NetworkStack hiding (listen, accept) +import System.IO +import Tor.NetworkStack.Hans +import Tor.NetworkStack.System +#endif + +import qualified Data.ByteString as S +import Tor.Link +import Tor.Circuit +import Tor.State.Credentials +import Control.Concurrent +import Crypto.Random +import Tor.RouterDesc +import Tor.DataFormat.Helpers +import Tor.State.Directories +import Tor.State.Routers + +--main :: IO () +--main = runDefaultMain $ \ flags -> +-- do rngMV <- newMVar =<< drgNew +-- addrsMV <- newMVar [] +-- (MkNS ns, logger) <- initializeSystem flags +---- dirdb <- newDirectoryDatabase ns logger +---- db <- newRouterDatabase ns dirdb logger +-- creds <- newCredentials logger +-- [_,printAscii] <- words `fmap` readFile "/Users/awick/.tor/fingerprint" +-- keyfile <- S.readFile "/Users/awick/.tor/keys/secret_onion_key_ntor" +-- let target = blankRouterDesc { routerIPv4Address = "10.0.1.27" +-- , routerORPort = 9001 +-- , routerFingerprint = readHex printAscii +-- , routerNTorOnionKey = Just (S.drop 64 keyfile) +-- } +---- second <- modifyMVar rngMV (getRouter db []) +---- third <- modifyMVar rngMV (getRouter db []) +-- link <- initLink ns creds rngMV addrsMV logger target +-- circId <- modifyMVar rngMV (linkNewCircuitId link) +-- circ <- createCircuit rngMV logger link target circId +---- extendCircuit circ second +---- putStrLn "Done." +---- extendCircuit circ third +---- putStrLn "Done." +-- foo <- resolveName circ "galois.com" +-- putStrLn ("Foo: " ++ show foo) + +main :: IO () +main = runDefaultMain $ \ flags -> + do (MkNS ns, logger) <- initializeSystem flags + let options = defaultTorOptions{ + torLog = logger + , torRelayOptions = Just defaultTorRelayOptions { + torOnionPort = getOnionPort flags + , torNickname = getNickname flags + , torContact = getContactInfo flags + } + } + tor <- startTor ns options + addrs <- torResolveName tor "www.whatismypublicip.com" + case addrs of + [] -> + putStrLn ("Could not resolve www.whatismypublicip.com!") + ((addr, _ttl) : _) -> + do sock <- torConnect tor addr 80 + torWrite sock (buildGet "/") + resp <- readLoop sock + torClose sock ReasonDone + +buildGet :: String -> ByteString +buildGet str = result + where + result = pack (requestLine ++ userAgent ++ crlf) + requestLine = "GET " ++ str ++ " HTTP/1.0\r\n" + userAgent = "User-Agent: CERN-LineMode/2.15 libwww/2.17b3\r\n" + crlf = "\r\n" + +readLoop :: TorSocket -> IO L.ByteString +readLoop sock = + do next <- torRead sock 256 + if L.length next < 256 + then return next + else do rest <- readLoop sock + return (next `L.append` rest) + +-- ----------------------------------------------------------------------------- + +initializeSystem :: [Flag] -> + IO (SomeNetworkStack, String -> IO ()) +#ifdef HaLVM_HOST_OS +initializeSystem _ = + do con <- initXenConsole + xs <- initXenStore + ns <- newNetworkStack + macstr <- findNIC xs + nic <- openNIC xs macstr + let mac = read macstr + addDevice ns mac (xenSend nic) (xenReceiveLoop nic) + deviceUp ns mac + ipaddr <- dhcpDiscover ns mac + return (MkNS (hansNetworkStack ns), makeLogger (\ x -> writeConsole con (x ++ "\n"))) + where + findNIC xs = + do nics <- listNICs xs + case nics of + [] -> threadDelay 1000000 >> findNIC xs + (x:_) -> return x +#else +initializeSystem flags = + case getTapDevice flags of + Nothing -> + do logger <- generateLogger flags + return (MkNS systemNetworkStack, logger) + Just tapName -> + do mfd <- openTapDevice tapName + case mfd of + Nothing -> + fail ("Couldn't open tap device " ++ tapName) + Just fd -> + do ns <- newNetworkStack + logger <- generateLogger flags + let mac = read "52:54:00:12:34:56" + addDevice ns mac (tapSend fd) (tapReceiveLoop fd) + deviceUp ns mac + ipaddr <- dhcpDiscover ns mac + logger ("Node has IP Address " ++ show ipaddr) + return (MkNS (hansNetworkStack ns), logger) + +generateLogger :: [Flag] -> IO (String -> IO ()) +generateLogger [] = return (makeLogger (hPutStrLn stdout)) +generateLogger ((OutputLog fp):_) = do h <- openFile fp AppendMode + return (makeLogger (hPutStrLn h)) +generateLogger (_:rest) = generateLogger rest +#endif diff --git a/haskell-tor.cabal b/haskell-tor.cabal new file mode 100644 --- /dev/null +++ b/haskell-tor.cabal @@ -0,0 +1,153 @@ +name: haskell-tor +version: 0.1.0.0 +synopsis: A Haskell Tor Node +description: An implementation of the Tor anonymity system in Haskell. + The core functionality is exported both as an application + and as a high-level library exported by the 'Tor' module. + Please see that module for common usage scenarios, and + dip only into the other files for advanced / unplanned + cases. +homepage: http://github.com/GaloisInc/haskell-tor +license: BSD3 +license-file: LICENSE +author: Adam Wick +maintainer: awick@galois.com +category: Network +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: http://github.com/GaloisInc/haskell-tor + +Flag network + Description: Use the base network library + +Flag hans + Description: Use the Haskell Network Stack (HaNS) + +library + default-language: Haskell2010 + default-extensions: CPP + other-extensions: DeriveDataTypeable, ExistentialQuantification, + FlexibleInstances, MultiWayIf, OverloadedStrings, + RecordWildCards + ghc-options: -Wall + hs-source-dirs: src + + build-depends: + array >= 0.5 && < 0.7, + asn1-encoding >= 0.9 && < 0.11, + asn1-types >= 0.3 && < 0.5, + async >= 2.0.2 && < 2.2, + attoparsec >= 0.13 && < 0.15, + base >= 4.7 && < 5.0, + base64-bytestring >= 1.0 && < 1.2, + binary >= 0.7.1 && < 0.9, + bytestring >= 0.10 && < 0.11, + cereal >= 0.4 && < 0.6, + containers >= 0.5 && < 0.7, + cryptonite >= 0.6 && < 0.8, + fingertree >= 0.1 && < 0.3, + hourglass >= 0.2.9 && < 0.4, + memory >= 0.7 && < 0.9, + monadLib >= 3.7 && < 3.9, + pretty-hex >= 1.0 && < 1.2, + pure-zlib >= 0.4 && < 0.5, + time >= 1.4 && < 1.6, + tls >= 1.3.2 && < 1.5, + x509 >= 1.6 && < 1.8, + x509-store >= 1.6 && < 1.8 + + other-modules: + Crypto.Hash.Easy, + Crypto.PubKey.RSA.KeyHash, + Paths_haskell_tor + + exposed-modules: + Data.Hourglass.Now, + Tor, + Tor.Circuit, + Tor.DataFormat.Consensus, + Tor.DataFormat.DefaultDirectory, + Tor.DataFormat.DirCertInfo, + Tor.DataFormat.Helpers, + Tor.DataFormat.RelayCell, + Tor.DataFormat.RouterDesc, + Tor.DataFormat.TorAddress, + Tor.DataFormat.TorCell, + Tor.HybridCrypto, + Tor.Link, + Tor.Link.DH, + Tor.Link.CipherSuites, + Tor.NetworkStack.Fetch, + Tor.NetworkStack, + Tor.Options, + Tor.RNG, + Tor.RouterDesc.Render, + Tor.RouterDesc, + Tor.State.CircuitManager, + Tor.State.Credentials, + Tor.State.Directories, + Tor.State.LinkManager, + Tor.State.Routers + + if flag(network) + build-depends: network >= 2.5 && < 2.7 + exposed-modules: Tor.NetworkStack.System + if flag(hans) + build-depends: hans >= 2.6 && < 2.8 + exposed-modules: Tor.NetworkStack.Hans + +executable haskell-tor + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: exe + build-depends: + asn1-encoding >= 0.8 && < 0.10, + asn1-types >= 0.2 && < 0.4, + base >= 4.7 && < 5.0, + base64-bytestring >= 1.0 && < 1.2, + bytestring >= 0.10 && < 0.11, + cryptonite >= 0.6 && < 0.8, + haskell-tor >= 0.1 && < 0.3, + hourglass >= 0.2.9 && < 0.4, + memory >= 0.7 && < 0.9, + time >= 1.4 && < 1.6, + tls >= 1.3.2 && < 1.5, + x509 >= 1.6 && < 1.8 + if flag(hans) + build-depends: hans >= 2.6 && < 2.8 + if flag(network) + build-depends: network >= 2.5 && < 2.7 + if os(HaLVM) + build-depends: HALVMCore >= 2.0 && < 2.4, + XenDevice >= 2.0 && < 2.4 + +test-suite test-tor + type: exitcode-stdio-1.0 + main-is: Test.hs + ghc-options: -Wall + hs-source-dirs: test + default-language: Haskell2010 + other-extensions: FlexibleInstances, TypeSynonymInstances + ghc-options: -fno-warn-orphans + build-depends: + asn1-types >= 0.2 && < 0.4, + base >= 4.7 && < 5.0, + binary >= 0.7 && < 0.9, + bytestring >= 0.10 && < 0.11, + cryptonite >= 0.6 && < 0.8, + haskell-tor >= 0.1 && < 0.3, + hourglass >= 0.2.9 && < 0.4, + HUnit >= 1.2 && < 1.4, + QuickCheck >= 2.7 && < 2.9, + memory >= 0.7 && < 0.9, + pretty-hex >= 1.0 && < 1.4, + test-framework >= 0.8 && < 0.10, + test-framework-hunit >= 0.3 && < 0.5, + test-framework-quickcheck2 >= 0.3 && < 0.5, + time >= 1.4 && < 1.6, + x509 >= 1.6 && < 1.8 diff --git a/src/Crypto/Hash/Easy.hs b/src/Crypto/Hash/Easy.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Hash/Easy.hs @@ -0,0 +1,33 @@ +-- |Handy shorthands for dealing with cryptographic hashes. +module Crypto.Hash.Easy(sha1, sha256, + sha1lazy, sha256lazy, + noHash) + where + +import Crypto.Hash +import Data.ByteArray +import Data.ByteString(ByteString) +import qualified Data.ByteString.Lazy as L + +type HashLazy a = L.ByteString -> Digest a + +-- |Generate a SHA1 hash of a bytestring. +sha1 :: ByteString -> ByteString +sha1 = convert . hashWith SHA1 + +-- |Generate a SHA256 hash of a bytestring. +sha256 :: ByteString -> ByteString +sha256 = convert . hashWith SHA256 + +-- |Generate a SHA1 hash of a lazy bytestring. +sha1lazy :: L.ByteString -> L.ByteString +sha1lazy = L.fromStrict . convert . (hashlazy :: HashLazy SHA1) + +-- |Generate a SHA256 hash of a lazy bytestring. +sha256lazy :: L.ByteString -> L.ByteString +sha256lazy = L.fromStrict . convert . (hashlazy :: HashLazy SHA256) + +-- |When generating a signautre, don't include any information about the +-- underlying hash function. +noHash :: Maybe SHA256 +noHash = Nothing diff --git a/src/Crypto/PubKey/RSA/KeyHash.hs b/src/Crypto/PubKey/RSA/KeyHash.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/PubKey/RSA/KeyHash.hs @@ -0,0 +1,28 @@ +-- |Routines for generating Tor hashes of keys and certificates. +module Crypto.PubKey.RSA.KeyHash( + keyHash + , keyHash' + ) + where + +import Data.ByteString(ByteString) +import Crypto.PubKey.RSA +import Data.ASN1.BinaryEncoding +import Data.ASN1.Encoding +import Data.ASN1.Types +import Data.X509 + +-- |Generate a hash of the given certificate using the given hash algorithm. +keyHash :: (ByteString -> ByteString) -> Certificate -> ByteString +keyHash hash cert = + case certPubKey cert of + PubKeyRSA k -> keyHash' hash k + _ -> error "Unknown key type in keyHash." + +-- |Generate a hash of the given public key using the given hash algorithm. +keyHash' :: (ByteString -> ByteString) -> PublicKey -> ByteString +keyHash' hash k = hash (encodeASN1' DER asn1) + where + asn1 = [Start Sequence, IntVal n, IntVal e, End Sequence] + n = public_n k + e = public_e k diff --git a/src/Data/Hourglass/Now.hs b/src/Data/Hourglass/Now.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hourglass/Now.hs @@ -0,0 +1,18 @@ +-- |A helper module, which will likely evenutally be removable. +{-# LANGUAGE RecordWildCards #-} +module Data.Hourglass.Now(getCurrentTime) + where + +import Data.Hourglass +import Data.Hourglass.Compat +import qualified Data.Time as T + +-- |Fetch the current date, and return it as a DateTime. +getCurrentTime :: IO DateTime +getCurrentTime = + do now <- T.getCurrentTime + let dtDate = dateFromTAIEpoch (T.toModifiedJulianDay (T.utctDay now)) + dtTime = diffTimeToTimeOfDay (T.utctDayTime now) + return DateTime{..} + + diff --git a/src/Tor.hs b/src/Tor.hs new file mode 100644 --- /dev/null +++ b/src/Tor.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE ExistentialQuantification #-} +-- |The high-level interface to the Tor implementation. Basic usage, for +-- using Tor as a mechanism for connecting to Internet services anonymously: +-- +-- @ +-- main :: IO () +-- main = +-- do tor <- startTor systemNetworkStack defaultTorOptions +-- addrs <- torResolveName tor "hostname.com" +-- case addrs of +-- [] -> ... +-- ((x, _):_) -> +-- do sock <- torConnect tor x 80 +-- torWrite sock ... +-- resp <- torRead sock 1024 +-- ... +-- @ +-- +-- HaLVM users should initialize a HaNS network stack, and use that instead of +-- systemNetworkStack, above. +module Tor( + -- * Setup and initialization + Tor + , startTor + -- * Options + , module Tor.Options + -- * Functions for Tor entrance nodes + , TorAddress(..) + , RelayEndReason(..) + , torResolveName + , TorSocket + , torConnect + , torClose + , torWrite + , torRead + ) + where + +import Control.Exception +import Control.Monad +import Data.Maybe +import Data.Word +import Network.TLS +import System.Timeout +import Tor.Circuit +import Tor.DataFormat.RelayCell +import Tor.DataFormat.TorAddress +import Tor.NetworkStack hiding (connect) +import Tor.Options +import Tor.State.CircuitManager +import Tor.State.Credentials +import Tor.State.Directories +import Tor.State.LinkManager +import Tor.State.Routers + +type HostName = String + +-- |A handle to the current Tor system state. +data Tor = forall ls s . HasBackend s => Tor (CircuitManager ls s) + +-- |Start up the underlying Tor system, given a network stack to operate in and +-- some setup options. +startTor :: HasBackend s => TorNetworkStack ls s -> TorOptions -> IO Tor +startTor ns o = + do creds <- newCredentials o + dirDB <- newDirectoryDatabase ns (torLog o) + routerDB <- newRouterDatabase ns dirDB (torLog o) + lm <- newLinkManager o ns routerDB creds + cm <- newCircuitManager o ns creds routerDB lm + when (not isRelay && isExit) $ + do torLog o "WARNING: Requested exit without relay support: weird." + torLog o "WARNING: Please check that this is really what you want." + let res = Tor cm + when (isRelay || isExit) $ + handle (checkPublicFail o) $ + do _ <- torResolveName res "google.com" -- not important + addrs <- getAddresses creds + torLog o ("I believe I have the following addrs: " ++ show addrs) + fin <- timeout (15 * 1000000) $ tryConnect res orPort addrs + unless (isJust fin) $ fail "Timeout connecting to myself." + torLog o ("At least one of which is routable. Starting relay.") + (_, PrivKeyRSA pkey) <- getSigningKey creds + desc <- getRouterDesc creds + sendRouterDescription ns (torLog o) dirDB desc pkey + return (Tor cm) + where + isRelay = isJust (torRelayOptions o) + isExit = isJust (torExitOptions o) + orPort = maybe 9374 torOnionPort (torRelayOptions o) + +tryConnect :: Tor -> Word16 -> [TorAddress] -> IO () +tryConnect _ _ [] = fail "Could not connect to any addresses." +tryConnect tor p (x:rest) = + handle failRecurse $ + do con <- torConnect tor x p + torClose con ReasonDone + where + failRecurse :: SomeException -> IO () + failRecurse _ = tryConnect tor p rest + +checkPublicFail :: TorOptions -> SomeException -> IO () +checkPublicFail o _ = + torLog o ("Failed to create connection to myself. No relay/exit support.") + +-- ----------------------------------------------------------------------------- + +-- |Resolve the given host name, anonymously. This routine will create a new +-- circuit unless torMaxCircuits has been reached, at which point it will re-use +-- an existing circuit. +torResolveName :: Tor -> HostName -> IO [(TorAddress, Word32)] +torResolveName (Tor cm) name = + do circ <- openCircuit cm [ExitNode] + resolveName circ name + +-- |Connect to the given address via Tor. The TorAddress should be one of the +-- IP4 or IP6 variants, rather than a hostname or an error. The result will be +-- the built circuit. This will throw exceptions if failures occur during the +-- building process. +torConnect :: Tor -> TorAddress -> Word16 -> IO TorSocket +torConnect (Tor cm) addr port = + do circ <- openCircuit cm [ExitNodeAllowing addr port] + connectToHost circ addr port + + + diff --git a/src/Tor/Circuit.hs b/src/Tor/Circuit.hs new file mode 100644 --- /dev/null +++ b/src/Tor/Circuit.hs @@ -0,0 +1,1064 @@ +-- |Low-level routines for generating, extending, and destroying circuits. We +-- strongly recommend not using this module unless you have a very good reason. +-- You should probably just use the high-level Tor module or the CircuitManager +-- module instead. +{-# LANGUAGE RecordWildCards #-} +module Tor.Circuit( + -- * High-level type for Tor circuits that originate at the current + -- node, and operations upon them. + OriginatedCircuit + , createCircuit + , destroyCircuit + , extendCircuit + -- * High-level type and operations on circuits that are passing through + -- or exiting at this node. + , TransverseCircuit + , acceptCircuit + , destroyTransverse + -- * Name resolution support. + , resolveName + -- * Tor sockets. + , TorSocket(..) + , connectToHost + , connectToHost' + , torRead + , torWrite + , torClose + -- * Miscellaneous routines, mostly exported for testing. + , CryptoData + , Curve25519Pair + , EncryptionState + , startTAPHandshake + , advanceTAPHandshake + , completeTAPHandshake + , startNTorHandshake + , advanceNTorHandshake + , completeNTorHandshake + , generate25519 + ) + where + +import Control.Concurrent +import Control.Exception +import Control.Monad(void, when, unless, forever, join, forM_) +import Crypto.Cipher.AES +import Crypto.Cipher.Types +import Crypto.Error +import Crypto.Hash hiding (hash) +import Crypto.Hash.Easy +import Crypto.MAC.HMAC(hmac,HMAC) +import Crypto.Number.Serialize +import Crypto.PubKey.Curve25519 as Curve +import Crypto.PubKey.DH +import Crypto.PubKey.RSA.KeyHash +import Crypto.PubKey.RSA.Types +import Crypto.Random +import Data.Binary.Get +import Data.Bits +import Data.ByteArray(ByteArrayAccess,ByteArray,convert) +import Data.ByteString(ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Data.Either +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable hiding (all,forM_) +#endif +import Data.IntSet(IntSet) +import qualified Data.IntSet as IntSet +import Data.Maybe +import Data.Map.Strict(Map) +import qualified Data.Map.Strict as Map +import Data.Tuple +import Data.Word +import Data.X509 +import Hexdump +import Network.TLS(HasBackend) +#if !MIN_VERSION_base(4,8,0) +import Prelude hiding (mapM_) +#endif +import Tor.DataFormat.RelayCell +import Tor.DataFormat.TorAddress +import Tor.DataFormat.TorCell +import Tor.HybridCrypto +import Tor.Link +import Tor.Link.DH +import Tor.NetworkStack +import Tor.Options +import Tor.RNG +import Tor.RouterDesc +import Tor.State.Credentials +import Tor.State.Routers + +-- ----------------------------------------------------------------------------- + +-- |A circuit that originates with this node +data OriginatedCircuit = OriginatedCircuit { + ocLink :: TorLink + , ocLog :: String -> IO () + , ocId :: Word32 + , ocRNG :: MVar TorRNG + , ocOptions :: TorOptions + , ocState :: MVar (Either DestroyReason [ThreadId]) + , ocTakenStreamIds :: MVar IntSet + , ocExtendWaiter :: MVar RelayCell + , ocResolveWaiters :: MVar (Map Word16 (MVar [(TorAddress, Word32)])) + , ocSockets :: MVar (Map Word16 TorSocket) + , ocConnWaiters :: MVar (Map Word16 (MVar (Either String TorSocket))) + , ocForeCryptoData :: MVar [CryptoData] + , ocBackCryptoData :: MVar [CryptoData] + } + + +-- |Create a new one-hop circuit across the given link. The router description +-- given must be the router description for the given link, or the handshake +-- will fail. The Word32 argument is the circuit id to use. The result is the +-- new, one-hop circuit or a thrown exception. If you care about anonymity, you +-- should extend this circuit a few times before trying to make any +-- connections. +createCircuit :: MVar TorRNG -> TorOptions -> + TorLink -> RouterDesc -> Word32 -> + IO OriginatedCircuit +createCircuit ocRNG ocOptions ocLink router1 ocId = + case routerNTorOnionKey router1 of + Nothing -> + do (x,cbstr) <- modifyMVar' ocRNG (startTAPHandshake router1) + linkWrite ocLink (Create ocId cbstr) + Created cid bstr <- linkRead ocLink ocId + unless ((ocId == cid) && (S.length bstr == (128 + 20))) $ + fail "Unacceptable response to CREATE message." + finishCreateCircuit (completeTAPHandshake x bstr) + Just _ -> + do Just (pair, cbody) <- modifyMVar' ocRNG (startNTorHandshake router1) + linkWrite ocLink (Create2 ocId NTor cbody) + Created2 cid bstr <- linkRead ocLink ocId + unless ((ocId == cid) && (S.length bstr == (32 + 32))) $ + fail "Unacceptable response to CREATE2 message." + finishCreateCircuit (completeNTorHandshake router1 pair bstr) + where + ocLog = torLog ocOptions + finishCreateCircuit (Left err) = failLog ("Create handshake failed: " ++ err) + finishCreateCircuit (Right (fencstate, bencstate)) = + do ocForeCryptoData <- newMVar [fencstate] + ocBackCryptoData <- newMVar [bencstate] + ocState <- newEmptyMVar + ocTakenStreamIds <- newMVar IntSet.empty + ocExtendWaiter <- newEmptyMVar + ocSockets <- newMVar Map.empty + ocResolveWaiters <- newMVar Map.empty + ocConnWaiters <- newMVar Map.empty + let circ = OriginatedCircuit { .. } + handler <- forkIO (runBackward circ) + putMVar ocState (Right [handler]) + ocLog ("Created circuit " ++ show ocId) + return circ + -- + failLog str = ocLog str >> throwIO (userError str) + runBackward circ = + forever $ do next <- linkRead ocLink ocId + processBackwardInput circ next + +-- |Extend the extant circuit to the given router. This is purely +-- side-effecting, although it may thrw an error if an error occurs during the +-- extension process. +extendCircuit :: OriginatedCircuit -> RouterDesc -> IO () +extendCircuit circ nxt = + do state <- readMVar (ocState circ) + when (isLeft state) $ + throwIO (userError ("Attempted to extend a closed circuit.")) + case Nothing of -- routerNTorOnionKey nxt of + Nothing -> + do (x,b) <- modifyMVar' (ocRNG circ) (startTAPHandshake nxt) + writeCellOnCircuit circ RelayExtend { + relayStreamId = 0 + , relayExtendAddress = routerIPv4Address nxt + , relayExtendPort = routerORPort nxt + , relayExtendSkin = b + , relayExtendIdent = keyHash' sha1 (routerSigningKey nxt) + } + res@RelayExtended{} <- takeMVar (ocExtendWaiter circ) + finishExtend (completeTAPHandshake x (relayExtendedData res)) + Just _ -> + do Just (p,b) <- modifyMVar' (ocRNG circ) (startNTorHandshake nxt) + let ip4 = routerIPv4Address nxt + writeCellOnCircuit circ RelayExtend2 { + relayStreamId = 0 + , relayExtendTarget = [ExtendIP4 ip4 (routerORPort nxt)] + , relayExtendType = NTor + , relayExtendData = b + } + res@RelayExtended2{} <- takeMVar (ocExtendWaiter circ) + finishExtend (completeNTorHandshake nxt p (relayExtendedData res)) + where + finishExtend (Left err) = + throwIO (userError ("Failed extension handshake on circuit " ++ + show (ocId circ) ++ ": " ++ err)) + finishExtend (Right (fencstate, bencstate)) = + do modifyMVar_ (ocForeCryptoData circ) $ \ rest -> + return (rest ++ [fencstate]) + modifyMVar_ (ocBackCryptoData circ) $ \ rest -> + return (rest ++ [bencstate]) + +-- |Destroy a circuit, and all the streams and computations running through it. +destroyCircuit :: OriginatedCircuit -> DestroyReason -> IO () +destroyCircuit circ rsn = + do ts <- modifyMVar (ocState circ) $ \ state -> + case state of + Left _ -> return (state, []) + Right threads -> + do mapM_ killSockets =<< readMVar (ocSockets circ) + mapM_ killConnWaiters =<< readMVar (ocConnWaiters circ) + mapM_ killResWaiters =<< readMVar (ocResolveWaiters circ) + -- FIXME: Send a message out, kill the crypto after + _ <- takeMVar (ocForeCryptoData circ) + _ <- takeMVar (ocBackCryptoData circ) + ocLog circ ("Destroy circuit " ++ show (ocId circ) ++ + ": " ++ show rsn) + return (Left rsn, threads) + mapM_ killThread ts + where + killSockets sock = + do modifyMVar_ (tsState sock) (const (return (Just ReasonDestroyed))) + writeChan (tsInChan sock) (Left ReasonDestroyed) + killConnWaiters mv = + void $ tryPutMVar mv (Left ("Underlying circuit destroyed: " ++ show rsn)) + killResWaiters mv = + void $ tryPutMVar mv [] + +-- |Write a cell on the circuit we just created, pushing it through the network. +writeCellOnCircuit :: OriginatedCircuit -> RelayCell -> IO () +writeCellOnCircuit circ relay = + do keysnhashes <- takeMVar (ocForeCryptoData circ) + let (cell, keysnhashes') = synthesizeRelay keysnhashes + linkWrite (ocLink circ) (pickBuilder relay (ocId circ) cell) + putMVar (ocForeCryptoData circ) keysnhashes' + where + synthesizeRelay [] = error "synthesizeRelay reached empty list?!" + synthesizeRelay [(estate, hash)] = + let (bstr, hash') = renderRelayCell hash relay + (encbstr, estate') = encryptData estate bstr + in (encbstr, [(estate', hash')]) + synthesizeRelay ((estate, hash) : rest) = + let (bstr, rest') = synthesizeRelay rest + (encbstr, estate') = encryptData estate bstr + in (encbstr, (estate', hash) : rest') + -- + pickBuilder RelayExtend{} = RelayEarly + pickBuilder RelayExtend2{} = RelayEarly + pickBuilder _ = RelayEarly + +-- ---------------------------------------------------------------------------- + +-- |A handle for a circuit that orginated elsewhere, and is either passing +-- through or exiting at this node. +data TransverseCircuit s = TransverseCircuit { + tcLink :: TorLink + , tcNextHop :: MVar TorLink + , tcLog :: String -> IO () + , tcId :: Word32 + , tcRNG :: MVar TorRNG + , tcOptions :: TorOptions + , tcCredentials :: Credentials + , tcRouterDB :: RouterDB + , tcConnections :: MVar (Map Word16 s) + , tcThreads :: MVar [ThreadId] + , tcForeCryptoData :: MVar CryptoData + , tcBackCryptoData :: MVar CryptoData + } + + +-- |Accept a circuit from someone who just connected to us. +acceptCircuit :: HasBackend s => + TorNetworkStack ls s -> TorOptions -> + RouterDesc -> Credentials -> RouterDB -> + TorLink -> MVar TorRNG -> + IO (Maybe (TransverseCircuit s)) +acceptCircuit ns tcOptions me tcCredentials tcRouterDB tcLink tcRNG = + do msg <- linkRead tcLink 0 + (_, PrivKeyRSA priv) <- getOnionKey tcCredentials + (_, skey) <- getNTorOnionKey tcCredentials + case msg of + Create tcId bstr -> + do (created, fes, bes) <- modifyMVar' tcRNG + (advanceTAPHandshake priv tcId bstr) + tcForeCryptoData <- newMVar fes + tcBackCryptoData <- newMVar bes + tcConnections <- newMVar Map.empty + tcThreads <- newEmptyMVar + tcNextHop <- newEmptyMVar + let circ = TransverseCircuit { .. } + thread <- forkIO (runForward circ) + putMVar tcThreads [thread] + linkWrite tcLink created + tcLog ("Created transverse circuit " ++ show tcId) + return (Just circ) + Create2 tcId TAP bstr -> + do (created, fes, bes) <- modifyMVar' tcRNG + (advanceTAPHandshake priv tcId bstr) + tcForeCryptoData <- newMVar fes + tcBackCryptoData <- newMVar bes + tcConnections <- newMVar Map.empty + tcThreads <- newEmptyMVar + tcNextHop <- newEmptyMVar + let circ = TransverseCircuit { .. } + thread <- forkIO (runForward circ) + putMVar tcThreads [thread] + linkWrite tcLink created + tcLog ("Created transverse circuit " ++ show tcId) + return (Just circ) + Create2 tcId NTor bstr -> + -- FIXME: Really should gate this on "UseNTorHandshake" being in the + -- consensus parameters. + do res <- modifyMVar' tcRNG (advanceNTorHandshake me skey tcId bstr) + case res of + Left err -> + do tcLog ("Error creating transverse circuit: " ++ err) + linkWrite tcLink (Destroy tcId TorProtocolViolation) + return Nothing + Right (response, fes, bes) -> + do tcForeCryptoData <- newMVar fes + tcBackCryptoData <- newMVar bes + tcConnections <- newMVar Map.empty + tcThreads <- newEmptyMVar + tcNextHop <- newEmptyMVar + let circ = TransverseCircuit { .. } + thread <- forkIO (runForward circ) + putMVar tcThreads [thread] + linkWrite tcLink response + tcLog ("Create transverse circuit (ntor) " ++ show tcId) + return (Just circ) + Create2 tcId hstype _ -> + do tcLog ("Unfamiliar CREATE2 handshake type: " ++ show hstype) + linkWrite tcLink (Destroy tcId TorProtocolViolation) + return Nothing + CreateFast tcId _ -> + -- FIXME: Really should look up "usecreatefast" in the consensus + -- parameters. + do tcLog ("Rejecting CREATE_FAST attempt.") + linkWrite tcLink (Destroy tcId TorProtocolViolation) + return Nothing + _ -> + do tcLog ("Unexpected message waiting for CREATE: " ++ show msg) + linkWrite tcLink (Destroy 0 TorProtocolViolation) + return Nothing + where + tcLog = torLog tcOptions + runForward circ = + forever $ do next <- linkRead tcLink (tcId circ) + processForwardInput ns circ next + +-- |Destroy a circuit that is transiting us. +destroyTransverse :: TorNetworkStack ls s -> + TransverseCircuit s -> DestroyReason -> + IO () +destroyTransverse ns circ rsn = + do tcLog circ ("Destroy transverse circuit: " ++ show rsn) + mlink <- tryTakeMVar (tcNextHop circ) + case mlink of + Nothing -> return () + Just link -> linkClose link + thrs <- takeMVar (tcThreads circ) + forM_ thrs killThread + conns <- takeMVar (tcConnections circ) + forM_ (Map.elems conns) $ \ s -> close ns s + +-- ---------------------------------------------------------------------------- + +processBackwardInput :: OriginatedCircuit -> TorCell -> IO () +processBackwardInput circ cell = + handle logException $ + case cell of + Relay _ body -> processBackwardRelay circ body + RelayEarly _ body -> processBackwardRelay circ body + Destroy _ rsn -> destroyCircuit circ rsn + _ -> ocLog circ ("Spurious message along circuit.") + where + logException e = + ocLog circ ("Caught exception processing backwards input: " + ++ show (e :: SomeException)) + +processBackwardRelay :: OriginatedCircuit -> ByteString -> IO () +processBackwardRelay circ body = + do clearBody <- modifyMVar' (ocBackCryptoData circ) (decryptUntilClean body) + case clearBody of + Nothing -> ocLog circ "Dropped upstream packet on originated circuit." + Just x -> processLocalBackwardsRelay circ x + where + decryptUntilClean :: ByteString -> [CryptoData] -> + ([CryptoData], Maybe RelayCell) + decryptUntilClean _ [] = ([], Nothing) + decryptUntilClean bstr ((encstate, h1):rest) = + let (bstr', encstate') = decryptData encstate bstr + in case runGetOrFail (parseRelayCell h1) (L.fromStrict bstr') of + Left _ -> + let (rest', res) = decryptUntilClean bstr' rest + in ((encstate', h1) : rest', res) + Right (_, _, (x, h1')) -> + (((encstate', h1') : rest), Just x) + +processLocalBackwardsRelay :: OriginatedCircuit -> RelayCell -> IO () +processLocalBackwardsRelay circ x = + case x of + RelayData{ relayStreamId = strmId, relayData = bstr } -> + withMVar (ocSockets circ) $ \ smap -> + case Map.lookup strmId smap of + Nothing -> + ocLog circ ("Dropping traffic to unknown stream " ++ show strmId) + Just sock -> + do state <- readMVar (tsState sock) + unless (isJust state) $ writeChan (tsInChan sock) (Right bstr) + + RelayEnd{ relayStreamId = strmId, relayEndReason = rsn } -> + modifyMVar_ (ocSockets circ) $ \ smap -> + case Map.lookup strmId smap of + Nothing -> + return smap + Just sock -> + do modifyMVar_ (tsState sock) (const (return (Just rsn))) + writeChan (tsInChan sock) (Left rsn) + return (Map.delete strmId smap) + + RelayConnected{ relayStreamId = tsStreamId } -> + modifyMVar_ (ocConnWaiters circ) $ \ cwaits -> + case Map.lookup tsStreamId cwaits of + Nothing -> + do ocLog circ ("CONNECTED without waiter?") + return cwaits + Just wait -> + do let tsCircuit = circ + tsState <- newMVar Nothing + tsInChan <- newChan + tsLeftover <- newMVar S.empty + tsReadWindow <- newMVar 500 -- See spec, 7.4, stream flow + let sock = TorSocket { .. } + modifyMVar_ (ocSockets circ) $ \ socks -> + return (Map.insert tsStreamId sock socks) + _ <- tryPutMVar wait (Right sock) + return (Map.delete tsStreamId cwaits) + + RelaySendMe {} -> + do ocLog circ "SENDME" + return () + + RelayExtended {} -> + void $ tryPutMVar (ocExtendWaiter circ) x + + RelayTruncated {} -> + do ocLog circ ("TRUNCATED: " ++ show (relayTruncatedRsn x)) + return () -- FIXME + + RelayDrop {} -> + return () + + RelayResolved { relayStreamId = strmId } -> + modifyMVar_ (ocResolveWaiters circ) $ \ resolveds -> + case Map.lookup strmId resolveds of + Nothing -> + do ocLog circ ("Resolved unknown request.") + return resolveds + Just wait -> + do _ <- tryPutMVar wait (relayResolvedAddrs x) + return (Map.delete strmId resolveds) + + RelayExtended2 {} -> + void $ tryPutMVar (ocExtendWaiter circ) x + + _ -> + ocLog circ ("Unexpected relay cell on backward link.") + +-- ---------------------------------------------------------------------------- + +processForwardInput :: HasBackend s => + TorNetworkStack ls s -> TransverseCircuit s -> TorCell -> + IO () +processForwardInput ns circ cell = + handle logException $ + case cell of + Relay circId body -> processForwardRelay ns circ circId body + RelayEarly circId body -> processForwardRelay ns circ circId body + Destroy _ rsn -> destroyTransverse ns circ rsn + _ -> + tcLog circ ("Spurious message along circuit.") + where + logException e = + tcLog circ ("Caught exception processing backwards input: " + ++ show (e :: SomeException)) + +processForwardRelay :: HasBackend s => + TorNetworkStack ls s -> TransverseCircuit s -> + Word32 -> ByteString -> + IO () +processForwardRelay ns circ circId body = + do clearBody <- modifyMVar' (tcForeCryptoData circ) (decryptBody body) + case clearBody of + Left body' -> + do mlink <- tryReadMVar (tcNextHop circ) + case mlink of + Nothing -> return () + Just link -> linkWrite link (Relay circId body') + Right x -> processLocalForwardRelay ns circ x + where + decryptBody bstr (encstate, h1) = + let (bstr', encstate') = decryptData encstate bstr + in case runGetOrFail (parseRelayCell h1) (L.fromStrict bstr') of + Left _ -> ((encstate', h1), Left bstr') + Right (_, _, (x, h1')) -> ((encstate', h1'), Right x) + +processLocalForwardRelay :: HasBackend s => + TorNetworkStack ls s -> + TransverseCircuit s -> RelayCell -> + IO () +processLocalForwardRelay ns circ x = + case x of + RelayBegin{} | not (isExitNode circ) -> + circRelayUpstream circ (RelayEnd (relayStreamId x) ReasonTorProtocol) + + RelayBegin{ relayStreamId = strmId } -> + -- FIXME: Figure out how to get TTLs from our network stacks. + void $ forkIO $ + do eaddr <- getAddress' ns (relayBeginAddress x) + case eaddr of + [] -> + circRelayUpstream circ (RelayEnd strmId ReasonResolveFailed) + (f:_) | matchesExitCriteria f (relayBeginPort x) circ -> + do ms <- connect' ns f (relayBeginPort x) + case ms of + Nothing -> + circRelayUpstream circ + (RelayEnd strmId ReasonConnectionRefused) + Just sock -> + do modifyMVar_' (tcConnections circ) (Map.insert strmId sock) + readThr <- forkIO $ transferData sock + modifyMVar_' (tcThreads circ) (readThr :) + circRelayUpstream circ (RelayConnected strmId f 600) + (f:_) -> + circRelayUpstream circ (RelayEnd strmId (ReasonExitPolicy f 600)) + where + transferData sock = + do bstr <- recv ns sock 1024 + if S.null bstr + then do close ns sock + circRelayUpstream circ (RelayEnd strmId ReasonDone) + else do circRelayUpstream circ (RelayData strmId bstr) + transferData sock + + RelayData{ relayStreamId = strmId } -> + void $ forkIO $ + do msock <- withMVar' (tcConnections circ) (Map.lookup strmId) + case msock of + Nothing -> tcLog circ "Ignoring write to unknown stream." + Just s -> write ns s (L.fromStrict (relayData x)) + + RelayEnd{ relayStreamId = strmId } -> + do msock <- withMVar' (tcConnections circ) (Map.lookup strmId) + case msock of + Nothing -> tcLog circ "Ignoring end to unknown stream." + Just s -> close ns s + + RelaySendMe{} -> + return () -- FIXME + + RelayExtend{ relayStreamId = strmId } -> + void $ forkIO $ handle abortExtend tryExtend + where + abortExtend :: SomeException -> IO () + abortExtend _ = circRelayUpstream circ (RelayEnd strmId ReasonTorProtocol) + -- + tryExtend = + do let target = [ExtendIP4 (relayExtendAddress x) (relayExtendPort x), + ExtendDigest (relayExtendIdent x)] + tcLog circ ("Going to try to extending a circuit to " ++ show target) + Just desc <- findRouter (tcRouterDB circ) target + -- FIXME: Run this through the link manager, instead. + link <- initLink ns (tcCredentials circ) (tcRNG circ) (tcLog circ) desc + linkWrite link (Create (tcId circ) (relayExtendSkin x)) + Created cid bstr <- linkRead link (tcId circ) + unless ((tcId circ == cid) && (S.length bstr == (128 + 20))) $ + fail "Unacceptable response to extend CREATE message." + good <- tryPutMVar (tcNextHop circ) link + if good + then do circRelayUpstream circ (RelayExtended strmId bstr) + tcLog circ "Circuit extension succeeded." + forever $ do next <- linkRead link (tcId circ) + processBackwardTransverse circ next + else do tcLog circ "Duplicate extension. Failing." + linkClose link + fail "Duplicate extension." + + RelayTruncate{} -> + void $ forkIO $ + do mlink <- tryReadMVar (tcNextHop circ) + case mlink of + Nothing -> return () + Just link -> linkWrite link (Destroy (tcId circ) NoReason) + circRelayUpstream circ (RelayTruncated 0 NoReason) + + RelayDrop{} -> + return () + + RelayResolve{} | not (isExitNode circ) -> + circRelayUpstream circ (RelayEnd (relayStreamId x) ReasonTorProtocol) + + RelayResolve{ relayStreamId = strmId, relayResolveName = name } -> + void $ forkIO $ + do resolve <- getAddress ns name + let results = map (\ a -> (a, 600)) resolve -- FIXME: TTLs! + circRelayUpstream circ (RelayResolved strmId results) + + RelayBeginDir{ relayStreamId = strmId } -> + circRelayUpstream circ (RelayEnd strmId ReasonNotDirectory) + + RelayExtend2{ relayStreamId = strmId } -> + void $ forkIO $ handle abortExtend tryExtend + where + abortExtend :: SomeException -> IO () + abortExtend _ = circRelayUpstream circ (RelayEnd strmId ReasonTorProtocol) + -- + tryExtend = -- FIXME: This is probably worth abstracting + do let target = relayExtendTarget x + tcLog circ ("Going to try to extending a circuit to " ++ show target) + Just desc <- findRouter (tcRouterDB circ) target + -- FIXME: Run this through the link manager, instead. + link <- initLink ns (tcCredentials circ) (tcRNG circ) (tcLog circ) desc + linkWrite link (Create2 (tcId circ) (relayExtendType x) (relayExtendSkin x)) + Created2 cid bstr <- linkRead link (tcId circ) + unless ((tcId circ == cid) && (S.length bstr == (32 + 32))) $ + fail "Unacceptable response to extend CREATE2 message." + good <- tryPutMVar (tcNextHop circ) link + if good + then do circRelayUpstream circ (RelayExtended2 strmId bstr) + tcLog circ "Circuit extension succeeded." + forever $ do next <- linkRead link (tcId circ) + processBackwardTransverse circ next + else do tcLog circ "Duplicate extension. Failing." + linkClose link + fail "Duplicate extension." + + _ -> + tcLog circ ("Unexpected relay cell on backward link.") + +processBackwardTransverse :: TransverseCircuit s -> TorCell -> IO () +processBackwardTransverse circ cell = + case cell of + Relay _ body -> process body + RelayEarly _ body -> process body + _ -> tcLog circ ("Got weird backwards transverse cell: " ++ show cell) + where + process body = + do body' <- modifyMVar' (tcBackCryptoData circ) (processBody body) + linkWrite (tcLink circ) (Relay (tcId circ) body') + processBody body (estate, hash) = + let (body', estate') = encryptData estate body + in ((estate', hash), body') + +isExitNode :: TransverseCircuit s -> Bool +isExitNode = isJust . torExitOptions . tcOptions + +getAddress' :: TorNetworkStack ns s -> TorAddress -> IO [TorAddress] +getAddress' ns addr = + case addr of + Hostname str -> getAddress ns str + IP4 _ -> return [addr] + IP6 _ -> return [addr] + _ -> return [] + +connect' :: TorNetworkStack ns s -> TorAddress -> Word16 -> IO (Maybe s) +connect' ns (IP4 a) p = connect ns a p +connect' ns (IP6 a) p = connect ns a p +connect' _ _ _ = return Nothing + +matchesExitCriteria :: TorAddress -> Word16 -> TransverseCircuit s -> Bool +matchesExitCriteria addr port circ = + case torExitOptions (tcOptions circ) of + Nothing -> False + Just opts -> allowsExit (torExitRules opts) addr port + +circRelayUpstream :: TransverseCircuit s -> RelayCell -> IO () +circRelayUpstream circ relay = + do cell <- modifyMVar' (tcBackCryptoData circ) synthesizeRelay + linkWrite (tcLink circ) (Relay (tcId circ) cell) + where + synthesizeRelay (estate, hash) = + let (bstr, hash') = renderRelayCell hash relay + (encbstr, estate') = encryptData estate bstr + in ((estate', hash'), encbstr) + +-- ---------------------------------------------------------------------------- + +-- |Resolve the given hostname, anonymously. The result is a list of addresses +-- associated with that hostname, and the TTL for those values. +resolveName :: OriginatedCircuit -> String -> IO [(TorAddress, Word32)] +resolveName circ str = + do strmId <- getNextStreamId circ + resMV <- newEmptyMVar + modifyMVar_ (ocResolveWaiters circ) $ \ m -> + return (Map.insert strmId resMV m) + writeCellOnCircuit circ (RelayResolve strmId str) + takeMVar resMV + +-- ---------------------------------------------------------------------------- + +-- |A socket for communicating with a server, anonymously, via Tor. +data TorSocket = TorSocket { + tsCircuit :: OriginatedCircuit + , tsStreamId :: Word16 + , tsState :: MVar (Maybe RelayEndReason) + , tsReadWindow :: MVar Int + , tsInChan :: Chan (Either RelayEndReason ByteString) + , tsLeftover :: MVar ByteString + } + +-- |Connect to the given address and port through the given circuit. The result +-- is a connection that can be used to read, write, and close the connection. +-- (This is equivalent to calling connectToHost' with True, True, and False for +-- the extra arguments.) +connectToHost :: OriginatedCircuit -> TorAddress -> Word16 -> IO TorSocket +connectToHost tc a p = connectToHost' tc a p True True False + +-- |Connect to the given address and port through the given circuit. The result +-- is a connection that can be used to read, write, and close the connection. +-- The booleans determine if an IPv4 connection is OK, an IPv6 connection is OK, +-- and whether IPv6 is preferred, respectively. +connectToHost' :: OriginatedCircuit -> + TorAddress -> Word16 -> + Bool -> Bool -> Bool -> + IO TorSocket +connectToHost' circ addr port ip4ok ip6ok ip6pref = + do strmId <- getNextStreamId circ + resMV <- newEmptyMVar + modifyMVar_ (ocConnWaiters circ) $ \ m -> + return (Map.insert strmId resMV m) + writeCellOnCircuit circ (RelayBegin strmId addr port ip4ok ip6ok ip6pref) + throwLeft =<< takeMVar resMV + where + throwLeft (Left a) = throwIO (userError a) + throwLeft (Right x) = return x + +-- |Write the given ByteString to the given Tor socket. Blocks until the entire +-- ByteString has been written out to the network. Will throw an error if the +-- socket has been closed. +torWrite :: TorSocket -> ByteString -> IO () +torWrite sock block = + do state <- readMVar (tsState sock) + case state of + Just reason -> + throwIO (userError ("Write to closed socket: " ++ show reason)) + Nothing -> + loop block + where + loop bstr + | S.null bstr = return () + | otherwise = + do let (cur, rest) = S.splitAt 503 bstr + strmId = tsStreamId sock + writeCellOnCircuit (tsCircuit sock) (RelayData strmId cur) + loop rest + +-- |Read the given number of bytes from the socket. Blocks until either the +-- entire buffer has been read or the socket closes for some reason. Will throw +-- an error if the socket was closed before the read starts. +torRead :: TorSocket -> Int -> IO L.ByteString +torRead sock amt = + modifyMVar (tsLeftover sock) $ \ headBuf -> + if S.length headBuf >= amt + then do let (res, headBuf') = S.splitAt amt headBuf + return (headBuf', L.fromStrict res) + else do let amt' = amt - S.length headBuf + res <- loop amt' [headBuf] + return res + where + loop x acc = + do nextBuf <- readChan (tsInChan sock) + join $ modifyMVar (tsReadWindow sock) $ \ strmWindow -> + do let newval = strmWindow - 1 + if newval <= 450 + then return (newval + 50, sendMe) + else return (newval, return ()) + case nextBuf of + Left err | all S.null acc -> + do writeChan (tsInChan sock) nextBuf + throwIO (userError ("Read from closed socket: " ++ show err)) + Left _ -> + do writeChan (tsInChan sock) nextBuf + return (S.empty, L.fromChunks (reverse acc)) + Right buf | S.length buf >= x -> + do let (mine, leftover) = S.splitAt x buf + return (leftover, L.fromChunks (reverse (mine:acc))) + Right buf -> + loop (x - S.length buf) (buf : acc) + -- + sendMe = + writeCellOnCircuit (tsCircuit sock) (RelaySendMe (tsStreamId sock)) + +-- |Close a Tor socket. This will notify the other end of the connection that +-- you are done, so you should be sure you really don't need to do any more +-- reading before calling this. At this point, this implementation does not +-- support a half-closed option. +torClose :: TorSocket -> RelayEndReason -> IO () +torClose sock reason = + do let strmId = tsStreamId sock + modifyMVar_ (tsState sock) (const (return (Just reason))) + modifyMVar_' (ocSockets (tsCircuit sock)) (Map.delete strmId) + writeCellOnCircuit (tsCircuit sock) (RelayEnd strmId reason) + +-- ---------------------------------------------------------------------------- + +-- |The current state of an encryptor. +newtype EncryptionState = ES L.ByteString + +instance Eq EncryptionState where + (ES a) == (ES b) = (L.take 256 a) == (L.take 256 b) + +instance Show EncryptionState where + show (ES x) = "EncryptionState(" ++ simpleHex (L.toStrict (L.take 8 x)) ++ " ...)" + +initEncryptionState :: AES128 -> EncryptionState +initEncryptionState k = ES (xorStream k) + +encryptData :: EncryptionState -> ByteString -> (ByteString, EncryptionState) +encryptData (ES state) bstr = + let (ebstr, state') = L.splitAt (fromIntegral (S.length bstr)) state + in (xorBS (L.toStrict ebstr) bstr, ES state') + +decryptData :: EncryptionState -> ByteString -> (ByteString, EncryptionState) +decryptData = encryptData + +xorStream :: AES128 -> L.ByteString +xorStream k = L.fromChunks (go 0) + where + go :: Integer -> [ByteString] + go x = ecbEncrypt k (i2ospOf_ 16 x) : go (plus1' x) + -- + plus1' x = (x + 1) `mod` (2 ^ (128 :: Integer)) + +xorBS :: ByteString -> ByteString -> ByteString +xorBS a b = S.pack (S.zipWith xor a b) + +-- ---------------------------------------------------------------------------- + +getNextStreamId :: OriginatedCircuit -> IO Word16 +getNextStreamId circ = + do nextId <- modifyMVar' (ocRNG circ) randWord16 + let nextId' = fromIntegral nextId + good <- modifyMVar (ocTakenStreamIds circ) $ \ set -> + if IntSet.member nextId' set || nextId == 0 + then return (set, False) + else return (IntSet.insert nextId' set, True) + if good + then return nextId + else getNextStreamId circ + where + randWord16 rng = swap (withRandomBytes rng 2 toWord16) + toWord16 bs = fromIntegral (S.index bs 0) `shiftL` 8 + + fromIntegral (S.index bs 1) + +-- ----------------------------------------------------------------------------- + +-- |Perform the first step in a TAP handshake, generating a private value and +-- the public cell body to send to the other side. +startTAPHandshake :: RouterDesc -> TorRNG -> + (TorRNG, (PrivateNumber, ByteString)) +startTAPHandshake rtr g = (g'', (x, egx)) + where + (x, g') = withDRG g (generatePrivate oakley2) + PublicNumber gx = calculatePublic oakley2 x + gxBS = i2ospOf_ 128 gx + nodePub = routerOnionKey rtr + (egx, g'') = withDRG g' (hybridEncrypt True nodePub gxBS) + +-- |Given our information and the public value provided by the other side, +-- compute both the shared secret and our public value to send back to the +-- originator. +advanceTAPHandshake :: PrivateKey -> Word32 -> ByteString -> TorRNG -> + (TorRNG, (TorCell, CryptoData, CryptoData)) +advanceTAPHandshake privkey circId egx g = (g'', (created, f, b)) + where + (y, g') = withDRG g (generatePrivate oakley2) + PublicNumber gy = calculatePublic oakley2 y + gyBS = i2ospOf_ 128 gy + (gxBS, g'') = withDRG g' (hybridDecrypt privkey egx) + gx = PublicNumber (os2ip gxBS) + (kh, f, b) = computeTAPValues y gx + created = Created circId (gyBS `S.append` kh) + +-- |Given the private number generated before and the server's response, +-- generate the shared secret and the appropriate crypto data. +completeTAPHandshake :: PrivateNumber -> ByteString -> + Either String (CryptoData, CryptoData) +completeTAPHandshake x rbstr + | kh == kh' = Right (f, b) + | otherwise = Left "Key agreement failure." + where + (gyBS, kh) = S.splitAt 128 rbstr + gy = PublicNumber (os2ip gyBS) + (kh', f, b) = computeTAPValues x gy + +computeTAPValues :: PrivateNumber -> PublicNumber -> + (ByteString, CryptoData, CryptoData) +computeTAPValues b ga = (L.toStrict kh, (encsf, fhash), (encsb, bhash)) + where + SharedKey k0 = getShared oakley2 b ga + (kh, rest1) = L.splitAt 20 (kdfTor (i2ospOf_ 128 k0)) + (df, rest2) = L.splitAt 20 rest1 + (db, rest3) = L.splitAt 20 rest2 + (kf, rest4) = L.splitAt 16 rest3 + (kb, _) = L.splitAt 16 rest4 + keyf = throwCryptoError (cipherInit (L.toStrict kf)) + keyb = throwCryptoError (cipherInit (L.toStrict kb)) + encsf = initEncryptionState keyf + encsb = initEncryptionState keyb + fhash = hashUpdate hashInit (L.toStrict df) + bhash = hashUpdate hashInit (L.toStrict db) + +kdfTor :: ByteString -> L.ByteString +kdfTor k0 = L.fromChunks (map kdfTorChunk [0..255]) + where kdfTorChunk x = sha1 (S.snoc k0 x) + +-- ----------------------------------------------------------------------------- + +-- |A shorthand for the pair of encryption and hashing state used by Tor. Note, +-- because it's easy to forget, that the encryption state is updated on every +-- cell that passes through the system, but the hashing state is only updated on +-- cells that are destined for us. +type CryptoData = (EncryptionState, Context SHA1) + +-- |Start an NTor handshake by generating a local Curve25519 pair and a public +-- value to send to the server. +startNTorHandshake :: RouterDesc -> TorRNG -> + (TorRNG, Maybe (Curve25519Pair, ByteString)) +startNTorHandshake router g0 = + case routerNTorOnionKey router of + Nothing -> + (g0, Nothing) + Just key -> + let (pair@(bigX, _), g1) = withDRG g0 generate25519 + nodeid = routerFingerprint router + client_pk = convert bigX + bstr = S.concat [nodeid, convert key, client_pk] + in (g1, Just (pair, bstr)) + +-- |As a server, accept the client's public value, generate the shared +-- encryption state from that value, and generate a response to the client they +-- can use to generate the same values. +advanceNTorHandshake :: RouterDesc -> Curve.SecretKey -> Word32 -> + ByteString -> TorRNG -> + (TorRNG, + Either String (TorCell, CryptoData, CryptoData)) +advanceNTorHandshake me littleB circId bstr0 g0 + | Nothing <- routerNTorOnionKey me = + (g0, Left "Called advance, but I don't support NTor handshakes.") + | (nodeid /= routerFingerprint me) || (Just bigB /= routerNTorOnionKey me) = + (g0, Left "Called advance, but their fingerprint doesn't match me.") + | Left err <- publicKey keyid = + (g0, Left ("Couldn't decode bigX in advance: " ++ err)) + | otherwise = (g1, Right (msg,fenc,benc)) + where + (nodeid, bstr1) = S.splitAt 20 bstr0 + (keyid, xpub) = S.splitAt 32 bstr1 + Right bigB = publicKey keyid + Right bigX = publicKey xpub + ((bigY, littleY), g1) = withDRG g0 generate25519 + secret_input = S.concat [curveExp bigX littleY, + curveExp bigX littleB, + nodeid, convert bigB, convert bigX, + convert bigY, protoid] + key_seed = hmacSha256 t_key secret_input + verify = hmacSha256 t_verify secret_input + auth_input = S.concat [verify, nodeid, convert bigB, convert bigY, + convert bigX, protoid, S8.pack "Server"] + server_pk = convert bigY + auth = hmacSha256 t_mac auth_input + -- + msg = Created2 circId outdata + outdata = S.concat [server_pk, auth] + (fenc, benc) = computeNTorValues key_seed + +-- |Complete the NTor handhsake using the server's public value. +completeNTorHandshake :: RouterDesc -> Curve25519Pair -> ByteString -> + Either String (CryptoData, CryptoData) +completeNTorHandshake router (bigX, littleX) bstr + | Nothing <- routerNTorOnionKey router = Left "Internal error complete/ntor" + | Left err <- publicKey public_pk = Left ("Couldn't decode bigY: "++err) + | Left err <- publicKey server_ntorid = Left ("Couldn't decode bigB: "++err) + | auth /= auth' = Left "Authorization failure" + | otherwise = Right res + where + nodeid = routerFingerprint router + (public_pk, auth) = S.splitAt 32 bstr + Just server_ntorid = routerNTorOnionKey router + Right bigY = publicKey public_pk + Right bigB = publicKey server_ntorid + secret_input = S.concat [curveExp bigY littleX, curveExp bigB littleX, + nodeid, convert bigB, convert bigX, convert bigY, + protoid] + key_seed = hmacSha256 t_key secret_input + verify = hmacSha256 t_verify secret_input + auth_input = S.concat [verify, nodeid, convert bigB, convert bigY, + convert bigX, protoid, S8.pack "Server"] + auth' = hmacSha256 t_mac auth_input + res = computeNTorValues key_seed + +curveExp :: Curve.PublicKey -> Curve.SecretKey -> ByteString +curveExp a b = convert (dh a b) + +-- |A handy shorthand for a public and private Curve25519 pair. +type Curve25519Pair = (Curve.PublicKey, Curve.SecretKey) + +-- |Generate a new Curve25519 key pair. +generate25519 :: MonadRandom m => m Curve25519Pair +generate25519 = + do bytes <- getRandomBytes 32 + case secretKey (bytes :: ByteString) of + Left err -> + fail ("Couldn't convert to a secret key: " ++ show err) + Right privKey -> + do let pubKey = toPublic privKey + return (pubKey, privKey) + +computeNTorValues :: ByteString -> (CryptoData, CryptoData) +computeNTorValues key_seed = ((encsf, fhash), (encsb, bhash)) + where + bstr0 = kdfRFC5869 key_seed + (df, bstr1) = L.splitAt 20 bstr0 + (db, bstr2) = L.splitAt 20 bstr1 + (kf, bstr3) = L.splitAt 16 bstr2 + (kb, _ ) = L.splitAt 16 bstr3 + -- FIXME: We should take a final DIGEST_LEN bytes here "for use in the + -- place of KH in the hidden service protocol." + keyf = throwCryptoError (cipherInit (L.toStrict kf)) + keyb = throwCryptoError (cipherInit (L.toStrict kb)) + encsf = initEncryptionState keyf + encsb = initEncryptionState keyb + fhash = hashUpdate hashInit (L.toStrict df) + bhash = hashUpdate hashInit (L.toStrict db) + +kdfRFC5869 :: ByteString -> L.ByteString +kdfRFC5869 kseed = L.fromChunks (map kn [1..250]) + where + kn i + | i < 1 = error "Internal error, kdfRFC5859" + | i == 1 = hmacSha256 kseed (m_expand `S.snoc` 1) + | otherwise = hmacSha256 kseed (S.concat [kn (i-1),m_expand,S.singleton i]) + +hmacSha256 :: (ByteArrayAccess key, ByteArray message, ByteArray res) => + key -> message -> res +hmacSha256 k m = convert res + where res = hmac k m :: HMAC SHA256 + +protoid, t_mac, t_key, t_verify, m_expand :: ByteString +protoid = S8.pack "ntor-curve25519-sha256-1" +t_mac = protoid `S.append` S8.pack ":mac" +t_key = protoid `S.append` S8.pack ":key_extract" +t_verify = protoid `S.append` S8.pack ":verify" +m_expand = protoid `S.append` S8.pack ":key_expand" + +-- ----------------------------------------------------------------------------- + +withMVar' :: MVar a -> (a -> b) -> IO b +withMVar' mv f = withMVar mv (return . f) + +modifyMVar' :: MVar a -> (a -> (a, b)) -> IO b +modifyMVar' mv f = modifyMVar mv (return . f) + +modifyMVar_' :: MVar a -> (a -> a) -> IO () +modifyMVar_' mv f = modifyMVar_ mv (return . f) diff --git a/src/Tor/DataFormat/Consensus.hs b/src/Tor/DataFormat/Consensus.hs new file mode 100644 --- /dev/null +++ b/src/Tor/DataFormat/Consensus.hs @@ -0,0 +1,290 @@ +{-# 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." diff --git a/src/Tor/DataFormat/DefaultDirectory.hs b/src/Tor/DataFormat/DefaultDirectory.hs new file mode 100644 --- /dev/null +++ b/src/Tor/DataFormat/DefaultDirectory.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- |Routines for parsing and rendering the default directories included in this +-- binary. +module Tor.DataFormat.DefaultDirectory( + DefaultDirectory(..) + , parseDefaultDirectory + ) + where + +import Data.Attoparsec.ByteString +import Data.ByteString(ByteString) +import Data.Word +import Tor.DataFormat.Helpers + +-- |A default directory for pulling consensus and other data. +data DefaultDirectory = DefaultDirectory { + ddirNickname :: String + , ddirIsBridge :: Bool + , ddirAddress :: String + , ddirOnionPort :: Word16 + , ddirDirPort :: Word16 + , ddirV3Ident :: Maybe ByteString + , ddirFingerprint :: ByteString + } + deriving (Show) + +-- FIXME: Make this handle partial input +-- |Parse a directory structure. +parseDefaultDirectory :: ByteString -> Either String DefaultDirectory +parseDefaultDirectory bstr = + case parse defaultDirectory bstr of + Fail _ _ err -> Left err + Partial _ -> Left "Incomplete default directory!" + Done _ res -> Right res + +defaultDirectory :: Parser DefaultDirectory +defaultDirectory = + do ddirNickname <- nickname + _ <- sp + _ <- string "orport=" + ddirOnionPort <- port False + _ <- sp + ddirV3Ident <- option Nothing $ do res <- v3Ident + _ <- sp + return (Just res) + ddirIsBridge <- option False $ do _ <- string "bridge " + return True + (ddirAddress, ddirDirPort) <- addrPort + ddirFingerprint <- fingerprint + return DefaultDirectory{..} + +v3Ident :: Parser ByteString +v3Ident = + do _ <- string "v3ident=" + hexDigest + +addrPort :: Parser (String, Word16) +addrPort = + do a <- ip4 + _ <- char8 ':' + p <- port False + return (a, p) + +fingerprint :: Parser ByteString +fingerprint = + do parts <- count 10 (sp >> toString `fmap` count 4 hexDigit) + return (readHex (concat parts)) + diff --git a/src/Tor/DataFormat/DirCertInfo.hs b/src/Tor/DataFormat/DirCertInfo.hs new file mode 100644 --- /dev/null +++ b/src/Tor/DataFormat/DirCertInfo.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- |Data formats for directory cert information. +module Tor.DataFormat.DirCertInfo( + DirectoryCertInfo(..) + , parseDirectoryCertInfo + ) + where + +import Control.Monad +import Crypto.Hash.Easy +import Crypto.PubKey.RSA +import Crypto.PubKey.RSA.PKCS15 +import Data.Attoparsec.ByteString +import Data.ByteString(ByteString) +import qualified Data.ByteString as BS +import Data.Hourglass +import Tor.DataFormat.Helpers + +-- |Information about a directory cert. +data DirectoryCertInfo = DirectoryCertInfo { + dcFingerprint :: ByteString + , dcPublished :: DateTime + , dcExpires :: DateTime + , dcIdentityKey :: PublicKey + , dcSigningKey :: PublicKey + , dcKeyCertification :: ByteString + } + deriving (Show) + +-- FIXME: Handle partial input +-- |Parse in a DirectoryCertInfo. +parseDirectoryCertInfo :: ByteString -> Either String DirectoryCertInfo +parseDirectoryCertInfo bstr = + case parse dirCertInfo bstr of + Fail bstr' _ err -> Left (err ++ "[" ++ show (BS.take 10 bstr') ++ "]") + Partial _ -> Left "Incomplete Directory cert info." + Done _ res -> + if verify noHash (dcIdentityKey res) digest (dcKeyCertification res) + then Right res + else Left "RSA verification failed." + where + digest = generateHash bstr + +generateHash :: ByteString -> ByteString +generateHash infile = sha1 (run infile) + where + run bstr = + case BS.span (/= 10) bstr of + (start, finale) | "\ndir-key-certification\n" `BS.isPrefixOf` finale -> + start `BS.append` "\ndir-key-certification\n" + (start, rest) -> + start `BS.append` (BS.singleton 10) `BS.append` run (BS.drop 1 rest) + +dirCertInfo :: Parser DirectoryCertInfo +dirCertInfo = + do _ <- string "dir-key-certificate-version 3\n" + dcFingerprint <- standardLine "fingerprint" hexDigest + dcPublished <- standardLine "dir-key-published" utcTime + dcExpires <- standardLine "dir-key-expires" utcTime + _ <- string "dir-identity-key\n" + (dcIdentityKey, idbstr) <- publicKey' + _ <- string "dir-signing-key\n" + dcSigningKey <- publicKey + _ <- string "dir-key-crosscert\n" + idsig <- signature + _ <- string "dir-key-certification\n" + dcKeyCertification <- signature + unless (verify noHash dcSigningKey (sha1 idbstr) idsig) $ + fail "RSA ID key verification failed." + return DirectoryCertInfo{..} + +signature :: Parser ByteString +signature = + do _ <- string "-----BEGIN " + _ <- option undefined $ string "ID " + _ <- string "SIGNATURE-----\n" + let end = string "-----END " + bstr <- decodeBase64 =<< manyTill base64Char end + _ <- option undefined $ string "ID " + _ <- string "SIGNATURE-----\n" + return bstr diff --git a/src/Tor/DataFormat/Helpers.hs b/src/Tor/DataFormat/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Tor/DataFormat/Helpers.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- |Miscellaneous very useful parsing routines. +module Tor.DataFormat.Helpers( + PortSpec(..) + , AddrSpec(..) + , standardLine + , nickname + , hexDigest + , port + , addrSpec + , portSpec + , ip4 + , ip6 + , publicKey, publicKey' + , utcTime + -- + , bool + , char8 + , alphaNum + , decDigit + , hexDigit + , base64Char + , decimalNum + , whitespace, whitespace1 + , sp + , nl, newline + -- + , toString + , readHex + , decodeBase64 + ) + where + +import Control.Applicative +import Crypto.PubKey.RSA +import Data.ASN1.BinaryEncoding +import Data.ASN1.Encoding +import Data.ASN1.Types +import Data.Attoparsec.ByteString +import Data.ByteString.Char8(pack) +import Data.ByteString.Base64 +import Data.ByteString(ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Char hiding (isHexDigit, isAlphaNum) +import Data.Hourglass +import Data.Word +import Tor.RouterDesc + +-- |Parse a standard line of " \n". +standardLine :: String -> Parser a -> Parser a +standardLine thing parser = + do _ <- string (pack thing) + _ <- sp + x <- parser + _ <- nl + return x + +-- |Parse a Tor nickname. +nickname :: Parser String +nickname = + do first <- alphaNum + toString <$> run 1 [first] + "nickname" + where + run :: Int -> [Word8] -> Parser [Word8] + run 20 acc = return (reverse acc) + run x acc = + do next <- option Nothing (Just <$> alphaNum) + case next of + Nothing -> return (reverse acc) + Just c -> run (x + 1) (c : acc) + +-- |Parse a 20 byte hex digest. +hexDigest :: Parser ByteString +hexDigest = (readHex . toString) <$> count 40 hexDigit + +-- |Parse a port specifier +portSpec :: Parser PortSpec +portSpec = choice [ allPorts, somePorts, onePort ] "portSpec" + where + allPorts = + do _ <- char8 '*' + return PortSpecAll + somePorts = + do p1 <- port False + _ <- char8 '-' + p2 <- port False + return (PortSpecRange p1 p2) + onePort = + do p <- port False + return (PortSpecSingle p) + +-- |Parse a port number. +port :: Bool -> Parser Word16 +port zeroOK = + do base <- toString <$> many1 decDigit + let result = read base :: Integer + if | (result >= 1) && (result <= 65535) -> return (fromIntegral result) + | zeroOK && result == 0 -> return 0 + | otherwise -> empty + "port" + +-- |Parse an address specifier. +addrSpec :: Parser AddrSpec +addrSpec = choice [ allAddrs, ip4Addrs, ip6Addrs ] + where + allAddrs = char8 '*' >> return AddrSpecAll + ip4Addrs = choice [ip4Mask, ip4Bits, ip4Single] + ip6Addrs = choice [ip6Bits, ip6Single] + ip4Mask = do a <- ip4 + _ <- char8 '/' + b <- ip4mask + return (AddrSpecIP4Mask a b) + ip4Bits = do a <- ip4 + _ <- char8 '/' + b <- num_ip4_bits + return (AddrSpecIP4Bits a b) + ip4Single = AddrSpecIP4 <$> ip4 + ip6Bits = do a <- ip6 + _ <- char8 '/' + b <- num_ip6_bits + return (AddrSpecIP6Bits a b) + ip6Single = AddrSpecIP6 <$> ip6 + -- + ip4mask = ip4 + -- + num_ip4_bits = decimalNum (<= 32) + num_ip6_bits = decimalNum (<= 128) + +-- |Parse an IPv4 address. +ip4 :: Parser String +ip4 = + do a <- decimalNum ip4num + _ <- char8 '.' + b <- decimalNum ip4num + _ <- char8 '.' + c <- decimalNum ip4num + _ <- char8 '.' + d <- decimalNum ip4num + return (show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d) + where + ip4num :: Int -> Bool + ip4num x = x < 256 + +-- |Parse an IPv6 address; assuming [0000:1111:....] format, with braces. +ip6 :: Parser String +ip6 = do + _ <- char8 '[' -- FIXME: This parser is terrible + a <- many1 (satisfy (\ x -> isHexDigit x || x == 58)) + _ <- char8 ']' + return (toString a) + +-- |Parse a public key. Returns both the public key and the raw data behind it. +publicKey' :: Parser (PublicKey, ByteString) +publicKey' = + do _ <- string "-----BEGIN RSA PUBLIC KEY-----\n" + let end = string "-----END RSA PUBLIC KEY-----\n" + bstr <- decodeBase64 =<< manyTill base64Char end + case decodeASN1' DER bstr of + Left _ -> empty + Right asn1 -> + case fromASN1' asn1 of + Left _ -> empty + Right x -> return (x, bstr) + where + fromASN1' (Start Sequence : IntVal n : IntVal e : End Sequence : _) = + Right (PublicKey { public_size = calculate_modulus n 1 + , public_n = n + , public_e = e + }) + fromASN1' _ = Left ("fromASN1: RSA PublicKey: unexpected format" :: String) + -- + calculate_modulus n i = + if (2 ^ (i * 8)) > n then i else calculate_modulus n (i + 1) + +-- |Parse a public key. +publicKey :: Parser PublicKey +publicKey = fst <$> publicKey' + +-- |Parse a timestamp in UTC format. +utcTime :: Parser DateTime +utcTime = + do dateYear <- toEnum' `fmap` count 4 decDigit + _ <- char8 '-' + dateMonth <- toEnum' `fmap` count 2 decDigit + _ <- char8 '-' + dateDay <- toEnum' `fmap` count 2 decDigit + _ <- char8 ' ' + todHour <- toEnum' `fmap` count 2 decDigit + _ <- char8 ':' + todMin <- toEnum' `fmap` count 2 decDigit + _ <- char8 ':' + todSec <- toEnum' `fmap` count 2 decDigit + let todNSec = 0 + dtDate = Date { .. } + dtTime = TimeOfDay { .. } + return DateTime{..} + where + toEnum' :: Enum a => [Word8] -> a + toEnum' = toEnum . read . BSC.unpack . BS.pack + +-- ---------------------------------------------------------------------------- + +-- |Parse a boolean. (0/1) +bool :: Parser Bool +bool = choice [ true, false ] + where + true = char8 '1' >> return True + false = char8 '0' >> return False + +-- |Parse a character. +char8 :: Char -> Parser Word8 +char8 c = word8 (fromIntegral (ord c)) + +-- |Parse an alphanumeric character. +alphaNum :: Parser Word8 +alphaNum = satisfy isAlphaNum + +isAlphaNum :: Word8 -> Bool +isAlphaNum = inClass (['A'..'Z']++['a'..'z']++['0'..'9']) + +-- |Parse a hex digit. +hexDigit :: Parser Word8 +hexDigit = satisfy isHexDigit + +isHexDigit :: Word8 -> Bool +isHexDigit = inClass (['0'..'9']++['a'..'f']++['A'..'F']) + +-- |Parse a decimal digit. +decDigit :: Parser Word8 +decDigit = satisfy isDecimalDigit + +isDecimalDigit :: Word8 -> Bool +isDecimalDigit = inClass ['0'..'9'] + +-- |Parse a character in a Base64 stream. +base64Char :: Parser Word8 +base64Char = satisfy isBase64Char + +isBase64Char :: Word8 -> Bool +isBase64Char x = isAlphaNum x || (x == 10) || inClass "/+=" x + +-- |Parse a decimal number that matches the given predicate. +decimalNum :: (Integral a, Read a) => (a -> Bool) -> Parser a +decimalNum isOK = + do n <- many1 decDigit + case reads (toString n) of + [(x, "")] | isOK x -> return x + _ -> empty + +-- |Eat up some whitespace. +whitespace :: Parser () +whitespace = many (satisfy (inClass " \t")) >> return () "whitespace" + +-- |Eat up at least one character of whitespace. +whitespace1 :: Parser () +whitespace1 = many1 (satisfy (inClass " \t")) >> return () + +-- |Eat some amount of whitespace and then a newline. +newline :: Parser () +newline = whitespace >> word8 10 >> return () + +-- |Read a space. +sp :: Parser Word8 +sp = char8 ' ' + +-- |Read a newline. +nl :: Parser Word8 +nl = char8 '\n' + +-- ---------------------------------------------------------------------------- + +-- |Convert a series of bytes into a character string. +toString :: [Word8] -> String +toString = map (chr . fromIntegral) + +-- |Read a hex number into a bytestring in the obvious way. +readHex :: String -> ByteString +readHex [] = BS.empty +readHex [_] = error "Attempted to readHex an odd-lengthed string." +readHex (a:b:rest) = + let x = fromIntegral ((digitToInt a * 16) + digitToInt b) + in BS.cons x (readHex rest) + +-- |Decode a series of characters as a Base64 stream. +decodeBase64 :: [Word8] -> Parser ByteString +decodeBase64 bytes = + case decode (BS.pack (filter (/= 10) bytes)) of + Left _ -> empty + Right res -> return res diff --git a/src/Tor/DataFormat/RelayCell.hs b/src/Tor/DataFormat/RelayCell.hs new file mode 100644 --- /dev/null +++ b/src/Tor/DataFormat/RelayCell.hs @@ -0,0 +1,509 @@ +-- |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." + + diff --git a/src/Tor/DataFormat/RouterDesc.hs b/src/Tor/DataFormat/RouterDesc.hs new file mode 100644 --- /dev/null +++ b/src/Tor/DataFormat/RouterDesc.hs @@ -0,0 +1,490 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +-- |Routines for parsing router descriptions from a directory listing. +module Tor.DataFormat.RouterDesc( + parseDirectory + ) + where + +import Control.Applicative +import Crypto.Hash.Easy +import qualified Crypto.PubKey.Curve25519 as Curve +import Crypto.PubKey.RSA.PKCS15 +import Data.Attoparsec.ByteString +import Data.ByteString(ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Hourglass +import Data.Map(Map) +import qualified Data.Map.Strict as Map +import Data.String +import Tor.DataFormat.Helpers +import Tor.RouterDesc + +-- FIXME: Accept partial input. +-- |Parse a directory listing full of router descriptions, returning, for each +-- entry, either a parse error or the parsed router description. +parseDirectory :: ByteString -> [Either String RouterDesc] +parseDirectory bstr = map parseChunk (chunkRouters bstr) + where + parseChunk (chunk, signedPortion) = + case parse parseRouterDesc chunk of + Partial f -> processParse signedPortion (f BS.empty) + x -> processParse signedPortion x + processParse _ (Fail _ _ _) = Left "Router description failed to parse." + processParse _ (Partial _) = Left "Partial data for router description." + processParse signedPortion (Done leftover res) | BS.null leftover = + let key = routerSigningKey res + sig = routerSignature res + body = sha1 signedPortion + -- Tor uses a weird variation on PKCS signing in which they don't + -- transmit the hash type + in if verify noHash key body sig + then Right res + else Left "RSA verification failed." + processParse _ _ = Left "Unconsumed input in router description." + +chunkRouters :: ByteString -> [(ByteString, ByteString)] +chunkRouters bstr = + case nextRouter bstr of + Nothing -> + [] + Just (routerHeader, routerAll, rest) -> + (routerAll, routerHeader) : chunkRouters rest + +nextRouter :: ByteString -> Maybe (ByteString, ByteString, ByteString) +nextRouter orig = goState1 orig 0 + where + goState1 bstr off = + case BSC.uncons bstr of + Nothing -> Nothing + Just ('r', rest) -> + let (start, possibleSig) = BSC.splitAt 17 bstr + in if BSC.unpack start == "router-signature\n" + then let mainDesc = BSC.take (off + 17) orig + in goState2 mainDesc (off + 17) possibleSig 0 + else goState1 rest (off + 1) + Just (_, rest) -> + goState1 rest (off + 1) + -- + goState2 :: ByteString -> Int -> ByteString -> Int -> + Maybe (ByteString, ByteString, ByteString) + goState2 mainDesc mainoff bstr off = + case BSC.uncons bstr of + Nothing -> + Just (mainDesc, orig, BS.empty) + Just ('r', rest) -> + let start = BS.take 7 bstr + in if BSC.unpack start == "router " + then let (ent, rest') = BSC.splitAt mainoff orig + in Just (mainDesc, ent, rest') + else goState2 mainDesc (mainoff + 1) rest (off + 1) + Just (_, rest) -> + goState2 mainDesc (mainoff + 1) rest (off + 1) + +-- ---------------------------------------------------------------------------- + +parseRouterDesc :: Parser RouterDesc +parseRouterDesc = + do initial <- routerStart + result <- runOptionals initial initialParseState + _ <- many newline + return result + where + runOptionals router state = + do let options = map (\ parserGen -> parserGen state router) + wrappedOptionParsers + (router', state', final) <- choice options + let router'' = checkFinalStates router' state' + if final + then return router'' + else runOptionals router' state' + +data ParseAmount = Never | AtMostOnce | ExactlyOnce | AnyNumber | EndsRouter + deriving (Eq, Show) + +initialParseState :: Map Int ParseAmount +initialParseState = Map.fromList (map (\ (a,b,_,_) -> (a,b)) routerDescOptions) + +type OptionParser = Map Int ParseAmount -> RouterDesc -> + Parser (RouterDesc, Map Int ParseAmount, Bool) + +wrappedOptionParsers :: [OptionParser] +wrappedOptionParsers = map addWrapper routerDescOptions + +addWrapper :: (Int, ParseAmount, String, RouterDesc -> Parser RouterDesc) -> + OptionParser +addWrapper (idx, _, oname, parser) state r = + do res <- parser r oname + case Map.lookup idx state of + Nothing -> + let res' = warn res ("Failed to look up option " ++ show idx) + in return (res', state, True) + -- Good cases + Just ExactlyOnce -> + let state' = Map.insert idx Never state + in return (res, state', False) + Just AtMostOnce -> + let state' = Map.insert idx Never state + in return (res, state', False) + Just AnyNumber -> + return (res, state, False) + Just EndsRouter -> + return (res, state, True) + -- Bad cases + Just Never -> + let res' = warn res ("Got multiple versions of option " ++ oname) + in return (res', state, False) + +checkFinalStates :: RouterDesc -> Map Int ParseAmount -> RouterDesc +checkFinalStates inr stateMap = checkMissing inr (Map.toList stateMap) + where + checkMissing r [] = r + checkMissing r ((idx, ExactlyOnce) : rest) = + let r' = warn r ("Missing field: " ++ getName idx routerDescOptions) + in checkMissing r' rest + checkMissing r (_ : rest) = + checkMissing r rest + -- + getName _ [] = "unkwnown field" + getName x ((y,_,n,_):rest) + | x == y = n + | otherwise = getName x rest + +-- ---------------------------------------------------------------------------- + +warn :: RouterDesc -> String -> RouterDesc +warn r msg = r{ routerParseLog = routerParseLog r ++ [msg] } + +-- ---------------------------------------------------------------------------- + +routerDescOptions :: [(Int, ParseAmount, String, RouterDesc -> Parser RouterDesc)] +routerDescOptions = [ + ( 0, ExactlyOnce, "bandwidth", bandwidth) + , ( 1, AtMostOnce, "platform", platform) + , ( 2, ExactlyOnce, "published", published) + , ( 3, AtMostOnce, "fingerprint", fingerprint) + , ( 4, AtMostOnce, "hibernating", hibernating) + , ( 5, AtMostOnce, "uptime", uptime) + , ( 6, ExactlyOnce, "onionKey", onionKey) + , ( 7, AtMostOnce, "ntorOnionKey", ntorOnionKey) + , ( 8, ExactlyOnce, "SigningKey", signingKey) + , ( 9, AnyNumber, "ExitRule", exitRule) + , (10, AtMostOnce, "ipv6Policy", ipv6Policy) + , (11, EndsRouter, "routerSignature", routerSig) + , (12, AtMostOnce, "contact", contactInfo) + , (13, AtMostOnce, "family", family) + , (14, AtMostOnce, "readHistory", readHistory) + , (15, AtMostOnce, "writeHistory", writeHistory) + , (16, AtMostOnce, "eventDNS", eventDNS) + , (17, AtMostOnce, "cachesExtraInfo", cachesExtraInfo) + , (18, AtMostOnce, "extraInfoDigest", extraInfoDigest) + , (19, AtMostOnce, "hiddenServiceDir", hiddenServiceDir) + , (20, AtMostOnce, "protocols", protocols) + , (21, AtMostOnce, "allowSingleHopExits",allowSingleHopExits) + , (22, AnyNumber, "orAddress", orAddress) + ] + + +routerStart :: Parser RouterDesc +routerStart = + do _ <- string "router" + _ <- whitespace + nick <- nickname + _ <- whitespace + addr <- ip4 + _ <- whitespace + orport <- port False + _ <- whitespace + socksport <- port True + _ <- whitespace + dirport <- port True + let dirport' = if dirport == 0 then Nothing else Just dirport + _ <- newline + let result = RouterDesc { + routerNickname = nick + , routerIPv4Address = addr + , routerORPort = orport + , routerDirPort = dirport' + , routerAvgBandwidth = 0 + , routerBurstBandwidth = 0 + , routerObservedBandwidth = 0 + , routerPlatformName = "" + , routerEntryPublished = timeFromElapsed (Elapsed 0) + , routerFingerprint = BS.empty + , routerHibernating = False + , routerUptime = Nothing + , routerOnionKey = error "No onion key!" + , routerNTorOnionKey = Nothing + , routerSigningKey = error "No signing key!" + , routerExitRules = [] + , routerIPv6Policy = Left [PortSpecRange 1 65535] + , routerSignature = BS.empty + , routerContact = Nothing + , routerFamily = [] + , routerReadHistory = Nothing + , routerWriteHistory = Nothing + , routerCachesExtraInfo = False + , routerExtraInfoDigest = Nothing + , routerHiddenServiceDir = Nothing + , routerLinkProtocolVersions = [] + , routerCircuitProtocolVersions = [] + , routerAllowSingleHopExits = False + , routerAlternateORAddresses = [] + , routerParseLog = [] + , routerStatus = [] + } + if socksport /= 0 + then return (warn result "RouterDesc incorrectly set nonzero SOCKS port.") + else return result + +bandwidth :: RouterDesc -> Parser RouterDesc +bandwidth r = + do _ <- string "bandwidth" + _ <- whitespace + avg <- decimalNum (const True) + _ <- whitespace + burst <- decimalNum (const True) + _ <- whitespace + obs <- decimalNum (const True) + _ <- newline + return r{ routerAvgBandwidth = avg + , routerBurstBandwidth = burst + , routerObservedBandwidth = obs } + +platform :: RouterDesc -> Parser RouterDesc +platform r = + do _ <- string "platform" + _ <- whitespace + ident <- toString <$> manyTill anyWord8 newline + return r{ routerPlatformName = ident } + +published :: RouterDesc -> Parser RouterDesc +published r = + do _ <- string "published" + _ <- whitespace + t <- utcTime + _ <- newline + return r{ routerEntryPublished = t } + +fingerprint :: RouterDesc -> Parser RouterDesc +fingerprint r = + do _ <- option "" (string "opt") + _ <- whitespace + _ <- string "fingerprint" + _ <- whitespace + fp <- sepBy1 (count 4 hexDigit) whitespace1 + _ <- newline + return r{ routerFingerprint = readHex (toString (concat fp)) } + +hibernating :: RouterDesc -> Parser RouterDesc +hibernating r = + do _ <- option "" (string "opt") + _ <- whitespace + _ <- string "hibernating" + _ <- whitespace + b <- bool + _ <- newline + return r{ routerHibernating = b } + +uptime :: RouterDesc -> Parser RouterDesc +uptime r = + do _ <- string "uptime" + _ <- whitespace + n <- decimalNum (const True) + _ <- newline + return r{ routerUptime = Just n } + +onionKey :: RouterDesc -> Parser RouterDesc +onionKey r = + do _ <- string "onion-key" + _ <- newline + k <- publicKey + return r{ routerOnionKey = k } + +ntorOnionKey :: RouterDesc -> Parser RouterDesc +ntorOnionKey r = + do _ <- string "ntor-onion-key" + _ <- whitespace + x <- decodeBase64 =<< manyTill base64Char newline + case Curve.publicKey x of + Left err -> fail ("Failure decoding curve25519 public key: " ++ err) + Right k -> return r{ routerNTorOnionKey = Just k } + +signingKey :: RouterDesc -> Parser RouterDesc +signingKey r = + do _ <- string "signing-key" + _ <- newline + k <- publicKey + return r{ routerSigningKey = k } + +exitRule :: RouterDesc -> Parser RouterDesc +exitRule r = + do builder <- accept <|> reject + _ <- whitespace + (a, p) <- exitPattern + _ <- newline + return r{ routerExitRules = routerExitRules r ++ [builder a p] } + where + accept = string "accept" >> return ExitRuleAccept + reject = string "reject" >> return ExitRuleReject + +ipv6Policy :: RouterDesc -> Parser RouterDesc +ipv6Policy r = + do _ <- string "ipv6-policy" + _ <- whitespace + b <- accept <|> reject + _ <- whitespace + l <- sepBy1 portSpec (char8 ',') + _ <- newline + return r{ routerIPv6Policy = b l } + where + accept = string "accept" >> return Right + reject = string "reject" >> return Left + +routerSig :: RouterDesc -> Parser RouterDesc +routerSig r = + do _ <- string "router-signature" + _ <- newline + _ <- string "-----BEGIN SIGNATURE-----\n" + let end = string "-----END SIGNATURE-----" + sig <- decodeBase64 =<< manyTill base64Char end + _ <- newline + return r{ routerSignature = sig } + +contactInfo :: RouterDesc -> Parser RouterDesc +contactInfo r = + do _ <- string "contact" + _ <- whitespace + l <- manyTill anyWord8 newline + return r{ routerContact = Just (toString l) } + +family :: RouterDesc -> Parser RouterDesc +family r = + do _ <- string "family" + _ <- whitespace + l <- sepBy1 familyDef whitespace + _ <- newline + return r{ routerFamily = l } + where + familyDef = digestWithName <|> digestWithoutName <|> nameWithoutDigest + digestWithName = + do _ <- char8 '$' + d <- hexDigest + _ <- char8 '=' + n <- nickname + return (NodeFamilyBoth n d) + digestWithoutName = + do _ <- char8 '$' + d <- hexDigest + return (NodeFamilyDigest d) + nameWithoutDigest = + do n <- nickname + return (NodeFamilyNickname n) + +readHistory :: RouterDesc -> Parser RouterDesc +readHistory r = + do rhist <- history "read-history" + return r{ routerReadHistory = Just rhist } + +writeHistory :: RouterDesc -> Parser RouterDesc +writeHistory r = + do whist <- history "write-history" + return r{ routerWriteHistory = Just whist } + +history :: String -> Parser (DateTime, Int, [Int]) +history kind = + do _ <- option "" (string "opt") + _ <- whitespace + _ <- string (fromString kind) + _ <- whitespace + t <- utcTime + _ <- whitespace + n <- decimalNum (const True) + _ <- whitespace + v <- sepBy1 (decimalNum (const True)) (char8 ',') + _ <- newline + return (t, n, v) + +eventDNS :: RouterDesc -> Parser RouterDesc +eventDNS r = + do _ <- string "eventdns" + _ <- whitespace + _ <- bool + _ <- newline + return (warn r "Router used obsolete 'eventdns' flag.") + +cachesExtraInfo :: RouterDesc -> Parser RouterDesc +cachesExtraInfo r = + do _ <- option "" (string "opt") + _ <- whitespace + _ <- string "caches-extra-info" + _ <- newline + return r{ routerCachesExtraInfo = True } + +extraInfoDigest :: RouterDesc -> Parser RouterDesc +extraInfoDigest r = + do _ <- option "" (string "opt") + _ <- whitespace + _ <- string "extra-info-digest" + _ <- whitespace + d <- toString <$> manyTill hexDigit newline + return r{ routerExtraInfoDigest = Just (readHex d) } + +hiddenServiceDir :: RouterDesc -> Parser RouterDesc +hiddenServiceDir r = + do _ <- option "" (string "opt") + _ <- whitespace + _ <- string "hidden-service-dir" + _ <- whitespace + v <- option 2 $ decimalNum (const True) + _ <- newline + return r{ routerHiddenServiceDir = Just v } + +protocols :: RouterDesc -> Parser RouterDesc +protocols r = + do _ <- option "" (string "opt") + _ <- whitespace + _ <- string "protocols" + _ <- whitespace + _ <- string "Link" + _ <- whitespace + l <- sepBy (decimalNum (const True)) whitespace1 + _ <- whitespace + _ <- string "Circuit" + _ <- whitespace + c <- sepBy (decimalNum (const True)) whitespace1 + _ <- newline + return r{ routerLinkProtocolVersions = l + , routerCircuitProtocolVersions = c } + +allowSingleHopExits :: RouterDesc -> Parser RouterDesc +allowSingleHopExits r = + do _ <- option "" (string "opt") + _ <- whitespace + _ <- string "allow-single-hop-exits" + _ <- newline + return r{ routerAllowSingleHopExits = True } + +orAddress :: RouterDesc -> Parser RouterDesc +orAddress r = + do _ <- option "" (string "opt") + _ <- whitespace + _ <- string "or-address" + _ <- whitespace + addr <- ip4 <|> ip6 + _ <- char8 ':' + pnum <- port False + _ <- newline + let prev = routerAlternateORAddresses r + return r{ routerAlternateORAddresses = prev ++ [(addr, pnum)] } + +-- ---------------------------------------------------------------------------- + +exitPattern :: Parser (AddrSpec, PortSpec) +exitPattern = + do a <- addrSpec + _ <- char8 ':' + p <- portSpec + return (a, p) + "exitPattern" diff --git a/src/Tor/DataFormat/TorAddress.hs b/src/Tor/DataFormat/TorAddress.hs new file mode 100644 --- /dev/null +++ b/src/Tor/DataFormat/TorAddress.hs @@ -0,0 +1,141 @@ +-- |Addresses within Tor. TODO/FIXME: Fix everything about this module. +module Tor.DataFormat.TorAddress( + TorAddress(..), putTorAddress, getTorAddress + , unTorAddress + , torAddressByteString + , ip4ToString, ip6ToString + , putIP4String, putIP6String + ) + where + +import Control.Monad +import Data.Bits +import Data.ByteString(ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Char8(pack,unpack) +import Data.ByteString.Lazy(toStrict) +import Data.Binary.Get +import Data.Binary.Put +import Data.List(intercalate) +import Data.Word +import Numeric + +-- |An abstract data type representing either an address or an address +-- processing error, used in a variety of Tor protocols. +data TorAddress = Hostname String -- ^A hostname, as usual. + | IP4 String -- ^An IP4 address, as 'a.b.c.d', in decimal + | IP6 String -- ^An IP6 adddress, as '[...]', in usual hex form + | TransientError String -- ^A transient error occurred when + -- performing some action. Try again. + | NontransientError String -- ^A non-transient error occurred + -- when performing some action. Do + -- not try again, or you will annoy + -- the dragon. + deriving (Eq, Ord, Show) + +-- |Turn a TorAddress into a string. Will result in an error for either of the +-- error options. +unTorAddress :: TorAddress -> String +unTorAddress (Hostname s) = s +unTorAddress (IP4 s) = s +unTorAddress (IP6 s) = s +unTorAddress _ = error "unTorAddress: invalid input." + +-- |Parse a TorAddress off the wire. +getTorAddress :: Get TorAddress +getTorAddress = + do atype <- getWord8 + len <- getWord8 + value <- getByteString (fromIntegral len) + case (atype, len) of + (0x00, _) -> return (Hostname (unpack value)) + (0x04, 4) -> return (IP4 (ip4ToString value)) + (0x04, _) -> return (TransientError "Bad length for IP4 address.") + (0x06, 16) -> return (IP6 (ip6ToString value)) + (0x06, _) -> return (TransientError "Bad length for IP6 address.") + (0xF0, _) -> return (TransientError "External transient error.") + (0xF1, _) -> return (NontransientError "External nontransient error.") + (_, _) -> return (NontransientError ("Unknown address type: " ++ show atype)) + +-- |Turn a 32-bit ByteString containing an IP4 address into the normal String +-- version of that IP4 address. +ip4ToString :: ByteString -> String +ip4ToString bstr = intercalate "." (map show (BS.unpack bstr)) + +-- |Turn a normal 128-bit ByteString containing an IP6 address into the normal +-- String version of that IP6 address. Recall that for Tor, the normal String +-- version is wrapped in square braces ([0000:11111:...]). +ip6ToString :: ByteString -> String +ip6ToString bstr = "[" ++ intercalate ":" (run (BS.unpack bstr)) ++ "]" + where + run :: [Word8] -> [String] + run [] = [] + run [_] = ["ERROR"] + run (a:b:rest) = + let a' = fromIntegral a :: Word16 + b' = fromIntegral b :: Word16 + v = (a' `shiftL` 8) .|. b' + in (showHex v "" : run rest) + +-- |A putter for TorAddresses. +putTorAddress :: TorAddress -> Put +putTorAddress (Hostname str) = + do putWord8 0x00 + let bstr = pack str + putWord8 (fromIntegral (BS.length bstr)) + putByteString bstr +putTorAddress (IP4 str) = + do putWord8 0x04 + putWord8 4 + putIP4String str +putTorAddress (IP6 str) = + do putWord8 0x06 + putWord8 16 + putIP6String str +putTorAddress (TransientError _) = + do putWord8 0xF0 + putWord8 0 +putTorAddress (NontransientError _) = + do putWord8 0xF1 + putWord8 0 + +-- |Given a normally-formatted IP4 String (a.b.c.d), turn that into a 32-bit +-- ByteString containing that IP address. +putIP4String :: String -> Put +putIP4String str = forM_ (unintercalate '.' str) (putWord8 . read) + +-- |Given a normally-formatted IP6 String ([aaaa:bbbb:...]), turn that into a +-- 128-bit ByteString containing that IP address. Note that this function does +-- not support IP6 address compression ([aaaa::bbbbb]), so this must be a +-- fully-expanded address. +putIP6String :: String -> Put +putIP6String str = + do let str' = unwrapIP6 str + forM_ (unintercalate ':' str') $ \ v -> + case readHex v of + [] -> fail "Couldn't read IP6 address component." + ((x,_):_) -> putWord16be x + +-- |Translate a TorAddress into a ByteString. +torAddressByteString :: TorAddress -> ByteString +torAddressByteString (IP4 x) = + toStrict (runPut (forM_ (unintercalate '.' x) (putWord8 . read))) +torAddressByteString (IP6 x) = + toStrict $ runPut $ forM_ (unintercalate ':' (unwrapIP6 x)) $ \ v -> + case readHex v of + [] -> fail "Couldn't read IP6 addr component." + ((w,_):_) -> putWord16be w +torAddressByteString _ = error "Can't turn error into bytestring." + +unintercalate :: Char -> String -> [String] +unintercalate _ "" = [] +unintercalate c str = + let (first, rest) = span (/= c) str + in first : (unintercalate c (drop 1 rest)) + +unwrapIP6 :: String -> String +unwrapIP6 ('[':rest) = + case reverse rest of + (']':rrest) -> reverse rrest + _ -> error ("IPv6 not in wrapped format (2): [" ++ rest) +unwrapIP6 x = error ("IPv6 not in wrapped format: " ++ x) diff --git a/src/Tor/DataFormat/TorCell.hs b/src/Tor/DataFormat/TorCell.hs new file mode 100644 --- /dev/null +++ b/src/Tor/DataFormat/TorCell.hs @@ -0,0 +1,372 @@ +{-# 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) + diff --git a/src/Tor/HybridCrypto.hs b/src/Tor/HybridCrypto.hs new file mode 100644 --- /dev/null +++ b/src/Tor/HybridCrypto.hs @@ -0,0 +1,67 @@ +-- |Tor defines a form of hybrid crypto, in which data is either just encrypted +-- with a public key, or, encrypted using a hybrid of RSA and AES. This module +-- implements this technique. +module Tor.HybridCrypto( + hybridEncrypt + , hybridDecrypt + ) + where + +import Crypto.Cipher.AES +import Crypto.Cipher.Types +import Crypto.Error +import Crypto.Hash.Algorithms +import Crypto.PubKey.MaskGenFunction +import Crypto.PubKey.RSA.OAEP +import Crypto.PubKey.RSA.Types +import Crypto.Random +import Data.ByteString +import Prelude hiding (length, splitAt) + +-- |Encrypt a piece of data using the given public key, optionally forcing the +-- routine to use hybrid encryption even if the size of the data doesn't warrant +-- it. +hybridEncrypt :: MonadRandom m => + Bool -> PublicKey -> ByteString -> + m ByteString +hybridEncrypt force pubkey m + | not force && (length m < (128 - 42)) = -- PK_ENC_LEN - PK_PAD_LEN + failLeft (encrypt oaepParams pubkey m) + | otherwise = + do -- Generate a KEY_LEN byte random key K; + kbs <- getRandomBytes 16 + -- let M1 = the first PK_ENC_LEN - PK_PAD_LEN - KEY_LEN bytes of M + -- and let M2 = the rest of M. + let (m1, m2) = splitAt (128 - 42 - 16) m + -- pad and encrypt K|M1 with PK + ekm1 <- failLeft (encrypt oaepParams pubkey (kbs `append` m1)) + -- encrypt M2 with our stream cipher, using the key K + let key = throwCryptoError (cipherInit kbs) :: AES128 + em2 = ctrCombine key nullIV m2 + return (ekm1 `append` em2) + +-- |Decrypt a piece of data using the given private key. +hybridDecrypt :: MonadRandom m => + PrivateKey -> ByteString -> + m ByteString +hybridDecrypt privKey em + | length em <= fromIntegral (private_size privKey) = + failLeft (decryptSafer oaepParams privKey em) + | otherwise = + do let (ekm1, em2) = splitAt (fromIntegral (private_size privKey)) em + km1 <- failLeft (decryptSafer oaepParams privKey ekm1) + let (kbs, m1) = splitAt 16 km1 + key = throwCryptoError (cipherInit kbs) :: AES128 + m2 = ctrCombine key nullIV em2 + return (m1 `append` m2) + +oaepParams :: OAEPParams SHA1 ByteString ByteString +oaepParams = OAEPParams SHA1 (mgf1 SHA1) Nothing + +failLeft :: (Show a, Monad m) => m (Either a b) -> m b +failLeft action = + do v <- action + case v of + Left err -> + fail ("Received unexpected left value (HybridCrypto): " ++ show err) + Right x -> return x diff --git a/src/Tor/Link.hs b/src/Tor/Link.hs new file mode 100644 --- /dev/null +++ b/src/Tor/Link.hs @@ -0,0 +1,737 @@ +-- |Low-level interface for establishing links between Tor nodes. +{-# LANGUAGE MultiWayIf #-} +module Tor.Link( + TorLink + , initLink + , acceptLink + , linkInitiatedRemotely + , linkRouterDesc + , linkRead + , linkWrite + , linkClose + , linkNewCircuitId + ) + where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Concurrent +import Control.Exception +import Control.Monad +import Crypto.Hash(SHA256) +import Crypto.Hash.Easy +import Crypto.MAC.HMAC(hmac,HMAC) +import Crypto.PubKey.RSA +import Crypto.PubKey.RSA.KeyHash +import Crypto.PubKey.RSA.PKCS15 +import Crypto.Random +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 qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Char8(pack) +import Data.Hourglass +import Data.Hourglass.Now +import Data.IORef +import Data.Map.Strict(Map) +import qualified Data.Map.Strict as Map +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif +import qualified Data.Serialize.Get as Cereal +import Data.Tuple(swap) +import Data.Word +import Data.X509 hiding (HashSHA1, HashSHA256) +import Data.X509.CertificateStore +import Network.TLS hiding (Credentials) +import qualified Network.TLS as TLS +import Tor.DataFormat.RelayCell +import Tor.DataFormat.TorAddress +import Tor.DataFormat.TorCell +import Tor.Link.CipherSuites +import Tor.Link.DH +import Tor.NetworkStack +import Tor.RNG +import Tor.RouterDesc +import Tor.State.Credentials +import Tor.State.Routers + +-- ----------------------------------------------------------------------------- + +-- |A direct link between us and another Tor node. +data TorLink = TorLink { + linkContext :: Context + -- FIXME: Should disallowing unknown nodes be an option? + -- |The RouterDesc associated with this link, if we have one. (It will + -- not always be possible to find incoming links in the database.) + , linkRouterDesc :: Maybe RouterDesc + -- |Whether the link was initiated here (False) or elsewhere (True) + , linkInitiatedRemotely :: Bool + , linkReaderThread :: ThreadId + , linkReadBuffers :: MVar (Map Word32 (Chan TorCell)) + } + +-- |Read the next incoming cell from the given circuit identifier on the given +-- link. This will throw an exception if the circuit has been appropriately +-- registered. +linkRead :: TorLink -> Word32 -> IO TorCell +linkRead link circ = + do chanMap <- readMVar (linkReadBuffers link) + case Map.lookup circ chanMap of + Nothing -> throwIO (userError ("Read from unknown circ " ++ show circ)) + Just chan -> readChan chan + +-- |Write a cell to the link. +linkWrite :: TorLink -> TorCell -> IO () +linkWrite link cell = sendData (linkContext link) (putCell cell) + +-- |Close the link +linkClose :: TorLink -> IO () +linkClose link = + do killThread (linkReaderThread link) + bye (linkContext link) + contextClose (linkContext link) + +-- |Create a direct link to the given tor node. note that this routine performs +-- some internal certificate checking, but you should verify that the +-- certificate you expected from the connection is what you expected it to be. +-- YOU SHOULD PROBABLY NOT USE THIS ROUTINE. Instead, use 'newLinkCircuit', +-- elsewhere. +initLink :: HasBackend s => + TorNetworkStack ls s -> + Credentials -> + MVar TorRNG -> + (String -> IO ()) -> + RouterDesc -> + IO TorLink +initLink ns creds rngMV llog them = + do now <- getCurrentTime + let validity = (now, now `timeAdd` mempty{ durationHours = 2 }) + (idCert, idKey) <- getSigningKey creds + (authPriv, authCert) <- modifyMVar rngMV + (return . genCertificate idKey validity) + llog ("Trying to connect to " ++ (routerIPv4Address them)) + msock <- connect ns (routerIPv4Address them) (routerORPort them) + case msock of + Nothing -> + throwIO (userError ("Could not create TLS connection to " ++ + show (routerIPv4Address them) ++ ":" ++ + show (routerORPort them))) + Just sock -> + do llog ("Just built connection with them.") + let tcreds = TLS.Credentials [((CertificateChain [authCert,idCert]), + PrivKeyRSA authPriv)] + serverCertsIO <- newIORef (CertificateChain []) + tls <- contextNew sock (clientTLSOpts "FIXME" tcreds serverCertsIO) + handshake tls + -- send out our initial message + let vers = putCell Versions + sendData tls vers + -- get their initial message + serverCerts <- readIORef serverCertsIO + (r2i, left, rLink, rCert, myAddr) <- getRespInitialMsgs tls serverCerts + myAddrs' <- addNewAddresses creds myAddr + -- build and send the CERTS message + let certs = putCell (Certs [RSA1024Identity idCert, + RSA1024Auth authCert]) + sendData tls certs + -- build and send the AUTHENTICATE message + let i2r = BSL.toStrict (vers `BSL.append` certs) + idCert' = signedObject (getSigned idCert) + hdr <- authMessageHeader tls idCert' rCert r2i i2r rLink + rand <- modifyMVar rngMV (return . swap . randomBytesGenerate 24) + let signedBit = hdr `BS.append` rand + Right sig <- signSafer noHash authPriv (sha256 signedBit) + let msg = signedBit `BS.append` sig + sendData tls $ putCell (Authenticate msg) + -- finally, build and send the NETINFO message + let ni = NetInfo (fromElapsed (timeGetElapsed now)) + (IP4 (routerIPv4Address them)) myAddrs' + sendData tls (putCell ni) + -- ... and return the link pointer + llog ("Created new link to " ++ routerIPv4Address them ++ + if null (routerNickname them) then "" else + (" (" ++ show (routerNickname them) ++ ")")) + bufCh <- newMVar Map.empty + thr <- forkIO (runLink llog bufCh tls [left]) + return (TorLink tls (Just them) False thr bufCh) + +runLink :: (String -> IO ()) -> MVar (Map Word32 (Chan TorCell)) -> + Context -> [ByteString] -> + IO () +runLink llog rChansMV context initialBS = + catch (run initialState initialBS) logException + where + logException :: SomeException -> IO () + logException e + | Just ThreadKilled <- fromException e = return () + | otherwise = llog ("Exception raised running link: " ++ show e) + -- + initialState = runGetIncremental getTorCell + -- + run x bstrs = + case x of + Fail _ _ e -> llog ("Error reading link: " ++ e) + Partial next -> + case bstrs of + [] -> recvData context >>= (\ b -> run x [b]) + (f:rest) -> run (next (Just f)) rest + Done r1 _ c -> process c >> run initialState (r1:bstrs) + -- + process x = + case x of + -- Section #1: Requests to create new circuits. + Create _ _ -> sendUpProtocol 0 x + CreateFast _ _ -> sendUpProtocol 0 x + Create2 _ _ _ -> sendUpProtocol 0 x + -- Section #2: Responses to us, or relay packets, to be passed + -- on to a higher layer. + Created circId _ -> sendUpProtocol circId x + CreatedFast circId _ _ -> sendUpProtocol circId x + Created2 circId _ -> sendUpProtocol circId x + Destroy circId _ -> sendUpProtocol circId x + Relay circId _ -> sendUpProtocol circId x + RelayEarly circId _ -> sendUpProtocol circId x + -- Section #3: Padding, which we should ignore + Padding -> return () + VPadding _ -> return () + -- Section #4: Everything else ... none of which we should + -- get here. + _ -> llog ("Spurious cell read on link.") + -- + sendUpProtocol circId x = + do rmap <- readMVar rChansMV + case Map.lookup circId rmap of + Nothing -> llog ("Received cell to unknown circuit " ++ show circId) + Just c -> writeChan c x + +-- ----------------------------------------------------------------------------- + +-- |Generate a random new circuit id for a link. +linkNewCircuitId :: DRG g => + TorLink -> g -> + IO (g, Word32) +linkNewCircuitId link rng = modifyMVar (linkReadBuffers link) (find rng) + where + find g rtable = + do let (rv, g') = withRandomBytes g 4 (Cereal.runGet Cereal.getWord32host) + v = either (const 0) id rv + v' | linkInitiatedRemotely link = clearBit v 31 + | otherwise = setBit v 31 + if (v' == 0) || Map.member (fromIntegral v') rtable + then find g' rtable + else do rChan <- newChan + return (Map.insert (fromIntegral v') rChan rtable, (g', v')) + +-- ----------------------------------------------------------------------------- + +getRespInitialMsgs :: Context -> CertificateChain -> + IO (ByteString, ByteString, + SignedCertificate, Certificate, + TorAddress) +getRespInitialMsgs tls (CertificateChain tlsCerts) = + do cells <- getBaseCells baseDecodeStart BS.empty BS.empty + let (bstr, left, Certs cs, AuthChallenge _ methods) = cells + unless (1 `elem` methods) $ fail "No supported auth challenge method." + -- "To authenticate the responder, the initiator MUST check the following: + -- * The CERTS cell contains exactly one CertType 1 'Link' certificate + let linkCert = exactlyOneLink cs Nothing + linkCert' = signedObject (getSigned linkCert) + -- * The CERTS cell contains exactly one CertType 2 'Id' certificate + let idCert = exactlyOneId cs Nothing + idCert' = signedObject (getSigned idCert) + -- * Both certificates have validAfter and validUntil dates that + -- are not expired. + now <- getCurrentTime + when (certExpired linkCert' now) $ fail "Link certificate expired." + when (certExpired idCert' now) $ fail "Identity certificate expired." + -- * The certified key in the Link certificate matches the link key + -- that was used to negotiate the TLS connection. + unless (linkCert `elem` tlsCerts) $ fail "Link certificated different?" + -- * The certified key in the ID certificate is a 1024-bit RSA key + unless (is1024BitRSAKey idCert) $ fail "Bad identity certificate type." + -- * The certified key in the ID certificate was used to sign both + -- certificates. + -- * The link certificate is correctly signed with the key in the ID + -- certificate. + -- * The ID certificate is correctly self-signed. + unless (linkCert `isSignedBy` idCert') $ fail "Bad link cert signature." + unless (idCert `isSignedBy` idCert') $ fail "Bad identity cert signature." + -- Checking these conditions is sufficient to authenticate that the + -- initiator is talking to the Tor node with the expected identity, as + -- certified in the ID certificate." -- tor-spec, 4.2 + (left', NetInfo _ myAddr _) <- getNetInfoCellBit (netinfoDecodeStart left) + return (bstr, left', linkCert, idCert', myAddr) + where + baseDecodeStart = runGetIncremental getResponderStart + getBaseCells getter lastBS acc = + case getter of + Fail _ _ str -> + fail str + Done _ i (a,b) -> + do let (accchunk, leftover) = BS.splitAt (fromIntegral i) lastBS + return (acc `BS.append` accchunk, leftover, a, b) + Partial next -> + do b <- recvData tls + let getter' = next (Just b) + getBaseCells getter' b (acc `BS.append` lastBS) + -- + netinfoDecodeStart l = + case runGetIncremental getNetInfoCell of + f@(Fail _ _ _) -> f + d@(Done _ _ _) -> d + Partial next -> next (Just l) + getNetInfoCellBit getter = + case getter of + Fail _ _ str -> + fail str + Done leftover _ x -> + return (leftover, x) + Partial next -> + do b <- recvData tls + let getter' = next (Just b) + getNetInfoCellBit getter' + +getResponderStart :: Get (TorCell, TorCell) +getResponderStart = + do _ <- getWord16be + c <- getWord8 + case c of + 132 -> -- AUTHORIZE; ignored + do l <- fromIntegral <$> getWord16be + _ <- getLazyByteString l + getResponderStart + 128 -> -- VPADDING; ignored + do l <- fromIntegral <$> getWord16be + _ <- getLazyByteString l + getResponderStart + 7 -> -- VERSIONS; yay! + do l <- fromIntegral <$> getWord16be + vs <- replicateM (l `div` 2) getWord16be + unless (4 `elem` vs) $ fail "Couldn't negotiate a common version." + run Nothing Nothing + _ -> -- something else; fail + fail "Unacceptable initial cell from responder." + where + run (Just a) (Just b) = return (a, b) + run ma mb = + do cell <- getTorCell + case cell of + Padding -> run ma mb + VPadding _ -> run ma mb + Certs _ -> run (Just cell) mb + AuthChallenge _ _ -> run ma (Just cell) + _ -> fail "Weird cell in initial response." + +getNetInfoCell :: Get TorCell +getNetInfoCell = + do cell <- getTorCell + case cell of + Padding -> getNetInfoCell + VPadding _ -> getNetInfoCell + NetInfo _ _ _ -> return cell + _ -> fail "Unexpected cell in getNetInfoCell." + +authMessageHeader :: Context -> + Certificate -> Certificate -> + ByteString -> ByteString -> + SignedCertificate -> + IO ByteString +authMessageHeader tls iIdent rIdent r2i i2r rLink = + do let atype = pack "AUTH0001" + cid = keyHash sha256 iIdent + sid = keyHash sha256 rIdent + slog = sha256 r2i + clog = sha256 i2r + scert = sha256 (encodeSignedObject rLink) + ctxt <- nothingError <$> contextGetInformation tls + let cRandom = unClientRandom (nothingError (infoClientRandom ctxt)) + sRandom = unServerRandom (nothingError (infoServerRandom ctxt)) + masterSecret = nothingError (infoMasterSecret ctxt) + let ccert = pack "Tor V3 handshake TLS cross-certification\0" + blob = BS.concat [convert cRandom, convert sRandom, ccert] + tlssecrets = convert (hmac masterSecret blob :: HMAC SHA256) + return (BS.concat [atype, cid, sid, slog, clog, scert, tlssecrets]) + where + nothingError Nothing = error "Failure to generate authentication secrets." + nothingError (Just a) = a + +putCell :: TorCell -> BSL.ByteString +putCell = runPut . putTorCell + +genCertificate :: DRG g => + PrivKey -> (DateTime, DateTime) -> g -> + (g, (PrivateKey, SignedCertificate)) +genCertificate signer valids g = (g', (priv, cert)) + where + (pub, priv, g') = generateKeyPair g 1024 + cert = createCertificate (PubKeyRSA pub) signer 998 "auth" valids + +clientTLSOpts :: String -> TLS.Credentials -> + IORef CertificateChain -> + ClientParams +clientTLSOpts target creds ccio = ClientParams { + clientUseMaxFragmentLength = Nothing + , clientServerIdentification = (target, mempty) + , clientUseServerNameIndication = False + , clientWantSessionResume = Nothing + , clientShared = Shared { + sharedCredentials = creds + , sharedSessionManager = noSessionManager + , sharedCAStore = makeCertificateStore [] + , sharedValidationCache = exceptionValidationCache [] + } + , clientHooks = ClientHooks { + onCertificateRequest = const (return (getRealCreds creds)) + , onNPNServerSuggest = Nothing + , onServerCertificate = \ _ _ _ cc -> + do writeIORef ccio cc + return [] -- FIXME???? + , onSuggestALPN = return Nothing + } + , clientSupported = Supported { + supportedVersions = [TLS10,TLS11,TLS12] + , supportedCiphers = [suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA, + suiteTLS_DHE_RSA_WITH_AES_128_CBC_SHA, + suiteTLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA, + suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA256] + , supportedCompressions = [nullCompression] + , supportedHashSignatures = [(HashSHA1, SignatureRSA), + (HashSHA256, SignatureRSA)] + , supportedSecureRenegotiation = True + , supportedSession = False + , supportedFallbackScsv = True + , supportedClientInitiatedRenegotiation = True + } + } + where + getRealCreds (TLS.Credentials []) = Nothing + getRealCreds (TLS.Credentials (a:_)) = Just a + +is1024BitRSAKey :: SignedCertificate -> Bool +is1024BitRSAKey cert = + case certPubKey (signedObject (getSigned cert)) of + PubKeyRSA pk -> public_size pk == 128 + _ -> False + +certExpired :: Certificate -> DateTime -> Bool +certExpired cert t = (aft > t) || (t > unt) + where (aft, unt) = certValidity cert + +fromElapsed :: Integral t => Elapsed -> t +fromElapsed (Elapsed secs) = fromIntegral secs + +exactlyOneId :: [TorCert] -> Maybe SignedCertificate -> SignedCertificate +exactlyOneId [] Nothing = error "Not enough id certs." +exactlyOneId [] (Just x) = x +exactlyOneId ((RSA1024Identity _):_) (Just _) = error "Too many id certs." +exactlyOneId ((RSA1024Identity c):rest) Nothing = exactlyOneId rest (Just c) +exactlyOneId (_:rest) acc = exactlyOneId rest acc + +exactlyOneLink :: [TorCert] -> Maybe SignedCertificate -> SignedCertificate +exactlyOneLink [] Nothing = error "Not enough link certs." +exactlyOneLink [] (Just x) = x +exactlyOneLink ((LinkKeyCert _):_) (Just _) = error "Too many link certs." +exactlyOneLink ((LinkKeyCert c):rest) Nothing = exactlyOneLink rest (Just c) +exactlyOneLink (_:rest) acc = exactlyOneLink rest acc + +-- |Given an incoming socket, accept a formal Tor link from the incoming party. +-- Or throw an error. Whatever. +acceptLink :: HasBackend s => + Credentials -> RouterDB -> MVar TorRNG -> (String -> IO ()) -> + s -> TorAddress -> + IO TorLink +acceptLink creds routerDB rngMV llog sock who = + do now <- getCurrentTime + let validity = (now, now `timeAdd` mempty{ durationHours = 2 }) + (idCert, idKey) <- getSigningKey creds + let idCert' = signedObject (getSigned idCert) + (linkPriv, linkCert) <- modifyMVar rngMV + (return . genCertificate idKey validity) + let tcreds = TLS.Credentials [(CertificateChain [linkCert, idCert], + PrivKeyRSA linkPriv)] + tls <- contextNew sock (serverTLSOpts tcreds) + (versions, iversstr) <- getVersions tls + unless (4 `elem` versions) $ fail "Link doesn't support version 4." + -- "The responder sends a VERSIONS cell, ..." + let versstr = putCell Versions + sendData tls versstr + -- "... a CERTS cell (4.2 below) to give the initiator the certificates + -- it needs to learn the responder's identity, ..." + let certsbstr = putCell (Certs [RSA1024Identity idCert, + LinkKeyCert linkCert]) + + sendData tls certsbstr + -- "... an AUTH_CHALLENGE cell (4.3) that the initiator must include as + -- part of its answer if it chooses to authenticate, ..." + chalBStr <- modifyMVar rngMV (return . swap . randomBytesGenerate 32) + let authcbstr = putCell (AuthChallenge chalBStr [1]) + sendData tls authcbstr + -- "... and a NETINFO cell (4.5) " + others <- getAddresses creds + epochsec <- (fromElapsed . timeGetElapsed) <$> getCurrentTime + sendData tls (putCell (NetInfo epochsec who others)) + -- "At this point the initiator may send a NETINFO cell if it does not + -- wish to authenticate, or a CERTS cell, an AUTHENTICATE cell, and a + -- NETINFO cell if it does." + (iresp, leftOver) <- getInitiatorInfo tls + case iresp of + Left _ -> + fail "Initiator chose not to authenticate." + Right (Certs certs, Authenticate amsg, NetInfo _ _ _) -> + do -- "To authenticate the initiator, the responder MUST check the + -- following: + -- * The CERTS cell contains exactly one CerType 3 'AUTH' + -- certificate. + let authCert = exactlyOneAuth certs Nothing + authCert' = signedObject (getSigned authCert) + -- * The CERTS cell contains exactly one CerType 2 'ID' + -- certificate + let iidCert = exactlyOneId certs Nothing + iidCert' = signedObject (getSigned iidCert) + -- * Both certificates have validAfter and validUntil dates + -- that are not expired. + when (certExpired authCert' now) $ fail "Auth certificate expired." + when (certExpired iidCert' now) $ fail "Id certificate expired." + -- * The certified key in the AUTH certificate is a 1024-bit RSA + -- key. + unless (is1024BitRSAKey authCert) $ + fail "Auth certificate key is the wrong size." + -- * The certified key in the ID certificate is a 1024-bit RSA + -- key. + unless (is1024BitRSAKey iidCert) $ + fail "Identity certificate key is the wrong size." + -- * The auth certificate is correctly signed with the key in the + -- ID certificate. + unless (authCert `isSignedBy` iidCert') $ + fail "Auth certificate not signed by identity cert." + -- * The ID certificate is correctly self-signed." + unless (iidCert `isSignedBy` iidCert') $ + fail "Identity cert incorrectly self-signed." + -- Checking these conditions is NOT sufficient to authenticate that + -- the initiator has the ID it claims; to do so, the cells in 4.3 + -- [ACW: AUTH_CHALLENGE, send by us] and 4.4 [ACW: AUTHENTICATE, + -- processed next] below must be exchanged." - tor-spec, Section 4.2 + -- If AuthType is 1 (meaning 'RSA-SHA256-TLSSecret'), then the + -- Authentication contains the following: + -- TYPE: The characters 'AUTH0001' [8 octets] + let (auth0001, rest1) = BS.splitAt 8 amsg + unless (auth0001 == (pack "AUTH0001")) $ + fail "Bad type in AUTHENTICATE cell." + -- CID: A SHA256 hash of the initiator's RSA1024 identity key + -- [32 octets] + let (cid, rest2) = BS.splitAt 32 rest1 + unless (cid == keyHash sha256 iidCert') $ + fail "Bad initiator key hash in AUTHENTICATE cell." + -- SID: A SHA256 hash of the responder's RSA1024 identity key + -- [32 octets] + let (sid, rest3) = BS.splitAt 32 rest2 + unless (sid == keyHash sha256 idCert') $ + fail "Bad responder key hash in AUTHENTICATE cell." + -- SLOG: A SHA256 hash of all bytes sent from the responder to + -- the initiator as part of the negotiation up to and + -- including the AUTH_CHALLENGE cell; that is, the + -- VERSIONS cell, the CERTS cell, the AUTH_CHALLENGE + -- cell, and any padding cells. [32 octets] + let (slog, rest4) = BS.splitAt 32 rest3 + r2i = BSL.concat [versstr, certsbstr, authcbstr] + unless (slog == sha256 (BSL.toStrict r2i)) $ + fail "Bad hash of responder log in AUTHENTICATE cell." + -- CLOG: A SHA256 hash of all bytes sent from the initiator to + -- the responder as part of the negotiation so far; that is + -- the VERSIONS cell and the CERTS cell and any padding + -- cells. [32 octets] + let (clog, rest5) = BS.splitAt 32 rest4 + i2r = iversstr `BSL.append` putCell (Certs certs) + unless (clog == sha256 (BSL.toStrict i2r)) $ + fail "Bad hash of initiator log in AUTHENTICATE cell." + -- SCERT: A SHA256 hash of the responder's TLS link certificate. + -- [32 octets] + let (scert, rest6) = BS.splitAt 32 rest5 + linkCertBStr = encodeSignedObject linkCert + unless (scert == sha256 linkCertBStr) $ + fail "Bad hash of my link cert in AUTHENTICATE cell." + -- TLSSECRETS: A SHA256 HMAC, using the TLS master secret as the + -- secret key, of the following: + -- - client_random, as sent in the TLS Client Hello + -- - server_random, as sent in the TLS Server Hello + -- - the NUL terminated ASCII string: + -- "Tor V3 handshake TLS cross-certificate" + -- [32 octets] + let (tlssecrets, rest7) = BS.splitAt 32 rest6 + ctxt <- nothingError <$> contextGetInformation tls + let cRandom = unClientRandom (nothingError (infoClientRandom ctxt)) + sRandom = unServerRandom (nothingError (infoServerRandom ctxt)) + masterSecret = nothingError (infoMasterSecret ctxt) + let ccert = pack "Tor V3 handshake TLS cross-certification\0" + blob = BS.concat [cRandom, sRandom, ccert] + tlssecrets' = convert (hmac masterSecret blob :: HMAC SHA256) + unless (tlssecrets == tlssecrets') $ + fail "TLS secret mismatch in AUTHENTICATE cell." + -- RAND: A 24 byte value, randomly chosen by the initiator + let (rand, sig) = BS.splitAt 24 rest7 + -- SIG: A signature of a SHA256 hash of all the previous fields + -- using the initiator's "Authenticate" key as presented. + let msg = BS.concat [auth0001, cid, sid, slog, clog, scert, + tlssecrets, rand] + hash = sha256 msg + PubKeyRSA pub = certPubKey authCert' + res = verify noHash pub hash sig + unless res $ + fail "Signature verification failure in AUTHENITCATE cell." + -- + controlChan <- newChan + bufCh <- newMVar (Map.singleton 0 controlChan) + thr <- forkIO (runLink llog bufCh tls [leftOver]) + desc <- findRouter routerDB [ExtendDigest cid] + llog ("Incoming link created from " ++ show who) + return (TorLink tls desc True thr bufCh) + Right (_, _, _) -> + fail "Internal error getting initiator data." + where + nothingError :: Maybe a -> a + nothingError Nothing = error "Couldn't fetch TLS secrets." + nothingError (Just x) = x + +serverTLSOpts :: TLS.Credentials -> ServerParams +serverTLSOpts creds = ServerParams { + serverWantClientCert = False + , serverCACertificates = signedCerts + , serverDHEParams = Just oakley2 + , serverShared = Shared { + sharedCredentials = creds + , sharedSessionManager = noSessionManager + , sharedCAStore = makeCertificateStore [] + , sharedValidationCache = exceptionValidationCache [] + } + , serverHooks = ServerHooks { + onClientCertificate = const (return CertificateUsageAccept) -- FIXME? + , onUnverifiedClientCert = return True -- FIXME? + , onCipherChoosing = chooseTorCipher + , onSuggestNextProtocols = return Nothing + , onNewHandshake = \ _ -> return True -- FIXME? + , onALPNClientSuggest = Nothing + } + , serverSupported = Supported { + supportedVersions = [TLS12] + , supportedCiphers = [suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA, + suiteTLS_DHE_RSA_WITH_AES_128_CBC_SHA, + suiteTLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA, + suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA256] + , supportedCompressions = [nullCompression] + , supportedHashSignatures = [(HashSHA1, SignatureRSA), + (HashSHA256, SignatureRSA)] + , supportedSecureRenegotiation = True + , supportedSession = False + , supportedFallbackScsv = True + , supportedClientInitiatedRenegotiation = True + } + } + where + TLS.Credentials innerCreds = creds + certChains = map fst innerCreds + signedCerts = concatMap (\ (CertificateChain x) -> x) certChains + +chooseTorCipher :: Version -> [Cipher] -> Cipher +chooseTorCipher _ ciphers + | ciphers `isEquivList` fixedCipherList = + suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA + | isV2PlusCipherSet ciphers = + suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA + | otherwise = + error "Unacceptable cipher list provided by client." + +isEquivList :: Eq a => [a] -> [a] -> Bool +isEquivList xs ys = (length xs == length ys) && and (map (`elem` ys) xs) + +isV2PlusCipherSet :: [Cipher] -> Bool +isV2PlusCipherSet suites = + -- FIXME: This is wrong, as the last test should be "and there's another + -- one that isn't one of those three" + (suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA `elem` suites) && + (suiteTLS_DHE_RSA_WITH_AES_128_CBC_SHA `elem` suites) && + (suiteTLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA `elem` suites) && + (length suites > 3) + +fixedCipherList :: [Cipher] +fixedCipherList = [ + suiteTLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA + , suiteTLS_ECDHE_RSA_WITH_AES_256_CBC_SHA + , suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA + , suiteTLS_DHE_DSS_WITH_AES_256_CBC_SHA + , suiteTLS_ECDH_RSA_WITH_AES_256_CBC_SHA + , suiteTLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA + , suiteTLS_RSA_WITH_AES_256_CBC_SHA + , suiteTLS_ECDHE_ECDSA_WITH_RC4_128_SHA + , suiteTLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA + , suiteTLS_ECDHE_RSA_WITH_RC4_128_SHA + , suiteTLS_ECDHE_RSA_WITH_AES_128_CBC_SHA + , suiteTLS_DHE_RSA_WITH_AES_128_CBC_SHA + , suiteTLS_DHE_DSS_WITH_AES_128_CBC_SHA + , suiteTLS_ECDH_RSA_WITH_RC4_128_SHA + , suiteTLS_ECDH_RSA_WITH_AES_128_CBC_SHA + , suiteTLS_ECDH_ECDSA_WITH_RC4_128_SHA + , suiteTLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA + , suiteTLS_RSA_WITH_RC4_128_MD5 + , suiteTLS_RSA_WITH_RC4_128_SHA + , suiteTLS_RSA_WITH_AES_128_CBC_SHA + , suiteTLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA + , suiteTLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA + , suiteSSL3_EDH_RSA_DES_192_CBC3_SHA + , suiteSSL3_EDH_DSS_DES_192_CBC3_SHA + , suiteTLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA + , suiteTLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA + , suiteSSL3_RSA_FIPS_WITH_3DES_EDE_CBC_SHA + , suiteTLS_RSA_WITH_3DES_EDE_CBC_SHA + ] + +-- ----------------------------------------------------------------------------- + +getVersions :: Context -> IO ([Word16], BSL.ByteString) +getVersions tls = + do bstr <- BSL.fromStrict <$> recvData tls + return (runGet getVersions' bstr, bstr) + where + getVersions' = + do _ <- getWord16be + cmd <- getWord8 + unless (cmd == 7) $ fail "Versions command /= 7" + len <- getWord16be + replicateM (fromIntegral len `div` 2) getWord16be + +getInitiatorInfo :: Context -> + IO (Either TorCell (TorCell,TorCell,TorCell), ByteString) +getInitiatorInfo tls = getCells base + where + getCells (Fail _ _ str) = fail str + getCells (Done rest _ x) = return (x, rest) + getCells (Partial f) = + do next <- recvData tls + getCells (f (Just next)) + -- + base = runGetIncremental (run Nothing Nothing Nothing) + -- + run (Just a) (Just b) (Just c) = return (Right (a, b, c)) + run ma mb mc = + do cell <- getTorCell + case cell of + Padding -> run ma mb mc + VPadding _ -> run ma mb mc + NetInfo _ _ _ + | (ma == Nothing) && (mb == Nothing) -> return (Left cell) + | otherwise -> run ma mb (Just cell) + Certs _ -> run (Just cell) mb mc + Authenticate _ -> run ma (Just cell) mc + _ -> + fail "Weird cell in initiator response." + +exactlyOneAuth :: [TorCert] -> Maybe SignedCertificate -> SignedCertificate +exactlyOneAuth [] Nothing = error "Not enough auth certs." +exactlyOneAuth [] (Just x) = x +exactlyOneAuth ((RSA1024Auth _):_) (Just _) = error "Too many auth certs." +exactlyOneAuth ((RSA1024Auth c):rest) Nothing = exactlyOneAuth rest (Just c) +exactlyOneAuth (_:rest) acc = exactlyOneAuth rest acc diff --git a/src/Tor/Link/CipherSuites.hs b/src/Tor/Link/CipherSuites.hs new file mode 100644 --- /dev/null +++ b/src/Tor/Link/CipherSuites.hs @@ -0,0 +1,457 @@ +-- |Useful TLS ciphersuites for running Tor. +module Tor.Link.CipherSuites( + suiteTLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA + , suiteTLS_ECDHE_RSA_WITH_AES_256_CBC_SHA + , suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA + , suiteTLS_DHE_DSS_WITH_AES_256_CBC_SHA + , suiteTLS_ECDH_RSA_WITH_AES_256_CBC_SHA + , suiteTLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA + , suiteTLS_RSA_WITH_AES_256_CBC_SHA + , suiteTLS_ECDHE_ECDSA_WITH_RC4_128_SHA + , suiteTLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA + , suiteTLS_ECDHE_RSA_WITH_RC4_128_SHA + , suiteTLS_ECDHE_RSA_WITH_AES_128_CBC_SHA + , suiteTLS_DHE_RSA_WITH_AES_128_CBC_SHA + , suiteTLS_DHE_DSS_WITH_AES_128_CBC_SHA + , suiteTLS_ECDH_RSA_WITH_RC4_128_SHA + , suiteTLS_ECDH_RSA_WITH_AES_128_CBC_SHA + , suiteTLS_ECDH_ECDSA_WITH_RC4_128_SHA + , suiteTLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA + , suiteTLS_RSA_WITH_RC4_128_MD5 + , suiteTLS_RSA_WITH_RC4_128_SHA + , suiteTLS_RSA_WITH_AES_128_CBC_SHA + , suiteTLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA + , suiteTLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA + , suiteSSL3_EDH_RSA_DES_192_CBC3_SHA + , suiteSSL3_EDH_DSS_DES_192_CBC3_SHA + , suiteTLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA + , suiteTLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA + , suiteSSL3_RSA_FIPS_WITH_3DES_EDE_CBC_SHA + , suiteTLS_RSA_WITH_3DES_EDE_CBC_SHA + , suiteTLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA + , suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA256 + ) + where + +import Data.ByteArray +import Data.ByteString(ByteString) +import qualified Data.ByteString as B +import Network.TLS +import Crypto.Cipher.AES +import Crypto.Cipher.TripleDES +import Crypto.Cipher.RC4 +import Crypto.Cipher.Types hiding(Cipher, cipherName) +import qualified Crypto.Cipher.Types as C +import Crypto.Error + +-- ----------------------------------------------------------------------------- + +prep :: (C.Cipher c, BlockCipher c, ByteArray key) => + key -> (c -> IV c -> ByteString -> ByteString) -> c -> + BulkBlock +prep key f _ iv input = + let output = f ctx (makeIV_ iv) input + in (output, takeLast 16 output) + where + ctx = noFail (cipherInit key) + makeIV_ = maybe (error "makeIV_") id . makeIV + takeLast i b = B.drop (B.length b - i) b + +noFail :: CryptoFailable a -> a +noFail = throwCryptoError + +bulkAES128 :: Bulk +bulkAES128 = + Bulk { + bulkName = "AES128" + , bulkKeySize = 16 + , bulkIVSize = 16 + , bulkExplicitIV = 0 + , bulkAuthTagLen = 0 + , bulkBlockSize = 16 + , bulkF = BulkBlockF aes128cbc + } + where + aes128cbc BulkEncrypt key = prep key cbcEncrypt (undefined :: AES128) + aes128cbc BulkDecrypt key = prep key cbcDecrypt (undefined :: AES128) + +bulkAES256 :: Bulk +bulkAES256 = + Bulk { + bulkName = "AES256" + , bulkKeySize = 32 + , bulkIVSize = 16 + , bulkExplicitIV = 0 + , bulkAuthTagLen = 0 + , bulkBlockSize = 16 + , bulkF = BulkBlockF aes256cbc + } + where + aes256cbc BulkEncrypt key = prep key cbcEncrypt (undefined :: AES256) + aes256cbc BulkDecrypt key = prep key cbcDecrypt (undefined :: AES256) + +bulk3DES :: Bulk +bulk3DES = + Bulk { + bulkName = "3DES-EDE-CBC" + , bulkKeySize = 24 + , bulkIVSize = 8 + , bulkExplicitIV = 0 + , bulkAuthTagLen = 0 + , bulkBlockSize = 8 + , bulkF = BulkBlockF tripledes + } + where + tripledes BulkEncrypt key = prep key cbcEncrypt (undefined :: DES_EDE3) + tripledes BulkDecrypt key = prep key cbcDecrypt (undefined :: DES_EDE3) + +bulkRC4 :: Bulk +bulkRC4 = + Bulk { + bulkName = "RC4-128" + , bulkKeySize = 16 + , bulkIVSize = 0 + , bulkExplicitIV = 0 + , bulkAuthTagLen = 0 + , bulkBlockSize = 0 + , bulkF = BulkStreamF rc4 + } + where + rc4 _ bulkKey = BulkStream (combineRC4 (initialize bulkKey)) + combineRC4 ctx input = + let (ctx', output) = combine ctx input + in (output, BulkStream (combineRC4 ctx')) + +-- ----------------------------------------------------------------------------- + +suiteTLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA :: Cipher +suiteTLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA = + Cipher { + cipherID = 0xc009 + , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA" + , cipherBulk = bulkAES256 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDHE_RSA_WITH_AES_256_CBC_SHA :: Cipher +suiteTLS_ECDHE_RSA_WITH_AES_256_CBC_SHA = + Cipher { + cipherID = 0xc014 + , cipherName = "TLS_ECDHE_RSA_WIT_AES_256_CBC_SHA" + , cipherBulk = bulkAES256 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA :: Cipher +suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA = + Cipher { + cipherID = 0x0039 + , cipherName = "TLS_DHE_RSA_WITH_AES_256_CBC_SHA" + , cipherBulk = bulkAES256 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_DHE_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_DHE_DSS_WITH_AES_256_CBC_SHA :: Cipher +suiteTLS_DHE_DSS_WITH_AES_256_CBC_SHA = + Cipher { + cipherID = 0x0038 + , cipherName = "TLS_DHE_DSS_WITH_AES_256_CBC_SHA" + , cipherBulk = bulkAES256 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_DHE_DSS + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDH_RSA_WITH_AES_256_CBC_SHA :: Cipher +suiteTLS_ECDH_RSA_WITH_AES_256_CBC_SHA = + Cipher { + cipherID = 0xc00f + , cipherName = "TLS_ECDH_RSA_WITH_AES_256_CBC_SHA" + , cipherBulk = bulkAES256 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDH_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA :: Cipher +suiteTLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA = + Cipher { + cipherID = 0xc005 + , cipherName = "TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA" + , cipherBulk = bulkAES256 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDH_ECDSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_RSA_WITH_AES_256_CBC_SHA :: Cipher +suiteTLS_RSA_WITH_AES_256_CBC_SHA = + Cipher { + cipherID = 0x0035 + , cipherName = "TLS_RSA_WITH_AES_256_CBC_SHA" + , cipherBulk = bulkAES256 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDHE_ECDSA_WITH_RC4_128_SHA :: Cipher +suiteTLS_ECDHE_ECDSA_WITH_RC4_128_SHA = + Cipher { + cipherID = 0xc007 + , cipherName = "TLS_ECDHE_ECDSA_WITH_RC4" + , cipherBulk = bulkRC4 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA :: Cipher +suiteTLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA = + Cipher { + cipherID = 0xc009 + , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA" + , cipherBulk = bulkAES128 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDHE_RSA_WITH_RC4_128_SHA :: Cipher +suiteTLS_ECDHE_RSA_WITH_RC4_128_SHA = + Cipher { + cipherID = 0xc011 + , cipherName = "TLS_ECDHE_RSA_WITH_RC4_128_SHA" + , cipherBulk = bulkRC4 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDHE_RSA_WITH_AES_128_CBC_SHA :: Cipher +suiteTLS_ECDHE_RSA_WITH_AES_128_CBC_SHA = + Cipher { + cipherID = 0xc013 + , cipherName = "TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA" + , cipherBulk = bulkAES128 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_DHE_RSA_WITH_AES_128_CBC_SHA :: Cipher +suiteTLS_DHE_RSA_WITH_AES_128_CBC_SHA = + Cipher { + cipherID = 0x0033 + , cipherName = "TLS_DHE_RSA_WITH_AES_128_CBC_SHA" + , cipherBulk = bulkAES128 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_DHE_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_DHE_DSS_WITH_AES_128_CBC_SHA :: Cipher +suiteTLS_DHE_DSS_WITH_AES_128_CBC_SHA = + Cipher { + cipherID = 0x0032 + , cipherName = "TLS_DHE_DSS_WITH_AES_128_CBC_SHA" + , cipherBulk = bulkAES128 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_DHE_DSS + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDH_RSA_WITH_RC4_128_SHA :: Cipher +suiteTLS_ECDH_RSA_WITH_RC4_128_SHA = + Cipher { + cipherID = 0xc00c + , cipherName = "TLS_ECDH_RSA_WITH_RC4_128_SHA" + , cipherBulk = bulkRC4 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDH_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDH_RSA_WITH_AES_128_CBC_SHA :: Cipher +suiteTLS_ECDH_RSA_WITH_AES_128_CBC_SHA = + Cipher { + cipherID = 0xc00e + , cipherName = "TLS_ECDH_RSA_WITH_AES_128_CBC_SHA" + , cipherBulk = bulkAES128 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDH_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDH_ECDSA_WITH_RC4_128_SHA :: Cipher +suiteTLS_ECDH_ECDSA_WITH_RC4_128_SHA = + Cipher { + cipherID = 0xc002 + , cipherName = "TLS_ECDH_ECDSA_WITH_RC4_128_SHA" + , cipherBulk = bulkRC4 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDH_ECDSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA :: Cipher +suiteTLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA = + Cipher { + cipherID = 0xc004 + , cipherName = "TLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA" + , cipherBulk = bulkAES128 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDH_ECDSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_RSA_WITH_RC4_128_MD5 :: Cipher +suiteTLS_RSA_WITH_RC4_128_MD5 = + Cipher { + cipherID = 0x0004 + , cipherName = "TLS_RSA_WITH_RC4_128_MD5" + , cipherBulk = bulkRC4 + , cipherHash = MD5 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_RSA_WITH_RC4_128_SHA :: Cipher +suiteTLS_RSA_WITH_RC4_128_SHA = + Cipher { + cipherID = 0x0005 + , cipherName = "TLS_RSA_WITH_RC4_128_SHA" + , cipherBulk = bulkRC4 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_RSA_WITH_AES_128_CBC_SHA :: Cipher +suiteTLS_RSA_WITH_AES_128_CBC_SHA = + Cipher { + cipherID = 0x002f + , cipherName = "TLS_RSA_WITH_AES_128_CBC_SHA" + , cipherBulk = bulkAES128 + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA :: Cipher +suiteTLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA = + Cipher { + cipherID = 0xc008 + , cipherName = "TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA" + , cipherBulk = bulk3DES + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA :: Cipher +suiteTLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA = + Cipher { + cipherID = 0xc012 + , cipherName = "TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA" + , cipherBulk = bulk3DES + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA :: Cipher +suiteTLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA = + Cipher { + cipherID = 0xc00d + , cipherName = "TLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA" + , cipherBulk = bulk3DES + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDH_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA :: Cipher +suiteTLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA = + Cipher { + cipherID = 0xc003 + , cipherName = "TLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA" + , cipherBulk = bulk3DES + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDH_ECDSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_RSA_WITH_3DES_EDE_CBC_SHA :: Cipher +suiteTLS_RSA_WITH_3DES_EDE_CBC_SHA = + Cipher { + cipherID = 0x000a + , cipherName = "TLS_RSA_WITH_3DES_EDE_CBC_SHA" + , cipherBulk = bulk3DES + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just TLS12 + } + +suiteSSL3_EDH_RSA_DES_192_CBC3_SHA :: Cipher +suiteSSL3_EDH_RSA_DES_192_CBC3_SHA = + Cipher { + cipherID = 0x0016 + , cipherName = "SSL3_EDH_RSA_DES_192_CBC3_SHA" + , cipherBulk = bulk3DES + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_ECDH_RSA + , cipherMinVer = Just SSL3 + } + +suiteSSL3_EDH_DSS_DES_192_CBC3_SHA :: Cipher +suiteSSL3_EDH_DSS_DES_192_CBC3_SHA = + Cipher { + cipherID = 0x0013 + , cipherName = "SSL3_EDH_DSS_DES_192_CBC3_SHA" + , cipherBulk = bulk3DES + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_DH_DSS -- FIXME: THIS IS WRONG + , cipherMinVer = Just SSL3 + } + +suiteSSL3_RSA_FIPS_WITH_3DES_EDE_CBC_SHA :: Cipher +suiteSSL3_RSA_FIPS_WITH_3DES_EDE_CBC_SHA = + Cipher { + cipherID = 0xFEFF + , cipherName = "SSL3_RSA_FIPS_WITH_3DES_EDE_CBC_SHA" + , cipherBulk = bulk3DES + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just SSL3 + } + +suiteTLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA :: Cipher +suiteTLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA = + Cipher { + cipherID = 0x0016 + , cipherName = "TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA" + , cipherBulk = bulk3DES + , cipherHash = SHA1 + , cipherKeyExchange = CipherKeyExchange_DHE_RSA + , cipherMinVer = Just TLS12 + } + +suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA256 :: Cipher +suiteTLS_DHE_RSA_WITH_AES_256_CBC_SHA256 = + Cipher { + cipherID = 0x006B + , cipherName = "TLS_DHE_RSA_WITH_AES_256_CBC_SHA256" + , cipherBulk = bulkAES256 + , cipherHash = SHA256 + , cipherKeyExchange = CipherKeyExchange_DHE_RSA + , cipherMinVer = Just TLS12 + } + + diff --git a/src/Tor/Link/DH.hs b/src/Tor/Link/DH.hs new file mode 100644 --- /dev/null +++ b/src/Tor/Link/DH.hs @@ -0,0 +1,15 @@ +-- |Handy Diffie-Hellman constants +module Tor.Link.DH( + oakley2 + ) + where + +import Crypto.PubKey.DH + +-- |The second Oakley group from RFC 2409, which provides ~1024 bits of +-- security. +oakley2 :: Params +oakley2 = Params { + params_p = 0xFFFFFFFFFFFFFFFFC90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A637ED6B0BFF5CB6F406B7EDEE386BFB5A899FA5AE9F24117C4B1FE649286651ECE65381FFFFFFFFFFFFFFFF + , params_g = 2 + } diff --git a/src/Tor/NetworkStack.hs b/src/Tor/NetworkStack.hs new file mode 100644 --- /dev/null +++ b/src/Tor/NetworkStack.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE ExistentialQuantification #-} +-- |Defines the network API required for a Tor implementation to run. +module Tor.NetworkStack( + TorNetworkStack(..) + , SomeNetworkStack(..) + , toBackend + , recvAll + , recvLine + ) + where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Word +import Network.TLS +import Tor.DataFormat.TorAddress + +-- |A network stack, but with the type variables hidden. +data SomeNetworkStack = forall lsock sock . HasBackend sock => + MkNS (TorNetworkStack lsock sock) + +-- |The type of a Tor-compatible network stack. The first type variable is the +-- type of a listener socket, the second the type of a standard connection +-- socket. +data TorNetworkStack lsock sock = TorNetworkStack { + connect :: String -> Word16 -> IO (Maybe sock) + -- |Lookup the given hostname and return any IP6 (Left) or IP4 (Right) + -- addresses associated with it. + , getAddress :: String -> IO [TorAddress] + , listen :: Word16 -> IO lsock + , accept :: lsock -> IO (sock, TorAddress) + , recv :: sock -> Int -> IO S.ByteString + , write :: sock -> L.ByteString -> IO () + , flush :: sock -> IO () + , close :: sock -> IO () + , lclose :: lsock -> IO () + } + +-- |Receive a line of ASCII text from a socket. +recvLine :: TorNetworkStack ls s -> s -> IO L.ByteString +recvLine ns s = go [] + where + go acc = + do next <- recv ns s 1 + case S.uncons next of + Nothing -> return (L.pack (reverse acc)) + Just (10, _) -> return (L.pack (reverse acc)) + Just (f, _) -> go (f:acc) + +-- |Receive all the input from the socket as a lazy ByteString; this may cause +-- the system to block upon some ByteString operations to fetch more data. +recvAll :: TorNetworkStack ls s -> s -> IO L.ByteString +recvAll ns s = go [] + where + go acc = + do next <- recv ns s 4096 + if S.null next + then return (L.fromChunks (reverse acc)) + else go (next:acc) + +-- |Convert a Tor-compatible network stack to a TLS-compatible Backend +-- structure. +toBackend :: TorNetworkStack ls s -> s -> Backend +toBackend ns s = Backend { + backendFlush = flush ns s + , backendClose = close ns s + , backendRecv = recv ns s + , backendSend = write ns s . L.fromStrict + } diff --git a/src/Tor/NetworkStack/Fetch.hs b/src/Tor/NetworkStack/Fetch.hs new file mode 100644 --- /dev/null +++ b/src/Tor/NetworkStack/Fetch.hs @@ -0,0 +1,175 @@ +-- |Automatic fetching and decoding of resources needed for Tor; specifically, +-- this hides a lot of the HTTP GET cruft that would otherwise be sprinkled +-- about the code. +-- +-- Users should avoid using this module for long-term projects. It ended up both +-- growing a little bit beyond what was intended, and also managed to be less +-- generally useful than I had thought. Thus, I suspect this module will be +-- overhauled in the not-too-distant future. +-- +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Tor.NetworkStack.Fetch( + FetchItem(..) + , Fetchable + , fetch + , readResponse + ) + where + +-- FIXME: This whole interface could use a re-think. + +import Codec.Compression.Zlib +import Control.Exception +import Crypto.Hash.Easy +import Crypto.PubKey.RSA.KeyHash +import Data.Attoparsec.ByteString +import Data.ByteString(ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.Char8(pack) +import Data.Either +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Word +import System.IO.Unsafe +import System.Timeout +import Tor.DataFormat.Consensus +import Tor.DataFormat.DirCertInfo +import Tor.DataFormat.Helpers +import Tor.DataFormat.RouterDesc +import Tor.NetworkStack +import Tor.RouterDesc + +-- |A set of types that are automatically fetchable by this subsystem. +class Fetchable a where + -- |Parse a blob of incoming data, emitting either an error string of the + -- item. A moral equivalent to ReadS, except for ByteStrings, and we're + -- not planning to make this widely used. + parseBlob :: ByteString -> Either String a + +instance Fetchable DirectoryCertInfo where + parseBlob = parseDirectoryCertInfo + +instance Fetchable (Consensus, ByteString, ByteString) where + parseBlob = parseConsensusDocument + +instance Fetchable (Map ByteString RouterDesc) where + parseBlob bstr = Right (convertEntries Map.empty xs) + where + (_, xs) = partitionEithers (parseDirectory bstr) + -- + convertEntries m [] = m + convertEntries m (d:r) = + convertEntries (Map.insert (keyHash' sha1 (routerSigningKey d)) d m) r + +-- |One of the things we can automatically fetch. +data FetchItem = ConsensusDocument + | KeyCertificate + | Descriptors + deriving (Show) + +-- |Given an item to fetch, get the directory and file name for that thing. +fetchItemFile :: FetchItem -> String +fetchItemFile ConsensusDocument = "/tor/status-vote/current/consensus.z" +fetchItemFile KeyCertificate = "/tor/keys/authority.z" +fetchItemFile Descriptors = "/tor/server/all.z" + +-- |Given an item to fetch, get a time we should be willing to wait to download +-- and process that item. +fetchItemTime :: FetchItem -> Int +fetchItemTime ConsensusDocument = 60 * 1000000 +fetchItemTime KeyCertificate = 5 * 1000000 +fetchItemTime Descriptors = 3 * 60 * 1000000 + +-- |Fetch the given item from the given host and port, using the given network +-- stack, returning either the error that occurred fetching that item or the +-- item. The String used for the host will be directly passed to the network +-- stack's connect function without further processing, so you should think +-- about whether that means you need to address resolution or not. +fetch :: Fetchable a => + TorNetworkStack ls s -> + String -> Word16 -> FetchItem -> + IO (Either String a) +fetch ns host tcpport item = + handle (\ err -> return (Left (show (err :: SomeException)))) $ + timeout' (fetchItemTime item) $ + do msock <- connect ns host tcpport + case msock of + Nothing -> return (Left "Connection failure.") + Just sock -> + do write ns sock (buildGet (fetchItemFile item)) + resp <- readResponse ns sock + case resp of + Left err -> return (Left err) + Right body -> + case decompress body of + Nothing -> return (Left "Decompression failure.") + Just body' -> return (parseBlob (L.toStrict body')) + `finally` close ns sock + where + timeout' tm io = + do res <- timeout tm io + case res of + Nothing -> return (Left "Fetch timed out.") + Just x -> return x + +-- |Build a GET request for the given resource. +buildGet :: String -> L.ByteString +buildGet str = result + where + result = pack (requestLine ++ userAgent ++ crlf) + requestLine = "GET " ++ str ++ " HTTP/1.0\r\n" + userAgent = "User-Agent: CERN-LineMode/2.15 libwww/2.17b3\r\n" + crlf = "\r\n" + +-- |Read the response to a GET request. This returns the parsed interior of a +-- GET response, rather than the whole response, so one of the possible errors +-- you might receive is an HTTP response parsing error. +readResponse :: TorNetworkStack ls s -> s -> IO (Either String L.ByteString) +readResponse ns sock = getResponse (parse httpResponse) + where + getResponse parseStep = + do chunk <- recv ns sock 4096 + case parseStep chunk of + Fail bstr _ err -> + do let start = show (S.take 10 bstr) + msg = "Parser error: " ++ err ++ " [" ++ start ++ "]" + return (Left msg) + Partial f -> + getResponse f + Done res () -> + (Right . L.fromChunks . (res:)) `fmap` lazyRead + -- + lazyRead :: IO [ByteString] + lazyRead = unsafeInterleaveIO $ do chunk <- recv ns sock 4096 + if S.null chunk + then return [] + else do rest <- lazyRead + return (chunk : rest) + +-- |An attoparsec parser for HTTP responses. This is not, in any way, fully +-- general. +httpResponse :: Parser () +httpResponse = + do _ <- string "HTTP/" + _ <- decDigit + _ <- char8 '.' + _ <- decDigit + _ <- sp + v <- decimalNum (const True) + _ <- sp + msg <- toString `fmap` many1 (notWord8 13) + _ <- crlf + if v /= (200 :: Integer) + then fail ("HTTP Error: " ++ msg) + else do _ <- many1 keyval + _ <- crlf + return () + where + crlf = char8 '\r' >> char8 '\n' + keyval = + do _ <- many1 (notWord8 13) + _ <- crlf + return () + diff --git a/src/Tor/NetworkStack/Hans.hs b/src/Tor/NetworkStack/Hans.hs new file mode 100644 --- /dev/null +++ b/src/Tor/NetworkStack/Hans.hs @@ -0,0 +1,78 @@ +-- |The way to integrate Tor with Hans. +module Tor.NetworkStack.Hans(hansNetworkStack) where + +import Data.ByteString(ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Word +import Hans.Address.IP4 +import Hans.NetworkStack +import Tor.DataFormat.TorAddress(TorAddress) +import qualified Tor.DataFormat.TorAddress as TorAddr +import Tor.NetworkStack(TorNetworkStack(TorNetworkStack)) +import qualified Tor.NetworkStack + +-- |Create a Tor-compatible network stack from the given Hans network stack. +hansNetworkStack :: (HasTcp stack, HasDns stack) => + stack -> + TorNetworkStack Socket Socket +hansNetworkStack ns = TorNetworkStack { + Tor.NetworkStack.connect = systemConnect ns + , Tor.NetworkStack.getAddress = systemLookup ns + , Tor.NetworkStack.listen = systemListen ns + , Tor.NetworkStack.accept = systemAccept + , Tor.NetworkStack.recv = systemRead + , Tor.NetworkStack.write = systemWrite + , Tor.NetworkStack.flush = const (return ()) + , Tor.NetworkStack.close = close + , Tor.NetworkStack.lclose = close + } + +systemConnect :: (HasTcp stack, HasDns stack) => + stack -> String -> Word16 -> + IO (Maybe Socket) +systemConnect stack addr port = + do mipAddr <- getAddr (reads addr) addr + case mipAddr of + Nothing -> return Nothing + Just ipAddr -> Just `fmap` connect stack ipAddr port' Nothing + where + port' = fromIntegral port + -- + getAddr [(x, _)] _ = return (Just x) + getAddr _ x = + do hentry <- getHostByName stack x + case hostAddresses hentry of + [] -> return Nothing + (i:_) -> return (Just i) + +systemLookup :: HasDns stack => stack -> String -> IO [TorAddress] +systemLookup stack name = + do host <- getHostByName stack name + return (map (TorAddr.IP4 . show) (hostAddresses host)) + +systemListen :: (HasTcp stack) => + stack -> Word16 -> + IO Socket +systemListen stack port = listen stack broadcastIP4 (fromIntegral port) + +systemAccept :: Socket -> IO (Socket, TorAddress) +systemAccept lsock = + do sock <- accept lsock + return (sock, TorAddr.IP4 (show (sockRemoteHost sock))) + +systemRead :: Socket -> Int -> IO ByteString +systemRead sock amt = L.toStrict `fmap` loop (fromIntegral amt) + where loop x | x <= 0 = return L.empty + | otherwise = + do bstr <- recvBytes sock x + if L.null bstr + then return L.empty + else (bstr `L.append`) `fmap` loop (x - L.length bstr) + +systemWrite :: Socket -> L.ByteString -> IO () +systemWrite sock bstr = + do amt <- sendBytes sock bstr + if (amt == 0) || (amt == L.length bstr) + then return () + else systemWrite sock (L.drop amt bstr) + diff --git a/src/Tor/NetworkStack/System.hs b/src/Tor/NetworkStack/System.hs new file mode 100644 --- /dev/null +++ b/src/Tor/NetworkStack/System.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE CPP #-} +-- |Routines for integrating Tor with the standard network library. +module Tor.NetworkStack.System(systemNetworkStack) where + +import Data.Binary.Put +import Data.ByteString(ByteString) +import Data.ByteString.Lazy(toStrict) +import qualified Data.ByteString as BS +import Data.Word +import Network(listenOn, PortID(..)) +import Network.BSD +import Network.Socket as Sys hiding (recv) +import Network.Socket.ByteString.Lazy(sendAll) +import qualified Network.Socket.ByteString as Sys +import Tor.DataFormat.TorAddress +import Tor.NetworkStack + +-- |A Tor-compatible network stack that uses the 'network' library. +systemNetworkStack :: TorNetworkStack Socket Socket +systemNetworkStack = TorNetworkStack { + Tor.NetworkStack.connect = systemConnect + , Tor.NetworkStack.getAddress = systemLookup + , Tor.NetworkStack.listen = systemListen + , Tor.NetworkStack.accept = systemAccept + , Tor.NetworkStack.recv = systemRead + , Tor.NetworkStack.write = sendAll + , Tor.NetworkStack.flush = const (return ()) + , Tor.NetworkStack.close = Sys.close + , Tor.NetworkStack.lclose = Sys.close + } + +systemConnect :: String -> Word16 -> IO (Maybe Socket) +systemConnect addrStr port = + do let ainfo = defaultHints { addrFamily = AF_INET, addrSocketType = Stream } + hname = addrStr + sname = show port + addrinfos <- getAddrInfo (Just ainfo) (Just hname) (Just sname) + case addrinfos of + [] -> return Nothing + (x:_) -> + do sock <- socket AF_INET Stream defaultProtocol + Sys.connect sock (addrAddress x) + return (Just sock) + +systemLookup :: String -> IO [TorAddress] +systemLookup hostname = + -- FIXME: Tack the hostname on the end, as a default? + do res <- getAddrInfo Nothing (Just hostname) Nothing + return (map (convertAddress . addrAddress) res) + +systemListen :: Word16 -> IO Socket +systemListen port = listenOn (PortNumber (fromIntegral port)) + +convertAddress :: SockAddr -> TorAddress +convertAddress (SockAddrInet _ x) = + IP4 (ip4ToString (toStrict (runPut (putWord32be x)))) +convertAddress (SockAddrInet6 _ _ (a,b,c,d) _) = + IP6 (ip6ToString (toStrict (runPut (mapM_ putWord32be [a,b,c,d])))) +convertAddress x = + error ("Incompatible address type: " ++ show x) + +systemAccept :: Socket -> IO (Socket, TorAddress) +systemAccept lsock = + do (res, addr) <- Sys.accept lsock + return (res, convertAddress addr) + +systemRead :: Socket -> Int -> IO ByteString +systemRead _ 0 = return BS.empty +systemRead sock amt = + do start <- Sys.recv sock (fromIntegral amt) + let left = fromIntegral (amt - fromIntegral (BS.length start)) + if BS.null start + then return BS.empty + else (start `BS.append`) `fmap` systemRead sock left + diff --git a/src/Tor/Options.hs b/src/Tor/Options.hs new file mode 100644 --- /dev/null +++ b/src/Tor/Options.hs @@ -0,0 +1,143 @@ +-- |Various options for running a Tor node +module Tor.Options( + -- * Options for running Tor + TorOptions(..), defaultTorOptions + , TorEntranceOptions(..), defaultTorEntranceOptions + , TorRelayOptions(..), defaultTorRelayOptions + , TorExitOptions(..), defaultTorExitOptions + , ExitRule(..), AddrSpec(..), PortSpec(..) + -- * Handy utilities + , makeLogger + ) + where + +import Data.Hourglass +import Data.Hourglass.Now +import Data.Word +import Tor.RouterDesc + +-- |How the node should be set up during initialization. For each of these +-- items, 'Nothing' means that the node will not operate in that capacity, while +-- Just of the option type will initialize that system with those options. +-- +-- Note that while we will do our best to make it work, it doesn't make a whole +-- lot of sense to be an Exit node and not be a Relay node. +data TorOptions = TorOptions { + torLog :: String -> IO () + , torEntranceOptions :: Maybe TorEntranceOptions + , torRelayOptions :: Maybe TorRelayOptions + , torExitOptions :: Maybe TorExitOptions + } + +-- |A reasonable default set of options for a Tor node. Sets the node up as an +-- entrance and relay node with their standard options, and logging output +-- printed to stdout. +defaultTorOptions :: TorOptions +defaultTorOptions = TorOptions { + torLog = makeLogger putStrLn + , torEntranceOptions = Just defaultTorEntranceOptions + , torRelayOptions = Just defaultTorRelayOptions + , torExitOptions = Nothing + } + +-- |Options for allowing circuits that originated at this node. +data TorEntranceOptions = TorEntranceOptions { + -- |The number of intermediate hops to use between this node and + -- the exit node. To be clear, created circuits will have an entrance + -- node, this number of nodes, and then the exit node. + torInternalCircuitLength :: Int + -- |The target number of external connections to keep alive for + -- outgoing connections. Note that this is a target, rather than a hard + -- minimum or limit. + , torTargetLinks :: Int + } + +-- |A reasonable set of entrance options. The internal circuit length is set to +-- 4, and a target number of links of 5. +defaultTorEntranceOptions :: TorEntranceOptions +defaultTorEntranceOptions = TorEntranceOptions { + torInternalCircuitLength = 4 + , torTargetLinks = 5 + } + +-- |Options for allowing circuits that pass through this node. +data TorRelayOptions = TorRelayOptions { + -- |The port to listen on. By default, this is 9374, but there are + -- compelling reasons to have it be some other wel-known port, like + -- 80. + torOnionPort :: Word16 + -- |The nickname for this node. This is completely optional, but can + -- be helpful in finding yourself in node lists. + , torNickname :: String + -- |A contact email address. If not provided, we will either provide + -- no email address or just include a junk address. + , torContact :: Maybe String + -- |If you're setting up a number of nodes within the same operating + -- environment, you might want to provide a "family" identifier. That way, + -- those building circuits can limit what percentage of their hops might + -- go through this group. A node can be a member of zero, one, or more + -- families, thus the list. + , torFamilies :: [NodeFamily] + -- |The maximum number of links from this node. Note that this should be + -- greater than or equal to torTargetLinks if this node is also to be used + -- as an entrance node. + , torMaximumLinks :: Int + } + +-- |A reasonable set of relay options. The onion port is set to 9374, the +-- nickname is set to "", and no contact information is provided. These options +-- set the maximum number of links to 50. +defaultTorRelayOptions :: TorRelayOptions +defaultTorRelayOptions = TorRelayOptions { + torOnionPort = 9374 + , torNickname = "" + , torContact = Nothing + , torFamilies = [] + , torMaximumLinks = 50 + } + +-- |Options for allowing circuits that end at this node. +data TorExitOptions = TorExitOptions { + -- |The rules for allowing or rejecting traffic leaving this node. + torExitRules :: [ExitRule] + -- |The ports to disallow (Left) or allow (Right) when forwarding + -- IPv6 traffic. + , torIPv6Policy :: Either [PortSpec] [PortSpec] + -- |Set this flag if you want to allow single-hop exits. These are + -- usually not advisable, but according to the spec they may be + -- usefule for "specialized controllers desgined to support perspective + -- access and such." + , torAllowSingleHopExits :: Bool + } + +-- |A reasonable default exit node options. This allows all outgoing +-- traffic to ports 22 (SSH), 80 (HTTP), 443 (HTTPS), 465 (SMTPS), and +-- 993 (IMAPS), and disallows single hop exits. +defaultTorExitOptions :: TorExitOptions +defaultTorExitOptions = TorExitOptions { + torExitRules = map (\ p -> ExitRuleAccept AddrSpecAll (PortSpecSingle p)) + allowPorts + , torIPv6Policy = Right (map PortSpecSingle allowPorts) + , torAllowSingleHopExits = False + } + where allowPorts = [22, 80, 443, 465, 993] + +-- ----------------------------------------------------------------------------- + +-- |If you like the output format of the default log function, but want to +-- send it to your own output stream, this is the function for you! This +-- function takes an outgoing logger and a string to log, and adds a nicely- +-- formatted and easily-sortable timestamp to the front of it. +-- +-- NOTE: The default value for the logger is (makeLogger putStrLn). +makeLogger :: (String -> IO ()) -> String -> IO () +makeLogger out msg = + do now <- getCurrentTime + out (timePrint timeFormat now ++ msg) + where + timeFormat = [Format_Text '[', Format_Year4, Format_Text '-', Format_Month2, + Format_Text '-', Format_Day2, Format_Text ' ', Format_Hour, + Format_Text ':', Format_Minute, Format_Text ']', + Format_Text ' '] + + diff --git a/src/Tor/RNG.hs b/src/Tor/RNG.hs new file mode 100644 --- /dev/null +++ b/src/Tor/RNG.hs @@ -0,0 +1,9 @@ +-- |RNG routines +module Tor.RNG(TorRNG) where + +import Crypto.Random + +-- |The current alias for random number generators within the Tor +-- implementation. Renamed here because we may want to change this in the +-- future. +type TorRNG = ChaChaDRG diff --git a/src/Tor/RouterDesc.hs b/src/Tor/RouterDesc.hs new file mode 100644 --- /dev/null +++ b/src/Tor/RouterDesc.hs @@ -0,0 +1,126 @@ +-- |Structures and rules for describing routers. +module Tor.RouterDesc( + RouterDesc(..) + , blankRouterDesc + , NodeFamily(..) + , ExitRule(..) + , AddrSpec(..) + , PortSpec(..) + ) + where + +import Crypto.PubKey.Curve25519 as Curve +import Crypto.PubKey.RSA as RSA +import Data.ByteString(ByteString, empty) +import Data.Hourglass +import Data.Word + +-- |The complete description of a router within the Tor network. +data RouterDesc = RouterDesc { + routerNickname :: String + , routerIPv4Address :: String + , routerORPort :: Word16 + , routerDirPort :: Maybe Word16 + , routerParseLog :: [String] + , routerAvgBandwidth :: Int + , routerBurstBandwidth :: Int + , routerObservedBandwidth :: Int + , routerPlatformName :: String + , routerEntryPublished :: DateTime + , routerFingerprint :: ByteString + , routerHibernating :: Bool + , routerUptime :: Maybe Integer + , routerOnionKey :: RSA.PublicKey + , routerNTorOnionKey :: Maybe Curve.PublicKey + , routerSigningKey :: RSA.PublicKey + , routerExitRules :: [ExitRule] + , routerIPv6Policy :: Either [PortSpec] [PortSpec] + , routerSignature :: ByteString + , routerContact :: Maybe String + , routerFamily :: [NodeFamily] + , routerReadHistory :: Maybe (DateTime, Int, [Int]) + , routerWriteHistory :: Maybe (DateTime, Int, [Int]) + , routerCachesExtraInfo :: Bool + , routerExtraInfoDigest :: Maybe ByteString + , routerHiddenServiceDir :: Maybe Int + , routerLinkProtocolVersions :: [Int] + , routerCircuitProtocolVersions :: [Int] + , routerAllowSingleHopExits :: Bool + , routerAlternateORAddresses :: [(String, Word16)] + , routerStatus :: [String] + } + deriving (Show) + +instance Eq RouterDesc where + a == b = routerSigningKey a == routerSigningKey b + +-- |A blank router description, with most of the options initialized with +-- standard "blank" values. +blankRouterDesc :: RouterDesc +blankRouterDesc = + RouterDesc { + routerNickname = "" + , routerIPv4Address = "0.0.0.0" + , routerORPort = 0 + , routerDirPort = Nothing + , routerParseLog = [] + , routerAvgBandwidth = 0 + , routerBurstBandwidth = 0 + , routerObservedBandwidth = 0 + , routerPlatformName = "Haskell" + , routerEntryPublished = timeFromElapsed (Elapsed (Seconds 0)) + , routerFingerprint = empty + , routerHibernating = False + , routerUptime = Nothing + , routerOnionKey = error "No public onion key" + , routerNTorOnionKey = Nothing + , routerSigningKey = error "No signing key" + , routerExitRules = [] + , routerIPv6Policy = Left [] + , routerSignature = empty + , routerContact = Nothing + , routerFamily = [] + , routerReadHistory = Nothing + , routerWriteHistory = Nothing + , routerCachesExtraInfo = False + , routerExtraInfoDigest = Nothing + , routerHiddenServiceDir = Nothing + , routerLinkProtocolVersions = [] + , routerCircuitProtocolVersions = [] + , routerAllowSingleHopExits = False + , routerAlternateORAddresses = [] + , routerStatus = [] + } + +-- |A family descriptor for a node. Either a nickname, or a digest referencing +-- the family, or both. +data NodeFamily = NodeFamilyNickname String + | NodeFamilyDigest ByteString + | NodeFamilyBoth String ByteString + deriving (Show) + +-- |A rule for accepting or rejecting traffic, usually specified by exit nodes. +data ExitRule = ExitRuleAccept AddrSpec PortSpec -- ^Accept matching traffic. + | ExitRuleReject AddrSpec PortSpec -- ^Reject matching traffic. + deriving (Show) + +-- |A port specifier +data PortSpec = PortSpecAll -- ^Accept any port + | PortSpecRange Word16 Word16 -- ^Accept ports between the two + -- values, inclusive. + | PortSpecSingle Word16 -- ^Accept only the given port. + deriving (Eq, Show) + +-- |An address or subnet specifier. +data AddrSpec = AddrSpecAll -- ^Accept any address + | AddrSpecIP4 String -- ^Accept this specific address. + | AddrSpecIP4Mask String String -- ^Accept this IP address and + -- subnet mask (255.255.255.0,etc.) + | AddrSpecIP4Bits String Int -- ^Accept this IP address and CIDR + -- mask (/24,etc.) + | AddrSpecIP6 String -- ^Accept this specific IP6 address. + | AddrSpecIP6Bits String Int -- ^Accept this subnet and CIDR + -- mask. + deriving (Eq, Show) + + diff --git a/src/Tor/RouterDesc/Render.hs b/src/Tor/RouterDesc/Render.hs new file mode 100644 --- /dev/null +++ b/src/Tor/RouterDesc/Render.hs @@ -0,0 +1,337 @@ +-- |Routines for rendering router descriptions. +module Tor.RouterDesc.Render( + renderRouterDesc + ) + where + +import Control.Monad +import Crypto.Hash.Easy +import Crypto.Number.Serialize +import Crypto.PubKey.RSA +import Crypto.PubKey.RSA.PKCS15 +import Data.Bits +import Data.ByteArray(convert) +import Data.ByteString.Base64 +import Data.ByteString(ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Char hiding (isHexDigit, isAlphaNum) +import Data.Hourglass +import MonadLib +import MonadLib.Monads +import Tor.RouterDesc + +type Render = Writer String + +putWord :: String -> Render () +putWord x = put x >> put " " + +putWord' :: Show a => a -> Render () +putWord' x = put (show x) >> put " " + +endLine :: Render () +endLine = put "\n" + +putFourGroups :: String -> Render () +putFourGroups [] = return () +putFourGroups xs = + do let (f, rest) = splitAt 4 xs + putWord f + putFourGroups rest + +putPublicKey :: PublicKey -> Render () +putPublicKey (PublicKey _ n _) = + do let encoded = encode (i2ospOf_ (1024 `div` 8) n) + put "-----BEGIN RSA PUBLIC KEY-----\n" + putLines (BSC.unpack encoded) + put "-----END RSA PUBLIC KEY-----\n" + +putLines :: String -> Render () +putLines [] = return () +putLines xs = + do let (f, rest) = splitAt 64 xs + put f + endLine + putLines rest + +putSeperated :: String -> (a -> Render ()) -> [a] -> Render () +putSeperated _ _ [] = return () +putSeperated _ render [x] = render x +putSeperated sep render (x:rest) = + do render x + put sep + putSeperated sep render rest + +-- ---------------------------------------------------------------------------- + +-- |Render the given router description, signing it with the given private +-- signing key. +renderRouterDesc :: RouterDesc -> PrivateKey -> String +renderRouterDesc r k = snd (runWriter (renderRouterDesc' r k)) + +renderRouterDesc' :: RouterDesc -> PrivateKey -> Render () +renderRouterDesc' r k = + do let (_, desc) = runWriter $ do renderRouterLine r + renderBandwidth r + renderPlatform r + renderPublished r + renderFingerprint r + renderHibernating r + renderUptime r + renderOnionKey r + renderNTorKey r + renderSigningKey r + renderExitRules r + renderIPv6Policy r + renderContactInfo r + renderFamily r + renderReadHistory r + renderWriteHistory r + renderCachesExtraInfo r + renderExtraInfoDigest r + renderHiddenServiceDir r + renderProtocols r + renderAllowSingleHopExits r + renderAltAddresses r + putWord "router-signature" + endLine + let descbstr = BSC.pack desc + msignature = sign Nothing noHash k (sha1 descbstr) + case msignature of + Left _ -> return () -- error? + Right signature -> + do let encodedsig = encode signature + put desc + put "-----BEGIN SIGNATURE-----\n" + putLines (BSC.unpack encodedsig) + put "-----END SIGNATURE-----\n" + +renderRouterLine :: RouterDesc -> Render () +renderRouterLine r = + do putWord "router" + putWord (routerNickname r) + putWord (routerIPv4Address r) + putWord' (routerORPort r) + putWord "0" + case routerDirPort r of + Nothing -> putWord "0" + Just x -> putWord' x + endLine + +renderBandwidth :: RouterDesc -> Render () +renderBandwidth r = + do putWord "bandwidth" + putWord' (routerAvgBandwidth r) + putWord' (routerBurstBandwidth r) + putWord' (routerObservedBandwidth r) + endLine + +renderPlatform :: RouterDesc -> Render () +renderPlatform r = + when (routerPlatformName r /= "") $ + do putWord "platform" + put (routerPlatformName r) + endLine + +renderPublished :: RouterDesc -> Render () +renderPublished r = + do putWord "published" + let fmt = [Format_Year4, Format_Text '-', Format_Month2, Format_Text '-', + Format_Day2, Format_Text ' ', Format_Hour, Format_Text ':', + Format_Minute, Format_Text ':', Format_Second] + put (timePrint fmt (routerEntryPublished r)) + endLine + +renderFingerprint :: RouterDesc -> Render () +renderFingerprint r = + unless (BS.null (routerFingerprint r)) $ + do putWord "opt" + putWord "fingerprint" + let fprint = showHex (routerFingerprint r) + putFourGroups fprint + endLine + +renderHibernating :: RouterDesc -> Render () +renderHibernating r = + when (routerHibernating r) $ + do putWord "opt" + putWord "hibernating" + putWord "1" + endLine + +renderUptime :: RouterDesc -> Render () +renderUptime r = + case routerUptime r of + Nothing -> return () + Just x -> + do putWord "uptime" + putWord' x + endLine + +renderOnionKey :: RouterDesc -> Render () +renderOnionKey r = + do putWord "onion-key" + endLine + putPublicKey (routerOnionKey r) + +renderNTorKey :: RouterDesc -> Render () +renderNTorKey r = + case routerNTorOnionKey r of + Nothing -> return () + Just k -> + do putWord "ntor-onion-key" + putWord (BSC.unpack (encode (convert k))) + endLine + +renderSigningKey :: RouterDesc -> Render () +renderSigningKey r = + do putWord "signing-key" + endLine + putPublicKey (routerSigningKey r) + +renderExitRules :: RouterDesc -> Render () +renderExitRules r = mapM_ renderExitRule (routerExitRules r) + where + renderExitRule (ExitRuleAccept a p ) = putWord "accept" >> renderRest a p + renderExitRule (ExitRuleReject a p ) = putWord "reject" >> renderRest a p + renderRest a p = + do renderAddrSpec a + put ":" + renderPortSpec p + endLine + +renderAddrSpec :: AddrSpec -> Render () +renderAddrSpec AddrSpecAll = put "*" +renderAddrSpec (AddrSpecIP4 a) = put a +renderAddrSpec (AddrSpecIP6 a) = put "[" >> put a >> put "]" +renderAddrSpec (AddrSpecIP4Mask a m) = put a >> put "/" >> put m +renderAddrSpec (AddrSpecIP4Bits a b) = put a >> put "/" >> put (show b) +renderAddrSpec (AddrSpecIP6Bits a b) = put a >> put "/" >> put (show b) + +renderPortSpec :: PortSpec -> Render () +renderPortSpec PortSpecAll = put "*" +renderPortSpec (PortSpecSingle p) = put (show p) +renderPortSpec (PortSpecRange p q) = put (show p) >> put "-" >> put (show q) + +renderIPv6Policy :: RouterDesc -> Render () +renderIPv6Policy r = + case routerIPv6Policy r of + Left [PortSpecRange 1 65535] -> + return () + Left ps -> + do putWord "ipv6-policy reject" + putSeperated "," renderPortSpec ps + endLine + Right ps -> + do putWord "ipv6-policy accept" + putSeperated "," renderPortSpec ps + endLine + +renderContactInfo :: RouterDesc -> Render () +renderContactInfo r = + case routerContact r of + Nothing -> return () + Just x -> + do putWord "contact" + put x + endLine + +renderFamily :: RouterDesc -> Render () +renderFamily r = + unless (null (routerFamily r)) $ + do putWord "family" + putSeperated " " renderRouterFamily (routerFamily r) + where + renderRouterFamily :: NodeFamily -> Render () + renderRouterFamily (NodeFamilyNickname n) = put n + renderRouterFamily (NodeFamilyDigest d) = put "$" >> put (showHex d) + renderRouterFamily (NodeFamilyBoth n d) = + do put "$" + put (showHex d) + put "=" + put n + +renderReadHistory :: RouterDesc -> Render () +renderReadHistory r = renderHistory "read" (routerReadHistory r) + +renderWriteHistory :: RouterDesc -> Render () +renderWriteHistory r = renderHistory "write" (routerWriteHistory r) + +renderHistory :: String -> Maybe (DateTime, Int, [Int]) -> Render () +renderHistory _ Nothing = + return () +renderHistory histtype (Just (tstamp, interval, counts)) = + do put histtype + putWord "-history" + let fmt = [Format_Year4, Format_Text '-', Format_Month2, Format_Text '-', + Format_Day2, Format_Text ' ', Format_Hour, Format_Text ':', + Format_Minute, Format_Text ':', Format_Second] + put (timePrint fmt tstamp) + putWord' interval + putSeperated "," (put . show) counts + endLine + +renderCachesExtraInfo :: RouterDesc -> Render () +renderCachesExtraInfo r = + when (routerCachesExtraInfo r) $ + do putWord "caches-extra-info" + endLine + +renderExtraInfoDigest :: RouterDesc -> Render () +renderExtraInfoDigest r = + case routerExtraInfoDigest r of + Nothing -> + return () + Just x -> + do putWord "extra-info-digest" + putWord (showHex x) + endLine + +renderHiddenServiceDir :: RouterDesc -> Render () +renderHiddenServiceDir r = + case routerHiddenServiceDir r of + Nothing -> + return () + Just x -> + do putWord "hidden-service-dir" + putWord' x + endLine + +renderProtocols :: RouterDesc -> Render () +renderProtocols r = + case (routerLinkProtocolVersions r, routerCircuitProtocolVersions r) of + ([], []) -> return () + (lvs, cvs) -> + do putWord "protocols" + putWord "Link" + mapM_ putWord' lvs + putWord "Circuit" + mapM_ putWord' cvs + endLine + +renderAllowSingleHopExits :: RouterDesc -> Render () +renderAllowSingleHopExits r = + when (routerAllowSingleHopExits r) $ + do putWord "allow-single-hop-exits" + endLine + +renderAltAddresses :: RouterDesc -> Render () +renderAltAddresses r = + unless (null (routerAlternateORAddresses r)) $ + forM_ (routerAlternateORAddresses r) $ + \ (addr, orport) -> + do putWord "or-address" + put $ if any (== ':') addr + then "[" ++ addr ++ "]" + else addr + put ":" + putWord' orport + endLine + +showHex :: ByteString -> String +showHex = BS.foldr addChars "" + where + addChars x acc = hexChar (x `shiftR` 4) : hexChar (x .&. 0xF) : acc + hexChar = toUpper . intToDigit . fromIntegral + + diff --git a/src/Tor/State/CircuitManager.hs b/src/Tor/State/CircuitManager.hs new file mode 100644 --- /dev/null +++ b/src/Tor/State/CircuitManager.hs @@ -0,0 +1,185 @@ +-- |This module provides a high-level interface for building, closing, and +-- managing open circuits within the Tor network. +module Tor.State.CircuitManager( + CircuitManager + , newCircuitManager + , openCircuit + , closeCircuit + ) + where + +import Control.Concurrent +import Control.Concurrent.Async(Async,async,wait,waitCatch) +import Control.Exception +import Control.Monad +import Crypto.Random +import Network.TLS(HasBackend) +import System.Mem.Weak +import Tor.Circuit +import Tor.DataFormat.TorCell +import Tor.Link +import Tor.NetworkStack +import Tor.Options +import Tor.RNG +import Tor.RouterDesc +import Tor.State.Credentials +import Tor.State.LinkManager +import Tor.State.Routers + +-- |A handle for the circuit manager component, to be passed amongst functions +-- in this module. +data HasBackend s => CircuitManager ls s + = NoCircuitManager + | CircuitManager { + cmCircuitLength :: Int + , cmRouterDB :: RouterDB + , cmOptions :: TorOptions + , cmLinkManager :: LinkManager ls s + , cmRNG :: MVar TorRNG + , cmOpenCircuits :: MVar [CircuitEntry s] + } + +data CircuitEntry s = Pending { + ceExitNode :: RouterDesc + , _cePendingEntrance :: Async OriginatedCircuit + } + | Entry { + ceExitNode :: RouterDesc + , _ceWeakEntrance :: Weak OriginatedCircuit + } + | Transverse { + _ceIncomingLink :: TorLink + , _ceCircuit :: Weak (TransverseCircuit s) + } + +-- |Create a new circuit manager given the previously-initialized components. +-- Using a circuit manager will allow you to more easily reuse circuits across +-- multiple connections, decreasing the overhead of using Tor. In additionally, +-- eventually you will be able to track and gather statistics on circuit history +-- over time by using this component. +newCircuitManager :: HasBackend s => + TorOptions -> TorNetworkStack ls s -> + Credentials -> RouterDB -> LinkManager ls s -> + IO (CircuitManager ls s) +newCircuitManager opts ns creds rdb lm = + case torEntranceOptions opts of + Nothing -> return NoCircuitManager + Just entOpts -> + do let circLen = torInternalCircuitLength entOpts + rngMV <- newMVar =<< drgNew + circMV <- newMVar [] + let cm = CircuitManager circLen rdb opts lm rngMV circMV + setIncomingLinkHandler lm $ \ link -> + handle logException $ + do me <- getRouterDesc creds + mcircuit <- acceptCircuit ns opts me creds rdb link rngMV + case mcircuit of + Nothing -> + torLog opts ("Failed to build transverse circuit.") + Just circuit -> + do wkCircuit <- mkWeakPtr circuit Nothing + let circ = Transverse link wkCircuit + modifyMVar_ circMV $ \ circs -> return (circ : circs) + return cm + where + logException e = torLog opts ("Exception creating incoming circuit: " ++ + show (e :: SomeException)) + +-- |Open a circuit to an exit node that allows connections according to the +-- given restrictions. +openCircuit :: HasBackend s => + CircuitManager ls s -> [RouterRestriction] -> + IO OriginatedCircuit +openCircuit NoCircuitManager _ = fail "This node doesn't support entrance." +openCircuit cm restricts = + join $ modifyMVar (cmOpenCircuits cm) $ \ circs -> + case findApplicable circs of + Nothing -> + do exitNode <- modifyMVar (cmRNG cm) $ \ rng -> + getRouter (cmRouterDB cm) restricts rng + pendRes <- async (buildNewCircuit cm exitNode (cmCircuitLength cm)) + return (snoc circs (Pending exitNode pendRes), + waitAndUpdate exitNode pendRes) + Just (pend@(Pending _ entrance), rest) -> + return (snoc rest pend, wait entrance) + Just (ent@(Entry _ wkEnt), rest) -> + do ment <- deRefWeak wkEnt + case ment of + Nothing -> + return (rest, openCircuit cm restricts) + Just res -> + return (snoc rest ent, return res) + _ -> + fail "Serious internal error (openCircuit)" + where + findApplicable ls = loop ls [] + where + loop [] _ = Nothing + loop (x : rest) acc + | ceExitNode x `meetsRestrictions` restricts = Just (x, rest ++ acc) + | otherwise = loop rest (snoc acc x) + -- + waitAndUpdate exitNode pendRes = + do eres <- waitCatch pendRes + case eres of + Left err -> + do modifyMVar_ (cmOpenCircuits cm) + (return . removeEntry exitNode) + throwIO err + Right res -> + do weak <- mkWeakPtr res (Just (destroyCircuit res RequestedDestroy)) + let newent = Entry exitNode weak + modifyMVar_ (cmOpenCircuits cm) + (return . replaceEntry exitNode newent) + return res + -- + removeEntry _ [] = [] + removeEntry exitNode (x : rest) + | exitNode == ceExitNode x = removeEntry exitNode rest + | otherwise = x : removeEntry exitNode rest + -- + replaceEntry _ _ [] = [] + replaceEntry exitNode new (x : rest) + | exitNode == ceExitNode x = new : replaceEntry exitNode new rest + | otherwise = x : replaceEntry exitNode new rest + +-- |Close a circuit. DO NOT CALL THIS. Instead, just drop all references to the +-- structure; we'll worry about this later. +closeCircuit :: HasBackend s => CircuitManager ls s -> OriginatedCircuit -> IO () +closeCircuit = error "closeCircuit" -- FIXME + +-- This is the code that actually builds a circuit, given an appropriate +-- final node. +-- +-- FIXME: Make sure that we don't use two routers within the same family. +-- FIXME: Make sure that we don't use two routers within the same /16 subnet. +-- FIXME: Use the path selection weighting criteria in path-spec.txt +-- +buildNewCircuit :: HasBackend s => + CircuitManager ls s -> RouterDesc -> Int -> + IO OriginatedCircuit +buildNewCircuit cm exitNode len = + do let notExit = [NotRouter exitNode] + (link, desc, circId) <- newLinkCircuit (cmLinkManager cm) notExit + cmLog cm ("Built initial link to " ++ show (routerIPv4Address desc) ++ + " with circuit ID " ++ show circId) + circ <- createCircuit (cmRNG cm) (cmOptions cm) link desc circId + loop circ (NotRouter desc : notExit) len + where + loop circ _ 0 = + do cmLog cm ("Extending circuit to exit node " ++ + show (routerIPv4Address exitNode)) + extendCircuit circ exitNode + return circ + loop circ restricts x = + do next <- modifyMVar (cmRNG cm) (getRouter (cmRouterDB cm) restricts) + cmLog cm ("Extending circuit to " ++ show (routerIPv4Address next)) + extendCircuit circ next + loop circ (NotRouter next : restricts) (x - 1) + +snoc :: [a] -> a -> [a] +snoc [] x = [x] +snoc (x:rest) y = x : snoc rest y + +cmLog :: HasBackend s => CircuitManager ls s -> (String -> IO ()) +cmLog = torLog . cmOptions diff --git a/src/Tor/State/Credentials.hs b/src/Tor/State/Credentials.hs new file mode 100644 --- /dev/null +++ b/src/Tor/State/Credentials.hs @@ -0,0 +1,314 @@ +-- |Credential management for a Tor node. +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Tor.State.Credentials( + Credentials + , createCertificate + , generateKeyPair + , newCredentials + , getSigningKey + , getOnionKey + , getNTorOnionKey + , getTLSKey + , getAddresses + , getRouterDesc + , addNewAddresses + , isSignedBy + ) + where + +import Control.Concurrent +import Crypto.Hash +import Crypto.Hash.Easy +import Crypto.PubKey.Curve25519 as Curve +import Crypto.PubKey.RSA as RSA +import Crypto.PubKey.RSA.KeyHash +import Crypto.PubKey.RSA.PKCS15 +import Crypto.Random +import Data.ASN1.OID +import Data.ByteString(ByteString) +import Data.Hourglass +import Data.Hourglass.Now +#if MIN_VERSION_base(4,8,0) +import Data.List(sortOn) +#else +import Data.List(sortBy) +import Data.Ord(comparing) +#endif +import Data.Map.Strict(Map,empty,insertWith,toList) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif +import Data.String +import Data.Word +import Data.X509 +import Hexdump +import Tor.DataFormat.TorAddress +import Tor.Options +import Tor.RNG +import Tor.RouterDesc + +-- |A snapshot of the current credential state for the system. +data CredentialState = CredentialState { + credRNG :: TorRNG + , credStartTime :: DateTime + , credNextSerialNum :: Integer + , credBaseDesc :: RouterDesc + , credAddresses :: Map TorAddress Int + , credIdentity :: (SignedCertificate, PrivKey) + , credOnion :: (SignedCertificate, PrivKey) + , credOnionNTor :: (Curve.PublicKey, SecretKey) + , credTLS :: (SignedCertificate, PrivKey) + } + +-- |The current credentials held by the node. +newtype Credentials = Credentials (MVar CredentialState) + +-- |Generate new credentials fora fresh node. +newCredentials :: TorOptions -> IO Credentials +newCredentials opts = + do g <- drgNew + now <- getCurrentTime + let s = generateState g opts now + creds <- Credentials `fmap` newMVar s + logMsg "Credentials created." + logMsg (" Signing key fingerprint: " ++ (showFingerprint (credIdentity s))) + logMsg (" Onion key fingerprint: " ++ (showFingerprint (credOnion s))) + logMsg (" TLS key fingerprint: " ++ (showFingerprint (credTLS s))) + return creds + where + logMsg = torLog opts + showFingerprint c = + filter (/= ' ') (simpleHex (keyHash sha1 (signedObject (getSigned (fst c))))) + +-- |Get the public signing certificate and its associated private key. +getSigningKey :: Credentials -> IO (SignedCertificate, PrivKey) +getSigningKey = getCredentials credIdentity + +-- |Get the public onion certificate and its associated private key. +getOnionKey :: Credentials -> IO (SignedCertificate, PrivKey) +getOnionKey = getCredentials credOnion + +-- |Get the public NTor Curve25519 public and private keys. +getNTorOnionKey :: Credentials -> IO (Curve.PublicKey, SecretKey) +getNTorOnionKey = getCredentials credOnionNTor + +-- |Get the public TLS certificate and its associated private key. +getTLSKey :: Credentials -> IO (SignedCertificate, PrivKey) +getTLSKey = getCredentials credTLS + +getCredentials :: (CredentialState -> a) -> Credentials -> IO a +getCredentials getter (Credentials stateMV) = + do state <- takeMVar stateMV + now <- getCurrentTime + let state' = updateKeys state now + putMVar stateMV $! state' + return (getter state') + +-- |Get the current set of addresses we believe are associated with the node. +-- You should make sure to establish at least one outgoing link before calling +-- this. +getAddresses :: Credentials -> IO [TorAddress] +getAddresses (Credentials stateMV) = + withMVar stateMV $ \ state -> + return (orderList (credAddresses state)) + +-- |Get our own, current router decsription. +getRouterDesc :: Credentials -> IO RouterDesc +getRouterDesc (Credentials stateMV) = + withMVar stateMV $ \ state -> + do let port = routerORPort (credBaseDesc state) + addrs = orderList (credAddresses state) + (ip4addr, oaddrs) = splitAddresses port False addrs + (onionCert, _) = credOnion state + PubKeyRSA onionkey = certPubKey (signedObject (getSigned onionCert)) + (signCert, _) = credIdentity state + PubKeyRSA signkey = certPubKey (signedObject (getSigned signCert)) + (ntorkey, _) = credOnionNTor state + now <- getCurrentTime + return (credBaseDesc state) { + routerIPv4Address = ip4addr + , routerFingerprint = keyHash' sha1 signkey + , routerUptime = Just (fromIntegral (timeDiff (credStartTime state) now)) + , routerOnionKey = onionkey + , routerNTorOnionKey = Just ntorkey + , routerSigningKey = signkey + , routerAlternateORAddresses = oaddrs + } + where + splitAddresses :: Word16 -> Bool -> [TorAddress] -> (String, [(String, Word16)]) + splitAddresses _ False [] = ("127.0.0.1", []) + splitAddresses _ True [] = (error "Internal error (splitAddresses)", []) + splitAddresses p False (IP4 x : rest) = (x, snd (splitAddresses p True rest)) + splitAddresses p state (x : rest) = + let (f, rest') = splitAddresses p state rest + in case x of + IP4 a -> (f, (a,p):rest') + IP6 a -> (f, (a,p):rest') + _ -> (f, rest') + +-- |Add a new set of addresses that should be associated with our node. +addNewAddresses :: Credentials -> TorAddress -> IO [TorAddress] +addNewAddresses (Credentials stateMV) addr = + modifyMVar stateMV $ \ state -> + do let addrs' = insertWith (+) addr 1 (credAddresses state) + state' = state{ credAddresses = addrs' } + return (state', orderList addrs') + +orderList :: Map TorAddress Int -> [TorAddress] +orderList x = reverse (map fst (sortOn snd (toList x))) + +generateState :: TorRNG -> TorOptions -> DateTime -> CredentialState +generateState rng opts now = s3 + where + s0 = CredentialState rng now 100 desc empty un un un un + un = undefined + (s1, _) = maybeRegenId True now s0 + (s2, _) = maybeRegenOnion True now s1 + (s3, _) = maybeRegenTLS True now s2 + -- + desc = blankRouterDesc { + routerNickname = maybe "" torNickname (torRelayOptions opts) + , routerORPort = maybe 9001 torOnionPort (torRelayOptions opts) + , routerPlatformName = "Haskell" + , routerEntryPublished = timeFromElapsed (Elapsed (Seconds 0)) + , routerExitRules = maybe [] torExitRules (torExitOptions opts) + , routerIPv6Policy = maybe (Left [PortSpecAll]) torIPv6Policy (torExitOptions opts) + , routerContact = maybe Nothing torContact (torRelayOptions opts) + , routerFamily = maybe [] torFamilies (torRelayOptions opts) + , routerAllowSingleHopExits = maybe False torAllowSingleHopExits (torExitOptions opts) + } + +updateKeys :: CredentialState -> DateTime -> CredentialState +updateKeys s0 now = s3 + where + (s1, forceOnion) = maybeRegenId False now s0 + (s2, forceTLS) = maybeRegenOnion forceOnion now s1 + (s3, _) = maybeRegenTLS forceTLS now s2 + +getCredCert :: (SignedCertificate, PrivKey) -> Certificate +getCredCert = signedObject . getSigned . fst + +maybeRegenId :: Bool -> DateTime -> CredentialState -> (CredentialState, Bool) +maybeRegenId force now state | force || (now > expiration) = (state', True) + | otherwise = (state, False) + where + (_, expiration) = certValidity (getCredCert (credIdentity state)) + -- + serial = credNextSerialNum state + (pub, priv, g') = generateKeyPair (credRNG state) 1024 + cert = createCertificate (PubKeyRSA pub) (PrivKeyRSA priv) serial + "haskell tor" (now, twoYears) + twoYears = now `timeAdd` mempty{ durationHours = (2 * 365 * 24) } + -- + state' = state{ credRNG = g', credNextSerialNum = serial + 1 + , credIdentity = (cert, PrivKeyRSA priv) } + +maybeRegenOnion :: Bool -> DateTime -> CredentialState -> (CredentialState,Bool) +maybeRegenOnion force now state | force || (now > expiration) = (state', True) + | otherwise = (state, False) + where + (_, expiration) = certValidity (getCredCert (credIdentity state)) + -- + serial = credNextSerialNum state + (pub, priv, g') = generateKeyPair (credRNG state) 1024 + (_, idpriv) = credIdentity state + cert = createCertificate (PubKeyRSA pub) idpriv serial + "haskell tor node" (now, twoWeeks) + twoWeeks = now `timeAdd` mempty{ durationHours = (14 * 24) } + -- + findKey rng = + let (bytes, rng') = withRandomBytes rng 32 id + in case secretKey (bytes :: ByteString) of + Left _ -> findKey rng' + Right privkey -> (privkey, rng') + (privntor, g'') = findKey g' + pubntor = toPublic privntor + -- + state' = state{ credRNG = g'', credNextSerialNum = serial + 1 + , credOnion = (cert, PrivKeyRSA priv) + , credOnionNTor = (pubntor, privntor) + } + +maybeRegenTLS :: Bool -> DateTime -> CredentialState -> (CredentialState,Bool) +maybeRegenTLS force now state | force || (now > expiration) = (state', True) + | otherwise = (state, False) + where + (_, expiration) = certValidity (getCredCert (credIdentity state)) + -- + serial = credNextSerialNum state + (pub, priv, g') = generateKeyPair (credRNG state) 1024 + (_, idpriv) = credIdentity state + cert = createCertificate (PubKeyRSA pub) idpriv serial + "haskell tor node" (now, twoHours) + twoHours = now `timeAdd` mempty{ durationHours = 2 } + -- + state' = state{ credRNG = g', credNextSerialNum = serial + 1 + , credTLS = (cert, PrivKeyRSA priv) } + +-- ---------------------------------------------------------------------------- + +-- |Create a new certificate containing the public key and signed by the private +-- key, using the given serial number, CommonName, and validity period. +createCertificate :: PubKey -> PrivKey -> + Integer -> String -> (DateTime, DateTime) -> + SignedExact Certificate +createCertificate certPubKey sigKey certSerial cName certValidity = signedCert + where + (signedCert, _) = objectToSignedExact (signMsg sigKey) unsignedCert + certSignatureAlg = SignatureALG HashSHA1 PubKeyALG_RSA + unsignedCert = Certificate{ .. } + certVersion = 3 + certExtensions = Extensions Nothing + certSubjectDN = makeDN cName + certIssuerDN = makeDN "haskell" + makeDN str = DistinguishedName [ + (getObjectID DnCommonName, fromString str) + , (getObjectID DnCountry, "US") + , (getObjectID DnOrganization, "Haskell Community") + , (getObjectID DnOrganizationUnit, "cabal") + ] + +signMsg :: PrivKey -> ByteString -> (ByteString, SignatureALG, ()) +signMsg (PrivKeyRSA key) bstr = (sig, SignatureALG HashSHA1 PubKeyALG_RSA, ()) + where + sig = errorLeft (sign Nothing (Just SHA1) key bstr) + errorLeft (Left e) = error ("Signing error: " ++ show e) + errorLeft (Right x) = x +signMsg _ _ = error "Sign with non-RSA private key." + +-- |Generate a new public/private RSA key pair of the given bit size. +generateKeyPair :: DRG g => g -> Int -> (RSA.PublicKey, PrivateKey, g) +generateKeyPair g bitSize = (pubKey, privKey, g') + where + ((pubKey, privKey), g') = withDRG g (generate (bitSize `div` 8) 65537) + +-- |Return true if the first certificate is signed by the second. +isSignedBy :: SignedCertificate -> Certificate -> Bool +isSignedBy cert bycert = + case signedAlg (getSigned cert) of + SignatureALG_Unknown _ -> False + SignatureALG HashMD2 PubKeyALG_RSA -> False + SignatureALG hashAlg PubKeyALG_RSA -> + case certPubKey bycert of + PubKeyRSA pubkey -> + let sig = signedSignature (getSigned cert) + bstr = getSignedData cert + verify' = toVerify hashAlg + in verify' pubkey bstr sig + _ -> False + SignatureALG _ _ -> False + where + toVerify HashSHA1 = verify (Just SHA1) + toVerify HashSHA224 = verify (Just SHA224) + toVerify HashSHA256 = verify (Just SHA256) + toVerify HashSHA384 = verify (Just SHA384) + toVerify HashSHA512 = verify (Just SHA512) + toVerify _ = \ _ _ _ -> False + + +#if !MIN_VERSION_base(4,8,0) +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = + map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) +#endif diff --git a/src/Tor/State/Directories.hs b/src/Tor/State/Directories.hs new file mode 100644 --- /dev/null +++ b/src/Tor/State/Directories.hs @@ -0,0 +1,214 @@ +-- |Routines for tracking Tor directory servicers. +module Tor.State.Directories( + Directory(..) + , DirectoryDB + , newDirectoryDatabase + , sendRouterDescription + , getRandomDirectory + , findDirectory + , addDirectory + ) + where + +import Control.Concurrent +import Crypto.PubKey.RSA +import Crypto.Random +import Control.Monad +import qualified Data.ByteString as S +import Data.ByteString(ByteString) +import Data.ByteString.Char8(pack) +import qualified Data.ByteString.Lazy as L +import Data.Either +import Data.Hourglass +import Data.List +import Data.Maybe +import Data.Word +import Tor.DataFormat.Consensus +import Tor.DataFormat.DefaultDirectory +import Tor.DataFormat.DirCertInfo +import Tor.NetworkStack +import Tor.NetworkStack.Fetch +import Tor.RouterDesc +import Tor.RouterDesc.Render + +-- |The information about a directory within the Tor network. +data Directory = Directory { + dirNickname :: String + , dirIsBridge :: Bool + , dirAddress :: String + , dirOnionPort :: Word16 + , dirDirPort :: Word16 + , dirV3Ident :: Maybe ByteString + , dirFingerprint :: ByteString + , dirPublished :: DateTime + , dirExpires :: DateTime + , dirIdentityKey :: PublicKey + , dirSigningKey :: PublicKey + } + deriving (Show) + +-- |The current directory database available to the node. +newtype DirectoryDB = DDB (MVar [Directory]) + +-- |Generate a directory of available databases from which we can pull router +-- lists and publish our own router information, as necessary. +newDirectoryDatabase :: TorNetworkStack ls s -> (String -> IO ()) -> + IO DirectoryDB +newDirectoryDatabase ns logMsg = + do let defaultDirs = rights (map (parseDefaultDirectory . pack) defaultStrs) + dirs <- forM defaultDirs $ \ d -> + do logMsg ("Fetching credentials for default directory " ++ + (ddirNickname d) ++ " [" ++ ddirAddress d ++ ":" ++ + show (ddirDirPort d) ++ "]") + e <- fetch ns (ddirAddress d) (ddirDirPort d) KeyCertificate + case (e, ddirV3Ident d) of + (Left err, _) -> + do logMsg ("Fetch failed: " ++ err) + return Nothing + (Right _, Nothing) -> + do logMsg ("Ignoring directory w/o V3Ident.") + return Nothing + (Right i, Just v3ident) | v3ident /= dcFingerprint i -> + do logMsg ("Weird: fingerprint mismatch. Ignoring dir.") + return Nothing + (Right i, Just _) -> + do return $ Just $ Directory { + dirNickname = ddirNickname d + , dirIsBridge = ddirIsBridge d + , dirAddress = ddirAddress d + , dirOnionPort = ddirOnionPort d + , dirDirPort = ddirDirPort d + , dirV3Ident = ddirV3Ident d + , dirFingerprint = ddirFingerprint d + , dirPublished = dcPublished i + , dirExpires = dcExpires i + , dirIdentityKey = dcIdentityKey i + , dirSigningKey = dcSigningKey i + } + let loadedDirs = catMaybes dirs + logMsg (show (length loadedDirs) ++ " of " ++ show (length defaultStrs) ++ + " default directories loaded.") + DDB `fmap` newMVar loadedDirs + +-- |Send our router description to all of the directories we know about. +sendRouterDescription :: TorNetworkStack ls s -> (String -> IO ()) -> + DirectoryDB -> + RouterDesc -> PrivateKey -> + IO () +sendRouterDescription ns out (DDB dirlsMV) desc pkey = + do dirls <- readMVar dirlsMV + forM_ dirls $ \ dir -> + do msock <- connect ns (dirAddress dir) (dirDirPort dir) + case msock of + Nothing -> + out "Could not connect to directory server for desc push." + Just sock -> + do let body = pack (renderRouterDesc desc pkey) + header = pack (buildPost body) + write ns sock (L.fromStrict header) + write ns sock (L.fromStrict body) + resp <- readResponse ns sock + close ns sock + case resp of + Left err -> + out ("Error posting descriptor: " ++ show err) + Right _ -> + out ("Posted descriptor to " ++ show (dirNickname dir)) + where + buildPost bstr = + "POST /tor/ HTTP/1.0\r\n" ++ + "Content-Length: " ++ show (S.length bstr) ++ "\r\n\r\n" + +-- |Select a random directory. +getRandomDirectory :: DRG g => g -> DirectoryDB -> IO (Directory, g) +getRandomDirectory g ddb@(DDB dirlsMV) = + do ls <- readMVar dirlsMV + let (bstr, g') = randomBytesGenerate 1 g + case S.uncons bstr of + Nothing -> + do threadDelay 1000000 + getRandomDirectory g ddb + Just (x, _) -> + do let idx = fromIntegral x `mod` length ls + return (ls !! idx, g') + +-- |Find a directory that matches the given fingerprint. +findDirectory :: ByteString -> DirectoryDB -> IO (Maybe Directory) +findDirectory fprint (DDB dirlsMV) = + find matchesFingerprint `fmap` readMVar dirlsMV + where + matchesFingerprint dir = + case dirV3Ident dir of + Nothing -> False + Just x -> x == fprint + +-- |Add a new directory to our set of known directories. +addDirectory :: TorNetworkStack ls s -> (String -> IO ()) -> + DirectoryDB -> Authority -> + IO () +addDirectory ns logMsg (DDB dirsMV) auth = + do dirs <- takeMVar dirsMV + case find matchesFingerprint dirs of + Just _ -> putMVar dirsMV dirs + Nothing -> + do e <- fetch ns (authAddress auth) (authDirPort auth) KeyCertificate + case e of + Left _ -> + do logMsg ("Failed to add new directory for " ++ authName auth) + putMVar dirsMV dirs + Right i -> + do let newdir = Directory { + dirNickname = authName auth + , dirIsBridge = False + , dirAddress = authAddress auth + , dirOnionPort = authOnionPort auth + , dirDirPort = authDirPort auth + , dirV3Ident = Just (dcFingerprint i) + , dirFingerprint = authIdent auth + , dirPublished = dcPublished i + , dirExpires = dcExpires i + , dirIdentityKey = dcIdentityKey i + , dirSigningKey = dcSigningKey i + } + putMVar dirsMV (newdir : dirs) + logMsg ("Added new directory entry for " ++ authName auth) + where + matchesFingerprint dir = + case dirV3Ident dir of + Nothing -> False + Just x -> x == authIdent auth + +-- This is pretty much a copy and paste from the Tor reference source code, and +-- should remain that way in order to make updating it as simple as possible. +defaultStrs :: [String] +defaultStrs = [ + "moria1 orport=9101 " ++ + "v3ident=D586D18309DED4CD6D57C18FDB97EFA96D330566 " ++ + "128.31.0.39:9131 9695 DFC3 5FFE B861 329B 9F1A B04C 4639 7020 CE31", + "tor26 orport=443 " ++ + "v3ident=14C131DFC5C6F93646BE72FA1401C02A8DF2E8B4 " ++ + "86.59.21.38:80 847B 1F85 0344 D787 6491 A548 92F9 0493 4E4E B85D", + "dizum orport=443 " ++ + "v3ident=E8A9C45EDE6D711294FADF8E7951F4DE6CA56B58 " ++ + "194.109.206.212:80 7EA6 EAD6 FD83 083C 538F 4403 8BBF A077 587D D755", + "Tonga orport=443 bridge " ++ + "82.94.251.203:80 4A0C CD2D DC79 9508 3D73 F5D6 6710 0C8A 5831 F16D", + "gabelmoo orport=443 " ++ + "v3ident=ED03BB616EB2F60BEC80151114BB25CEF515B226 " ++ + "131.188.40.189:80 F204 4413 DAC2 E02E 3D6B CF47 35A1 9BCA 1DE9 7281", + "dannenberg orport=443 " ++ + "v3ident=585769C78764D58426B8B52B6651A5A71137189A " ++ + "193.23.244.244:80 7BE6 83E6 5D48 1413 21C5 ED92 F075 C553 64AC 7123", +-- "urras orport=80 " ++ +-- "v3ident=80550987E1D626E3EBA5E5E75A458DE0626D088C " ++ +-- "208.83.223.34:443 0AD3 FA88 4D18 F89E EA2D 89C0 1937 9E0E 7FD9 4417", +-- "maatuska orport=80 " ++ +-- "v3ident=49015F787433103580E3B66A1707A00E60F2D15B " ++ +-- "171.25.193.9:443 BD6A 8292 55CB 08E6 6FBE 7D37 4836 3586 E46B 3810", + "Faravahar orport=443 " ++ + "v3ident=EFCBE720AB3A82B99F9E953CD5BF50F7EEFC7B97 " ++ + "154.35.175.225:80 CF6D 0AAF B385 BE71 B8E1 11FC 5CFF 4B47 9237 33BC", + "longclaw orport=443 " ++ + "v3ident=23D15D965BC35114467363C165C4F724B64B4F66 " ++ + "199.254.238.52:80 74A9 1064 6BCE EFBC D2E8 74FC 1DC9 9743 0F96 8145" + ] diff --git a/src/Tor/State/LinkManager.hs b/src/Tor/State/LinkManager.hs new file mode 100644 --- /dev/null +++ b/src/Tor/State/LinkManager.hs @@ -0,0 +1,120 @@ +-- |A module for managing the collection of links held by the Tor node. +module Tor.State.LinkManager( + LinkManager + , newLinkManager + , newLinkCircuit + , setIncomingLinkHandler + ) + where + +import Control.Concurrent +import Control.Monad +import Crypto.Random +import Data.Maybe +import Data.Word +import Network.TLS hiding (Credentials) +import Tor.Link +import Tor.NetworkStack +import Tor.Options +import Tor.RNG +import Tor.RouterDesc +import Tor.State.Credentials +import Tor.State.Routers + +-- |The LinkManager, as you'd guess, serves as a unique management point for +-- holding all the links the current Tor node is operating on. The goal of this +-- module is to allow maximal re-use of incoming and outgoing links while also +-- maintaining enough links to provide anonymity guarantees. +data HasBackend s => LinkManager ls s = LinkManager { + lmNetworkStack :: TorNetworkStack ls s + , lmRouterDB :: RouterDB + , lmCredentials :: Credentials + , lmIdealLinks :: Int + , lmMaxLinks :: Int + , lmLog :: String -> IO () + , lmRNG :: MVar TorRNG + , lmLinks :: MVar [TorLink] + , lmIncomingLinkHandler :: MVar (TorLink -> IO ()) + } + +-- |Create a new link manager with the given options, network stack, router +-- database and credentials. +newLinkManager :: HasBackend s => + TorOptions -> + TorNetworkStack ls s -> + RouterDB -> Credentials -> + IO (LinkManager ls s) +newLinkManager o ns routerDB creds = + do rngMV <- newMVar =<< drgNew + linksMV <- newMVar [] + ilHndlrMV <- newMVar (const (return ())) + let lm = LinkManager { + lmNetworkStack = ns + , lmRouterDB = routerDB + , lmCredentials = creds + , lmIdealLinks = idealLinks + , lmMaxLinks = maxLinks + , lmLog = torLog o + , lmRNG = rngMV + , lmLinks = linksMV + , lmIncomingLinkHandler = ilHndlrMV + } + when (isRelay || isExit) $ + do lsock <- listen ns orPort + lmLog lm ("Waiting for Tor connections on port " ++ show orPort) + forkIO_ $ forever $ + do (sock, addr) <- accept ns lsock + forkIO_ $ + do link <- acceptLink creds routerDB rngMV (torLog o) sock addr + modifyMVar_ linksMV (return . (link:)) + return lm + where + isRelay = isJust (torRelayOptions o) + isExit = isJust (torExitOptions o) + orPort = maybe 9374 torOnionPort (torRelayOptions o) + idealLinks = maybe 3 torTargetLinks (torEntranceOptions o) + maxLinks = maybe 3 torMaximumLinks (torRelayOptions o) + +-- |Generate the first link in a new circuit, where the first hop meets the +-- given restrictions. The result is the new link, the router description of +-- that link, and a new circuit id to use when creating the circuit. +newLinkCircuit :: HasBackend s => + LinkManager ls s -> [RouterRestriction] -> + IO (TorLink, RouterDesc, Word32) +newLinkCircuit lm restricts = + modifyMVar (lmLinks lm) $ \ curLinks -> + if length curLinks >= lmIdealLinks lm + then getExistingLink curLinks [] + else buildNewLink curLinks + where + getExistingLink :: [TorLink] -> [TorLink] -> + IO ([TorLink], (TorLink, RouterDesc, Word32)) + getExistingLink [] acc = buildNewLink acc + getExistingLink (link:rest) acc + | Just rd <- linkRouterDesc link + , rd `meetsRestrictions` restricts = + do circId <- modifyMVar (lmRNG lm) (linkNewCircuitId link) + return (rest ++ acc, (link, rd, circId)) + | otherwise = + getExistingLink rest (acc ++ [link]) + -- + buildNewLink :: [TorLink] -> + IO ([TorLink], (TorLink, RouterDesc, Word32)) + buildNewLink curLinks = + do entranceDesc <- modifyMVar (lmRNG lm) + (getRouter (lmRouterDB lm) restricts) + link <- initLink (lmNetworkStack lm) (lmCredentials lm) + (lmRNG lm) (lmLog lm) + entranceDesc + circId <- modifyMVar (lmRNG lm) (linkNewCircuitId link) + return (curLinks ++ [link], (link, entranceDesc, circId)) + +-- |Set a callback that will fire any time a new link is added to the system. +setIncomingLinkHandler :: HasBackend s => + LinkManager ls s -> (TorLink -> IO ()) -> + IO () +setIncomingLinkHandler lm h = + modifyMVar_ (lmIncomingLinkHandler lm) (const (return h)) + +forkIO_ :: IO () -> IO () +forkIO_ m = forkIO m >> return () diff --git a/src/Tor/State/Routers.hs b/src/Tor/State/Routers.hs new file mode 100644 --- /dev/null +++ b/src/Tor/State/Routers.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE RecordWildCards #-} +-- |A module for maintaining an up-to-date list of Tor nodes in the Tor network. +module Tor.State.Routers( + RouterDB + , RouterRestriction(..) + , newRouterDatabase + , findRouter + , getRouter + , meetsRestrictions + , allowsExit + ) + where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Foldable(find) +#endif +import Control.Concurrent +import Control.Monad +import Crypto.Hash.Easy +import Crypto.PubKey.RSA.KeyHash +import Crypto.PubKey.RSA.PKCS15 +import Crypto.Random +import Data.Array +import Data.Bits +import Data.Serialize.Get +import Data.ByteString(ByteString,unpack) +import Data.Hourglass +import Data.Hourglass.Now +import Data.List +#if !MIN_VERSION_base(4,8,0) + hiding (find) +#endif +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Word +import MonadLib +import Tor.DataFormat.Consensus +import Tor.DataFormat.RelayCell +import Tor.DataFormat.TorAddress +import Tor.NetworkStack +import Tor.NetworkStack.Fetch +import Tor.RNG +import Tor.RouterDesc +import Tor.State.Directories + +-- |The current router database, refreshed at regular intervals. +newtype RouterDB = RouterDB (MVar RouterDBVersion) + +data RouterDBVersion = RDB { + rdbRevision :: Word + , rdbRouters :: Array Word RouterDesc + } + +-- |Restrictions to apply when searching for a router or set of routers. +data RouterRestriction = IsStable -- ^Marked with the Stable flag + | NotRouter RouterDesc -- ^Is not the given router + | NotTorAddr TorAddress -- ^Is not the given address + | ExitNode -- ^Is an exit node of some kind + | ExitNodeAllowing TorAddress Word16 + -- ^Is an exit node that allows traffic to the given + -- address and port. + +-- |Build a new router database. This database will return before it is fully +-- initialized, in order to make general start-up faster. This may mean that +-- some queries of the database will take longer upon initial loading, or when +-- the database is being refreshed periodicatly. +newRouterDatabase :: TorNetworkStack ls s -> + DirectoryDB -> (String -> IO ()) -> + IO RouterDB +newRouterDatabase ns ddb logMsg = + do rdbMV <- newEmptyMVar + _ <- forkIO (updateConsensus ns ddb logMsg rdbMV) + return (RouterDB rdbMV) + +-- |Find a router given its fingerprint. +findRouter :: RouterDB -> [ExtendSpec] -> IO (Maybe RouterDesc) +findRouter (RouterDB routerDB) specs = + (find matchesSpecs . rdbRouters) `fmap` readMVar routerDB + where + matchesSpecs x = any (matchSpec x) specs + -- + matchSpec r (ExtendIP4 x p) = + ((routerIPv4Address r) == x && (routerORPort r) == p) + || ((x,p) `elem` (routerAlternateORAddresses r)) + matchSpec r (ExtendIP6 x p) = + (x,p) `elem` (routerAlternateORAddresses r) + matchSpec r (ExtendDigest x) = + x == keyHash' sha256 (routerSigningKey r) + +-- |Fetch a router matching the given restrictions. The restrictions list should +-- be thought of an "AND" with a default of True given the empty list. This +-- routine may take awhile to find a suitable entry if the restrictions are +-- cumbersome or if the database is being reloaded. +getRouter :: RouterDB -> [RouterRestriction] -> TorRNG -> + IO (TorRNG, RouterDesc) +getRouter (RouterDB routerDB) restrictions rng = + do curdb <- readMVar routerDB + let (_, entriesPossib) = bounds (rdbRouters curdb) + loop (rdbRouters curdb) (entriesPossib + 1) rng + where + loop entries idxMod g = + do let (randBS, g') = randomBytesGenerate 8 g + randWord <- fromIntegral <$> runGetIO getWord64be randBS + let v = entries ! (randWord `mod` idxMod) + if v `meetsRestrictions` restrictions + then return (g', v) + else loop entries idxMod g' + -- + runGetIO getter bstr = + case runGet getter bstr of + Left _ -> fail "Cannot read 64-bit Word from 64 bytes ..." + Right x -> return x + +-- |Returns true iff the given router meets all the given restrictions. (If no +-- restrictions are provided, then the router meets all of them.) +meetsRestrictions :: RouterDesc -> [RouterRestriction] -> Bool +meetsRestrictions _ [] = True +meetsRestrictions rtr (r:rest) = + case r of + IsStable | "Stable" `elem` routerStatus rtr -> meetsRestrictions rtr rest + | otherwise -> False + NotRouter rdesc | rtr == rdesc -> False + | otherwise -> meetsRestrictions rtr rest + NotTorAddr taddr | isSameAddr taddr rtr -> False + | otherwise -> meetsRestrictions rtr rest + ExitNode | allowsExits (routerExitRules rtr) -> meetsRestrictions rtr rest + | otherwise -> False + ExitNodeAllowing a p + | allowsExit (routerExitRules rtr) a p -> meetsRestrictions rtr rest + | otherwise -> False + where + isSameAddr (IP4 x) s = x == routerIPv4Address s + isSameAddr (IP6 x) s = x `elem` map fst (routerAlternateORAddresses s) + isSameAddr _ _ = False + -- + allowsExits (ExitRuleReject AddrSpecAll PortSpecAll : _) = False + allowsExits _ = True + +-- |Returns true iff the given exit rules allow traffic to the given address / +-- port pair. +allowsExit :: [ExitRule] -> TorAddress -> Word16 -> Bool +allowsExit [] _ _ = True -- "if no rule matches, the address wil be accepted" +allowsExit (ExitRuleAccept addrrule portrule : rrest) addr port + | addrMatches addr addrrule && portMatches port portrule = True + | otherwise = allowsExit rrest addr port +allowsExit (ExitRuleReject addrrule portrule : rrest) addr port + | addrMatches addr addrrule && portMatches port portrule = False + | otherwise = allowsExit rrest addr port + +portMatches :: Word16 -> PortSpec -> Bool +portMatches _ PortSpecAll = True +portMatches p (PortSpecRange p1 p2) = (p >= p1) && (p <= p2) +portMatches p (PortSpecSingle p') = p == p' + +addrMatches :: TorAddress -> AddrSpec -> Bool +addrMatches (Hostname _) _ = False +addrMatches (TransientError _) _ = False +addrMatches (NontransientError _) _ = False +addrMatches _ AddrSpecAll = True +addrMatches (IP4 addr) (AddrSpecIP4 addr') = addr == addr' +addrMatches (IP4 addr) (AddrSpecIP4Mask a m) = ip4in' addr a m +addrMatches (IP4 addr) (AddrSpecIP4Bits a b) = ip4in addr a b +addrMatches (IP4 _) (AddrSpecIP6 _) = False +addrMatches (IP4 _) (AddrSpecIP6Bits _ _) = False +addrMatches (IP6 _) (AddrSpecIP4 _) = False +addrMatches (IP6 _) (AddrSpecIP4Mask _ _) = False +addrMatches (IP6 _) (AddrSpecIP4Bits _ _) = False +addrMatches (IP6 addr) (AddrSpecIP6 addr') = addr `ip6eq` addr' +addrMatches (IP6 addr) (AddrSpecIP6Bits a b) = ip6in addr a b + +ip4in' :: String -> String -> String -> Bool +ip4in' addr addr' mask = + masked (unAddr IP4 addr) mask' == masked (unAddr IP4 addr') mask' + where mask' = generateMaskFromMask mask + +ip4in :: String -> String -> Int -> Bool +ip4in addr addr' bits = + masked (unAddr IP4 addr) mask == masked (unAddr IP4 addr') mask + where mask = generateMaskFromBits bits 4 + +ip6in :: String -> String -> Int -> Bool +ip6in addr addr' bits = + masked (unAddr IP6 addr) mask == masked (unAddr IP6 addr') mask + where mask = generateMaskFromBits bits 16 + +ip6eq :: String -> String -> Bool +ip6eq addr1 addr2 = expandIPv6 addr1 == expandIPv6 addr2 + +unAddr :: (a -> TorAddress) -> a -> [Word8] +unAddr b = unpack . torAddressByteString . b + +generateMaskFromMask :: String -> [Word8] +generateMaskFromMask x = unAddr IP4 x + +generateMaskFromBits :: Int -> Int -> [Word8] +generateMaskFromBits bits len + | len == 0 = [] + | bits == 0 = 0 : generateMaskFromBits bits (len - 1) + | bits >= 8 = 255 : generateMaskFromBits (bits - 8) (len - 1) + | otherwise = (255 `shiftL` (8 - len)) : generateMaskFromBits 0 (len - 1) + +masked :: Bits a => [a] -> [a] -> [a] +masked a m = zipWith xor a m + +expandIPv6 :: String -> [Word8] +expandIPv6 = unAddr IP6 + +-- |The thread that updates the consensus document over time. +updateConsensus :: TorNetworkStack ls s -> + DirectoryDB -> (String -> IO ()) -> + MVar RouterDBVersion -> + IO () +updateConsensus ns ddb logMsg rdbMV = runUpdates =<< drgNew + where + runUpdates g = + do (res, g') <- runStateT g (runExceptionT update) + case res of + Right () -> return () + Left err -> logMsg ("Issue updating consensus document: " ++ err) + runUpdates g' + -- + update :: ExceptionT String (StateT TorRNG IO) () + update = + do logMsg' "String consensus document update." + dir <- withRNG (\ g -> inBase (getRandomDirectory g ddb)) + logMsg' ("Using directory " ++ dirNickname dir ++ " for consensus.") + let addr = dirAddress dir ; port = dirDirPort dir + (census, sha1dig, sha256dig) <- fetch' addr port ConsensusDocument + let sigs = conSignatures census + forM_ (conAuthorities census) (inBase . addDirectory ns logMsg ddb) + validSigs <- inBase (getValidSignatures ddb sha1dig sha256dig sigs) + when (length validSigs < 5) $ + raise "Couldn't get at least 5 valid signantures on consensus." + logMsg' ("Found enough valid signatures: " ++ intercalate ", " validSigs) + rdtable <- fetch' addr port Descriptors + let routers = filter goodRouter (conRouters census) + let table' = mapMaybe (crossReference rdtable) routers + logMsg' ("New router processing complete. " ++ show (length table') ++ + " of " ++ show (length routers) ++ " routers available.") + oldRdb <- inBase (tryTakeMVar rdbMV) + let rev = maybe 1 (succ . rdbRevision) oldRdb + arr = listArray (0, fromIntegral (length table' - 1)) table' + inBase (putMVar rdbMV (RDB rev arr)) + nextTime <- withRNG (return . computeNextTime census) + logMsg' ("Will reload census at "++showTime nextTime) + inBase $ waitUntil nextTime + logMsg' "Consensus expired. Reloading." + -- + crossReference rdtable rtr = + case Map.lookup (rtrIdentity rtr) rdtable of + Nothing -> Nothing + Just d -> Just d{ routerStatus = rtrStatus rtr } + -- + fetch' :: Fetchable a => + String -> Word16 -> FetchItem -> + ExceptionT String (StateT TorRNG IO) a + fetch' a p d = + do m <- inBase (fetch ns a p d) + case m of + Left err -> raise ("Couldn't get " ++ show d ++ ": " ++ err) + Right x -> return x + -- + withRNG :: (TorRNG -> IO (a, TorRNG)) -> ExceptionT String (StateT TorRNG IO) a + withRNG action = + do g <- get + (res, g') <- inBase (action g) + set g' + return res + -- + logMsg' = inBase . logMsg + -- + goodRouter r = + let s = rtrStatus r + in ("Valid" `elem` s) && ("Running" `elem` s) && ("Fast" `elem` s) + showTime = timePrint [Format_Hour, Format_Text ':', Format_Minute] + +getValidSignatures :: DirectoryDB -> ByteString -> ByteString -> + [(Bool, ByteString, ByteString, ByteString)] -> + IO [String] +getValidSignatures ddb sha1dig sha256dig sigs = + catMaybes <$> + (forM sigs $ \ (isSHA1, ident, _, sig) -> + do mdir <- findDirectory ident ddb + -- FIXME: Do something more useful in the failure cases? + case mdir of + Nothing -> return Nothing + Just dir -> + do let digest = if isSHA1 then sha1dig else sha256dig + key = dirSigningKey dir + if verify noHash key digest sig + then return (Just (dirNickname dir)) + else return Nothing) + +computeNextTime :: DRG g => + Consensus -> g -> + (DateTime, g) +computeNextTime consensus g = (timeAdd lowest diffAmt, g') + where + validAfter = conValidAfter consensus + freshUntil = conFreshUntil consensus + validUntil = conValidUntil consensus + interval = timeDiff freshUntil validAfter + lowest = timeAdd freshUntil (mulSeconds 0.75 interval) + interval' = timeDiff validUntil lowest + highest = timeAdd lowest (mulSeconds 0.875 interval') + diff = timeDiff highest lowest + (bstr, g') = randomBytesGenerate 8 g + Right amt = runGet ((Seconds . fromIntegral)`fmap` getWord64be) bstr + diffAmt = amt `mod` diff + -- + mulSeconds :: Double -> Seconds -> Seconds + mulSeconds f (Seconds s) = Seconds (round (f * fromIntegral s)) + +waitUntil :: DateTime -> IO () +waitUntil time = + do now <- getCurrentTime + if now > time + then return () + else do threadDelay 100000 -- (5 * 60 * 1000000) -- 5 minutes + waitUntil time diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,12 @@ +import Test.Framework.Runners.Console +import Test.Handshakes +import Test.HybridEncrypt +import Test.TorCell + +main :: IO () +main = + defaultMain [ + torCellTests + , hybridEncryptionTest + , handshakeTests + ]