{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.CLI.EraIndependent.Hash.Internal.Common
  ( getByteStringFromURL
  , carryHashChecks
  , allSchemes
  , httpsAndIpfsSchemes
  )
where

import Cardano.Api
import Cardano.Api.Ledger qualified as L

import Cardano.CLI.Parser (stringToAnchorScheme)
import Cardano.CLI.Type.Common
  ( AnchorScheme (..)
  , MustCheckHash (..)
  , PotentiallyCheckedAnchor (..)
  , SupportedSchemes
  )
import Cardano.CLI.Type.Error.HashCmdError
import Cardano.Ledger.Hashes qualified as L (hashAnnotated)
import Cardano.Prelude (first)

import Control.Exception (throw)
import Control.Monad (when)
import Control.Monad.Catch (Exception, Handler (Handler))
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as BSL
import Data.ByteString.Lazy.Char8 qualified as BSL8
import Data.List (intercalate)
import Data.Text qualified as Text
import Network.HTTP.Client (Response (..), httpLbs, newManager, requestFromURI)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types (Status (statusCode), statusMessage)
import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI, pathSegments)
import System.Environment qualified as IO
import System.FilePath ((</>))
import System.FilePath.Posix (isDrive)

-- | Fetches the content of a URL as a 'ByteString'.
-- The URL must be an absolute URL. The supported schemes are specified in the 'SupportedSchemes' argument.
-- If the scheme is not supported, an error is thrown.
getByteStringFromURL :: SupportedSchemes -> Text -> ExceptT FetchURLError IO BS.ByteString
getByteStringFromURL :: SupportedSchemes -> Text -> ExceptT FetchURLError IO ByteString
getByteStringFromURL SupportedSchemes
supportedSchemes Text
urlText = do
  let urlString :: [Char]
urlString = Text -> [Char]
Text.unpack Text
urlText
  uri@URI{uriScheme} <- FetchURLError -> Maybe URI -> ExceptT FetchURLError IO URI
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe ([Char] -> FetchURLError
FetchURLInvalidURLError [Char]
urlString) (Maybe URI -> ExceptT FetchURLError IO URI)
-> Maybe URI -> ExceptT FetchURLError IO URI
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URI
parseAbsoluteURI [Char]
urlString
  scheme <-
    hoistEither $
      first FetchURLUnsupportedURLSchemeError $
        stringToAnchorScheme supportedSchemes uriScheme
  case scheme of
    AnchorScheme
FileScheme ->
      let path :: [Char]
path = [[Char]] -> [Char]
uriPathToFilePath (URI -> [[Char]]
pathSegments URI
uri)
       in (IOException -> FetchURLError)
-> IO ByteString -> ExceptT FetchURLError IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT ([Char] -> IOException -> FetchURLError
FetchURLReadFileError [Char]
path) (IO ByteString -> ExceptT FetchURLError IO ByteString)
-> IO ByteString -> ExceptT FetchURLError IO ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile [Char]
path
    AnchorScheme
HttpScheme -> URI -> ExceptT FetchURLError IO ByteString
getFileFromHttp URI
uri
    AnchorScheme
HttpsScheme -> URI -> ExceptT FetchURLError IO ByteString
getFileFromHttp URI
uri
    AnchorScheme
IpfsScheme -> do
      httpUri <- URI -> ExceptT FetchURLError IO URI
convertToHttp URI
uri
      getFileFromHttp httpUri
 where
  uriPathToFilePath :: [String] -> FilePath
  uriPathToFilePath :: [[Char]] -> [Char]
uriPathToFilePath allPath :: [[Char]]
allPath@([Char]
letter : [[Char]]
path) =
    if [Char] -> Bool
isDrive [Char]
letter
      then ([Char] -> [Char] -> [Char]) -> [Char] -> [[Char]] -> [Char]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Char] -> [Char] -> [Char]
(</>) [Char]
letter [[Char]]
path
      else ([Char] -> [Char] -> [Char]) -> [Char] -> [[Char]] -> [Char]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Char] -> [Char] -> [Char]
(</>) [Char]
"/" [[Char]]
allPath
  uriPathToFilePath [] = [Char]
