diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for backblaze-b2-client + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. 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/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/backblaze-b2-hs.cabal b/backblaze-b2-hs.cabal new file mode 100644 --- /dev/null +++ b/backblaze-b2-hs.cabal @@ -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 diff --git a/src/LocalPrelude.hs b/src/LocalPrelude.hs new file mode 100644 --- /dev/null +++ b/src/LocalPrelude.hs @@ -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 diff --git a/src/Network/BackblazeB2.hs b/src/Network/BackblazeB2.hs new file mode 100644 --- /dev/null +++ b/src/Network/BackblazeB2.hs @@ -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 diff --git a/src/Network/BackblazeB2/B2API.hs b/src/Network/BackblazeB2/B2API.hs new file mode 100644 --- /dev/null +++ b/src/Network/BackblazeB2/B2API.hs @@ -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) diff --git a/src/Network/BackblazeB2/Crypto.hs b/src/Network/BackblazeB2/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Network/BackblazeB2/Crypto.hs @@ -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 diff --git a/src/Network/BackblazeB2/Data.hs b/src/Network/BackblazeB2/Data.hs new file mode 100644 --- /dev/null +++ b/src/Network/BackblazeB2/Data.hs @@ -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 + } diff --git a/src/Network/BackblazeB2/Utils.hs b/src/Network/BackblazeB2/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Network/BackblazeB2/Utils.hs @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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