diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ +# Version [0.1.0.0](https://github.com/blockfrost/blockfrost-haskell/compare/initial...0.1.0.0) (2021-09-14) + +* Initial release + +--- + +`blockfrost-client-core` uses [PVP Versioning][1]. + +[1]: https://pvp.haskell.org + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright 2021 blockfrost.io + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# blockfrost-client-core + +Instances and helpers shared by all clients. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/blockfrost-client-core.cabal b/blockfrost-client-core.cabal new file mode 100644 --- /dev/null +++ b/blockfrost-client-core.cabal @@ -0,0 +1,64 @@ +cabal-version: 2.2 +name: blockfrost-client-core +version: 0.1.0.0 +synopsis: blockfrost.io common client definitions / instances +description: HasClient for our auth +homepage: https://github.com/blockfrost/blockfrost-haskell +license: Apache-2.0 +license-file: LICENSE +author: blockfrost.io +maintainer: srk@48.io +copyright: 2021 blockfrost.io +category: Web +build-type: Simple + +extra-source-files: + CHANGELOG.md + LICENSE + README.md + +flag BuildFast + Default: True + Description: Turn off optimizations + +flag Production + Default: False + Manual: True + Description: Production build + +common libstuff + default-language: Haskell2010 + ghc-options: -Wall -Wunused-packages -fno-warn-orphans + if flag(BuildFast) + ghc-options: -O0 + if flag(Production) + ghc-options: -Werror + +library + import: libstuff + hs-source-dirs: src + exposed-modules: Blockfrost.Client.Core + , Blockfrost.Client.Auth + , Blockfrost.Client.Pagination + , Blockfrost.Client.Sorting + , Blockfrost.Client.Tag + build-depends: base >= 4.7 && < 5 + , blockfrost-api + , aeson + , bytestring + , case-insensitive + , containers + , data-default + , http-client + , http-client-tls + , http-types + , servant ^>= 0.18 + , servant-client + , servant-client-core + , servant-multipart-api + , servant-multipart-client + , text + +source-repository head + type: git + location: https://github.com/blockfrost/blockfrost-haskell diff --git a/src/Blockfrost/Client/Auth.hs b/src/Blockfrost/Client/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Blockfrost/Client/Auth.hs @@ -0,0 +1,36 @@ +-- | Blockfrost authentication scheme instance for HasClient + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Blockfrost.Client.Auth + ( Project + ) where + +import Blockfrost.Auth +import Data.CaseInsensitive (mk) +import Data.Proxy (Proxy (..)) +import Data.Sequence ((<|)) +import GHC.TypeLits +import Servant.API ((:>)) +import Servant.Client.Core (Client, HasClient (..), requestHeaders) + +import qualified Data.ByteString.Char8 +import qualified Data.Text.Encoding + +instance {-# OVERLAPS #-} (HasClient m api, KnownSymbol sym) => HasClient m (ProjectAuth '[APIKeyInHeader sym] a :> api) where + type Client m (ProjectAuth '[APIKeyInHeader sym] a :> api) = Project -> Client m api + + clientWithRoute m _ req proj + = clientWithRoute m (Proxy :: Proxy api) + $ req { requestHeaders = (headerName, headerVal) <| requestHeaders req } + where + headerVal = Data.Text.Encoding.encodeUtf8 $ projectId proj + headerName = mk $ Data.ByteString.Char8.pack $ symbolVal (Proxy @sym) + + hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl diff --git a/src/Blockfrost/Client/Core.hs b/src/Blockfrost/Client/Core.hs new file mode 100644 --- /dev/null +++ b/src/Blockfrost/Client/Core.hs @@ -0,0 +1,130 @@ +-- | 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 + , 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.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 = "blockfrost.io" + +newEnvByProject :: Project -> IO ClientEnv +newEnvByProject prj = do + conman <- Network.HTTP.Client.newManager Network.HTTP.Client.TLS.tlsManagerSettings + pure $ mkClientEnv conman (baseUrlByEnv $ projectEnv prj) + +buildUrl :: String -> BaseUrl +buildUrl subdomain = + BaseUrl + Https + (subdomain <> "." <> domain) + 443 + mempty + +baseUrlByEnv :: Env -> BaseUrl +baseUrlByEnv Localhost = BaseUrl Http "localhost" 8000 "" +baseUrlByEnv e = maybe (error "absurd") buildUrl (subdomainByEnv e) + +subdomainByEnv :: Env -> Maybe String +subdomainByEnv Alonzo = pure "cardano-alonzo" +subdomainByEnv Ipfs = pure "ipfs" +subdomainByEnv Mainnet = pure "cardano-mainnet" +subdomainByEnv Testnet = pure "cardano-testnet" +subdomainByEnv Localhost = Nothing + +-- | Read file according to BLOCKFROST_TOKEN_PATH environment variable name. +projectFromEnv :: IO Project +projectFromEnv = projectFromEnv' "BLOCKFROST_TOKEN_PATH" + +-- | Read file according to environment variable name. +projectFromEnv' :: String -> IO Project +projectFromEnv' envVarName = do + tokPath <- System.Environment.getEnv envVarName + projectFromFile tokPath + +-- | Read file with token and turn it into @Project@ +-- Expects tokens prefixed with environment, e.g. +-- @testnetA3C2E...@ +projectFromFile :: FilePath -> IO Project +projectFromFile f = mkProject <$> Data.Text.IO.readFile f + +data BlockfrostError = + BlockfrostError Text + | BlockfrostBadRequest Text -- 400 + | BlockfrostTokenMissing Text -- 403 + | BlockfrostNotFound -- 404 + | BlockfrostIPBanned -- 418 + | BlockfrostUsageLimitReached -- 429 + | BlockfrostFatal Text -- 500 + | ServantClientError ClientError + deriving (Eq, Show) + +fromServantClientError :: ClientError -> BlockfrostError +fromServantClientError e = case e of + FailureResponse _bUrl (Response s _ _ body) + | s == status400 -> + BlockfrostBadRequest (withMessage body) + | s == status403 -> + BlockfrostTokenMissing (withMessage body) + | s == status404 -> + BlockfrostNotFound + | s == status418 -> + BlockfrostIPBanned + | s == status429 -> + BlockfrostUsageLimitReached + | s == status500 -> + BlockfrostFatal (withMessage body) + | otherwise -> + BlockfrostError (withMessage body) + _ -> ServantClientError e + where + withMessage body = + case eitherDecode body of + (Right (ae :: ApiError)) -> apiErrorMessage ae + _ -> mempty + +instance ToMultipart Tmp Form where + toMultipart (Form fileName filePath) = + MultipartData + mempty -- no text fields + [ FileData "file" + fileName + "application/octet-stream" + filePath + ] diff --git a/src/Blockfrost/Client/Pagination.hs b/src/Blockfrost/Client/Pagination.hs new file mode 100644 --- /dev/null +++ b/src/Blockfrost/Client/Pagination.hs @@ -0,0 +1,57 @@ +-- | Pagination instance for HasClient + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Blockfrost.Client.Pagination + ( Paged (..) + , page + , paged + , nextPage + , allPages + ) where + +import Data.Default (Default (def)) +import Data.Proxy (Proxy (..)) +import Servant.API ((:>)) +import Servant.Client.Core (Client, HasClient (..)) + +import Blockfrost.Util.Pagination + ( Paged (..) + , Pagination + , PaginationExpanded + , page + , paged + , maxPageSize + , nextPage + ) + +-- | Query all results, until we get less than maximum +-- items per page. +allPages :: Monad m => (Paged -> m [a]) -> m [a] +allPages act = do + let fetch page' = do + res <- act page' + case res of + xs | length xs < maxPageSize -> pure xs + xs -> do + next <- fetch (nextPage page') + pure $ next ++ xs + fetch def + +instance HasClient m subApi => HasClient m (Pagination :> subApi) where + type Client m (Pagination :> subApi) = Paged -> Client m subApi + clientWithRoute pm _ req paged' = + clientWithRoute + pm + (Proxy @(PaginationExpanded subApi)) + req + (Just $ countPerPage paged') + (Just $ pageNumber paged') + + hoistClientMonad pm _ hst subCli = hoistClientMonad pm (Proxy @subApi) hst . subCli diff --git a/src/Blockfrost/Client/Sorting.hs b/src/Blockfrost/Client/Sorting.hs new file mode 100644 --- /dev/null +++ b/src/Blockfrost/Client/Sorting.hs @@ -0,0 +1,38 @@ +-- | Sorting instance for HasClient + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Blockfrost.Client.Sorting + ( SortOrder (..) + , asc + , desc + ) where + +import Data.Proxy (Proxy (..)) +import Servant.API ((:>)) +import Servant.Client.Core (Client, HasClient (..)) + +import Blockfrost.Util.Sorting + ( SortOrder (..) + , Sorting + , SortingExpanded + , asc + , desc + ) + +instance HasClient m subApi => HasClient m (Sorting :> subApi) where + type Client m (Sorting :> subApi) = SortOrder -> Client m subApi + clientWithRoute pm _ req sOrder = + clientWithRoute + pm + (Proxy @(SortingExpanded subApi)) + req + (Just sOrder) + + hoistClientMonad pm _ hst subCli = hoistClientMonad pm (Proxy @subApi) hst . subCli diff --git a/src/Blockfrost/Client/Tag.hs b/src/Blockfrost/Client/Tag.hs new file mode 100644 --- /dev/null +++ b/src/Blockfrost/Client/Tag.hs @@ -0,0 +1,23 @@ +-- | Tag instance for HasClient + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Blockfrost.Client.Tag + where + +import Data.Proxy (Proxy (..)) +import Servant.API ((:>)) +import Servant.Client.Core (Client, HasClient (..)) + +import Blockfrost.Util.Tag (Tag) + +instance HasClient m subApi => HasClient m (Tag name :> subApi) where + type Client m (Tag name :> subApi) = Client m subApi + clientWithRoute pm _ = clientWithRoute pm (Proxy @subApi) + hoistClientMonad pm _ hst = hoistClientMonad pm (Proxy @subApi) hst