{-# 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.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 (Text)
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
uri@URI{[Char]
uriScheme :: [Char]
uriScheme :: URI -> [Char]
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
  AnchorScheme
scheme <-
    Either FetchURLError AnchorScheme
-> ExceptT FetchURLError IO AnchorScheme
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either FetchURLError AnchorScheme
 -> ExceptT FetchURLError IO AnchorScheme)
-> Either FetchURLError AnchorScheme
-> ExceptT FetchURLError IO AnchorScheme
forall a b. (a -> b) -> a -> b
$
      ([Char] -> FetchURLError)
-> Either [Char] AnchorScheme -> Either FetchURLError AnchorScheme
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Char] -> FetchURLError
FetchURLUnsupportedURLSchemeError (Either [Char] AnchorScheme -> Either FetchURLError AnchorScheme)
-> Either [Char] AnchorScheme -> Either FetchURLError AnchorScheme
forall a b. (a -> b) -> a -> b
$
        SupportedSchemes -> [Char] -> Either [Char] AnchorScheme
stringToAnchorScheme SupportedSchemes
supportedSchemes [Char]
uriScheme
  case AnchorScheme
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
      URI
httpUri <- URI -> ExceptT FetchURLError IO URI
convertToHttp URI
uri
      URI -> ExceptT FetchURLError IO ByteString
getFileFromHttp URI
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
request <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
requestFromURI URI
uri
    Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
    let status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response
    if Status -> Int
statusCode Status
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
200
      then
        HttpRequestError -> IO ByteString
forall a e. Exception e => e -> a
throw (HttpRequestError -> IO ByteString)
-> HttpRequestError -> IO ByteString
forall a b. (a -> b) -> a -> b
$
          Int -> [Char] -> HttpRequestError
BadStatusCodeHRE
            (Status -> Int
statusCode Status
status)
            (ByteString -> [Char]
BS8.unpack (Status -> ByteString
statusMessage Status
status) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BSL8.unpack (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response))
      else ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BSL.toChunks (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
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
    Maybe [Char]
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"
    [Char]
ipfsGatewayUriString <- FetchURLError -> Maybe [Char] -> ExceptT FetchURLError IO [Char]
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe FetchURLError
FetchURLIpfsGatewayNotSetError Maybe [Char]
mIpfsGatewayUriString
    URI
ipfsGatewayUri <-
      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]
ipfsGatewayUriString) (Maybe URI -> ExceptT FetchURLError IO URI)
-> Maybe URI -> ExceptT FetchURLError IO URI
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URI
parseAbsoluteURI [Char]
ipfsGatewayUriString
    URI -> ExceptT FetchURLError IO URI
forall a. a -> ExceptT FetchURLError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> ExceptT FetchURLError IO URI)
-> URI -> ExceptT FetchURLError IO URI
forall a b. (a -> b) -> a -> b
$
      URI
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 L.StandardCrypto)
  -- ^ The information about anchor data and whether to check the hash (see 'PotentiallyCheckedAnchor')
  -> ExceptT HashCheckError IO ()
carryHashChecks :: forall anchorType.
PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
-> ExceptT HashCheckError IO ()
carryHashChecks PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
potentiallyCheckedAnchor =
  case PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
-> MustCheckHash anchorType
forall anchorType anchor.
PotentiallyCheckedAnchor anchorType anchor
-> MustCheckHash anchorType
pcaMustCheck PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
potentiallyCheckedAnchor of
    MustCheckHash anchorType
CheckHash -> do
      AnchorData
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 StandardCrypto -> Url
forall c. Anchor c -> Url
L.anchorUrl Anchor StandardCrypto
anchor)
      let hash :: SafeHash StandardCrypto AnchorData
hash = AnchorData -> SafeHash StandardCrypto AnchorData
forall c. Crypto c => AnchorData -> SafeHash c AnchorData
L.hashAnchorData AnchorData
anchorData
      Bool
-> ExceptT HashCheckError IO () -> ExceptT HashCheckError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SafeHash StandardCrypto AnchorData
hash SafeHash StandardCrypto AnchorData
-> SafeHash StandardCrypto AnchorData -> Bool
forall a. Eq a => a -> a -> Bool
/= Anchor StandardCrypto -> SafeHash StandardCrypto AnchorData
forall c. Anchor c -> SafeHash c AnchorData
L.anchorDataHash Anchor StandardCrypto
anchor) (ExceptT HashCheckError IO () -> ExceptT HashCheckError IO ())
-> ExceptT HashCheckError IO () -> ExceptT HashCheckError IO ()
forall a b. (a -> b) -> a -> b
$
        HashCheckError -> ExceptT HashCheckError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (HashCheckError -> ExceptT HashCheckError IO ())
-> HashCheckError -> ExceptT HashCheckError IO ()
forall a b. (a -> b) -> a -> b
$
          SafeHash StandardCrypto AnchorData
-> SafeHash StandardCrypto AnchorData -> HashCheckError
HashMismatchError (Anchor StandardCrypto -> SafeHash StandardCrypto AnchorData
forall c. Anchor c -> SafeHash c AnchorData
L.anchorDataHash Anchor StandardCrypto
anchor) SafeHash StandardCrypto AnchorData
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 StandardCrypto
anchor = PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
-> Anchor StandardCrypto
forall anchorType anchor.
PotentiallyCheckedAnchor anchorType anchor -> anchor
pcaAnchor PotentiallyCheckedAnchor anchorType (Anchor StandardCrypto)
potentiallyCheckedAnchor

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