content: {-# LANGUAGE MultiWayIf        #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards   #-}
  -- |Miscellaneous very useful parsing routines.
  module Tor.DataFormat.Helpers(
           PortSpec(..)
         , AddrSpec(..)
         , standardLine
         , nickname
         , hexDigest
         , port
         , addrSpec
         , portSpec
         , ip4
         , ip6
         , publicKey, publicKey'
         , utcTime
         --
         , bool
         , char8
         , alphaNum
         , decDigit
         , hexDigit
         , base64Char
         , decimalNum
         , whitespace, whitespace1
         , sp
         , nl, newline
         --
         , toString
         , readHex
         , decodeBase64
         )
   where
  
  import Control.Applicative
  import Crypto.PubKey.RSA
  import Data.ASN1.BinaryEncoding
  import Data.ASN1.Encoding
  import Data.ASN1.Types
  import Data.Attoparsec.ByteString
  import Data.ByteString.Char8(pack)
  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 Data.Word
  import Tor.RouterDesc
  
  -- |Parse a standard line of "<name> <thing>\n".
  standardLine :: String -> Parser a -> Parser a
  standardLine thing parser =
    do _ <- string (pack thing)
       _ <- sp
       x <- parser
       _ <- nl
       return x
  
  -- |Parse a Tor nickname.
  nickname :: Parser String
  nickname =
    do first <- alphaNum
       toString <$> run 1 [first]
    <?> "nickname"
   where
    run :: Int -> [Word8] -> Parser [Word8]
    run 20 acc = return (reverse acc)
    run x  acc =
      do next <- option Nothing (Just <$> alphaNum)
         case next of
           Nothing  -> return (reverse acc)
           Just c   -> run (x + 1) (c : acc)
  
  -- |Parse a 20 byte hex digest.
  hexDigest :: Parser ByteString
  hexDigest = (readHex . toString) <$> count 40 hexDigit
  
  -- |Parse a port specifier
  portSpec :: Parser PortSpec
  portSpec = choice [ allPorts, somePorts, onePort ] <?> "portSpec"
   where
    allPorts =
      do _ <- char8 '*'
         return PortSpecAll
    somePorts =
      do p1 <- port False
         _  <- char8 '-'
         p2 <- port False
         return (PortSpecRange p1 p2)
    onePort =
      do p <- port False
         return (PortSpecSingle p)
  
  -- |Parse a port number.
  port :: Bool -> Parser Word16
  port zeroOK =
    do base <- toString <$> many1 decDigit
       let result = read base :: Integer
       if | (result >= 1) && (result <= 65535) -> return (fromIntegral result)
          | zeroOK        &&  result == 0      -> return 0
          | otherwise                          -> empty
    <?> "port"
  
  -- |Parse an address specifier.
  addrSpec :: Parser AddrSpec 
  addrSpec = choice [ allAddrs, ip4Addrs, ip6Addrs ]
   where
    allAddrs  = char8 '*' >> return AddrSpecAll
    ip4Addrs  = choice [ip4Mask, ip4Bits, ip4Single]
    ip6Addrs  = choice [ip6Bits, ip6Single]
    ip4Mask   = do a <- ip4
                   _ <- char8 '/'
                   b <- ip4mask
                   return (AddrSpecIP4Mask a b)
    ip4Bits   = do a <- ip4
                   _ <- char8 '/'
                   b <- num_ip4_bits
                   return (AddrSpecIP4Bits a b)
    ip4Single = AddrSpecIP4 <$> ip4
    ip6Bits   = do a <- ip6
                   _ <- char8 '/'
                   b <- num_ip6_bits
                   return (AddrSpecIP6Bits a b)
    ip6Single = AddrSpecIP6 <$> ip6
    --
    ip4mask   = ip4
    --
    num_ip4_bits = decimalNum (<= 32)
    num_ip6_bits = decimalNum (<= 128)
  
  -- |Parse an IPv4 address.
  ip4 :: Parser String
  ip4 =
    do a <- decimalNum ip4num
       _ <- char8 '.'
       b <- decimalNum ip4num
       _ <- char8 '.'
       c <- decimalNum ip4num
       _ <- char8 '.'
       d <- decimalNum ip4num
       return (show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d)
   where
    ip4num :: Int -> Bool
    ip4num x = x < 256
  
  -- |Parse an IPv6 address; assuming [0000:1111:....] format, with braces.
  ip6 :: Parser String
  ip6 = do
    _ <- char8 '[' -- FIXME: This parser is terrible
    a <- many1 (satisfy (\ x -> isHexDigit x || x == 58))
    _ <- char8 ']'
    return (toString a)
  
  -- |Parse a public key. Returns both the public key and the raw data behind it.
  publicKey' :: Parser (PublicKey, ByteString)
  publicKey' =
    do _ <- string "-----BEGIN RSA PUBLIC KEY-----\n"
       let end = string "-----END RSA PUBLIC KEY-----\n"
       bstr <- decodeBase64 =<< manyTill base64Char end
       case decodeASN1' DER bstr of
         Left  _    -> empty
         Right asn1 ->
           case fromASN1' asn1 of
             Left  _ -> empty
             Right x -> return (x, bstr)
   where
    fromASN1' (Start Sequence : IntVal n : IntVal e : End Sequence : _) =
      Right (PublicKey { public_size = calculate_modulus n 1
                       , public_n    = n
                       , public_e    = e
                       })
    fromASN1' _ = Left ("fromASN1: RSA PublicKey: unexpected format" :: String)
    --
    calculate_modulus n i =
      if (2 ^ (i * 8)) > n then i else calculate_modulus n (i + 1)
  
  -- |Parse a public key.
  publicKey :: Parser PublicKey
  publicKey = fst <$> publicKey'
  
  -- |Parse a timestamp in UTC format.
  utcTime :: Parser DateTime
  utcTime =
    do dateYear  <- toEnum' `fmap` count 4 decDigit
       _         <- char8 '-'
       dateMonth <- toEnum' `fmap` count 2 decDigit
       _         <- char8 '-'
       dateDay   <- toEnum' `fmap` count 2 decDigit
       _         <- char8 ' '
       todHour   <- toEnum' `fmap` count 2 decDigit
       _         <- char8 ':'
       todMin    <- toEnum' `fmap` count 2 decDigit
       _         <- char8 ':'
       todSec    <- toEnum' `fmap` count 2 decDigit
       let todNSec = 0
           dtDate = Date { .. }
           dtTime = TimeOfDay { .. }
       return DateTime{..}
   where
    toEnum' :: Enum a => [Word8] -> a
    toEnum' = toEnum . read . BSC.unpack . BS.pack
  
  -- ----------------------------------------------------------------------------
  
  -- |Parse a boolean. (0/1)
  bool :: Parser Bool
  bool = choice [ true, false ]
   where
    true  = char8 '1' >> return True
    false = char8 '0' >> return False
  
  -- |Parse a character.
  char8 :: Char -> Parser Word8
  char8 c = word8 (fromIntegral (ord c))
  
  -- |Parse an alphanumeric character.
  alphaNum :: Parser Word8
  alphaNum = satisfy isAlphaNum
  
  isAlphaNum :: Word8 -> Bool
  isAlphaNum = inClass (['A'..'Z']++['a'..'z']++['0'..'9'])
  
  -- |Parse a hex digit.
  hexDigit :: Parser Word8
  hexDigit = satisfy isHexDigit
  
  isHexDigit :: Word8 -> Bool
  isHexDigit = inClass (['0'..'9']++['a'..'f']++['A'..'F'])
  
  -- |Parse a decimal digit.
  decDigit :: Parser Word8
  decDigit = satisfy isDecimalDigit
  
  isDecimalDigit :: Word8 -> Bool
  isDecimalDigit = inClass ['0'..'9']
  
  -- |Parse a character in a Base64 stream.
  base64Char :: Parser Word8
  base64Char = satisfy isBase64Char
  
  isBase64Char :: Word8 -> Bool
  isBase64Char x = isAlphaNum x || (x == 10) || inClass "/+=" x
  
  -- |Parse a decimal number that matches the given predicate.
  decimalNum :: (Integral a, Read a) => (a -> Bool) -> Parser a
  decimalNum isOK =
    do n <- many1 decDigit
       case reads (toString n) of
         [(x, "")] | isOK x -> return x
         _                  -> empty
  
  -- |Eat up some whitespace.
  whitespace :: Parser ()
  whitespace = many (satisfy (inClass " \t")) >> return () <?> "whitespace"
  
  -- |Eat up at least one character of whitespace.
  whitespace1 :: Parser ()
  whitespace1 = many1 (satisfy (inClass " \t")) >> return ()
  
  -- |Eat some amount of whitespace and then a newline.
  newline :: Parser ()
  newline = whitespace >> word8 10 >> return ()
  
  -- |Read a space.
  sp :: Parser Word8
  sp = char8 ' '
  
  -- |Read a newline.
  nl :: Parser Word8
  nl = char8 '\n'
  
  -- ----------------------------------------------------------------------------
  
  -- |Convert a series of bytes into a character string.
  toString :: [Word8] -> String
  toString = map (chr . fromIntegral)
  
  -- |Read a hex number into a bytestring in the obvious way.
  readHex :: String -> ByteString
  readHex []  = BS.empty
  readHex [_] = error "Attempted to readHex an odd-lengthed string."
  readHex (a:b:rest) = 
    let x = fromIntegral ((digitToInt a * 16) + digitToInt b)
    in BS.cons x (readHex rest)
  
  -- |Decode a series of characters as a Base64 stream.
  decodeBase64 :: [Word8] -> Parser ByteString
  decodeBase64 bytes =
    case decode (BS.pack (filter (/= 10) bytes)) of
      Left _    -> empty
      Right res -> return res
  