diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,4 +8,9 @@ ## Unreleased +## 1.1.0.0 - 2025-09-11 + +- Synchronized version bump for v1.1.0.0 release. +- Improved upload and download object with resumable link. + ## 0.1.0.0 - YYYY-MM-DD diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,3 +3,82 @@ Haskell idiomatic client for [Google Cloud Platform](https://cloud.google.com/) Storage service. Full docs are available at https://github.com/tusharad/google-cloud-haskell + +## Installation + +- Cabal: add to your `.cabal` + - `build-depends: google-cloud-storage == 1.1.0.0` +- Stack: add to your `package.yaml` + - `dependencies: - google-cloud-storage == 1.1.0.0` + +This package depends on `google-cloud-common` for authentication and HTTP helpers. + +## Authentication + +Authentication is handled by `google-cloud-common` and follows this order: + +1. Use `GOOGLE_APPLICATION_CREDENTIALS` to load a Service Account JSON and + exchange a signed JWT for an access token. +2. Otherwise, use the Compute metadata server (suitable for GCE/GKE). + +## Examples + +Minimal examples using `Google.Cloud.Storage.Bucket`: + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import qualified Data.ByteString.Lazy.Char8 as BSL +import Google.Cloud.Storage.Bucket + +-- List buckets in a project +listBucketsExample :: IO () +listBucketsExample = do + let projectId = "my-gcp-project" + eRes <- listBuckets projectId + case eRes of + Left err -> putStrLn ("Error: " <> err) + Right buckets -> print buckets + +-- Create a bucket +createBucketExample :: IO () +createBucketExample = do + let newBucket = CreateBucketData + { name = "my-unique-bucket-name" + , location = Location "us-central1" + , storageClass = STANDARD + , projectId = "my-gcp-project" + } + eRes <- createBucket newBucket + case eRes of + Left err -> putStrLn ("Create error: " <> err) + Right _ -> putStrLn "Bucket created" + +-- Upload and download objects +objectOpsExample :: IO () +objectOpsExample = do + let bucket = "my-bucket" + object = "my-object.txt" + _ <- uploadObject bucket object (BSL.pack "Hello, world!") + eBody <- downloadObject bucket object + case eBody of + Left err -> putStrLn ("Download error: " <> err) + Right body -> BSL.putStrLn body + +-- Copy and delete an object +copyDeleteExample :: IO () +copyDeleteExample = do + let req = CopyObjectRequest + { sourceBucketName = "my-bucket" + , sourceObjectName = "my-object.txt" + , destinationBucketName = "another-bucket" + , destinationObject = "copied-object.txt" + } + _ <- copyObject req + _ <- deleteObject "my-bucket" "my-object.txt" + pure () +``` + +## License + +MIT © Contributors diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/google-cloud-storage.cabal b/google-cloud-storage.cabal --- a/google-cloud-storage.cabal +++ b/google-cloud-storage.cabal @@ -1,12 +1,14 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack name: google-cloud-storage -version: 0.1.0.0 +version: 1.1.0.0 +synopsis: GCP Client for Haskell description: GCP Storage bucket client for Haskell. +category: Web homepage: https://github.com/tusharad/google-cloud-haskell#readme bug-reports: https://github.com/tusharad/google-cloud-haskell/issues author: tushar @@ -36,6 +38,8 @@ , base >=4.7 && <5 , bytestring >=0.9.1.4 , google-cloud-common + , http-conduit + , http-types , text >=1.2 && <3 default-language: Haskell2010 @@ -53,5 +57,9 @@ , bytestring >=0.9.1.4 , google-cloud-common , google-cloud-storage + , http-conduit + , http-types + , tasty >=1.4 + , tasty-hunit >=0.10 , text >=1.2 && <3 default-language: Haskell2010 diff --git a/src/Google/Cloud/Storage/Bucket.hs b/src/Google/Cloud/Storage/Bucket.hs --- a/src/Google/Cloud/Storage/Bucket.hs +++ b/src/Google/Cloud/Storage/Bucket.hs @@ -4,15 +4,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} --- | This module provides functions for interacting with Google Cloud Storage buckets and objects. --- It includes functionality for listing, creating, updating, and deleting buckets, as well as --- copying, deleting, downloading, and uploading objects. +{- | This module provides functions for interacting with Google Cloud Storage buckets and objects. +It includes functionality for listing, creating, updating, and deleting buckets, as well as +copying, deleting, downloading, and uploading objects. +-} module Google.Cloud.Storage.Bucket ( Buckets (..) , Location (..) , StorageClass (..) , CreateBucketData (..) , CopyObjectRequest (..) + , CopyObjectResp (..) , listBuckets , createBucket , updateBucketStorageClass @@ -29,69 +31,100 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import GHC.Generics (Generic) -import Google.Cloud.Common.Core +import Google.Cloud.Common.Core +import Network.HTTP.Simple +import Network.HTTP.Types (status200, status308) -- | Represents a list of buckets in a Google Cloud Storage project. data Buckets = Buckets - { kind :: String -- ^ The kind of item this is. For buckets, this is always "storage#buckets". - , items :: [Bucket] -- ^ The list of buckets. + { kind :: String + -- ^ The kind of item this is. For buckets, this is always "storage#buckets". + , items :: [Bucket] + -- ^ The list of buckets. } deriving (Show, Generic, FromJSON, ToJSON) -- | Represents a single bucket in Google Cloud Storage. data Bucket = Bucket - { kind :: String -- ^ The kind of item this is. For buckets, this is always "storage#bucket". - , selfLink :: String -- ^ The URL of this bucket. - , id :: String -- ^ The ID of the bucket. - , name :: String -- ^ The name of the bucket. - , projectNumber :: String -- ^ The project number of the project the bucket belongs to. - , generation :: String -- ^ The generation of this bucket. - , metageneration :: String -- ^ The metadata generation of this bucket. - , location :: String -- ^ The location of the bucket. - , storageClass :: String -- ^ The storage class of the bucket. - , etag :: String -- ^ The entity tag for this bucket. - , timeCreated :: String -- ^ The creation time of the bucket. - , updated :: String -- ^ The last modification time of the bucket. - , softDeletePolicy :: SoftDeletePolicy -- ^ The soft delete policy of the bucket. - , iamConfiguration :: IAMConfiguration -- ^ The IAM configuration of the bucket. - , locationType :: String -- ^ The type of location (e.g., region). - , satisfiesPZI :: Bool -- ^ Whether the bucket satisfies the PZI (Per-Zone Isolation) requirement. - , hierarchicalNamespace :: Maybe HierarchicalNamespace -- ^ The hierarchical namespace configuration. + { kind :: String + -- ^ The kind of item this is. For buckets, this is always "storage#bucket". + , selfLink :: String + -- ^ The URL of this bucket. + , id :: String + -- ^ The ID of the bucket. + , name :: String + -- ^ The name of the bucket. + , projectNumber :: String + -- ^ The project number of the project the bucket belongs to. + , generation :: String + -- ^ The generation of this bucket. + , metageneration :: String + -- ^ The metadata generation of this bucket. + , location :: String + -- ^ The location of the bucket. + , storageClass :: String + -- ^ The storage class of the bucket. + , etag :: String + -- ^ The entity tag for this bucket. + , timeCreated :: String + -- ^ The creation time of the bucket. + , updated :: String + -- ^ The last modification time of the bucket. + , softDeletePolicy :: SoftDeletePolicy + -- ^ The soft delete policy of the bucket. + , iamConfiguration :: IAMConfiguration + -- ^ The IAM configuration of the bucket. + , locationType :: String + -- ^ The type of location (e.g., region). + , satisfiesPZI :: Maybe Bool + -- ^ Whether the bucket satisfies the PZI (Per-Zone Isolation) requirement. + , hierarchicalNamespace :: Maybe HierarchicalNamespace + -- ^ The hierarchical namespace configuration. } deriving (Show, Generic, FromJSON, ToJSON) -- | Represents the soft delete policy of a bucket. data SoftDeletePolicy = SoftDeletePolicy - { retentionDurationSeconds :: String -- ^ The duration in seconds that soft-deleted objects are retained. - , effectiveTime :: String -- ^ The time from which the policy was enforced. + { retentionDurationSeconds :: String + -- ^ The duration in seconds that soft-deleted objects are retained. + , effectiveTime :: String + -- ^ The time from which the policy was enforced. } deriving (Show, Generic, FromJSON, ToJSON) -- | Represents the IAM configuration of a bucket. data IAMConfiguration = IAMConfiguration - { bucketPolicyOnly :: BucketPolicyOnly -- ^ The Bucket Policy Only configuration. - , uniformBucketLevelAccess :: UniformBucketLevelAccess -- ^ The Uniform Bucket-Level Access configuration. - , publicAccessPrevention :: String -- ^ The public access prevention status. + { bucketPolicyOnly :: BucketPolicyOnly + -- ^ The Bucket Policy Only configuration. + , uniformBucketLevelAccess :: UniformBucketLevelAccess + -- ^ The Uniform Bucket-Level Access configuration. + , publicAccessPrevention :: String + -- ^ The public access prevention status. } deriving (Show, Generic, FromJSON, ToJSON) -- | Represents the Bucket Policy Only configuration. data BucketPolicyOnly = BucketPolicyOnly - { enabled :: Bool -- ^ Whether Bucket Policy Only is enabled. - , lockedTime :: Maybe String -- ^ The time when the configuration was locked, if applicable. + { enabled :: Bool + -- ^ Whether Bucket Policy Only is enabled. + , lockedTime :: Maybe String + -- ^ The time when the configuration was locked, if applicable. } deriving (Show, Generic, FromJSON, ToJSON) -- | Represents the Uniform Bucket-Level Access configuration. data UniformBucketLevelAccess = UniformBucketLevelAccess - { enabled :: Bool -- ^ Whether Uniform Bucket-Level Access is enabled. - , lockedTime :: Maybe String -- ^ The time when the configuration was locked, if applicable. + { enabled :: Bool + -- ^ Whether Uniform Bucket-Level Access is enabled. + , lockedTime :: Maybe String + -- ^ The time when the configuration was locked, if applicable. } deriving (Show, Generic, FromJSON, ToJSON) -- | Represents the hierarchical namespace configuration of a bucket. newtype HierarchicalNamespace = HierarchicalNamespace - { enabled :: Bool -- ^ Whether hierarchical namespace is enabled. + { enabled :: Bool + -- ^ Whether hierarchical namespace is enabled. } deriving (Show, Generic, FromJSON, ToJSON) @@ -104,44 +137,62 @@ -- | Represents the storage class of a bucket or object. data StorageClass - = STANDARD -- ^ Standard storage class, for frequently accessed data. - | NEARLINE -- ^ Nearline storage class, for infrequently accessed data. - | COLDLINE -- ^ Coldline storage class, for rarely accessed data. - | ARCHIVE -- ^ Archive storage class, for long-term data archiving. + = -- | Standard storage class, for frequently accessed data. + STANDARD + | -- | Nearline storage class, for infrequently accessed data. + NEARLINE + | -- | Coldline storage class, for rarely accessed data. + COLDLINE + | -- | Archive storage class, for long-term data archiving. + ARCHIVE deriving (Eq, Show) -- | Data required to create a new bucket. data CreateBucketData = CreateBucketData - { name :: String -- ^ The name of the bucket to create. - , location :: Location -- ^ The location where the bucket will be created. - , storageClass :: StorageClass -- ^ The storage class for the bucket. - , projectId :: String -- ^ The ID of the project in which to create the bucket. + { name :: String + -- ^ The name of the bucket to create. + , location :: Location + -- ^ The location where the bucket will be created. + , storageClass :: StorageClass + -- ^ The storage class for the bucket. + , projectId :: String + -- ^ The ID of the project in which to create the bucket. } deriving (Show) -- | Request data for copying an object. data CopyObjectRequest = CopyObjectRequest - { sourceBucketName :: String -- ^ The name of the source bucket. - , sourceObjectName :: String -- ^ The name of the source object. - , destinationBucketName :: String -- ^ The name of the destination bucket. - , destinationObject :: String -- ^ The name of the destination object. + { sourceBucketName :: String + -- ^ The name of the source bucket. + , sourceObjectName :: String + -- ^ The name of the source object. + , destinationBucketName :: String + -- ^ The name of the destination bucket. + , destinationObject :: String + -- ^ The name of the destination object. } deriving (Show, Generic) -- | Response data for copying an object. data CopyObjectResp = CopyObjectResp - { kind :: String -- ^ The kind of item this is. - , totalBytesRewritten :: String -- ^ The total number of bytes rewritten. - , objectSize :: String -- ^ The size of the object. - , done :: Bool -- ^ Whether the copy operation is complete. - , rewriteToken :: Maybe String -- ^ Token for continuing the rewrite operation, if not done. + { kind :: String + -- ^ The kind of item this is. + , totalBytesRewritten :: String + -- ^ The total number of bytes rewritten. + , objectSize :: String + -- ^ The size of the object. + , done :: Bool + -- ^ Whether the copy operation is complete. + , rewriteToken :: Maybe String + -- ^ Token for continuing the rewrite operation, if not done. } deriving (Show, Eq, Generic, FromJSON) --- | Lists all buckets in a given project. --- --- @listBuckets projectId@ makes a request to list all buckets in the specified @projectId@. --- It returns either an error message or a 'Buckets' object containing the list of buckets. +{- | Lists all buckets in a given project. + +@listBuckets projectId@ makes a request to list all buckets in the specified @projectId@. +It returns either an error message or a 'Buckets' object containing the list of buckets. +-} listBuckets :: String -> IO (Either String Buckets) listBuckets projectId = doRequestJSON @@ -154,10 +205,11 @@ , mbReqPath = Nothing } --- | Creates a new bucket in Google Cloud Storage. --- --- @createBucket createBucketData@ creates a new bucket with the specified name, location, --- storage class, and project ID. It returns either an error message or a unit value indicating success. +{- | Creates a new bucket in Google Cloud Storage. + +@createBucket createBucketData@ creates a new bucket with the specified name, location, +storage class, and project ID. It returns either an error message or a unit value indicating success. +-} createBucket :: CreateBucketData -> IO (Either String ()) createBucket CreateBucketData {..} = doRequestJSON @@ -170,15 +222,16 @@ , mbQueryParams = Just [("project", Just (BS.pack projectId))] } --- | Updates the storage class of an existing bucket. --- --- @updateBucketStorageClass bucketName newStorageClass@ updates the storage class of the --- specified bucket to @newStorageClass@. It returns either an error message or a unit value --- indicating success. --- -- Example: --- --- >>> updateBucketStorageClass "my-bucket" COLDLINE --- Right () +{- | Updates the storage class of an existing bucket. + +@updateBucketStorageClass bucketName newStorageClass@ updates the storage class of the +specified bucket to @newStorageClass@. It returns either an error message or a unit value +indicating success. +-- Example: + +>>> updateBucketStorageClass "my-bucket" COLDLINE +Right () +-} updateBucketStorageClass :: String -> StorageClass -> IO (Either String ()) updateBucketStorageClass bucketName newStorageClass = doRequestJSON @@ -191,14 +244,15 @@ , mbQueryParams = Just [("fields", Just "storageClass")] } --- | Fetches the metadata of a specific bucket. --- --- @fetchBucket bucketName@ retrieves the metadata for the bucket with the given name. --- It returns either an error message or the 'Bucket' object. --- Example: --- --- >>> fetchBucket "my-bucket" --- Right (Bucket {name = "my-bucket", ...}) +{- | Fetches the metadata of a specific bucket. + +@fetchBucket bucketName@ retrieves the metadata for the bucket with the given name. +It returns either an error message or the 'Bucket' object. +Example: + +>>> fetchBucket "my-bucket" +Right (Bucket {name = "my-bucket", ...}) +-} fetchBucket :: String -> IO (Either String Bucket) fetchBucket bucketName = doRequestJSON @@ -211,17 +265,18 @@ , mbQueryParams = Nothing } --- | Copies an object from one bucket to another. --- --- @copyObject copyObjectRequest@ copies the specified source object to the destination bucket --- and object name. For large objects, this function handles the copy in multiple requests --- using rewrite tokens. It returns either an error message or a 'CopyObjectResp' indicating --- the status of the copy operation. --- Example: --- --- >>> let request = CopyObjectRequest "source-bucket" "source-object" "destination-bucket" "destination-object" --- >>> copyObject request --- Right (CopyObjectResp {kind = "storage#object", totalBytesRewritten = "12345", objectSize = "12345", done = True, rewriteToken = Nothing}) +{- | Copies an object from one bucket to another. + +@copyObject copyObjectRequest@ copies the specified source object to the destination bucket +and object name. For large objects, this function handles the copy in multiple requests +using rewrite tokens. It returns either an error message or a 'CopyObjectResp' indicating +the status of the copy operation. +Example: + +>>> let request = CopyObjectRequest "source-bucket" "source-object" "destination-bucket" "destination-object" +>>> copyObject request +Right (CopyObjectResp {kind = "storage#object", totalBytesRewritten = "12345", objectSize = "12345", done = True, rewriteToken = Nothing}) +-} copyObject :: CopyObjectRequest -> IO (Either String CopyObjectResp) copyObject CopyObjectRequest {..} = do go Nothing @@ -258,14 +313,15 @@ else do go (Just (rewriteToken resp)) --- | Deletes an object from a bucket. --- --- @deleteObject bucketName objectName@ deletes the specified object from the given bucket. --- It returns either an error message or a unit value indicating success. --- Example: --- --- >>> deleteObject "my-bucket" "my-object" --- Right () +{- | Deletes an object from a bucket. + +@deleteObject bucketName objectName@ deletes the specified object from the given bucket. +It returns either an error message or a unit value indicating success. +Example: + +>>> deleteObject "my-bucket" "my-object" +Right () +-} deleteObject :: String -> String -> IO (Either String ()) deleteObject bucketName objectName = doRequestJSON @@ -278,15 +334,16 @@ , mbQueryParams = Nothing } --- | Deletes a bucket. --- --- @deleteBucket bucketName@ deletes the specified bucket. Note that the bucket must be empty --- before it can be deleted. It returns either an error message or a unit value indicating success. --- --- Example: --- --- >>> deleteBucket "my-bucket" --- Right () +{- | Deletes a bucket. + +@deleteBucket bucketName@ deletes the specified bucket. Note that the bucket must be empty +before it can be deleted. It returns either an error message or a unit value indicating success. + +Example: + +>>> deleteBucket "my-bucket" +Right () +-} deleteBucket :: String -> IO (Either String ()) deleteBucket bucketName = doRequestJSON @@ -299,35 +356,49 @@ , mbQueryParams = Nothing } --- | Downloads an object from a bucket to a local file. --- --- @downloadObject bucketName objectName saveLocation@ returns the specified object in --- lazy bytestring format. It returns either an error message or content indicating success. --- Note: This function downloads the entire object at once; for large objects, consider --- implementing streaming or slicing (planned for future versions). --- Example: --- --- >>> downloadObject "my-bucket" "my-object" --- Right (bytestring content) +{- | Downloads an object from a bucket to a local file. + +@downloadObject bucketName objectName saveLocation@ returns the specified object in +lazy bytestring format. It returns either an error message or content indicating success. +Note: This function downloads the entire object at once; for large objects, consider +implementing streaming or slicing (planned for future versions). +Example: + +>>> downloadObject "my-bucket" "my-object" +Right (bytestring content) +-} downloadObject :: String -> String -> IO (Either String BSL.ByteString) -downloadObject bucketName objectName = do - let reqOpts = - RequestOptions - { reqMethod = GET - , reqUrl = googleStorageUrl - , mbQueryParams = Just [("alt", Just "media")] - , mbReqBody = Nothing - , mbReqHeaders = Nothing - , mbReqPath = Just $ "/" <> bucketName <> "/o/" <> objectName - } - res <- doRequest reqOpts - case res of - Left err -> return (Left err) - Right resp -> do - let body = resp - return $ Right body +downloadObject bucketName objectName = go 0 mempty + where + chunkSize :: Int + chunkSize = 1024 * 1024 -- 1 MB per chunk (tune as needed) + go :: Int -> BSL.ByteString -> IO (Either String BSL.ByteString) + go offset acc = do + let rangeHeader = + ( "Range" + , BS.pack $ + "bytes=" <> show offset <> "-" <> show (offset + chunkSize - 1) + ) + reqOpts = + RequestOptions + { reqMethod = GET + , reqUrl = googleStorageUrl + , mbReqPath = Just $ "/" <> bucketName <> "/o/" <> objectName + , mbReqHeaders = Just [rangeHeader] + , mbQueryParams = Just [("alt", Just "media")] + , mbReqBody = Nothing + } + eBody <- doRequest reqOpts + case eBody of + Left err -> pure $ Left err + Right body -> do + let len = fromIntegral (BSL.length body) + if len < chunkSize + then pure $ Right (acc `BSL.append` body) -- last chunk + else do + print ("donwloded so far: " :: String, offset + chunkSize) + go (offset + chunkSize) (acc `BSL.append` body) --- | Uploads an object to a bucket. -- -- @uploadObject bucketName objectName objectContent@ uploads the given content to the specified -- object in the bucket. It returns either an error message or a unit value indicating success. @@ -338,23 +409,103 @@ -- >>> uploadObject "my-bucket" "my-object" (BSL.pack "object content") -- Right () uploadObject :: String -> String -> BSL.ByteString -> IO (Either String ()) -uploadObject bucketName objectName objectContent = do - doRequestJSON - RequestOptions - { reqMethod = POST - , reqUrl = "https://storage.googleapis.com/upload/storage/v1/b" - , mbReqPath = Just $ "/" <> bucketName <> "/o" - , mbReqBody = Just objectContent - , mbReqHeaders = Nothing - , mbQueryParams = Just [("uploadType", Just "media"),("name", Just $ BS.pack objectName)] - } +uploadObject = resumableUploadObject +{- | Initiates a resumable upload session. + +Returns the resumable session URL (from the Location header) which can be +used to upload chunks of the object. +-} +initResumableUpload :: String -> String -> IO (Either String String) +initResumableUpload bucketName objectName = do + eResp <- + doRequestRaw + RequestOptions + { reqMethod = POST + , reqUrl = "https://storage.googleapis.com/upload/storage/v1/b" + , mbReqPath = Just ("/" <> bucketName <> "/o") + , mbReqBody = Nothing + , mbReqHeaders = Just [("Content-Type", "application/json")] + , mbQueryParams = + Just + [ ("uploadType", Just "resumable") + , ("name", BS.pack <$> Just objectName) + ] + } + case eResp of + Left err -> pure $ Left err + Right resp -> case getResponseHeader "location" resp of + [] -> pure $ Left "Missing resumable upload URL in response" + (loc : _) -> pure $ Right (BS.unpack loc) + +{- | Uploads a file using a resumable upload session in chunks. + +This function splits the objectContent into chunks and uploads sequentially. +-} +resumableUploadObject :: String -> String -> BSL.ByteString -> IO (Either String ()) +resumableUploadObject bucketName objectName objectContent = do + eSessionUrl <- initResumableUpload bucketName objectName + case eSessionUrl of + Left err -> pure $ Left err + Right sessionUrl -> uploadChunks sessionUrl 0 (BSL.toStrict objectContent) + where + chunkSize :: Int + chunkSize = 1024 * 1024 -- 1MB per chunk (tune as needed) + uploadChunks :: String -> Int -> BS.ByteString -> IO (Either String ()) + uploadChunks sessionUrl offset bs + | BS.null bs = pure $ Right () + | otherwise = do + let (chunk, rest) = BS.splitAt chunkSize bs + totalSize = offset + BS.length chunk + BS.length rest + endByte = offset + BS.length chunk - 1 + isLast = BS.null rest + contentRange = + if isLast + then + "bytes " + <> show offset + <> "-" + <> show endByte + <> "/" + <> show totalSize + else "bytes " <> show offset <> "-" <> show endByte <> "/*" + + headers = + [ ("Content-Length", BS.pack (show (BS.length chunk))) + , ("Content-Range", BS.pack contentRange) + ] + + eResp <- + doRequestRaw + RequestOptions + { reqMethod = PUT + , reqUrl = sessionUrl + , mbReqPath = Nothing + , mbReqBody = Just (BSL.fromStrict chunk) + , mbReqHeaders = Just headers + , mbQueryParams = Nothing + } + + case eResp of + Left err -> pure $ Left err + Right resp -> do + let status = getResponseStatus resp + if status == status200 + then pure $ Right () -- Finished + else + if status == status308 + then uploadChunks sessionUrl (offset + BS.length chunk) rest -- Continue + else pure $ Left $ "Unexpected status: " <> show status + -- Helper types and functions (not exported, so no Haddock documentation needed) data CreateBucketRequest = CreateBucketRequest - { name :: String -- ^ Name of the bucket - , location :: String -- ^ Location of bucket e.g us-central1-a - , storageClass :: StorageClass -- ^ Storage Class + { name :: String + -- ^ Name of the bucket + , location :: String + -- ^ Location of bucket e.g us-central1-a + , storageClass :: StorageClass + -- ^ Storage Class } deriving (Show) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Data.Aeson (eitherDecode) +import qualified Data.ByteString.Lazy.Char8 as BSL +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) + +import Google.Cloud.Storage.Bucket + ( Buckets (..) + , CopyObjectResp (..) + , Location (..) + , StorageClass (..) + , googleStorageUrl + ) +import qualified Google.Cloud.Storage.Bucket as CopyObject (CopyObjectResp (..)) + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "google-cloud-storage" + [ testCase "googleStorageUrl is JSON API buckets endpoint" $ do + assertEqual + "Expected JSON API base for buckets" + "https://storage.googleapis.com/storage/v1/b" + googleStorageUrl + , testCase "Location Show instance renders wrapped string" $ do + assertEqual "Show Location" "us-central1" (show (Location "us-central1")) + , testCase "StorageClass Show values match API names" $ do + assertEqual "STANDARD" "STANDARD" (show STANDARD) + assertEqual "NEARLINE" "NEARLINE" (show NEARLINE) + assertEqual "COLDLINE" "COLDLINE" (show COLDLINE) + assertEqual "ARCHIVE" "ARCHIVE" (show ARCHIVE) + , testCase "Decode CopyObjectResp from JSON (objects.rewrite)" $ do + let json = + BSL.pack + "{\n" + <> " \"kind\": \"storage#rewriteResponse\",\n" + <> " \"totalBytesRewritten\": \"12345\",\n" + <> " \"objectSize\": \"12345\",\n" + <> " \"done\": true,\n" + <> " \"rewriteToken\": null\n" + <> "}" + case eitherDecode json of + Left err -> assertBool ("Failed to decode: " <> err) False + Right resp -> do + let expected = + CopyObjectResp + { CopyObject.kind = "storage#rewriteResponse" + , totalBytesRewritten = "12345" + , objectSize = "12345" + , done = True + , rewriteToken = Nothing + } + assertEqual "CopyObjectResp" expected resp + , testCase "Decode Buckets with empty items" $ do + let json = BSL.pack "{\n \"kind\": \"storage#buckets\",\n \"items\": []\n}" + case eitherDecode json of + Left err -> assertBool ("Failed to decode: " <> err) False + Right (Buckets kindVal itemsVal) -> do + assertEqual "Buckets.kind" "storage#buckets" kindVal + assertEqual "Buckets.items length" 0 (length itemsVal) + ]