-- | Core shared by clients
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Blockfrost.Client.Core
  ( BlockfrostError (..)
  , Paged (..)
  , SortOrder (..)
  , asc
  , def
  , desc
  , fromServantClientError
  , newEnvByProject
  , page
  , paged
  , allPages
  , nextPage
  , projectFromEnv
  , projectFromEnv'
  , projectFromFile
  ) where

import Blockfrost.API (Form (..))
import Blockfrost.Auth
import Blockfrost.Client.Auth ()
import Blockfrost.Client.Pagination
import Blockfrost.Client.Sorting
import Blockfrost.Client.Tag ()
import Blockfrost.Client.UserAgent ()
import Blockfrost.Types.ApiError
import Data.Aeson (eitherDecode)
import Data.Default (Default (def))
import Data.Text (Text)
import qualified Data.Text.IO
import qualified Network.HTTP.Client
import qualified Network.HTTP.Client.TLS
import Network.HTTP.Types
import Servant.Client
import Servant.Multipart.API
import Servant.Multipart.Client ()
import qualified System.Environment

domain :: String
domain :: String
domain = String
"blockfrost.io"

newEnvByProject :: Project -> IO ClientEnv
newEnvByProject :: Project -> IO ClientEnv
newEnvByProject Project
prj = do
  Manager
conman <- ManagerSettings -> IO Manager
Network.HTTP.Client.newManager ManagerSettings
Network.HTTP.Client.TLS.tlsManagerSettings
  ClientEnv -> IO ClientEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientEnv -> IO ClientEnv) -> ClientEnv -> IO ClientEnv
forall a b. (a -> b) -> a -> b
$ Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
conman (Env -> BaseUrl
baseUrlByEnv (Env -> BaseUrl) -> Env -> BaseUrl
forall a b. (a -> b) -> a -> b
$ Project -> Env
projectEnv Project
prj)

buildUrl :: String -> BaseUrl
buildUrl :: String -> BaseUrl
buildUrl String
subdomain =
  Scheme -> String -> Int -> String -> BaseUrl
BaseUrl
    Scheme
Https
    (String
subdomain String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
domain)
    Int
443
    String
forall a. Monoid a => a
mempty

baseUrlByEnv :: Env -> BaseUrl
baseUrlByEnv :: Env -> BaseUrl
baseUrlByEnv Env
Localhost = Scheme -> String -> Int -> String -> BaseUrl
BaseUrl Scheme
Http String
"localhost" Int
8000 String
""
baseUrlByEnv Env
e         = BaseUrl -> (String -> BaseUrl) -> Maybe String -> BaseUrl
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> BaseUrl
forall a. HasCallStack => String -> a
error String
"absurd") String -> BaseUrl
buildUrl (Env -> Maybe String
subdomainByEnv Env
e)

subdomainByEnv :: Env -> Maybe String
subdomainByEnv :: Env -> Maybe String
subdomainByEnv Env
Ipfs      = String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"ipfs"
subdomainByEnv Env
Mainnet   = String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"cardano-mainnet"
subdomainByEnv Env
Testnet   = String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"cardano-testnet"
subdomainByEnv Env
Preprod   = String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"cardano-preprod"
subdomainByEnv Env
Preview   = String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"cardano-preview"
subdomainByEnv Env
Sanchonet = String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"cardano-sanchonet"
subdomainByEnv Env
Localhost = Maybe String
forall a. Maybe a
Nothing

-- | Read file according to BLOCKFROST_TOKEN_PATH environment variable name.
projectFromEnv :: IO Project
projectFromEnv :: IO Project
projectFromEnv = String -> IO Project
projectFromEnv' String
"BLOCKFROST_TOKEN_PATH"

-- | Read file according to environment variable name.
projectFromEnv' :: String -> IO Project
projectFromEnv' :: String -> IO Project
projectFromEnv' String
envVarName = do
  String
tokPath <- String -> IO String
System.Environment.getEnv String
envVarName
  String -> IO Project
projectFromFile String
tokPath

