Http.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Cardano.DbSync.OffChain.Http (
  httpGetOffChainPoolData,
  httpGetOffChainVoteData,
  parseAndValidateVoteData,
  parseOffChainUrl,
) where

import qualified Cardano.Crypto.Hash.Blake2b as Crypto
import qualified Cardano.Crypto.Hash.Class as Crypto
import Cardano.Db (PoolMetaHash (..), PoolUrl (..), VoteMetaHash (..), VoteUrl (..))
import qualified Cardano.Db as DB
import Cardano.DbSync.Config.Types (OffChainUserAgent (..))
import Cardano.DbSync.OffChain.Types (
  PoolOffChainMetadata (..),
  PoolTicker (..),
 )
import qualified Cardano.DbSync.OffChain.Vote.Types as Vote
import Cardano.DbSync.Types (
  OffChainFetchError (..),
  OffChainUrlType (..),
  SimplifiedOffChainPoolData (..),
  SimplifiedOffChainVoteData (..),
  showUrl,
 )
import Cardano.DbSync.Util (renderByteArray)
import Cardano.Prelude hiding (show)
import Control.Monad.Trans.Except.Extra (handleExceptT, hoistEither, left)
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.CaseInsensitive as CI
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import GHC.Show (show)
import Network.HTTP.Client (HttpException (..))
import qualified Network.HTTP.Client as Http
import Network.HTTP.Client.TLS (tlsManagerSettings)
import qualified Network.HTTP.Types as Http

-------------------------------------------------------------------------------------
-- Get OffChain data
-------------------------------------------------------------------------------------
httpGetOffChainPoolData ::
  Http.Manager ->
  Http.Request ->
  PoolUrl ->
  Maybe PoolMetaHash ->
  ExceptT OffChainFetchError IO SimplifiedOffChainPoolData
httpGetOffChainPoolData manager request purl expectedMetaHash = do
  httpRes <- handleExceptT (convertHttpException url) req
  (respBS, respLBS, mContentType) <- hoistEither httpRes
  let metadataHash = Crypto.digest (Proxy :: Proxy Crypto.Blake2b_256) respBS
  case unPoolMetaHash <$> expectedMetaHash of
    Just expectedMetaHashBs
      | metadataHash /= expectedMetaHashBs ->
          left $ OCFErrHashMismatch (Just url) (renderByteArray expectedMetaHashBs) (renderByteArray metadataHash)
    _ -> pure ()
  decodedMetadata <-
    case Aeson.eitherDecode' respLBS of
      Left err -> left $ OCFErrJsonDecodeFail (Just url) (Text.pack err)
      Right res -> pure res
  pure $
    SimplifiedOffChainPoolData
      { spodTickerName = unPoolTicker $ pomTicker decodedMetadata
      , spodHash = metadataHash
      , spodBytes = respBS
      , -- Instead of inserting the `respBS` here, we encode the JSON and then store that.
        -- This is necessary because the PostgreSQL JSON parser can reject some ByteStrings
        -- that the Aeson parser accepts.
        spodJson = Text.decodeUtf8 $ LBS.toStrict (Aeson.encode decodedMetadata)
      , spodContentType = mContentType
      }
  where
    req = httpGetBytes manager request 600 512 url
    url = OffChainPoolUrl purl

httpGetOffChainVoteData ::
  [Text] ->
  VoteUrl ->
  OffChainUserAgent ->
  Maybe VoteMetaHash ->
  DB.AnchorType ->
  ExceptT OffChainFetchError IO SimplifiedOffChainVoteData
httpGetOffChainVoteData gateways vurl userAgent metaHash anchorType = do
  case useIpfsGatewayMaybe vurl gateways of
    Nothing -> httpGetOffChainVoteDataSingle vurl userAgent metaHash anchorType
    Just [] -> left $ OCFErrNoIpfsGateway (OffChainVoteUrl vurl)
    Just urls -> tryAllGatewaysRec urls []
  where
    tryAllGatewaysRec [] acc = left $ OCFErrIpfsGatewayFailures (OffChainVoteUrl vurl) (reverse acc)
    tryAllGatewaysRec (url : rest) acc = do
      msocd <- liftIO $ runExceptT $ httpGetOffChainVoteDataSingle url userAgent metaHash anchorType
      case msocd of
        Right socd -> pure socd
        Left err -> tryAllGatewaysRec rest (err : acc)

