{-# LANGUAGE CPP               #-}
{-# LANGUAGE MultiWayIf        #-}
{-# LANGUAGE OverloadedStrings #-}
-- |Routines for parsing router descriptions from a directory listing.
module Tor.DataFormat.RouterDesc(
         parseDirectory
       )
 where

import Control.Applicative
#if MIN_VERSION_cryptonite(0,9,0)
import Crypto.Error
#endif
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 toEither (Curve.publicKey x) of
       Left err -> fail ("Failure decoding curve25519 public key: " ++ err)
       Right k  -> return r{ routerNTorOnionKey = Just k }
 where
#if MIN_VERSION_cryptonite(0,9,0)
   toEither (CryptoPassed x) = Right x
   toEither (CryptoFailed e) = Left (show e)
#else
   toEither = id
#endif

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"