content: -- |Automatic fetching and decoding of resources needed for Tor; specifically,
  -- this hides a lot of the HTTP GET cruft that would otherwise be sprinkled
  -- about the code.
  --
  -- Users should avoid using this module for long-term projects. It ended up both
  -- growing a little bit beyond what was intended, and also managed to be less
  -- generally useful than I had thought. Thus, I suspect this module will be
  -- overhauled in the not-too-distant future.
  --
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE OverloadedStrings #-}
  module Tor.NetworkStack.Fetch(
           FetchItem(..)
         , Fetchable
         , fetch
         , readResponse
         )
   where
  
  -- FIXME: This whole interface could use a re-think.
  
  import Codec.Compression.Zlib
  import Control.Exception
  import Crypto.Hash.Easy
  import Crypto.PubKey.RSA.KeyHash
  import Data.Attoparsec.ByteString
  import Data.ByteString(ByteString)
  import qualified Data.ByteString as S
  import qualified Data.ByteString.Lazy as L
  import Data.ByteString.Lazy.Char8(pack)
  import Data.Either
  import Data.Map(Map)
  import qualified Data.Map as Map
  import Data.Word
  import System.IO.Unsafe
  import System.Timeout
  import Tor.DataFormat.Consensus
  import Tor.DataFormat.DirCertInfo
  import Tor.DataFormat.Helpers
  import Tor.DataFormat.RouterDesc
  import Tor.NetworkStack
  import Tor.RouterDesc
  
  -- |A set of types that are automatically fetchable by this subsystem.
  class Fetchable a where
    -- |Parse a blob of incoming data, emitting either an error string of the
    -- item. A moral equivalent to ReadS, except for ByteStrings, and we're
    -- not planning to make this widely used.
    parseBlob :: ByteString -> Either String a
  
  instance Fetchable DirectoryCertInfo where
    parseBlob = parseDirectoryCertInfo
  
  instance Fetchable (Consensus, ByteString, ByteString) where
    parseBlob = parseConsensusDocument
  
  instance Fetchable (Map ByteString RouterDesc) where
    parseBlob bstr = Right (convertEntries Map.empty xs)
     where
      (_, xs) = partitionEithers (parseDirectory bstr)
      --
      convertEntries m []    = m
      convertEntries m (d:r) =
        convertEntries (Map.insert (keyHash' sha1 (routerSigningKey d)) d m) r
  
  -- |One of the things we can automatically fetch.
  data FetchItem = ConsensusDocument
                 | KeyCertificate
                 | Descriptors
   deriving (Show)
  
  -- |Given an item to fetch, get the directory and file name for that thing.
  fetchItemFile :: FetchItem -> String
  fetchItemFile ConsensusDocument = "/tor/status-vote/current/consensus.z"
  fetchItemFile KeyCertificate    = "/tor/keys/authority.z"
  fetchItemFile Descriptors       = "/tor/server/all.z"
  
  -- |Given an item to fetch, get a time we should be willing to wait to download
  -- and process that item.
  fetchItemTime :: FetchItem -> Int
  fetchItemTime ConsensusDocument =     60 * 1000000
  fetchItemTime KeyCertificate    =     5  * 1000000
  fetchItemTime Descriptors       = 3 * 60 * 1000000
  
  -- |Fetch the given item from the given host and port, using the given network
  -- stack, returning either the error that occurred fetching that item or the
  -- item. The String used for the host will be directly passed to the network
  -- stack's connect function without further processing, so you should think
  -- about whether that means you need to address resolution or not.
  fetch :: Fetchable a => 
           TorNetworkStack ls s ->
           String -> Word16 -> FetchItem ->
           IO (Either String a)
  fetch ns host tcpport item =
    handle (\ err -> return (Left (show (err :: SomeException)))) $
      timeout' (fetchItemTime item) $
        do msock <- connect ns host tcpport
           case msock of
             Nothing -> return (Left "Connection failure.")
             Just sock ->
               do write ns sock (buildGet (fetchItemFile item))
                  resp <- readResponse ns sock
                  case resp of
                    Left err   -> return (Left err)
                    Right body ->
                      case decompress body of
                        Nothing    -> return (Left "Decompression failure.")
                        Just body' -> return (parseBlob (L.toStrict body'))
              `finally` close ns sock
   where
    timeout' tm io =
      do res <- timeout tm io
         case res of
           Nothing -> return (Left "Fetch timed out.")
           Just x  -> return x
  
  -- |Build a GET request for the given resource.
  buildGet :: String -> L.ByteString
  buildGet str = result
   where
    result      = pack (requestLine ++ userAgent ++ crlf)
    requestLine = "GET " ++ str ++ " HTTP/1.0\r\n"
    userAgent   = "User-Agent: CERN-LineMode/2.15 libwww/2.17b3\r\n"
    crlf        = "\r\n"
  
  -- |Read the response to a GET request. This returns the parsed interior of a
  -- GET response, rather than the whole response, so one of the possible errors
  -- you might receive is an HTTP response parsing error.
  readResponse :: TorNetworkStack ls s -> s -> IO (Either String L.ByteString)
  readResponse ns sock = getResponse (parse httpResponse)
   where
    getResponse parseStep =
      do chunk <- recv ns sock 4096
         case parseStep chunk of
           Fail bstr _ err ->
             do let start = show (S.take 10 bstr)
                    msg = "Parser error: " ++ err ++ " [" ++ start ++ "]"
                return (Left msg)
           Partial f ->
             getResponse f
           Done res () ->
             (Right . L.fromChunks . (res:)) `fmap` lazyRead
    --
    lazyRead :: IO [ByteString]
    lazyRead = unsafeInterleaveIO $ do chunk <- recv ns sock 4096
                                       if S.null chunk
                                          then return []
                                          else do rest <- lazyRead
                                                  return (chunk : rest)
  
  -- |An attoparsec parser for HTTP responses. This is not, in any way, fully
  -- general.
  httpResponse :: Parser ()
  httpResponse =
    do _   <- string "HTTP/"
       _   <- decDigit
       _   <- char8 '.'
       _   <- decDigit
       _   <- sp
       v   <- decimalNum (const True)
       _   <- sp
       msg <- toString `fmap` many1 (notWord8 13)
       _   <- crlf
       if v /= (200 :: Integer)
          then fail ("HTTP Error: " ++ msg)
          else do _   <- many1 keyval
                  _   <- crlf
                  return ()
   where
    crlf = char8 '\r' >> char8 '\n'
    keyval =
      do _ <- many1 (notWord8 13)
         _ <- crlf
         return ()
  
  