httpGetOffChainVoteDataSingle ::
  VoteUrl ->
  OffChainUserAgent ->
  Maybe VoteMetaHash ->
  DB.AnchorType ->
  ExceptT OffChainFetchError IO SimplifiedOffChainVoteData
httpGetOffChainVoteDataSingle vurl userAgent metaHash anchorType = do
  manager <- liftIO $ Http.newManager tlsManagerSettings
  request <- parseOffChainUrl url userAgent
  let req = httpGetBytes manager request 3000000 3000000 url
  httpRes <- handleExceptT (convertHttpException url) req
  (respBS, respLBS, mContentType) <- hoistEither httpRes
  (ocvd, decodedValue, metadataHash, mWarning) <- parseAndValidateVoteData respBS respLBS metaHash anchorType (Just $ OffChainVoteUrl vurl)
  pure $
    SimplifiedOffChainVoteData
      { sovaHash = metadataHash
      , sovaBytes = respBS
      , sovaJson = Text.decodeUtf8 $ LBS.toStrict (Aeson.encode decodedValue)
      , sovaContentType = mContentType
      , sovaOffChainVoteData = ocvd
      , sovaWarning = mWarning
      }
  where
    url = OffChainVoteUrl vurl

parseAndValidateVoteData :: ByteString -> LBS.ByteString -> Maybe VoteMetaHash -> DB.AnchorType -> Maybe OffChainUrlType -> ExceptT OffChainFetchError IO (Vote.OffChainVoteData, Aeson.Value, ByteString, Maybe Text)
parseAndValidateVoteData bs lbs metaHash anchorType murl = do
  let metadataHash = Crypto.digest (Proxy :: Proxy Crypto.Blake2b_256) bs
  (hsh, mWarning) <- case unVoteMetaHash <$> metaHash of
    Just expectedMetaHashBs
      | metadataHash /= expectedMetaHashBs ->
          left $ OCFErrHashMismatch murl (renderByteArray expectedMetaHashBs) (renderByteArray metadataHash)
    _ -> pure (metadataHash, Nothing)
  decodedValue <-
    case Aeson.eitherDecode' @Aeson.Value lbs of
      Left err -> left $ OCFErrJsonDecodeFail murl (Text.pack err)
      Right res -> pure res
  ocvd <-
    case Vote.eitherDecodeOffChainVoteData lbs anchorType of
      Left err -> left $ OCFErrJsonDecodeFail murl (Text.pack err)
      Right res -> pure res
  pure (ocvd, decodedValue, hsh, mWarning)

httpGetBytes ::
  Http.Manager ->
  Http.Request ->
  Int ->
  Int ->
  OffChainUrlType ->
  IO (Either OffChainFetchError (ByteString, LBS.ByteString, Maybe ByteString))
httpGetBytes manager request bytesToRead maxBytes url =
  Http.withResponse request manager $ \responseBR -> do
    runExceptT $ do
      let status = Http.responseStatus responseBR
      unless (Http.statusCode status == 200)
        . left
        $ OCFErrHttpResponse url (Http.statusCode status) (Text.decodeLatin1 $ Http.statusMessage status)

      respLBS <- liftIO $ Http.brReadSome (Http.responseBody responseBR) bytesToRead
      let respBS = LBS.toStrict respLBS

      let mContentType = List.lookup Http.hContentType (Http.responseHeaders responseBR)
      case mContentType of
        Nothing -> pure () -- If there is no "content-type" header, assume its JSON.
        Just ct -> do
          -- There are existing pool metadata URLs in the database that specify a content type of
          -- "text/html" but provide pure valid JSON.
          -- Eventually this hack should be removed.
          if "text/html" `BS.isInfixOf` ct && isPossiblyJsonObject respBS
            then pure ()
            else do
              when ("text/html" `BS.isInfixOf` ct) $
                left $
                  OCFErrBadContentTypeHtml url (Text.decodeLatin1 ct)
              unless
                ( "application/json"
                    `BS.isInfixOf` ct
                    || "application/ld+json"
                      `BS.isInfixOf` ct
                    || "text/plain"
                      `BS.isInfixOf` ct
                    || "binary/octet-stream"
                      `BS.isInfixOf` ct
                    || "application/octet-stream"
                      `BS.isInfixOf` ct
                    || "application/binary"
                      `BS.isInfixOf` ct
                )
                . left
                $ OCFErrBadContentType url (Text.decodeLatin1 ct)

      unless (BS.length respBS <= maxBytes)
        . left
        $ OCFErrDataTooLong url
      pure (respBS, respLBS, mContentType)

