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