"/"

  getFileFromHttp :: URI -> ExceptT FetchURLError IO BS.ByteString
  getFileFromHttp :: URI -> ExceptT FetchURLError IO ByteString
getFileFromHttp URI
uri = [Handler IO FetchURLError]
-> IO ByteString -> ExceptT FetchURLError IO ByteString
forall (f :: * -> *) (m :: * -> *) x a.
(Foldable f, MonadCatch m) =>
f (Handler m x) -> m a -> ExceptT x m a
handlesExceptT [Handler IO FetchURLError]
handlers (IO ByteString -> ExceptT FetchURLError IO ByteString)
-> IO ByteString -> ExceptT FetchURLError IO ByteString
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO ByteString
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
    request <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
requestFromURI URI
uri
    manager <- newManager tlsManagerSettings
    response <- httpLbs request manager
    let status = Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response
    if statusCode status /= 200
      then
        throw $
          BadStatusCodeHRE
            (statusCode status)
            (BS8.unpack (statusMessage status) ++ ": " ++ BSL8.unpack (responseBody response))
      else return $ BS.concat . BSL.toChunks $ responseBody response

  handlers :: [Handler IO FetchURLError]
  handlers :: [Handler IO FetchURLError]
handlers =
    [ (HttpRequestError -> HttpRequestError) -> Handler IO FetchURLError
forall (m :: * -> *) e.
(Monad m, Exception e) =>
(e -> HttpRequestError) -> Handler m FetchURLError
mkHandler HttpRequestError -> HttpRequestError
forall a. a -> a
id
    , (HttpException -> HttpRequestError) -> Handler IO FetchURLError
forall (m :: * -> *) e.
(Monad m, Exception e) =>
(e -> HttpRequestError) -> Handler m FetchURLError
mkHandler HttpException -> HttpRequestError
HttpExceptionHRE
    , (IOException -> HttpRequestError) -> Handler IO FetchURLError
forall (m :: * -> *) e.
(Monad m, Exception e) =>
(e -> HttpRequestError) -> Handler m FetchURLError
mkHandler IOException -> HttpRequestError
IOExceptionHRE
    ]
   where
    mkHandler :: (Monad m, Exception e) => (e -> HttpRequestError) -> Handler m FetchURLError
    mkHandler :: forall (m :: * -> *) e.
(Monad m, Exception e) =>
(e -> HttpRequestError) -> Handler m FetchURLError
mkHandler e -> HttpRequestError
x = (e -> m FetchURLError) -> Handler m FetchURLError
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((e -> m FetchURLError) -> Handler m FetchURLError)
-> (e -> m FetchURLError) -> Handler m FetchURLError
forall a b. (a -> b) -> a -> b
$ FetchURLError -> m FetchURLError
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FetchURLError -> m FetchURLError)
-> (e -> FetchURLError) -> e -> m FetchURLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpRequestError -> FetchURLError
FetchURLGetFileFromHttpError (HttpRequestError -> FetchURLError)
-> (e -> HttpRequestError) -> e -> FetchURLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> HttpRequestError
x

  convertToHttp :: URI -> ExceptT FetchURLError IO URI
  convertToHttp :: URI -> ExceptT FetchURLError IO URI
convertToHttp URI
ipfsUri = do
    mIpfsGatewayUriString <- (IOException -> FetchURLError)
-> IO (Maybe [Char]) -> ExceptT FetchURLError IO (Maybe [Char])
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT IOException -> FetchURLError
FetchURLReadEnvVarError (IO (Maybe [Char]) -> ExceptT FetchURLError IO (Maybe [Char]))
-> IO (Maybe [Char]) -> ExceptT FetchURLError IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
IO.lookupEnv [Char]
"IPFS_GATEWAY_URI"
    ipfsGatewayUriString <- hoistMaybe FetchURLIpfsGatewayNotSetError mIpfsGatewayUriString
    ipfsGatewayUri <-
      hoistMaybe (FetchURLInvalidURLError ipfsGatewayUriString) $ parseAbsoluteURI ipfsGatewayUriString
    return $
      ipfsGatewayUri
        { uriPath =
            '/'
              : intercalate
                "/"
                ( pathSegments ipfsGatewayUri
                    ++ ["ipfs"]
                    ++ maybe [] (\URIAuth
ipfsAuthority -> [URIAuth -> [Char]
uriRegName URIAuth
ipfsAuthority]) (uriAuthority ipfsUri)
                    ++ pathSegments ipfsUri
                )
        }

