{-# LANGUAGE OverloadedStrings #-}
-- | This module contains a very basic HTTP client. At the moment, it doesn't
--   even handle redirects for you.
--
--   Note that, in order to use SSL, you need to have the root CA certificates
--   in a PEM file in @/etc/ssh/certs.pem@ and you need to have wrapped your
--   main function in 'OpenSSL.withOpenSSL'
module Network.MiniHTTP.Client
  ( fetchBasic
  , connection
  , transport
  , request
  ) where

import           Control.Monad (when)
import           Control.Concurrent.STM
import           Control.Exception (handle, throwIO)

import qualified Data.Binary.Put as P
import qualified Data.ByteString as B
import           Data.ByteString.Internal (w2c)
import qualified Data.ByteString.Lazy as BL
import           Data.Maybe (isNothing)
import           Data.String

import qualified Network.Connection as C
import qualified Network.DNS.Client as DNS
import qualified Network.DNS.Types as DNS
import           Network.MiniHTTP.Marshal
import           Network.MiniHTTP.HTTPConnection
import qualified Network.MiniHTTP.URL as URL
import           Network.Socket

import           System.IO.Unsafe (unsafePerformIO)

import qualified OpenSSL.Session as SSL
import qualified OpenSSL.X509 as X509


readReply :: C.Connection -> IO (Maybe (Reply, Maybe Source))
readReply conn = do
  r <- readIG conn 256 4096 parseReply
  case r of
       Nothing -> return Nothing
       Just reply ->
         case httpContentLength $ replyHeaders reply of
              Nothing ->
                if "chunked" `elem` (httpTransferEncoding $ replyHeaders reply)
                   then do
                     source <- connChunkedSource conn
                     return $ Just (reply, Just source)
                   else do
                     source <- connEOFSource conn
                     return $ Just (reply, Just source)
              Just n -> do
                source <- connSource n B.empty conn
                return $ Just (reply, Just source)

-- | A lower level HTTP client, but it allows you to perform POSTs etc
request :: C.Connection  -- ^ the connection to use
        -> Request  -- ^ a request to serialise
        -> Maybe Source  -- ^ a possible payload (for POSTs etc)
        -> IO (Maybe (Reply, Maybe Source))
request conn req msource = do
  let requestBytes = B.concat $ BL.toChunks $ P.runPut $ putRequest req
  atomically $ C.write conn requestBytes
  let lowWater = 32 * 1024

  case msource of
       (Just source) -> do
         success <- if isNothing $ httpContentLength $ reqHeaders req
                       then streamSourceChunked lowWater conn source
                       else streamSource lowWater conn source
         if not success
            then return Nothing
            else readReply conn
       Nothing -> readReply conn

globalOpenSSLClientContext :: SSL.SSLContext
globalOpenSSLClientContext = unsafePerformIO $ do
  ctx <- SSL.context
  SSL.contextSetDefaultCiphers ctx
  SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer False False
  SSL.contextSetCAFile ctx "/etc/ssl/cert.pem"
  return ctx

-- | Construct a connection to the correct host for the given URL. (i.e.
--   resolve the hostname and create a TCP connection to the correct port).
--
--   Note that the DNS resolution (if any) doesn't block the whole process.
connection :: URL.URL
           -> IO Socket
connection (URL.URL { URL.urlHost = URL.IPv4Literal host, URL.urlPort = port }) = do
  sock <- socket AF_INET Stream 0
  connect sock $ SockAddrInet (fromIntegral port) host
  return sock

connection (URL.URL { URL.urlHost = URL.IPv6Literal host, URL.urlPort = port }) = do
  sock <- socket AF_INET6 Stream 0
  connect sock $ SockAddrInet6 (fromIntegral port) 0 host 0
  return sock

connection (URL.URL { URL.urlHost = URL.Hostname hostname, URL.urlPort = port }) = do
  r <- DNS.resolve DNS.A $ map w2c $ B.unpack hostname
  case r of
       Left error -> fail $ show error
       Right [] -> fail "DNS returned no A records"
       Right (((_, DNS.RRA (haddr:_))):_) -> do
         sock <- socket AF_INET Stream 0
         connect sock $ SockAddrInet (fromIntegral port) haddr
         return sock

-- | Setup the transport (i.e. SSL) for the given URL. In the case of a HTTP
--   scheme, this just wraps the socket in a Connection.
transport :: URL.URL -> Socket -> IO C.Connection
transport (URL.URL { URL.urlScheme = URL.HTTP }) sock =
  C.new (return ()) $ C.baseConnectionFromSocket sock

transport (URL.URL { URL.urlScheme = URL.HTTPS, URL.urlHost = URL.Hostname hostname }) sock = do
  ssl <- SSL.connection globalOpenSSLClientContext sock
  SSL.connect ssl
  verified <- SSL.getVerifyResult ssl
  when (not verified) $ fail "Failed to verify SSL server certificate"
  mcert <- SSL.getPeerCertificate ssl
  case mcert of
       Nothing -> fail "No server certificate"
       Just cert -> do
         subjects <- X509.getSubjectName cert True
         case "commonName" `lookup` subjects of
              Nothing -> fail "No hostname in certificate"
              Just h -> do
                when (fromString h /= hostname) $ fail $
                  "Hostname doesn't match certificate (" ++
                   h ++ " vs " ++ show hostname ++ ")"
                conn <- C.new (return ()) $ sslToBaseConnection ssl
                return conn

transport _ _ = fail "Cannot create HTTPS connection to an IP address (cannot check certificate)"

-- | Fetch an HTTP(S) entity.
fetchBasic :: Headers  -- ^ the headers to use. This function will set the Host
                       --   header for you in the case that the URL has a
                       --   hostname in it. If in doubt, use 'emptyHeaders'
           -> URL.URL  -- ^ the resource to fetch
           -> IO (C.Connection, Reply, Maybe Source)
              -- ^ the connection (which you have to close once you are done
              --   reading the 'Source', if any), the Reply and a possible
              --   payload
fetchBasic headers url = do
  sock <- connection url
  handle (\e -> sClose sock >> throwIO e) $ do
    conn <- transport url sock
    let headers' = case URL.urlHost url of
                        URL.Hostname h -> headers { httpHost = Just h }
                        _ -> headers
    r <- request conn (Request GET (URL.toRelative url) 1 1 headers') Nothing
    case r of
         Nothing -> C.close conn >> fail "HTTP parse error"
         (Just (reply, msource)) -> return (conn, reply, msource)