-- | Read file with token and turn it into @Project@
-- Expects tokens prefixed with environment, e.g.
-- @testnetA3C2E...@
projectFromFile :: FilePath -> IO Project
projectFromFile :: String -> IO Project
projectFromFile String
f = Text -> Project
mkProject (Text -> Project) -> IO Text -> IO Project
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
Data.Text.IO.readFile String
f

data BlockfrostError =
    BlockfrostError Text
  | BlockfrostBadRequest Text   -- 400
  | BlockfrostTokenMissing Text -- 403
  | BlockfrostNotFound          -- 404
  | BlockfrostIPBanned          -- 418
  | BlockfrostMempoolFullOrPinQueueFull -- 425
  | BlockfrostUsageLimitReached -- 429
  | BlockfrostFatal Text        -- 500
  | ServantClientError ClientError
  deriving (BlockfrostError -> BlockfrostError -> Bool
(BlockfrostError -> BlockfrostError -> Bool)
-> (BlockfrostError -> BlockfrostError -> Bool)
-> Eq BlockfrostError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockfrostError -> BlockfrostError -> Bool
== :: BlockfrostError -> BlockfrostError -> Bool
$c/= :: BlockfrostError -> BlockfrostError -> Bool
/= :: BlockfrostError -> BlockfrostError -> Bool
Eq, Int -> BlockfrostError -> String -> String
[BlockfrostError] -> String -> String
BlockfrostError -> String
(Int -> BlockfrostError -> String -> String)
-> (BlockfrostError -> String)
-> ([BlockfrostError] -> String -> String)
-> Show BlockfrostError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> BlockfrostError -> String -> String
showsPrec :: Int -> BlockfrostError -> String -> String
$cshow :: BlockfrostError -> String
show :: BlockfrostError -> String
$cshowList :: [BlockfrostError] -> String -> String
showList :: [BlockfrostError] -> String -> String
Show)

fromServantClientError :: ClientError -> BlockfrostError
fromServantClientError :: ClientError -> BlockfrostError
fromServantClientError ClientError
e = case ClientError
e of
  FailureResponse RequestF () (BaseUrl, ByteString)
_bUrl (Response Status
s Seq Header
_ HttpVersion
_ ByteString
body)
    | Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status400 ->
        Text -> BlockfrostError
BlockfrostBadRequest (ByteString -> Text
withMessage ByteString
body)
    | Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status403 ->
        Text -> BlockfrostError
BlockfrostTokenMissing (ByteString -> Text
withMessage ByteString
body)
    | Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status404 ->
        BlockfrostError
BlockfrostNotFound
    | Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status418 ->
        BlockfrostError
BlockfrostIPBanned
    | Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ByteString -> Status
mkStatus Int
425 ByteString
"Mempool Full (TXs) or Pin Queue Full (IPFS)" ->
        BlockfrostError
BlockfrostMempoolFullOrPinQueueFull
    | Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status429 ->
        BlockfrostError
BlockfrostUsageLimitReached
    | Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status500 ->
        Text -> BlockfrostError
BlockfrostFatal (ByteString -> Text
withMessage ByteString
body)
    | Bool
otherwise ->
        Text -> BlockfrostError
BlockfrostError (ByteString -> Text
withMessage ByteString
body)
  ClientError
_ -> ClientError -> BlockfrostError
ServantClientError ClientError
e
  where
    withMessage :: ByteString -> Text
withMessage ByteString
body =
      case ByteString -> Either String ApiError
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body of
        (Right (ApiError
ae :: ApiError)) -> ApiError -> Text
apiErrorMessage ApiError
ae
        Either String ApiError
_                        -> Text
forall a. Monoid a => a
mempty

instance ToMultipart Tmp Form where
  toMultipart :: Form -> MultipartData Tmp
toMultipart (Form Text
fileName String
filePath) =
    [Input] -> [FileData Tmp] -> MultipartData Tmp
forall tag. [Input] -> [FileData tag] -> MultipartData tag
MultipartData
      [Input]
forall a. Monoid a => a
mempty -- no text fields
      [ Text -> Text -> Text -> MultipartResult Tmp -> FileData Tmp
forall tag.
Text -> Text -> Text -> MultipartResult tag -> FileData tag
FileData Text
"file"
                 Text
fileName
                 Text
"application/octet-stream"
                 String
MultipartResult Tmp
filePath
      ]