-- | Only HTTPS and IPFS schemes are allowed. We also allow HTTP for testing purposes
-- but it is discouraged, because it can lead to security vulnerabilities.
-- For example: If a user checks the anchor-data through a web browser and through the
-- `cardano-cli` independently, one of them could easily get spoofed, and the user would
-- not notice that the anchor-data being verified in the browser is not the same.
httpsAndIpfsSchemes :: SupportedSchemes
httpsAndIpfsSchemes :: SupportedSchemes
httpsAndIpfsSchemes =
  [ AnchorScheme
HttpScheme -- Insecure, only for testing purposes
  , AnchorScheme
HttpsScheme
  , AnchorScheme
IpfsScheme
  ]

-- | Check the hash of the anchor data against the hash in the anchor if
-- checkHash is set to CheckHash.
carryHashChecks
  :: PotentiallyCheckedAnchor anchorType L.Anchor
  -- ^ The information about anchor data and whether to check the hash (see 'PotentiallyCheckedAnchor')
  -> ExceptT HashCheckError IO ()
carryHashChecks :: forall anchorType.
PotentiallyCheckedAnchor anchorType Anchor
-> ExceptT HashCheckError IO ()
carryHashChecks PotentiallyCheckedAnchor anchorType Anchor
potentiallyCheckedAnchor =
  case PotentiallyCheckedAnchor anchorType Anchor
-> MustCheckHash anchorType
forall anchorType anchor.
PotentiallyCheckedAnchor anchorType anchor
-> MustCheckHash anchorType
pcaMustCheck PotentiallyCheckedAnchor anchorType Anchor
potentiallyCheckedAnchor of
    MustCheckHash anchorType
CheckHash -> do
      anchorData <-
        ByteString -> AnchorData
L.AnchorData
          (ByteString -> AnchorData)
-> ExceptT HashCheckError IO ByteString
-> ExceptT HashCheckError IO AnchorData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FetchURLError -> HashCheckError)
-> ExceptT FetchURLError IO ByteString
-> ExceptT HashCheckError IO ByteString
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT
            FetchURLError -> HashCheckError
FetchURLError
            (SupportedSchemes -> Text -> ExceptT FetchURLError IO ByteString
getByteStringFromURL SupportedSchemes
httpsAndIpfsSchemes (Text -> ExceptT FetchURLError IO ByteString)
-> Text -> ExceptT FetchURLError IO ByteString
forall a b. (a -> b) -> a -> b
$ Url -> Text
L.urlToText (Url -> Text) -> Url -> Text
forall a b. (a -> b) -> a -> b
$ Anchor -> Url
L.anchorUrl Anchor
anchor)
      let hash = AnchorData -> SafeHash AnchorData
forall x i. HashAnnotated x i => x -> SafeHash i
L.hashAnnotated AnchorData
anchorData
      when (hash /= L.anchorDataHash anchor) $
        left $
          HashMismatchError (L.anchorDataHash anchor) hash
    MustCheckHash anchorType
TrustHash -> () -> ExceptT HashCheckError IO ()
forall a. a -> ExceptT HashCheckError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  anchor :: Anchor
anchor = PotentiallyCheckedAnchor anchorType Anchor -> Anchor
forall anchorType anchor.
PotentiallyCheckedAnchor anchorType anchor -> anchor
pcaAnchor PotentiallyCheckedAnchor anchorType Anchor
potentiallyCheckedAnchor

-- | All the supported schemes are allowed.
allSchemes :: SupportedSchemes
allSchemes :: SupportedSchemes
allSchemes = [AnchorScheme
FileScheme, AnchorScheme
HttpScheme, AnchorScheme
HttpsScheme, AnchorScheme
IpfsScheme]