content: -- |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"
    ]
  