backblaze-b2-hs (empty) → 0.1.0.0
raw patch · 13 files changed
+1312/−0 lines, 13 filesdep +aesondep +backblaze-b2-hsdep +basesetup-changed
Dependencies added: aeson, backblaze-b2-hs, base, base64-bytestring, bytestring, case-insensitive, conduit, containers, cryptonite, formatting, http-client, http-types, protolude, req, req-conduit, scientific, tasty, tasty-hunit, text, time, unliftio, unliftio-core
Files
- ChangeLog.md +3/−0
- LICENSE +202/−0
- README.md +8/−0
- Setup.hs +2/−0
- app/Main.hs +18/−0
- backblaze-b2-hs.cabal +139/−0
- src/LocalPrelude.hs +30/−0
- src/Network/BackblazeB2.hs +20/−0
- src/Network/BackblazeB2/B2API.hs +289/−0
- src/Network/BackblazeB2/Crypto.hs +19/−0
- src/Network/BackblazeB2/Data.hs +388/−0
- src/Network/BackblazeB2/Utils.hs +98/−0
- test/Spec.hs +96/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for backblaze-b2-client++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ 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.
+ README.md view
@@ -0,0 +1,8 @@+# backblaze-b2-client++**NOTE:** This library is still in early development. Do not depend on+it just yet.++A client library to access Backblaze B2 Cloud storage in Haskell. It+provides a high-level API to access Backblaze B2 storage allowing for+quick application developlment.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,18 @@+module Main where++import Protolude+import UnliftIO.Exception (throwString)++import Network.BackblazeB2++main :: IO ()+main = do+ cMay <- credsFromEnv+ c <- case cMay of+ Nothing -> throwString "No creds found!"+ Just c' -> return c'++ connInfo <- authorizeAccount c++ bs <- flip runReaderT connInfo listBuckets+ print bs
+ backblaze-b2-hs.cabal view
@@ -0,0 +1,139 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: a44f5f58082c594184a198ffe895d30167c79bb71d7d64c6d44a02f1fe860874++name: backblaze-b2-hs+version: 0.1.0.0+synopsis: A client library to access Backblaze B2 cloud storage in Haskell.++description: A client library to access Backblaze B2 Cloud storage in Haskell. It+ provides a high-level API to access Backblaze B2 storage allowing+ for quick application developlment.+category: Network, Cloud+homepage: https://git.sr.ht/~donatello/backblaze-b2-hs+bug-reports: ~donatello/backblaze-b2-hs-dev@lists.sr.ht+author: Aditya Manthramurthy+maintainer: ~donatello/backblaze-b2-hs-dev@lists.sr.ht+copyright: 2019 Aditya Manthramurthy+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://git.sr.ht/~donatello/backblaze-b2-hs++library+ exposed-modules:+ Network.BackblazeB2+ Network.BackblazeB2.B2API+ other-modules:+ LocalPrelude+ Network.BackblazeB2.Crypto+ Network.BackblazeB2.Data+ Network.BackblazeB2.Utils+ Paths_backblaze_b2_hs+ hs-source-dirs:+ src+ default-extensions: BangPatterns FlexibleContexts FlexibleInstances MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections DataKinds+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ build-depends:+ aeson+ , base >=4.7 && <5+ , base64-bytestring+ , bytestring+ , case-insensitive+ , conduit+ , containers+ , cryptonite+ , formatting+ , http-client+ , http-types+ , protolude+ , req+ , req-conduit+ , scientific+ , text+ , time+ , unliftio+ , unliftio-core+ default-language: Haskell2010++executable backblaze-b2-hs+ main-is: Main.hs+ other-modules:+ Paths_backblaze_b2_hs+ hs-source-dirs:+ app+ default-extensions: BangPatterns FlexibleContexts FlexibleInstances MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections DataKinds+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , backblaze-b2-hs+ , base >=4.7 && <5+ , base64-bytestring+ , bytestring+ , case-insensitive+ , conduit+ , containers+ , cryptonite+ , formatting+ , http-client+ , http-types+ , protolude+ , req+ , req-conduit+ , scientific+ , text+ , time+ , unliftio+ , unliftio-core+ default-language: Haskell2010++test-suite backblaze-b2-hs-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ LocalPrelude+ Network.BackblazeB2+ Network.BackblazeB2.B2API+ Network.BackblazeB2.Crypto+ Network.BackblazeB2.Data+ Network.BackblazeB2.Utils+ Paths_backblaze_b2_hs+ hs-source-dirs:+ test+ src+ default-extensions: BangPatterns FlexibleContexts FlexibleInstances MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections DataKinds+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , backblaze-b2-hs+ , base >=4.7 && <5+ , base64-bytestring+ , bytestring+ , case-insensitive+ , conduit+ , containers+ , cryptonite+ , formatting+ , http-client+ , http-types+ , protolude+ , req+ , req-conduit+ , scientific+ , tasty+ , tasty-hunit+ , text+ , time+ , unliftio+ , unliftio-core+ default-language: Haskell2010
+ src/LocalPrelude.hs view
@@ -0,0 +1,30 @@+module LocalPrelude+ ( module Protolude+ , module Formatting+ , module Req+ , module UnliftIOEx++ , MonadUnliftIO+ , decodeUtf8LE+ )+where++import Control.Monad.IO.Unlift (MonadUnliftIO)+import Formatting as Formatting (sformat, shown, stext,+ (%))+import Network.HTTP.Req as Req (GET (..),+ MonadHttp (handleHttpException),+ NoReqBody (..), Option,+ POST (..), ReqBodyJson (..),+ Scheme (Https), Url, basicAuth,+ header, https, jsonResponse,+ parseUrlHttps, req, reqBr,+ responseBody, runReq, (/:),+ (/~), (=:))+import Protolude hiding (Option, throwIO, try, (%))+import UnliftIO.Exception as UnliftIOEx (throwIO, throwString,+ try)+++decodeUtf8LE :: ByteString -> Text+decodeUtf8LE = decodeUtf8With lenientDecode
+ src/Network/BackblazeB2.hs view
@@ -0,0 +1,20 @@+module Network.BackblazeB2+ ( Credentials(..)+ , credsFromEnv+ , ConnectInfo+ , authorizeAccount++ , BucketData(..)+ , createBucket+ , deleteBucket++ , AllBuckets(..)+ , listBuckets+ , getUploadUrl+ , ObjectConsumer(..)+ , ObjectMetadata(..)+ ) where+++import Network.BackblazeB2.B2API+import Network.BackblazeB2.Data
+ src/Network/BackblazeB2/B2API.hs view
@@ -0,0 +1,289 @@+module Network.BackblazeB2.B2API+ ( Credentials(..)+ , credsFromEnv+ , AuthInfo(..)+ , ConnectInfo(..)+ , authorizeAccount++ , LibErr(..)++ , Bucket+ , BucketType(..)+ , BucketOpts(..)+ , emptyBucketOpts+ , BucketData(..)+ , createBucket++ , deleteBucket++ , AllBuckets(..)+ , listBuckets++ , BucketId+ , UploadUrlInfo(..)+ , getUploadUrl++ , startLargeFile+ , PartUploadUrlInfo(..)+ , getUploadPartUrl+ , PartUploadResp(..)+ , finishLargeFile++ , FileInfo(..)+ , defaultFileProps+ , FileProps(..)+ , Stream(..)+ , uploadFile+ , uploadPart++ , getFileInfo++ , ObjectMetadata(..)+ , ObjectConsumer(..)+ , downloadFileByName+ , downloadFileById++ , FileVersion(..)+ , deleteFileVersion++ , ObjectListArgs(..)+ , ObjectListResult(..)+ , ListResultObjectItem(..)+ , ListResultFolderItem(..)+ , listFileNames+ ) where++import Data.Aeson ((.=))+import qualified Data.Aeson as Json+import qualified Data.Conduit as C+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified Network.HTTP.Types.Header as Hdr+import System.Environment (lookupEnv)++import LocalPrelude++import Network.BackblazeB2.Crypto+import Network.BackblazeB2.Data+import Network.BackblazeB2.Utils++-- | Creates `Credentials` from B2_APP_KEY_ID and B2_APP_KEY+-- environment variables.+credsFromEnv+ :: IO (Maybe Credentials)+credsFromEnv = do+ kIdMay <- fmap (fmap T.pack) $ lookupEnv "B2_APP_KEY_ID"+ keyMay <- fmap (fmap T.pack) $ lookupEnv "B2_APP_KEY"+ return $ Credentials <$> kIdMay <*> keyMay++authorizeAccount+ :: Credentials+ -> IO ConnectInfo+authorizeAccount c@(Credentials aId appKey) = do+ (ConnectInfo c . responseBody) <$>+ req GET url NoReqBody jsonResponse authOpt+ where+ url = https "api.backblazeb2.com" /: "b2api" /: "v2" /: "b2_authorize_account"+ authOpt = basicAuth (encodeUtf8 aId) (encodeUtf8 appKey)++createBucket+ :: (MonadReader ConnectInfo m, MonadIO m)+ => Bucket+ -> BucketType+ -> BucketOpts+ -> m BucketData+createBucket b bType bOpts = do+ accId <- asks (aiAccountId . authInfo)+ execRequest "b2_create_bucket" $+ Json.object ["accountId" .= accId,+ "bucketName" .= b,+ "bucketType" .= bType,+ "bucketInfo" .= boBucketInfo bOpts,+ "lifecycleRules" .= boLCRs bOpts]++deleteBucket+ :: (MonadReader ConnectInfo m, MonadIO m)+ => BucketId+ -> m BucketData+deleteBucket bucketId = do+ accId <- asks (aiAccountId . authInfo)+ execRequest "b2_delete_bucket" $+ Json.object [ "accountId" .= accId+ , "bucketId" .= bucketId+ ]++listBuckets+ :: (MonadReader ConnectInfo m, MonadIO m)+ => m AllBuckets+listBuckets = do+ accId <- asks (aiAccountId . authInfo)+ execRequest "b2_list_buckets" $ Json.object ["accountId" .= accId]++getUploadUrl+ :: (MonadReader ConnectInfo m, MonadIO m)+ => BucketId+ -> m UploadUrlInfo+getUploadUrl bId =+ execRequest "b2_get_upload_url" $ Json.object ["bucketId" .= bId]++startLargeFile+ :: (MonadReader ConnectInfo m, MonadIO m)+ => BucketId+ -> Object+ -> FileProps+ -> m FileInfo+startLargeFile bId obj props =+ execRequest "b2_start_large_file" $ Json.object+ [ "bucketId" .= bId+ , "fileName" .= obj+ , "contentType" .= fpContentType props+ , "fileInfo" .= (fpMetaInfo props <> lastModifiedMeta)+ ]+ where+ lastModifiedMeta =+ maybe Map.empty+ ((\(k, v) -> Map.singleton k v) . mkLastModifiedKV) $+ fpLastModified props++getUploadPartUrl+ :: (MonadReader ConnectInfo m, MonadIO m)+ => FileId+ -> m PartUploadUrlInfo+getUploadPartUrl fId =+ execRequest "b2_get_upload_part_url" $ Json.object [ "fileId" .= fId ]++finishLargeFile+ :: (MonadReader ConnectInfo m, MonadIO m)+ => FileId+ -> [Text]+ -> m FileInfo+finishLargeFile fId sha1List =+ execRequest "b2_finish_large_file" $ Json.object+ [ "fileId" .= fId+ , "partSha1Array" .= sha1List+ ]++deleteFileVersion+ :: (MonadReader ConnectInfo m, MonadIO m)+ => FileVersion+ -> m FileVersion+deleteFileVersion fv = do+ execRequest "b2_delete_file_version" fv++getFileInfo+ :: (MonadReader ConnectInfo m, MonadIO m)+ => ObjectId+ -> m FileInfo+getFileInfo objId =+ execRequest "b2_get_file_info" $ Json.object ["fileId" .= objId]++listFileNames+ :: (MonadReader ConnectInfo m, MonadIO m)+ => ObjectListArgs+ -> m ObjectListResult+listFileNames listArgs =+ execRequest "b2_list_file_names" listArgs++-- | Performs the b2_upload_file call with a `Stream` that provides+-- the bytes for the file content.+uploadFile+ :: MonadIO m+ => UploadUrlInfo+ -> Object+ -> FileProps+ -> Stream+ -> m FileInfo+uploadFile uu objName fileProps src = do+ let UploadUrl (url, opts') = uuUploadUrl uu+ opts = opts'+ <> header "Authorization"+ (encodeUtf8 $ uuAuthorizationToken uu)+ <> header "X-Bz-File-Name" (urlEncode objName)+ <> header "Content-Type"+ (encodeUtf8 $ fpContentType fileProps)+ <> header "X-Bz-Content-Sha1" "hex_digits_at_end"+ <> optHeaders+ body = streamToReqBody $+ Stream { streamLength = streamLength src + 40+ , streamSource = streamSource src C..| sha1Hasher+ }+ fmap responseBody $ liftIO $ req POST url body jsonResponse opts++ where+ modTimeHdrOpt = fromMaybe mempty $+ ( header "X-Bz-Info-src_last_modified_millis"+ . show+ . getMilliEpoch+ . BBTimestamp+ ) <$> fpLastModified fileProps+ mkMetaHdr (k, v) = header+ (encodeUtf8 $ sformat ("X-Bz-Info-" % stext) k) $+ urlEncode v+ optHeaders = modTimeHdrOpt+ <> (mconcat $ map mkMetaHdr $+ Map.toList $+ fpMetaInfo fileProps)++uploadPart+ :: MonadIO m+ => PartUploadUrlInfo+ -> Int+ -> Stream+ -> m PartUploadResp+uploadPart pu partNumber src = do+ let UploadUrl (url, opts') = puuUploadUrl pu+ opts = opts'+ <> header "Authorization"+ (encodeUtf8 $ puuAuthorizationToken pu)+ <> header "X-Bz-Part-Number" (show partNumber)+ <> header "Content-Length" (show $ 40 + streamLength src)+ <> header "X-Bz-Content-Sha1" "hex_digits_at_end"+ body = streamToReqBody $+ Stream { streamLength = streamLength src + 40+ , streamSource = streamSource src C..| sha1Hasher+ }+ fmap responseBody $ liftIO $ req POST url body jsonResponse opts++-- | Download a file by name and pass the result to the provided+-- consumer.+downloadFileByName+ :: (MonadReader ConnectInfo m, MonadIO m)+ => Bucket+ -> Object+ -> Hdr.ByteRanges+ -> ObjectConsumer a+ -> m a+downloadFileByName bucketName objName ranges consumer = do+ authTok <- encodeUtf8 <$> asks (aiAuthorizationToken . authInfo)+ dlUrl <- asks (getDownloadUrl . authInfo)+ let objPathSegments = T.splitOn "/" objName+ appendSegs s [] = s+ appendSegs s (x:xs) = appendSegs (s /: x) xs++ url = (dlUrl /: "file" /: bucketName) `appendSegs` objPathSegments++ rangeOpt = bool (header "Range" $ Hdr.renderByteRanges ranges)+ mempty $ null ranges+ opts = header "Authorization" authTok <> rangeOpt++ doRequest consumer (url, opts)++-- | downloadFileById downloads an object given its Id and calls the+-- provided consumer on it.+downloadFileById+ :: (MonadReader ConnectInfo m, MonadIO m)+ => ObjectId+ -> Hdr.ByteRanges+ -> ObjectConsumer a+ -> m a+downloadFileById objId ranges consumer = do+ authTok <- encodeUtf8 <$> asks (aiAuthorizationToken . authInfo)+ dlUrl <- asks (getDownloadUrl . authInfo)+ let url = dlUrl /: "b2api" /: "v2" /: "b2_download_file_by_id"+ rangeOpt = bool (header "Range" $ Hdr.renderByteRanges ranges)+ mempty $ null ranges+ opts = header "Authorization" authTok+ <> ("fileId" =: objId)+ <> rangeOpt++ doRequest consumer (url, opts)
+ src/Network/BackblazeB2/Crypto.hs view
@@ -0,0 +1,19 @@+module Network.BackblazeB2.Crypto where++import qualified Crypto.Hash as Hash+import qualified Data.Conduit as C++import LocalPrelude++sha1Hasher :: Monad m => C.ConduitT ByteString ByteString m ()+sha1Hasher = loop Hash.hashInit+ where+ loop :: Monad m => Hash.Context Hash.SHA1+ -> C.ConduitT ByteString ByteString m ()+ loop !context = do+ bytesM <- C.await+ case bytesM of+ Just bytes -> do C.yield bytes+ loop $ Hash.hashUpdate context bytes+ _ -> do let digest = Hash.hashFinalize context+ C.yield $ show digest
+ src/Network/BackblazeB2/Data.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE DeriveGeneric #-}+module Network.BackblazeB2.Data where++import qualified Conduit as C+import Control.Monad.Fail (fail)+import Data.Aeson ((.:), (.:?))+import qualified Data.Aeson as Json+import qualified Data.Aeson.Types as Json+import qualified Data.Char as Char+import qualified Data.Map.Strict as Map+import qualified Data.Ratio as R+import qualified Data.Scientific as Sc+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime,+ utcTimeToPOSIXSeconds)+import Network.HTTP.Client (HttpException (HttpExceptionRequest),+ HttpExceptionContent (StatusCodeException))+import Network.HTTP.Req (HttpException (VanillaHttpException),+ MonadHttp (..))+import qualified Network.HTTP.Req.Conduit as RC+import qualified Network.HTTP.Types.Header as Hdr+++import LocalPrelude++-- | Connection info with accountId and applicationKey from Backblaze+-- B2 account UI.+data Credentials =+ Credentials+ { cAccountId :: Text+ , cApplicationKey :: Text+ } deriving (Eq, Show)++instance MonadHttp IO where+ handleHttpException e =+ case e of+ stEx@(VanillaHttpException (HttpExceptionRequest _+ (StatusCodeException _ bs)))+ -> case Json.decodeStrict bs of+ Nothing -> throwIO stEx+ Just b2Err -> throwIO $ LEServer b2Err+ v -> throwIO v++-- | Helper function for JSON conversion+labelModifierFn :: Int -> Json.Options+labelModifierFn n = Json.defaultOptions {+ Json.fieldLabelModifier = fixCase . drop n+ }+ where+ fixCase "" = ""+ fixCase (h:t) = Char.toLower h : t++-- | TODO: Load the rest of the auth info response too!+data AuthInfo = AuthInfo+ { aiAccountId :: Text+ , aiAuthorizationToken :: Text+ , aiApiUrl :: Url 'Https+ , aiDownloadUrl :: Url 'Https+ , aiRecommendedPartSize :: Int64+ } deriving (Eq, Show)++instance Json.FromJSON AuthInfo where+ parseJSON (Json.Object v) = do+ accId <- v .: "accountId"+ authTok <- v .: "authorizationToken"+ apiUrlStr <- v .: "apiUrl"+ apiUrl <- case parseUrlHttps (encodeUtf8 apiUrlStr) of+ Just (url, _) -> return url+ _ -> fail "invalid url received."++ dwnUrlStr <- v .: "downloadUrl"+ dwnUrl <- case parseUrlHttps (encodeUtf8 dwnUrlStr) of+ Just (url, _) -> return url+ _ -> fail "invalid url received."+ rPsz <- v .: "recommendedPartSize"+ return $ AuthInfo accId authTok apiUrl dwnUrl rPsz+ parseJSON o = Json.typeMismatch "object" o++getDownloadUrl :: AuthInfo -> Url 'Https+getDownloadUrl ai = aiDownloadUrl ai++data ConnectInfo = ConnectInfo+ { creds :: Credentials+ , authInfo :: AuthInfo+ } deriving (Show, Eq)++-- | High-level error type for all errors from library+data LibErr = LEServer BB2Error+ | JsonErr Text+ | NoAuthFound+ | HeaderMissing Hdr.HeaderName+ | HeaderParseError Hdr.HeaderName ByteString [Char]+-- | LEOther (NC.Response LByteString)+ deriving (Eq, Show)++instance Exception LibErr++tryLibErr :: MonadUnliftIO m => m a -> m (Either LibErr a)+tryLibErr act = try act++-- | Backblaze B2 Server error response+data BB2Error = BB2Error { bb2eStatus :: Int+ , bb2eCode :: Text+ , bb2eMessage :: Text+ } deriving (Show, Eq, Generic)++instance Json.FromJSON BB2Error where+ parseJSON = Json.genericParseJSON $ labelModifierFn 4++type Bucket = Text++data BucketType = AllPublic | AllPrivate+ deriving (Eq, Show)++instance Json.FromJSON BucketType where+ parseJSON (Json.String "allPrivate") = return AllPrivate+ parseJSON (Json.String "allPublic") = return AllPublic+ parseJSON o = Json.typeMismatch "string" o++instance Json.ToJSON BucketType where+ toJSON AllPrivate = Json.String "allPrivate"+ toJSON AllPublic = Json.String "allPublic"++type BucketInfo = Map.Map Text Text++type BucketId = Text++type FileId = Text++data LifecycleRule = LifecycleRule {+ lcrFileNamePrefix :: Text+ , lcrDaysFromUploadingToHiding :: Maybe Int64+ , lcrDaysFromHidingToDeleting :: Maybe Int64+ } deriving (Show, Eq, Generic)++instance Json.ToJSON LifecycleRule where+ toJSON = Json.genericToJSON $ labelModifierFn 3+ toEncoding = Json.genericToEncoding $ labelModifierFn 3++instance Json.FromJSON LifecycleRule where+ parseJSON = Json.genericParseJSON $ labelModifierFn 3++data BucketOpts = BucketOpts {+ boBucketInfo :: Maybe BucketInfo+ , boLCRs :: [LifecycleRule]+ } deriving (Show, Eq)++emptyBucketOpts :: BucketOpts+emptyBucketOpts = BucketOpts Nothing []++data BucketData = BucketData {+ brdAccountId :: Text+ , brdBucketId :: BucketId+ , brdBucketName :: Bucket+ , brdBucketType :: BucketType+ , brdBucketInfo :: BucketInfo+ , brdLifecycleRules :: [LifecycleRule]+ , brdRevision :: Int64+ } deriving (Show, Eq, Generic)++instance Json.FromJSON BucketData where+ parseJSON = Json.genericParseJSON $ labelModifierFn 3++data AllBuckets = AllBuckets {+ abBuckets :: [BucketData]+ } deriving (Show, Eq, Generic)++instance Json.FromJSON AllBuckets where+ parseJSON = Json.genericParseJSON $ labelModifierFn 2++newtype UploadUrl = UploadUrl { unUploadUrl :: (Url 'Https, Option 'Https)}++instance Json.FromJSON UploadUrl where+ parseJSON (Json.String s) =+ case parseUrlHttps (encodeUtf8 s) of+ Just (url, opts) -> return $ UploadUrl (url, opts)+ _ -> fail "Invalid url received."+ parseJSON o = Json.typeMismatch "string" o++data UploadUrlInfo = UploadUrlInfo+ { uuBucketId :: BucketId+ , uuUploadUrl :: UploadUrl+ , uuAuthorizationToken :: Text+ } deriving (Generic)++instance Json.FromJSON UploadUrlInfo where+ parseJSON = Json.genericParseJSON $ labelModifierFn 2++-- instance Json.FromJSON UploadUrl where+-- parseJSON (Json.Object v) = do+-- bId <- v .: "bucketId"+-- upUrlStr <- v .: "uploadUrl"+-- upUrl <- case parseUrlHttps (encodeUtf8 upUrlStr) of+-- Just (url, opts) -> return (url, opts)+-- Nothing -> fail "invalid url received."+-- authTok <- v .: "authorizationToken"+-- return $ UploadUrl bId upUrl authTok+-- parseJSON o = Json.typeMismatch "object" o++data PartUploadUrlInfo =+ PartUploadUrlInfo+ { puuFileId :: FileId+ , puuUploadUrl :: UploadUrl+ , puuAuthorizationToken :: Text+ } deriving (Generic)++instance Json.FromJSON PartUploadUrlInfo where+ parseJSON = Json.genericParseJSON $ labelModifierFn 3++data PartUploadResp =+ PartUploadResp { purFileId :: FileId+ , purContentLength :: Int64+ , purContentSha1 :: Text+ , purUploadTimestamp :: BBTimestamp+ }+ deriving (Show, Generic)++instance Json.FromJSON PartUploadResp where+ parseJSON = Json.genericParseJSON $ labelModifierFn 3++-- | Type to allow easy conversion between BB2 timestamps+-- representation and UTCTime+newtype BBTimestamp = BBTimestamp { getBBTimestamp :: UTCTime }+ deriving (Eq, Show)++getMilliEpoch :: BBTimestamp -> Int64+getMilliEpoch (BBTimestamp t) =+ 1000 * round (utcTimeToPOSIXSeconds t)++instance Json.FromJSON BBTimestamp where+ parseJSON = Json.withScientific "UnixMilliEpoch" $ \n ->+ let millis = fromIntegral <$> (Sc.toBoundedInteger n :: Maybe Int64)+ in case millis of+ Just m -> pure . BBTimestamp . posixSecondsToUTCTime .+ fromRational $ m R.% 1000+ _ -> fail "could not parse milli-epoch time"++instance Json.ToJSON BBTimestamp where+ toJSON = Json.toJSON . getMilliEpoch+ toEncoding = Json.toEncoding . getMilliEpoch++data FileProps =+ FileProps+ { fpContentType :: Text -- default value is `b2/x-auto`+ , fpLastModified :: Maybe UTCTime+ , fpMetaInfo :: Map.Map Text Text -- Value is automatically+ -- percent encoded, Key is+ -- automatically prefixed+ -- with `X-Bz-Info-`+ } deriving (Show, Eq)++defaultFileProps :: FileProps+defaultFileProps = FileProps "b2/x-auto" Nothing Map.empty++data FileInfo =+ FileInfo+ { fiFileId :: Text+ , fiFileName :: Text+ , fiAccountId :: Text+ , fiBucketId :: BucketId+ , fiContentLength :: Int64+ , fiContentSha1 :: Text+ , fiContentType :: Text+ , fiFileInfo :: Map.Map Text Text+ , fiAction :: Text+ , fiUploadTimestamp :: BBTimestamp+ } deriving (Show, Eq, Generic)++instance Json.FromJSON FileInfo where+ parseJSON = Json.genericParseJSON $ labelModifierFn 2++data DownloadAuth = DownloadAuth {+ daBucketId :: BucketId+ , daFileNamePrefix :: Text+ , daAuthorizationToken :: Text+ } deriving (Show, Eq, Generic)++instance Json.FromJSON DownloadAuth where+ parseJSON = Json.genericParseJSON $ labelModifierFn 2++type Object = Text++type ObjectId = Text++data ObjectMetadata = ObjectMetadata {+ omContentLength :: Int64+ , omContentType :: Text+ , omObjectId :: ObjectId+ , omObjectName :: Object+ , omContentSha1 :: Text+ , omXBzInfo :: Map Text Text+ , omUploadTimestamp :: BBTimestamp+ , omCacheControl :: Text+ } deriving (Eq, Show)++data FileVersion = FileVersion {+ fvFileName :: Object+ , fvFileId :: ObjectId+ } deriving (Show, Eq, Generic)++instance Json.FromJSON FileVersion where+ parseJSON = Json.genericParseJSON $ labelModifierFn 2++instance Json.ToJSON FileVersion where+ toJSON = Json.genericToJSON $ labelModifierFn 2+ toEncoding = Json.genericToEncoding $ labelModifierFn 2++data ObjectListArgs = ObjectListArgs {+ olaBucketId :: BucketId+ , olaStartFileName :: Maybe Object+ , olaMaxFileCount :: Maybe Int+ , olaPrefix :: Maybe Object+ , olaDelimiter :: Maybe Text+ } deriving (Show, Eq, Generic)++instance Json.ToJSON ObjectListArgs where+ toJSON = Json.genericToJSON $ labelModifierFn 3+ toEncoding = Json.genericToEncoding $ labelModifierFn 3++data ListResultObjectItem = ListResultObjectItem {+ lroiFileId :: Text+ , lroiFileName :: Object+ , lroiContentLength :: Int64+ , lroiContentType :: Maybe Text+ , lroiContentSha1 :: Maybe Text+ , lroiFileInfo :: Maybe (Map.Map Text Text)+ , lroiAction :: Text+ , lroiUploadTimestamp :: BBTimestamp+ } deriving (Show, Eq, Generic)++instance Json.FromJSON ListResultObjectItem where+ parseJSON = Json.genericParseJSON $ labelModifierFn 4++data ListResultFolderItem = ListResultFolderItem {+ lrfiFileName :: Object+ , lrfiAction :: Text+ } deriving (Show, Eq, Generic)++instance Json.FromJSON ListResultFolderItem where+ parseJSON = Json.genericParseJSON $ labelModifierFn 4++data ListResultItem = LRIObject ListResultObjectItem+ | LRIFolder ListResultFolderItem+ deriving (Show, Eq)++instance Json.FromJSON ListResultItem where+ parseJSON v = (LRIObject <$> Json.parseJSON v)+ <|> (LRIFolder <$> Json.parseJSON v)++data ObjectListResult = ObjectListResult {+ olrFiles :: [ListResultObjectItem]+ , olrFolders :: [ListResultFolderItem]+ , olrNextFileName :: Maybe Object+ } deriving (Show, Eq, Generic)++instance Json.FromJSON ObjectListResult where+ parseJSON = Json.withObject "ObjectListResult" $ \o -> do+ nxt <- o .:? "nextFileName"+ listResultItems <- o .: "files"+ let (files, folders) = partitionIt listResultItems+ return $ ObjectListResult (reverse files) (reverse folders) nxt++ where+ partitionIt :: [ListResultItem] -> ([ListResultObjectItem],+ [ListResultFolderItem])+ partitionIt = flip foldl ([], []) $+ \(files, folders) item -> case item of+ LRIObject x -> (x:files, folders)+ LRIFolder x -> (files, x:folders)++-- | Stream type for uploading data to B2. It is made of a conduit and+-- a length representing the size of the stream in bytes.+data Stream = Stream+ { streamLength :: Int64+ , streamSource :: C.ConduitT () ByteString IO ()+ }++streamToReqBody :: Stream -> RC.ReqBodySource+streamToReqBody s =+ RC.ReqBodySource (streamLength s) (streamSource s)++-- | An object consumer is a function that receives object metadat and+-- an action that returns chunks of the body (returning an empty+-- bytestring when no more bytes are available).+newtype ObjectConsumer a =+ ObjectConsumer+ { unObjectConsumer :: (ObjectMetadata, IO ByteString) -> IO a+ }
+ src/Network/BackblazeB2/Utils.hs view
@@ -0,0 +1,98 @@+module Network.BackblazeB2.Utils where++import qualified Data.Aeson as Json+import qualified Data.ByteString as B+import Data.CaseInsensitive (mk)+import qualified Data.CaseInsensitive as CI+import qualified Data.Map.Strict as Map+import Data.Text.Read (decimal)+import Data.Time (UTCTime)+import qualified Network.HTTP.Client as HClient+import qualified Network.HTTP.Types.Header as Hdr+import qualified Network.HTTP.Types.URI as Uri+++import LocalPrelude++import Network.BackblazeB2.Data++urlEncode :: Text -> ByteString+urlEncode = Uri.urlEncode False . encodeUtf8++urlDecode :: ByteString -> Text+urlDecode = decodeUtf8LE . Uri.urlDecode True++execRequest :: ( Json.FromJSON a, Json.ToJSON b, MonadIO m+ , MonadReader ConnectInfo m+ )+ => Text+ -> b+ -> m a+execRequest apiName body = do+ ci <- ask+ let ai = authInfo ci+ url = mkUrl apiName ai+ atok = encodeUtf8 $ aiAuthorizationToken ai+ auth = header "Authorization" atok++ fmap responseBody $ liftIO $ req POST url (ReqBodyJson body) jsonResponse auth++ where++ mkUrl :: Text -> AuthInfo -> Url 'Https+ mkUrl name ai = (aiApiUrl ai) /: "b2api" /: "v2" /: name++mkLastModifiedKV+ :: UTCTime+ -> (Text, Text)+mkLastModifiedKV t =+ ("src_last_modified_millis",+ show $ getMilliEpoch $ BBTimestamp t)++parseObjectMetadataHeaders :: Hdr.ResponseHeaders+ -> Either LibErr ObjectMetadata+parseObjectMetadataHeaders r =+ ObjectMetadata+ <$> parseCL+ <*> (toS <$> lookup Hdr.hContentType)+ <*> (toS <$> lookup (mk "X-Bz-File-Id"))+ <*> (urlDecode <$> lookup (mk "X-Bz-File-Name"))+ <*> (toS <$> lookup (mk "X-Bz-Content-Sha1"))+ <*> pure parseMeta+ <*> (lookup (mk "X-Bz-Upload-Timestamp") >>= parseTimestamp)+ <*> (toS <$> lookup Hdr.hCacheControl)+ where+ h = Map.fromList r++ lookup :: CI.CI ByteString -> Either LibErr ByteString+ lookup k = maybe (Left $ HeaderMissing k) Right $+ Map.lookup k h++ parseCL :: Either LibErr Int64+ parseCL = do+ val <- lookup Hdr.hContentLength+ either (Left . HeaderParseError Hdr.hContentLength val)+ (Right . fst) $ decimal $ decodeUtf8LE val++ isMetaHdr (k, _) = "x-bz-info-" `B.isPrefixOf` (CI.foldedCase k)+ dropLen = B.length "x-bz-info-"+ extractMeta (k, v) = (decodeUtf8LE $ B.drop dropLen $ CI.original k,+ urlDecode v)+ parseMeta = Map.fromList $ map extractMeta $ filter isMetaHdr r++ parseTimestamp :: ByteString -> Either LibErr BBTimestamp+ parseTimestamp = either (Left . JsonErr . toS) Right+ . Json.eitherDecodeStrict++doRequest :: MonadIO m+ => ObjectConsumer b+ -> (Url scheme, Option scheme) -> m b+doRequest consumer (url, opts) =+ liftIO $ reqBr GET url NoReqBody opts $ \r -> do+ let hdrs = HClient.responseHeaders r+ metaE = parseObjectMetadataHeaders hdrs+ case metaE of+ Left e -> throwIO e+ Right meta -> do+ let bodyReader = HClient.responseBody r+ (unObjectConsumer consumer) (meta, bodyReader)
+ test/Spec.hs view
@@ -0,0 +1,96 @@+import Test.Tasty+import Test.Tasty.HUnit++import LocalPrelude+import Network.BackblazeB2.B2API++import qualified Conduit as C+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8++main :: IO ()+main = do+ credsM <- credsFromEnv+ c <- maybe (throwString "No creds env!") return credsM+ defaultMain $ funcTests c++funcTests :: Credentials -> TestTree+funcTests c = do+ testGroup "Functional tests" $ map (\f -> f c)+ [ basicBucketOpsTest+ , basicFileUploadDownloadTest+ ]++testBucket :: Bucket+testBucket = "bb2hs-test-xxx1"++basicBucketOpsTest :: Credentials -> TestTree+basicBucketOpsTest c = testCaseSteps "Basic Bucket Operations" $ \step -> do+ step "Authorizing account..."+ connInfo <- liftIO $ authorizeAccount c+ let b = "bb2hs-test-x1"+ step "Creating bucket.."+ bd <- liftIO $ flip runReaderT connInfo $+ createBucket b AllPrivate emptyBucketOpts+ brdBucketName bd @?= b++ let bucketId = brdBucketId bd++ step "Listing buckets.."+ AllBuckets bkts <- liftIO $ runReaderT listBuckets connInfo+ assertBool "Created bucket not found!" $+ isJust $ find ((b ==) . brdBucketName) bkts++ step "Deleting bucket.."+ void $ liftIO $ flip runReaderT connInfo $ deleteBucket bucketId++basicFileUploadDownloadTest :: Credentials -> TestTree+basicFileUploadDownloadTest c = testCaseSteps "Basic Upload/Download" $ \step -> do+ step "Authorizing account..."+ connInfo <- liftIO $ authorizeAccount c++ step "Check if testBucket exists..."+ AllBuckets bkts <- liftIO $ runReaderT listBuckets connInfo+ let listedBucketM = find ((testBucket ==) . brdBucketName) bkts+ createBucketFn = do+ step "Bucket does not exist: creating.."+ bd <- liftIO $ flip runReaderT connInfo $+ createBucket testBucket AllPrivate emptyBucketOpts+ brdBucketName bd @?= testBucket+ return bd++ bucketId <- maybe (brdBucketId <$> createBucketFn)+ (return . brdBucketId) listedBucketM++ step "Getting upload URL"+ uu <- liftIO $ flip runReaderT connInfo $ getUploadUrl bucketId+ uuBucketId uu @?= bucketId++ step "Upload some data"+ let fname = "small-test-file"+ flen = 500 :: Int64++ fi <- liftIO $ flip runReaderT connInfo $+ uploadFile uu fname+ defaultFileProps (Stream flen $ C.yield $+ B8.replicate (fromIntegral flen) 'a')++ fiFileName fi @?= "small-test-file"+ fiContentLength fi @?= flen++ step "Download the same data"+ let consumer (_, f) = loop f+ loop f = do b' <- f+ if | B.null b' -> return True+ | not (B8.all (== 'a') b') -> return False+ | otherwise -> loop f+ ok <- liftIO $ flip runReaderT connInfo $+ downloadFileByName testBucket fname [] $ ObjectConsumer consumer+ assertBool "Downloaded bytes did not match!" ok++ step "Deleting object"+ let fv = FileVersion fname (fiFileId fi)+ void $ flip runReaderT connInfo $ deleteFileVersion fv++ step "Deleting bucket.."+ void $ liftIO $ flip runReaderT connInfo $ deleteBucket bucketId