content: -- |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))
  
  
  #if !MIN_VERSION_base(4,7,0)
  -- Note that this implementation is flawed and requires extra care to avoid
  -- blocking on putMVar.
  -- See the discussion on
  -- https://mail.haskell.org/pipermail/haskell-cafe/2004-September/006732.html
  tryReadMVar :: MVar a -> IO (Maybe a)
  tryReadMVar mv =
    do mc <- tryTakeMVar mv
       case mc of
         Nothing -> return mc
         Just v  -> putMVar mv v >> return mc
  
  isLeft :: Either a b -> Bool
  isLeft Left {} = True
  isLeft _ = False
  #endif
  
  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 <- toEither (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            = toEither (publicKey keyid)
    Right bigX            = toEither (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 <- toEither (publicKey public_pk) =
        Left ("Couldn't decode bigY: "++err)
    | Left err <- toEither (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         = toEither (publicKey public_pk)
    Right bigB         = toEither (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 toEither (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)
  
  #if MIN_VERSION_cryptonite(0,9,0)
  toEither :: CryptoFailable a -> Either String a
  toEither (CryptoPassed x) = Right x
  toEither (CryptoFailed e) = Left (show e)
  #else
  toEither :: Either String a -> Either String a
  toEither = id
  #endif
  