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