-- | Is the provided ByteSring possibly JSON object?
-- Ignoring any leading whitespace, if the ByteString starts with a '{` character it might possibly
-- be a JSON object. We are are really only interested in differentiating between JSON and HTML
-- (where the first non-whitespace character will be '<'.
isPossiblyJsonObject :: ByteString -> Bool
isPossiblyJsonObject bs =
  case BS.uncons (BS.strip bs) of
    Just ('{', _) -> True
    _otherwise -> False

-------------------------------------------------------------------------------------
-- Url
-------------------------------------------------------------------------------------
parseOffChainUrl :: OffChainUrlType -> OffChainUserAgent -> ExceptT OffChainFetchError IO Http.Request
parseOffChainUrl url userAgent =
  handleExceptT wrapHttpException $ applyHeaders userAgent <$> Http.parseRequest (showUrl url)
  where
    wrapHttpException :: HttpException -> OffChainFetchError
    wrapHttpException err = OCFErrHttpException url (textShow err)

applyHeaders :: OffChainUserAgent -> Http.Request -> Http.Request
applyHeaders (OffChainUserAgent mUserAgent) req =
  req
    { Http.requestHeaders =
        Http.requestHeaders req
          ++ [ (CI.mk "content-type", "application/json")
             , (CI.mk "user-agent", Text.encodeUtf8 userAgent)
             ]
    }
  where
    userAgent = fromMaybe "cardano-db-sync" mUserAgent

-------------------------------------------------------------------------------------
-- Exceptions to Error
-------------------------------------------------------------------------------------
convertHttpException :: OffChainUrlType -> HttpException -> OffChainFetchError
convertHttpException url he =
  case he of
    HttpExceptionRequest _req hec ->
      case hec of
        Http.ResponseTimeout -> OCFErrTimeout url "Response"
        Http.ConnectionTimeout -> OCFErrTimeout url "Connection"
        Http.ConnectionFailure {} -> OCFErrConnectionFailure url
        Http.TooManyRedirects {} -> OCFErrHttpException url "Too many redirects"
        Http.OverlongHeaders -> OCFErrHttpException url "Overlong headers"
        Http.StatusCodeException resp _ -> OCFErrHttpException url ("Status code exception " <> Text.pack (show $ Http.responseStatus resp))
        Http.InvalidStatusLine {} -> OCFErrHttpException url "Invalid status line"
        other -> OCFErrHttpException url (Text.take 100 $ Text.pack $ show other)
    InvalidUrlException urlx err ->
      case url of
        OffChainPoolUrl _ -> OCFErrUrlParseFail (OffChainPoolUrl $ PoolUrl $ Text.pack urlx) (Text.pack err)
        OffChainVoteUrl _ -> OCFErrUrlParseFail (OffChainVoteUrl $ VoteUrl $ Text.pack urlx) (Text.pack err)

useIpfsGatewayMaybe :: VoteUrl -> [Text] -> Maybe [VoteUrl]
useIpfsGatewayMaybe vu gateways =
  case Text.stripPrefix "ipfs://" (unVoteUrl vu) of
    Just sf -> Just $ VoteUrl . (<> sf) <$> gateways
    Nothing -> Nothing