packages feed

haskell-tor (empty) → 0.1.0.0

raw patch · 36 files changed

+7364/−0 lines, 36 filesdep +HALVMCoredep +HUnitdep +QuickChecksetup-changed

Dependencies added: HALVMCore, HUnit, QuickCheck, XenDevice, array, asn1-encoding, asn1-types, async, attoparsec, base, base64-bytestring, binary, bytestring, cereal, containers, cryptonite, fingertree, hans, haskell-tor, hourglass, memory, monadLib, network, pretty-hex, pure-zlib, test-framework, test-framework-hunit, test-framework-quickcheck2, time, tls, x509, x509-store

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ exe/Main.hs view
@@ -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
+ haskell-tor.cabal view
@@ -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
+ src/Crypto/Hash/Easy.hs view
@@ -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
+ src/Crypto/PubKey/RSA/KeyHash.hs view
@@ -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
+ src/Data/Hourglass/Now.hs view
@@ -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{..}++
+ src/Tor.hs view
@@ -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+++
+ src/Tor/Circuit.hs view
@@ -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)
+ src/Tor/DataFormat/Consensus.hs view
@@ -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."
+ src/Tor/DataFormat/DefaultDirectory.hs view
@@ -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))+
+ src/Tor/DataFormat/DirCertInfo.hs view
@@ -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
+ src/Tor/DataFormat/Helpers.hs view
@@ -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 "<name> <thing>\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
+ src/Tor/DataFormat/RelayCell.hs view
@@ -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."++
+ src/Tor/DataFormat/RouterDesc.hs view
@@ -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"
+ src/Tor/DataFormat/TorAddress.hs view
@@ -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)
+ src/Tor/DataFormat/TorCell.hs view
@@ -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)+
+ src/Tor/HybridCrypto.hs view
@@ -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
+ src/Tor/Link.hs view
@@ -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
+ src/Tor/Link/CipherSuites.hs view
@@ -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+  }++
+ src/Tor/Link/DH.hs view
@@ -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+   }
+ src/Tor/NetworkStack.hs view
@@ -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+  }
+ src/Tor/NetworkStack/Fetch.hs view
@@ -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 ()+
+ src/Tor/NetworkStack/Hans.hs view
@@ -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)+
+ src/Tor/NetworkStack/System.hs view
@@ -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+
+ src/Tor/Options.hs view
@@ -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 ' ']++
+ src/Tor/RNG.hs view
@@ -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
+ src/Tor/RouterDesc.hs view
@@ -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)++
+ src/Tor/RouterDesc/Render.hs view
@@ -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++
+ src/Tor/State/CircuitManager.hs view
@@ -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
+ src/Tor/State/Credentials.hs view
@@ -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
+ src/Tor/State/Directories.hs view
@@ -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"+  ]
+ src/Tor/State/LinkManager.hs view
@@ -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 ()
+ src/Tor/State/Routers.hs view
@@ -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
+ test/Test.hs view
@@ -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+  ]