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