diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `google-cloud-storage` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2025 Tushar Adhatrao + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# google-cloud-storage + +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 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/google-cloud-storage.cabal b/google-cloud-storage.cabal new file mode 100644 --- /dev/null +++ b/google-cloud-storage.cabal @@ -0,0 +1,57 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: google-cloud-storage +version: 0.1.0.0 +description: GCP Storage bucket client for Haskell. +homepage: https://github.com/tusharad/google-cloud-haskell#readme +bug-reports: https://github.com/tusharad/google-cloud-haskell/issues +author: tushar +maintainer: tusharadhatrao@gmail.com +copyright: 2025 tushar +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/tusharad/google-cloud-haskell + +library + exposed-modules: + Google.Cloud.Storage.Bucket + other-modules: + Paths_google_cloud_storage + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + aeson <3 + , base >=4.7 && <5 + , bytestring >=0.9.1.4 + , google-cloud-common + , text >=1.2 && <3 + default-language: Haskell2010 + +test-suite google-cloud-storage-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_google_cloud_storage + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson <3 + , base >=4.7 && <5 + , bytestring >=0.9.1.4 + , google-cloud-common + , google-cloud-storage + , text >=1.2 && <3 + default-language: Haskell2010 diff --git a/src/Google/Cloud/Storage/Bucket.hs b/src/Google/Cloud/Storage/Bucket.hs new file mode 100644 --- /dev/null +++ b/src/Google/Cloud/Storage/Bucket.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# 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. +module Google.Cloud.Storage.Bucket + ( Buckets (..) + , Location (..) + , StorageClass (..) + , CreateBucketData (..) + , CopyObjectRequest (..) + , listBuckets + , createBucket + , updateBucketStorageClass + , fetchBucket + , copyObject + , deleteObject + , deleteBucket + , downloadObject + , uploadObject + , googleStorageUrl + ) where + +import Data.Aeson +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import GHC.Generics (Generic) +import Google.Cloud.Common.Core + +-- | 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. + } + 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. + } + 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. + } + 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. + } + 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. + } + 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. + } + deriving (Show, Generic, FromJSON, ToJSON) + +-- | Represents the hierarchical namespace configuration of a bucket. +newtype HierarchicalNamespace = HierarchicalNamespace + { enabled :: Bool -- ^ Whether hierarchical namespace is enabled. + } + deriving (Show, Generic, FromJSON, ToJSON) + +-- | Represents the location of a bucket. +newtype Location = Location String + deriving (Eq) + +instance Show Location where + show (Location location) = location + +-- | 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. + 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. + } + 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. + } + 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. + } + 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. +listBuckets :: String -> IO (Either String Buckets) +listBuckets projectId = + doRequestJSON + RequestOptions + { reqMethod = GET + , reqUrl = googleStorageUrl + , mbQueryParams = Just [("project", Just (BS.pack projectId))] + , mbReqBody = Nothing + , mbReqHeaders = Nothing + , 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. +createBucket :: CreateBucketData -> IO (Either String ()) +createBucket CreateBucketData {..} = + doRequestJSON + RequestOptions + { reqMethod = POST + , reqUrl = googleStorageUrl + , mbReqPath = Nothing + , mbReqBody = Just (encode $ CreateBucketRequest name (show location) storageClass) + , mbReqHeaders = Just [("Content-Type", "application/json")] + , 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 () +updateBucketStorageClass :: String -> StorageClass -> IO (Either String ()) +updateBucketStorageClass bucketName newStorageClass = + doRequestJSON + RequestOptions + { reqMethod = PATCH + , reqUrl = googleStorageUrl + , mbReqPath = Just ("/" <> bucketName) + , mbReqBody = Just (encode $ UpdateStorageClassReq newStorageClass) + , mbReqHeaders = Just [("Content-Type", "application/json")] + , 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", ...}) +fetchBucket :: String -> IO (Either String Bucket) +fetchBucket bucketName = + doRequestJSON + RequestOptions + { reqMethod = GET + , reqUrl = googleStorageUrl + , mbReqPath = Just ("/" <> bucketName) + , mbReqBody = Nothing + , mbReqHeaders = Nothing + , 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}) +copyObject :: CopyObjectRequest -> IO (Either String CopyObjectResp) +copyObject CopyObjectRequest {..} = do + go Nothing + where + go mbRewriteToken = do + eRes <- + doRequestJSON + RequestOptions + { reqMethod = POST + , reqUrl = googleStorageUrl + , mbReqPath = + Just + ( "/" + <> sourceBucketName + <> "/o/" + <> sourceObjectName + <> "/rewriteTo/b/" + <> destinationBucketName + <> "/o/" + <> destinationObject + ) + , mbReqBody = case mbRewriteToken of + Nothing -> Nothing + (Just r) -> Just (encode $ object ["rewriteToken" .= r]) + , mbReqHeaders = Just [("Content-Length", "0")] + , mbQueryParams = Nothing + } + case eRes of + Left err -> pure $ Left (show err) + Right resp -> do + if done resp + then + return $ Right resp + 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 () +deleteObject :: String -> String -> IO (Either String ()) +deleteObject bucketName objectName = + doRequestJSON + RequestOptions + { reqMethod = DELETE + , reqUrl = googleStorageUrl + , mbReqPath = Just ("/" <> bucketName <> "/o/" <> objectName) + , mbReqBody = Nothing + , mbReqHeaders = Nothing + , 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 () +deleteBucket :: String -> IO (Either String ()) +deleteBucket bucketName = + doRequestJSON + RequestOptions + { reqMethod = DELETE + , reqUrl = googleStorageUrl + , mbReqPath = Just ("/" <> bucketName) + , mbReqBody = Nothing + , mbReqHeaders = Nothing + , 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) +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 + +-- | 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. +-- Note: This function uploads the entire object at once; for large objects, consider +-- implementing streaming or slicing (planned for future versions). +-- Example: +-- +-- >>> 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)] + } + +-- 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 + } + deriving (Show) + +instance ToJSON CreateBucketRequest where + toJSON (CreateBucketRequest name location storageClass) = + object ["name" .= name, "location" .= location, "storageClass" .= show storageClass] + +newtype UpdateStorageClassReq = UpdateStorageClassReq StorageClass + deriving (Eq) + +instance ToJSON UpdateStorageClassReq where + toJSON (UpdateStorageClassReq storageClass) = object ["storageClass" .= show storageClass] + +-- | GCP Storage Url +googleStorageUrl :: String +googleStorageUrl = "https://storage.googleapis.com/storage/v1/b" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"