diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,4 +8,8 @@ ## Unreleased +## 1.1.0.0 - 2025-09-11 + +- Synchronized version bump for v1.1.0.0 release. + ## 0.1.0.0 - YYYY-MM-DD diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,3 +3,75 @@ Haskell idiomatic client for [Google Cloud Platform](https://cloud.google.com/) Compute service. Full docs are available at https://github.com/tusharad/google-cloud-haskell + +## Installation + +- Cabal: add to your `.cabal` + - `build-depends: google-cloud-compute == 1.1.0.0` +- Stack: add to your `package.yaml` + - `dependencies: - google-cloud-compute == 1.1.0.0` + +This package depends on `google-cloud-common` for auth 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 + +Below are minimal examples. See `examples/` in the repo for more. + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import Google.Cloud.Compute.Instance + +-- List instances +listInstancesExample :: IO () +listInstancesExample = do + let projectId = "my-gcp-project" + zone = "us-central1-a" + query = defaultListInstancesQuery + result <- listInstances projectId zone (Just query) + case result of + Left err -> putStrLn ("Error: " <> err) + Right instances -> print instances + +-- Create an instance +createInstanceExample :: IO () +createInstanceExample = do + let projectId = "my-gcp-project" + zone = "us-central1-a" + instanceName = "my-instance" + machineType = "e2-medium" + ops = defaultInsertInstanceOps projectId zone instanceName machineType + res <- insertInstance projectId zone ops (Just (InsertInstanceQuery (Just "req-123") Nothing)) + case res of + Left err -> putStrLn ("Create error: " <> err) + Right _ -> putStrLn "Create initiated" + +-- Start/Stop an instance +startStopExample :: IO () +startStopExample = do + let projectId = "my-gcp-project" + zone = "us-central1-a" + name = "my-instance" + reqId = defaultRequestIdQuery "req-456" + _ <- startInstance projectId zone name (Just reqId) + _ <- stopInstance projectId zone name (Just reqId) + putStrLn "Start/Stop submitted" +``` + +Additional modules: + +- `Google.Cloud.Compute.Disk` +- `Google.Cloud.Compute.Firewall` +- `Google.Cloud.Compute.Network` + +## 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-compute.cabal b/google-cloud-compute.cabal --- a/google-cloud-compute.cabal +++ b/google-cloud-compute.cabal @@ -1,11 +1,11 @@ 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-compute -version: 0.1.0.0 +version: 1.1.0.0 synopsis: GCP Client for Haskell description: GCP Compute client for Haskell. category: Web @@ -42,7 +42,7 @@ , base >=4.7 && <5 , bytestring >=0.9.1.4 , containers >=0.6 && <1 - , google-cloud-common + , google-cloud-common >=1.1.0.0 && <1.2.0.0 , http-conduit >=2.2 && <2.4 , text >=1.2 && <3 default-language: Haskell2010 @@ -60,7 +60,7 @@ , base >=4.7 && <5 , bytestring >=0.9.1.4 , containers >=0.6 && <1 - , google-cloud-common + , google-cloud-common >=1.1.0.0 && <1.2.0.0 , google-cloud-compute , hspec >=1.3 , http-conduit >=2.2 && <2.4 diff --git a/src/Google/Cloud/Compute/Common.hs b/src/Google/Cloud/Compute/Common.hs --- a/src/Google/Cloud/Compute/Common.hs +++ b/src/Google/Cloud/Compute/Common.hs @@ -1,3 +1,11 @@ +{- | +Module : Google.Cloud.Compute.Common +License : MIT +Maintainer : maintainers@google-cloud-haskell +Stability : experimental + +Common helpers and constants for Google Cloud Compute client modules. +-} module Google.Cloud.Compute.Common (googleComputeUrl) where googleComputeUrl :: String diff --git a/src/Google/Cloud/Compute/Disk.hs b/src/Google/Cloud/Compute/Disk.hs --- a/src/Google/Cloud/Compute/Disk.hs +++ b/src/Google/Cloud/Compute/Disk.hs @@ -1,17 +1,17 @@ -{-| +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- | Module : Google.Cloud.Compute.Disk Copyright : (c) 2025 License : MIT -Maintainer : +Maintainer : Stability : experimental This module provides a Haskell client for Google Cloud Compute Engine Disk operations. -} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - module Google.Cloud.Compute.Disk ( listDisks , insertDisk @@ -21,7 +21,7 @@ , Operation (..) , deleteDisk , createDiskSnapshot - , CreateSnapshotResp + , CreateSnapshotResp , CreateSnapshotOps (..) , Warning (..) , WarningData (..) @@ -31,6 +31,7 @@ import Data.Aeson import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Map (Map) import Google.Cloud.Common.Core import Google.Cloud.Compute.Common @@ -38,117 +39,183 @@ -- | Represents a warning object returned by Google Cloud API operations data Warning = Warning - { code :: String -- ^ Warning type identifier - , message :: String -- ^ Human-readable warning message - , data_ :: Maybe [WarningData] -- ^ Optional metadata about the warning + { code :: String + -- ^ Warning type identifier + , message :: String + -- ^ Human-readable warning message + , data_ :: Maybe [WarningData] + -- ^ Optional metadata about the warning } deriving (Show, Eq) -- | Key-value pair providing additional context for warnings data WarningData = WarningData - { key :: String -- ^ Metadata key describing the warning aspect - , value :: String -- ^ Metadata value associated with the key + { key :: String + -- ^ Metadata key describing the warning aspect + , value :: String + -- ^ Metadata value associated with the key } deriving (Show, Eq) -- | Response format for disk listing operations data DiskResponse = DiskResponse - { kind :: Maybe String -- ^ Type identifier ("compute#diskList") - , id :: Maybe String -- ^ Unique identifier for the resource - , items :: Maybe [DiskItem] -- ^ List of disks in the project/zone - , nextPageToken :: Maybe String -- ^ Pagination token for next page - , selfLink :: Maybe String -- ^ Server-defined URL for the resource - , warning :: Maybe Warning -- ^ Any warnings about the result + { kind :: Maybe String + -- ^ Type identifier ("compute#diskList") + , id :: Maybe String + -- ^ Unique identifier for the resource + , items :: Maybe [DiskItem] + -- ^ List of disks in the project/zone + , nextPageToken :: Maybe String + -- ^ Pagination token for next page + , selfLink :: Maybe String + -- ^ Server-defined URL for the resource + , warning :: Maybe Warning + -- ^ Any warnings about the result } deriving (Show, Eq) -- | Represents a Google Cloud Persistent Disk data DiskItem = DiskItem - { kind :: Maybe String -- ^ Type identifier ("compute#disk") - , id :: Maybe String -- ^ Unique numeric ID - , creationTimestamp :: Maybe String -- ^ ISO 8601 creation timestamp - , name :: Maybe String -- ^ User-provided disk name - , description :: Maybe String -- ^ Optional disk description - , sizeGb :: Maybe String -- ^ Disk size in gigabytes - , zone :: Maybe String -- ^ Zone where the disk resides - , status :: Maybe String -- ^ Current status (READY, CREATING, etc.) - , sourceSnapshot :: Maybe String -- ^ Source snapshot URL if applicable - , sourceSnapshotId :: Maybe String -- ^ Unique ID of source snapshot - , sourceImage :: Maybe String -- ^ Source image URL if applicable - , sourceImageId :: Maybe String -- ^ Unique ID of source image - , type_ :: Maybe String -- ^ Disk type (e.g., "pd-standard") - , labels :: Maybe (Map String String) -- ^ User-defined labels - , labelFingerprint :: Maybe String -- ^ Fingerprint for label operations - , licenses :: Maybe [String] -- ^ License resource URLs - , users :: Maybe [String] -- ^ Instances currently using the disk - , guestOsFeatures :: Maybe [GuestOsFeature] -- ^ OS-specific features - , diskEncryptionKey :: Maybe EncryptionKey -- ^ Disk encryption details - , sourceDisk :: Maybe String -- ^ Source disk URL for regional disks - , sourceDiskId :: Maybe String -- ^ Unique ID of source disk - , physicalBlockSizeBytes :: Maybe String -- ^ Physical block size in bytes - , provisionedIops :: Maybe String -- ^ Provisioned IOPS for SSD - , resourcePolicies :: Maybe [String] -- ^ Resource policy URLs - , selfLink :: Maybe String -- ^ Server-defined URL for the disk + { kind :: Maybe String + -- ^ Type identifier ("compute#disk") + , id :: Maybe String + -- ^ Unique numeric ID + , creationTimestamp :: Maybe String + -- ^ ISO 8601 creation timestamp + , name :: Maybe String + -- ^ User-provided disk name + , description :: Maybe String + -- ^ Optional disk description + , sizeGb :: Maybe String + -- ^ Disk size in gigabytes + , zone :: Maybe String + -- ^ Zone where the disk resides + , status :: Maybe String + -- ^ Current status (READY, CREATING, etc.) + , sourceSnapshot :: Maybe String + -- ^ Source snapshot URL if applicable + , sourceSnapshotId :: Maybe String + -- ^ Unique ID of source snapshot + , sourceImage :: Maybe String + -- ^ Source image URL if applicable + , sourceImageId :: Maybe String + -- ^ Unique ID of source image + , type_ :: Maybe String + -- ^ Disk type (e.g., "pd-standard") + , labels :: Maybe (Map String String) + -- ^ User-defined labels + , labelFingerprint :: Maybe String + -- ^ Fingerprint for label operations + , licenses :: Maybe [String] + -- ^ License resource URLs + , users :: Maybe [String] + -- ^ Instances currently using the disk + , guestOsFeatures :: Maybe [GuestOsFeature] + -- ^ OS-specific features + , diskEncryptionKey :: Maybe EncryptionKey + -- ^ Disk encryption details + , sourceDisk :: Maybe String + -- ^ Source disk URL for regional disks + , sourceDiskId :: Maybe String + -- ^ Unique ID of source disk + , physicalBlockSizeBytes :: Maybe String + -- ^ Physical block size in bytes + , provisionedIops :: Maybe String + -- ^ Provisioned IOPS for SSD + , resourcePolicies :: Maybe [String] + -- ^ Resource policy URLs + , selfLink :: Maybe String + -- ^ Server-defined URL for the disk } deriving (Show, Eq) -- | Guest OS features enabled on the disk -data GuestOsFeature = GuestOsFeature - { type_ :: String -- ^ Feature type (e.g., "UEFI_COMPATIBLE") +newtype GuestOsFeature = GuestOsFeature + { type_ :: String + -- ^ Feature type (e.g., "UEFI_COMPATIBLE") } deriving (Show, Eq) -- | Disk encryption key information data EncryptionKey = EncryptionKey - { rawKey :: Maybe String -- ^ Raw encryption key (base64) - , rsaEncryptedKey :: Maybe String -- ^ RSA-wrapped encryption key - , sha256 :: Maybe String -- ^ RFC 4648 base64 SHA-256 hash + { rawKey :: Maybe String + -- ^ Raw encryption key (base64) + , rsaEncryptedKey :: Maybe String + -- ^ RSA-wrapped encryption key + , sha256 :: Maybe String + -- ^ RFC 4648 base64 SHA-256 hash } deriving (Show, Eq) -- | Long-running operation resource data Operation = Operation - { id :: Maybe String -- ^ Unique operation ID - , name :: Maybe String -- ^ Operation name - , zone :: Maybe String -- ^ Zone where operation is executed - , operationType :: Maybe String -- ^ Operation type (insert, delete, etc.) - , targetLink :: Maybe String -- ^ URL of resource being modified - , status :: Maybe String -- ^ Current status (DONE, RUNNING, etc.) - , progress :: Maybe Int -- ^ Operation progress (0-100) - , insertTime :: Maybe String -- ^ ISO 8601 creation timestamp - , startTime :: Maybe String -- ^ ISO 8601 start timestamp - , endTime :: Maybe String -- ^ ISO 8601 completion timestamp - , error :: Maybe OperationError -- ^ Error details if failed - , warnings :: Maybe [Warning] -- ^ Warnings during operation - , selfLink :: Maybe String -- ^ Server-defined URL for the operation + { id :: Maybe String + -- ^ Unique operation ID + , name :: Maybe String + -- ^ Operation name + , zone :: Maybe String + -- ^ Zone where operation is executed + , operationType :: Maybe String + -- ^ Operation type (insert, delete, etc.) + , targetLink :: Maybe String + -- ^ URL of resource being modified + , status :: Maybe String + -- ^ Current status (DONE, RUNNING, etc.) + , progress :: Maybe Int + -- ^ Operation progress (0-100) + , insertTime :: Maybe String + -- ^ ISO 8601 creation timestamp + , startTime :: Maybe String + -- ^ ISO 8601 start timestamp + , endTime :: Maybe String + -- ^ ISO 8601 completion timestamp + , error :: Maybe OperationError + -- ^ Error details if failed + , warnings :: Maybe [Warning] + -- ^ Warnings during operation + , selfLink :: Maybe String + -- ^ Server-defined URL for the operation } deriving (Show, Eq) -- | Error information from failed operations -data OperationError = OperationError - { errors :: [ErrorDetail] -- ^ List of error details +newtype OperationError = OperationError + { errors :: [ErrorDetail] + -- ^ List of error details } deriving (Show, Eq) -- | Detailed error information data ErrorDetail = ErrorDetail - { code :: String -- ^ Error type identifier - , message :: String -- ^ Human-readable error message - , location :: Maybe String -- ^ Location in request that triggered error + { code :: String + -- ^ Error type identifier + , message :: String + -- ^ Human-readable error message + , location :: Maybe String + -- ^ Location in request that triggered error } deriving (Show, Eq) -- | Disk creation options data InsertDiskOps = InsertDiskOps - { name :: String -- ^ Required disk name - , sizeGb :: String -- ^ Required size in gigabytes - , description :: Maybe String -- ^ Optional description - , type_ :: Maybe String -- ^ Disk type (default: pd-standard) - , sourceImage :: Maybe String -- ^ Source image URL for disk creation - , sourceSnapshot :: Maybe String -- ^ Source snapshot URL for disk creation - , labels :: Maybe (Map String String) -- ^ Initial labels - , guestOsFeatures :: Maybe [GuestOsFeature] -- ^ OS features to enable - , diskEncryptionKey :: Maybe EncryptionKey -- ^ Encryption configuration + { name :: String + -- ^ Required disk name + , sizeGb :: String + -- ^ Required size in gigabytes + , description :: Maybe String + -- ^ Optional description + , type_ :: Maybe String + -- ^ Disk type (default: pd-standard) + , sourceImage :: Maybe String + -- ^ Source image URL for disk creation + , sourceSnapshot :: Maybe String + -- ^ Source snapshot URL for disk creation + , labels :: Maybe (Map String String) + -- ^ Initial labels + , guestOsFeatures :: Maybe [GuestOsFeature] + -- ^ OS features to enable + , diskEncryptionKey :: Maybe EncryptionKey + -- ^ Encryption configuration } deriving (Show, Eq) @@ -157,11 +224,16 @@ -- | Snapshot creation options data CreateSnapshotOps = CreateSnapshotOps - { name :: String -- ^ Required snapshot name - , description :: Maybe String -- ^ Optional description - , labels :: Maybe (Map String String) -- ^ Labels for the snapshot - , storageLocations :: Maybe [String] -- ^ Preferred storage locations - , snapshotEncryptionKey :: Maybe EncryptionKey -- ^ Snapshot encryption + { name :: String + -- ^ Required snapshot name + , description :: Maybe String + -- ^ Optional description + , labels :: Maybe (Map String String) + -- ^ Labels for the snapshot + , storageLocations :: Maybe [String] + -- ^ Preferred storage locations + , snapshotEncryptionKey :: Maybe EncryptionKey + -- ^ Snapshot encryption } deriving (Show, Eq) @@ -184,13 +256,13 @@ deriving (Show, Eq) -- | Query parameters for deleteDisk -data DeleteDiskQuery = DeleteDiskQuery +newtype DeleteDiskQuery = DeleteDiskQuery { force :: Maybe Bool } deriving (Show, Eq) -- | Query parameters for createDiskSnapshot -data CreateSnapshotQuery = CreateSnapshotQuery +newtype CreateSnapshotQuery = CreateSnapshotQuery { guestFlush :: Maybe Bool } deriving (Show, Eq) @@ -470,15 +542,22 @@ ] -- Functions --- | List disks in a zone --- --- Example: --- --- > listDisks "my-project" "us-central1-a" Nothing -listDisks :: String -- ^ GCP Project ID - -> String -- ^ Zone name - -> Maybe ListDisksQuery -- ^ Optional query parameters - -> IO (Either String DiskResponse) -- ^ List result or error} + +{- | List disks in a zone + +Example: + +> listDisks "my-project" "us-central1-a" Nothing +-} +listDisks :: + -- | GCP Project ID + String -> + -- | Zone name + String -> + -- | Optional query parameters + Maybe ListDisksQuery -> + -- | List result or error} + IO (Either String DiskResponse) listDisks project zone_ mbQuery = do let queryParams = maybe [] queryToList mbQuery doRequestJSON @@ -499,16 +578,23 @@ , maybe mempty (\x -> ("orderBy", Just $ BS.pack x)) orderBy ] --- | Create a new persistent disk --- --- Example: --- --- > insertDisk "my-project" "us-central1-a" (defaultInsertOps "disk1" "100") Nothing -insertDisk :: String -- ^ GCP Project ID - -> String -- ^ Zone name - -> InsertDiskOps -- ^ Disk configuration - -> Maybe InsertDiskQuery -- ^ Optional query parameters - -> IO (Either String InsertDiskResponse) -- ^ Operation or error} +{- | Create a new persistent disk + +Example: + +> insertDisk "my-project" "us-central1-a" (defaultInsertOps "disk1" "100") Nothing +-} +insertDisk :: + -- | GCP Project ID + String -> + -- | Zone name + String -> + -- | Disk configuration + InsertDiskOps -> + -- | Optional query parameters + Maybe InsertDiskQuery -> + -- | Operation or error} + IO (Either String InsertDiskResponse) insertDisk project zone_ insertDiskOps mbQuery = do let queryParams = maybe [] queryToList mbQuery doRequestJSON @@ -526,22 +612,29 @@ [ maybe mempty (\x -> ("sourceImage", Just $ BS.pack x)) sourceImage , maybe mempty - (\x -> ("sourceImageEncryptionKey", Just . BS.toStrict $ encode x)) + (\x -> ("sourceImageEncryptionKey", Just . BSL.toStrict $ encode x)) sourceImageEncryptionKey ] -- | Deletes a disk with optional query parameters --- | Delete a persistent disk --- --- Example: --- --- > deleteDisk "my-project" "us-central1-a" "old-disk" (Just DeleteDiskQuery { force = True }) -deleteDisk :: String -- ^ GCP Project ID - -> String -- ^ Zone name - -> String -- ^ Disk name to delete - -> Maybe DeleteDiskQuery -- ^ Optional force deletion - -> IO (Either String Operation) -- ^ Operation or error +{- | Delete a persistent disk + +Example: + +> deleteDisk "my-project" "us-central1-a" "old-disk" (Just DeleteDiskQuery { force = True }) +-} +deleteDisk :: + -- | GCP Project ID + String -> + -- | Zone name + String -> + -- | Disk name to delete + String -> + -- | Optional force deletion + Maybe DeleteDiskQuery -> + -- | Operation or error + IO (Either String Operation) deleteDisk project zone_ diskName mbQuery = do let queryParams = maybe [] queryToList mbQuery doRequestJSON @@ -559,19 +652,27 @@ [ maybe mempty (\x -> ("force", Just . BS.pack $ show x)) (force q) ] --- | Creates a snapshot of a disk with optional query parameters --- | Create disk snapshot --- --- Example: --- --- > createDiskSnapshot "my-project" "us-central1-a" "source-disk" --- > (defaultCreateSnapshotOps "daily-backup") Nothing -createDiskSnapshot :: String -- ^ GCP Project ID - -> String -- ^ Zone name - -> String -- ^ Source disk name - -> CreateSnapshotOps -- ^ Snapshot configuration - -> Maybe CreateSnapshotQuery -- ^ Optional guest flush - -> IO (Either String CreateSnapshotResp) -- ^ Operation or error +{- | Creates a snapshot of a disk with optional query parameters +| Create disk snapshot + +Example: + +> createDiskSnapshot "my-project" "us-central1-a" "source-disk" +> (defaultCreateSnapshotOps "daily-backup") Nothing +-} +createDiskSnapshot :: + -- | GCP Project ID + String -> + -- | Zone name + String -> + -- | Source disk name + String -> + -- | Snapshot configuration + CreateSnapshotOps -> + -- | Optional guest flush + Maybe CreateSnapshotQuery -> + -- | Operation or error + IO (Either String CreateSnapshotResp) createDiskSnapshot project zone_ diskName createSnapshotOps mbQuery = do let queryParams = maybe [] queryToList mbQuery doRequestJSON @@ -590,12 +691,13 @@ [ maybe mempty (\x -> ("guestFlush", Just . BS.pack $ show x)) (guestFlush q) ] --- | Default disk creation options --- --- Creates minimal valid configuration with required name and size. --- Other fields can be added using record update syntax: --- --- > defaultInsertOps "new-disk" "50" { type_ = Just "pd-ssd" } +{- | Default disk creation options + +Creates minimal valid configuration with required name and size. +Other fields can be added using record update syntax: + +> defaultInsertOps "new-disk" "50" { type_ = Just "pd-ssd" } +-} defaultInsertOps :: String -> String -> InsertDiskOps defaultInsertOps diskName diskSizeGb = InsertDiskOps @@ -610,12 +712,13 @@ , diskEncryptionKey = Nothing } --- | Default snapshot creation options --- --- Creates minimal valid configuration with required snapshot name. --- Additional fields can be added using record update syntax: --- --- > defaultCreateSnapshotOps "backup" { description = Just "Daily backup" } +{- | Default snapshot creation options + +Creates minimal valid configuration with required snapshot name. +Additional fields can be added using record update syntax: + +> defaultCreateSnapshotOps "backup" { description = Just "Daily backup" } +-} defaultCreateSnapshotOps :: String -> CreateSnapshotOps defaultCreateSnapshotOps snapshotName = CreateSnapshotOps diff --git a/src/Google/Cloud/Compute/Firewall.hs b/src/Google/Cloud/Compute/Firewall.hs --- a/src/Google/Cloud/Compute/Firewall.hs +++ b/src/Google/Cloud/Compute/Firewall.hs @@ -4,9 +4,9 @@ {- | Module : Google.Cloud.Compute.Firewall -Copyright : (c) 2025 +Copyright : (c) 2025 License : MIT -Maintainer : +Maintainer : Stability : experimental This module provides a Haskell client for Google Cloud Compute Engine Firewall operations. @@ -165,7 +165,7 @@ deriving (Show, Eq) -- | Error information from failed operations -data OperationError = OperationError +newtype OperationError = OperationError { errors :: [ErrorDetail] -- ^ List of error details } @@ -477,7 +477,7 @@ deriving (Show, Eq) -- | Query parameters for createFirewall -data CreateFirewallQuery = CreateFirewallQuery +newtype CreateFirewallQuery = CreateFirewallQuery { requestId :: Maybe String } deriving (Show, Eq) @@ -558,15 +558,16 @@ catMaybes [("requestId",) <$> requestId q] --- | Default firewall creation options --- --- Creates minimal valid configuration with required name. --- Additional fields can be added using record update syntax: --- --- > defaultCreateFirewallOps "web-allow" --- > { description = Just "Allow web traffic" --- > , allowed = Just [AllowedFirewall "tcp" (Just ["80","443"])] --- > } +{- | Default firewall creation options + +Creates minimal valid configuration with required name. +Additional fields can be added using record update syntax: + +> defaultCreateFirewallOps "web-allow" +> { description = Just "Allow web traffic" +> , allowed = Just [AllowedFirewall "tcp" (Just ["80","443"])] +> } +-} defaultCreateFirewallOps :: String -> CreateFirewallOps defaultCreateFirewallOps firewallName = CreateFirewallOps diff --git a/src/Google/Cloud/Compute/Instance.hs b/src/Google/Cloud/Compute/Instance.hs --- a/src/Google/Cloud/Compute/Instance.hs +++ b/src/Google/Cloud/Compute/Instance.hs @@ -1,8 +1,13 @@ -{-| +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +{- | Module : Google.Cloud.Compute.Instance Copyright : (c) 2025 Tushar License : MIT -Maintainer : +Maintainer : Stability : experimental This module provides types and functions for interacting with Google Cloud Platform (GCP) @@ -15,12 +20,6 @@ For more information on the underlying API, see: -} - -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} - module Google.Cloud.Compute.Instance ( -- Data Types InstanceMetadata (..) @@ -71,38 +70,38 @@ import Data.Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes) import Data.Text (Text) import Google.Cloud.Common.Core import Google.Cloud.Compute.Common -import qualified Data.Map.Strict as Map -- ** Query Parameter Types** -- | Query parameters for listing instances data ListInstancesQuery = ListInstancesQuery { filter_ :: Maybe String - -- ^ Filter expression for filtering listed instances + -- ^ Filter expression for filtering listed instances , maxResults :: Maybe Int - -- ^ Maximum number of results per page + -- ^ Maximum number of results per page , orderBy :: Maybe String - -- ^ Sort order for results + -- ^ Sort order for results , pageToken :: Maybe String - -- ^ Page token for paginated results + -- ^ Page token for paginated results , returnPartialSuccess :: Maybe Bool - -- ^ Whether to return partial success results + -- ^ Whether to return partial success results } deriving (Show, Eq) -- Query parameters for operations with requestId (start, stop, delete) -data RequestIdQuery = RequestIdQuery +newtype RequestIdQuery = RequestIdQuery { requestId :: Maybe String } deriving (Show, Eq) -- ** Data Types with Custom JSON Instances** -data RunDuration +newtype RunDuration = TerminationTime String deriving (Show, Eq) @@ -112,7 +111,7 @@ instance ToJSON RunDuration where toJSON (TerminationTime t) = object ["terminationTime" .= t] -data OnInstanceTerminationAction = DiscardLocalSsd {discardLocalSsd :: Bool} +newtype OnInstanceTerminationAction = DiscardLocalSsd {discardLocalSsd :: Bool} deriving (Show, Eq) instance FromJSON OnInstanceTerminationAction where @@ -161,7 +160,7 @@ , "instanceTerminationAction" .= instanceTerminationAction ] -data InstanceTerminationAction +newtype InstanceTerminationAction = RunDurationRunDuration RunDuration deriving (Show, Eq) @@ -215,57 +214,57 @@ -- | Metadata representing a Compute Engine instance data InstanceMetadata = InstanceMetadata { cpuPlatform :: Maybe String - -- ^ The CPU platform used by this instance + -- ^ The CPU platform used by this instance , labelFingerprint :: Maybe Text - -- ^ Fingerprint of the label metadata + -- ^ Fingerprint of the label metadata , instanceEncryptionKey :: Maybe InstanceEncryptionKey - -- ^ Encryption key configuration for the instance + -- ^ Encryption key configuration for the instance , minCpuPlatform :: Maybe Text - -- ^ Minimum CPU platform required by the instance + -- ^ Minimum CPU platform required by the instance , guestAccelerators :: Maybe [GuestAccelerator] - -- ^ List of guest accelerators attached to the instance + -- ^ List of guest accelerators attached to the instance , startRestricted :: Maybe Bool - -- ^ Whether instance start is restricted due to storage issues + -- ^ Whether instance start is restricted due to storage issues , deletionProtection :: Maybe Bool - -- ^ Whether deletion protection is enabled + -- ^ Whether deletion protection is enabled , resourcePolicies :: Maybe [Text] - -- ^ Resource policies applied to the instance + -- ^ Resource policies applied to the instance , sourceMachineImage :: Maybe Text - -- ^ Source machine image used to create the instance + -- ^ Source machine image used to create the instance , reservationAffinity :: Maybe ReservationAffinity - -- ^ Reservation affinity configuration + -- ^ Reservation affinity configuration , hostname :: Maybe Text - -- ^ Custom hostname assigned to the instance + -- ^ Custom hostname assigned to the instance , displayDevice :: Maybe DisplayDevice - -- ^ Display device configuration + -- ^ Display device configuration , shieldedInstanceConfig :: Maybe ShieldedInstanceConfig - -- ^ Shielded VM configuration + -- ^ Shielded VM configuration , shieldedInstanceIntegrityPolicy :: Maybe ShieldedInstanceIntegrityPolicy - -- ^ Integrity policy for shielded instances + -- ^ Integrity policy for shielded instances , sourceMachineImageEncryptionKey :: Maybe InstanceEncryptionKey - -- ^ Encryption key for source machine image + -- ^ Encryption key for source machine image , confidentialInstanceConfig :: Maybe ConfidentialInstanceConfig - -- ^ Confidential computing configuration + -- ^ Confidential computing configuration , fingerprint :: Maybe Text - -- ^ Unique fingerprint for resource metadata + -- ^ Unique fingerprint for resource metadata , privateIpv6GoogleAccess :: Maybe Text - -- ^ Private IPv6 Google access configuration + -- ^ Private IPv6 Google access configuration , lastStartTimestamp :: Maybe String - -- ^ Last start timestamp in RFC3339 format + -- ^ Last start timestamp in RFC3339 format , lastStopTimestamp :: Maybe String - -- ^ Last stop timestamp in RFC3339 format + -- ^ Last stop timestamp in RFC3339 format , lastSuspendedTimestamp :: Maybe String - -- ^ Last suspension timestamp in RFC3339 format + -- ^ Last suspension timestamp in RFC3339 format , satisfiesPzs :: Maybe Bool - -- ^ Whether instance satisfies zone separation policy + -- ^ Whether instance satisfies zone separation policy , satisfiesPzi :: Maybe Bool - -- ^ Whether instance satisfies instance separation policy + -- ^ Whether instance satisfies instance separation policy , resourceStatus :: Maybe ResourceStatus - -- ^ Current resource status of the instance + -- ^ Current resource status of the instance , networkPerformanceConfig :: Maybe NetworkPerformanceConfig - -- ^ Network performance configuration + -- ^ Network performance configuration , keyRevocationActionType :: Maybe Text - -- ^ Type of key revocation action if applicable + -- ^ Type of key revocation action if applicable } deriving (Show, Eq) @@ -373,7 +372,7 @@ , ("values" .=) <$> values ] -data DisplayDevice = DisplayDevice +newtype DisplayDevice = DisplayDevice { enableDisplay :: Bool } deriving (Show, Eq) @@ -408,7 +407,7 @@ , "enableIntegrityMonitoring" .= enableIntegrityMonitoring sic ] -data ShieldedInstanceIntegrityPolicy = ShieldedInstanceIntegrityPolicy +newtype ShieldedInstanceIntegrityPolicy = ShieldedInstanceIntegrityPolicy { policy :: Maybe UpdateAutoLearnPolicy } deriving (Show, Eq) @@ -424,7 +423,7 @@ catMaybes [("policy" .=) <$> policy sip] -data UpdateAutoLearnPolicy = UpdateAutoLearnPolicy {updateAutoLearnPolicy :: Bool} +newtype UpdateAutoLearnPolicy = UpdateAutoLearnPolicy {updateAutoLearnPolicy :: Bool} deriving (Show, Eq) instance FromJSON UpdateAutoLearnPolicy where @@ -484,7 +483,7 @@ , ("kmsKeyName" .=) <$> kmsKeyName iek ] -data NetworkPerformanceConfig = NetworkPerformanceConfig +newtype NetworkPerformanceConfig = NetworkPerformanceConfig { totalEgressBandwidthTier :: Text } deriving (Show, Eq) @@ -562,11 +561,11 @@ -- | Response structure for delete instance operation data InstanceDeleteResp = InstanceDeleteResp { kind :: Maybe String - -- ^ Type of resource (always "compute#operation") + -- ^ Type of resource (always "compute#operation") , id_ :: Maybe String - -- ^ Unique identifier for the operation + -- ^ Unique identifier for the operation , creationTimestamp :: Maybe String - -- ^ Creation timestamp in RFC3339 format + -- ^ Creation timestamp in RFC3339 format , name :: Maybe String , zone :: Maybe String , clientOperationId :: Maybe String @@ -649,7 +648,7 @@ , ("operationGroupId" .=) <$> operationGroupId ] -data Error_ = Error_ +newtype Error_ = Error_ { errors :: Maybe [ErrorDetail] } deriving (Show, Eq) @@ -761,7 +760,7 @@ , ("rolloutStatus" .=) <$> rolloutStatus qi ] -data Help = Help +newtype Help = Help { links :: Maybe [Link] } deriving (Show, Eq) @@ -870,7 +869,7 @@ } deriving (Show, Eq) -data NetworkInterface = NetworkInterface +newtype NetworkInterface = NetworkInterface { network :: String } deriving (Show, Eq) @@ -899,82 +898,86 @@ -- | Represents a disk attached to a Compute Engine instance data Disk = Disk { autoDelete :: Bool - -- ^ Whether disk should be auto-deleted when instance is deleted + -- ^ Whether disk should be auto-deleted when instance is deleted , boot :: Bool - -- ^ Whether this is a boot disk + -- ^ Whether this is a boot disk , deviceName :: String - -- ^ Unique device name visible to the guest OS + -- ^ Unique device name visible to the guest OS , initializeParams :: Maybe InitializeParams - -- ^ Initialization parameters for the disk + -- ^ Initialization parameters for the disk , mode :: String - -- ^ Access mode (READ_WRITE or READ_ONLY) + -- ^ Access mode (READ_WRITE or READ_ONLY) , type_ :: String - -- ^ Disk type (PERSISTENT or SCRATCH) + -- ^ Disk type (PERSISTENT or SCRATCH) } deriving (Show, Eq) -- | Disk initialization parameters for new disk creation data InitializeParams = InitializeParams { diskSizeGb :: String - -- ^ Size of the disk in GB (passed as String to match API format) + -- ^ Size of the disk in GB (passed as String to match API format) , diskType :: String - -- ^ Full URL of disk type resource + -- ^ Full URL of disk type resource , labels :: Map.Map String String - -- ^ Labels to apply to the disk + -- ^ Labels to apply to the disk , sourceImage :: String - -- ^ Source image used to create the disk + -- ^ Source image used to create the disk } deriving (Show, Eq) instance ToJSON Disk where - toJSON Disk{..} = object - [ "autoDelete" .= autoDelete - , "boot" .= boot - , "deviceName" .= deviceName - , "initializeParams" .= initializeParams - , "mode" .= mode - , "type" .= type_ -- Map type_ to "type" in JSON - ] + toJSON Disk {..} = + object + [ "autoDelete" .= autoDelete + , "boot" .= boot + , "deviceName" .= deviceName + , "initializeParams" .= initializeParams + , "mode" .= mode + , "type" .= type_ -- Map type_ to "type" in JSON + ] instance FromJSON Disk where - parseJSON = withObject "Disk" $ \v -> Disk - <$> v .: "autoDelete" - <*> v .: "boot" - <*> v .: "deviceName" - <*> v .:? "initializeParams" - <*> v .: "mode" - <*> v .: "type" -- Parse "type" field into type_ + parseJSON = withObject "Disk" $ \v -> + Disk + <$> v .: "autoDelete" + <*> v .: "boot" + <*> v .: "deviceName" + <*> v .:? "initializeParams" + <*> v .: "mode" + <*> v .: "type" -- Parse "type" field into type_ instance ToJSON InitializeParams where - toJSON InitializeParams{..} = object - [ "diskSizeGb" .= diskSizeGb - , "diskType" .= diskType - , "labels" .= labels - , "sourceImage" .= sourceImage - ] + toJSON InitializeParams {..} = + object + [ "diskSizeGb" .= diskSizeGb + , "diskType" .= diskType + , "labels" .= labels + , "sourceImage" .= sourceImage + ] instance FromJSON InitializeParams where - parseJSON = withObject "InitializeParams" $ \v -> InitializeParams - <$> v .: "diskSizeGb" - <*> v .: "diskType" - <*> v .: "labels" - <*> v .: "sourceImage" - + parseJSON = withObject "InitializeParams" $ \v -> + InitializeParams + <$> v .: "diskSizeGb" + <*> v .: "diskType" + <*> v .: "labels" + <*> v .: "sourceImage" -- ** Instance Operation Functions** --- | List instances in a given zone --- --- @ --- listInstances --- :: String -- ^ GCP Project ID --- -> String -- ^ Zone name --- -> Maybe ListInstancesQuery -- ^ Optional query parameters --- -> IO (Either String InstanceList) --- @ --- --- Returns either an error message or an 'InstanceList' containing --- the collection of instances +{- | List instances in a given zone + +@ +listInstances + :: String -- ^ GCP Project ID + -> String -- ^ Zone name + -> Maybe ListInstancesQuery -- ^ Optional query parameters + -> IO (Either String InstanceList) +@ + +Returns either an error message or an 'InstanceList' containing +the collection of instances +-} listInstances :: String -> String -> Maybe ListInstancesQuery -> IO (Either String InstanceList) listInstances projectId zone_ mbQuery = do @@ -1094,9 +1097,13 @@ -- ** Default Query Parameter Constructors** -- All fields set to 'Nothing', which the API interprets as: + -- * No filtering + -- * Default page size + -- * No sorting + -- * Return full results defaultListInstancesQuery :: ListInstancesQuery defaultListInstancesQuery = @@ -1111,12 +1118,13 @@ defaultRequestIdQuery :: String -> RequestIdQuery defaultRequestIdQuery rid = RequestIdQuery {requestId = Just rid} --- | Create a default instance configuration --- --- Creates a basic instance configuration with: --- * 10GB persistent boot disk --- * Default Debian image --- * Network interface on default VPC +{- | Create a default instance configuration + +Creates a basic instance configuration with: +* 10GB persistent boot disk +* Default Debian image +* Network interface on default VPC +-} defaultInsertInstanceOps :: String -> String -> String -> String -> InsertInstanceOps defaultInsertInstanceOps projectId zone instanceName machineType = InsertInstanceOps @@ -1124,22 +1132,25 @@ , machineType = "zones/" ++ zone ++ "/machineTypes/" ++ machineType , disks = Just [defaultDisk] , networkInterfaces = Just [defaultNetworkInterface] - } + } where - defaultDisk = Disk - { autoDelete = True - , boot = True - , deviceName = instanceName ++ "-boot" -- Dynamic, based on instanceName - , initializeParams = Just defaultInitializeParams - , mode = "READ_WRITE" - , type_ = "PERSISTENT" - } - defaultInitializeParams = InitializeParams - { diskSizeGb = "10" - , diskType = "projects/" ++ projectId ++ "/zones/" ++ zone ++ "/diskTypes/pd-standard" - , labels = Map.empty - , sourceImage = "projects/debian-cloud/global/images/debian-12-bookworm-v20250311" - } - defaultNetworkInterface = NetworkInterface - { network = "projects/" ++ projectId ++ "/global/networks/default" - } + defaultDisk = + Disk + { autoDelete = True + , boot = True + , deviceName = instanceName ++ "-boot" -- Dynamic, based on instanceName + , initializeParams = Just defaultInitializeParams + , mode = "READ_WRITE" + , type_ = "PERSISTENT" + } + defaultInitializeParams = + InitializeParams + { diskSizeGb = "10" + , diskType = "projects/" ++ projectId ++ "/zones/" ++ zone ++ "/diskTypes/pd-standard" + , labels = Map.empty + , sourceImage = "projects/debian-cloud/global/images/debian-12-bookworm-v20250311" + } + defaultNetworkInterface = + NetworkInterface + { network = "projects/" ++ projectId ++ "/global/networks/default" + } diff --git a/src/Google/Cloud/Compute/Network.hs b/src/Google/Cloud/Compute/Network.hs --- a/src/Google/Cloud/Compute/Network.hs +++ b/src/Google/Cloud/Compute/Network.hs @@ -1,8 +1,13 @@ -{-| +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +{- | Module : Google.Cloud.Compute.Network Copyright : (c) 2025 Tushar License : MIT -Maintainer : +Maintainer : Stability : experimental This module provides types and functions for interacting with Google Cloud Platform (GCP) @@ -15,204 +20,216 @@ For more information on the underlying API, see: -} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} - -module Google.Cloud.Compute.Network +module Google.Cloud.Compute.Network ( -- * Network Operations listNetworks + -- * Data Types - , NetworkList(..) - , NetworkMeta(..) - , NetworkPeering(..) - , ListNetworksQuery(..) + , NetworkList (..) + , NetworkMeta (..) + , NetworkPeering (..) + , ListNetworksQuery (..) + -- * Defaults , defaultListNetworksQuery ) where import Data.Aeson +import qualified Data.ByteString.Char8 as BS8 +import Data.Maybe (catMaybes) import Data.Text (Text) import Google.Cloud.Common.Core import Google.Cloud.Compute.Common -import Data.Maybe (catMaybes) -import qualified Data.ByteString.Char8 as BS8 -- | Response structure for listNetworks operation data NetworkList = NetworkList { kind :: Text - -- ^ Type of resource (always "compute#networkList") + -- ^ Type of resource (always "compute#networkList") , id_ :: Text - -- ^ Unique identifier for the resource - , items :: [NetworkMeta] - -- ^ List of network resources + -- ^ Unique identifier for the resource + , items :: Maybe [NetworkMeta] + -- ^ List of network resources , nextPageToken :: Maybe Text - -- ^ Pagination token for next page + -- ^ Pagination token for next page , selfLink :: Text - -- ^ Server-defined URL for the resource - } deriving (Eq, Show) + -- ^ Server-defined URL for the resource + } + deriving (Eq, Show) instance FromJSON NetworkList where - parseJSON = withObject "NetworkList" $ \v -> NetworkList - <$> v .: "kind" - <*> v .: "id" - <*> v .: "items" - <*> v .:? "nextPageToken" - <*> v .: "selfLink" + parseJSON = withObject "NetworkList" $ \v -> + NetworkList + <$> v .: "kind" + <*> v .: "id" + <*> v .: "items" + <*> v .:? "nextPageToken" + <*> v .: "selfLink" instance ToJSON NetworkList where - toJSON NetworkList{..} = object - [ "kind" .= kind - , "id" .= id_ - , "items" .= items - , "nextPageToken" .= nextPageToken - , "selfLink" .= selfLink - ] + toJSON NetworkList {..} = + object + [ "kind" .= kind + , "id" .= id_ + , "items" .= items + , "nextPageToken" .= nextPageToken + , "selfLink" .= selfLink + ] -- | Detailed network resource metadata data NetworkMeta = NetworkMeta { kind :: Text - -- ^ Type of resource (always "compute#network") + -- ^ Type of resource (always "compute#network") , id_ :: Text - -- ^ Unique identifier for the network + -- ^ Unique identifier for the network , creationTimestamp :: Text - -- ^ Creation timestamp in RFC3339 format + -- ^ Creation timestamp in RFC3339 format , name :: Text - -- ^ Name of the network + -- ^ Name of the network , description :: Maybe Text - -- ^ User-provided description + -- ^ User-provided description , autoCreateSubnetworks :: Maybe Bool - -- ^ Whether to auto-create subnetworks + -- ^ Whether to auto-create subnetworks , subnetworks :: [Text] - -- ^ List of subnetworks URLs in this network + -- ^ List of subnetworks URLs in this network , iPv4Range :: Maybe Text - -- ^ IPv4 range for legacy networks + -- ^ IPv4 range for legacy networks , iPv6Range :: Maybe Text - -- ^ IPv6 range for legacy networks + -- ^ IPv6 range for legacy networks , gatewayIPv4 :: Maybe Text - -- ^ Gateway IPv4 address + -- ^ Gateway IPv4 address , mtu :: Maybe Int - -- ^ Maximum transmission unit + -- ^ Maximum transmission unit , peerings :: Maybe [NetworkPeering] - -- ^ List of network peerings + -- ^ List of network peerings , selfLink :: Text - -- ^ Server-defined URL for the resource + -- ^ Server-defined URL for the resource , enableUlaInternalIpv6 :: Maybe Bool - -- ^ ULA internal IPv6 support + -- ^ ULA internal IPv6 support , internalIpv6Range :: Maybe Text - -- ^ Internal IPv6 range + -- ^ Internal IPv6 range , networkFirewallPolicyEnforcementOrder :: Maybe Text - -- ^ Firewall policy order - } deriving (Eq, Show) + -- ^ Firewall policy order + } + deriving (Eq, Show) instance FromJSON NetworkMeta where - parseJSON = withObject "NetworkMeta" $ \v -> NetworkMeta - <$> v .: "kind" - <*> v .: "id" - <*> v .: "creationTimestamp" - <*> v .: "name" - <*> v .:? "description" - <*> v .:? "autoCreateSubnetworks" - <*> v .: "subnetworks" - <*> v .:? "IPv4Range" -- Match API's casing - <*> v .:? "IPv6Range" - <*> v .:? "gatewayIPv4" - <*> v .:? "mtu" - <*> (v .:? "peerings") - <*> v .: "selfLink" - <*> v .:? "enableUlaInternalIpv6" - <*> v .:? "internalIpv6Range" - <*> v .:? "networkFirewallPolicyEnforcementOrder" + parseJSON = withObject "NetworkMeta" $ \v -> + NetworkMeta + <$> v .: "kind" + <*> v .: "id" + <*> v .: "creationTimestamp" + <*> v .: "name" + <*> v .:? "description" + <*> v .:? "autoCreateSubnetworks" + <*> v .: "subnetworks" + <*> v .:? "IPv4Range" -- Match API's casing + <*> v .:? "IPv6Range" + <*> v .:? "gatewayIPv4" + <*> v .:? "mtu" + <*> (v .:? "peerings") + <*> v .: "selfLink" + <*> v .:? "enableUlaInternalIpv6" + <*> v .:? "internalIpv6Range" + <*> v .:? "networkFirewallPolicyEnforcementOrder" instance ToJSON NetworkMeta where - toJSON NetworkMeta{..} = object $ catMaybes - [ Just ("kind" .= kind) - , Just ("id" .= id_) - , Just ("creationTimestamp" .= creationTimestamp ) - , Just ("name" .= name ) - , ("description" .=) <$> description - , ("autoCreateSubnetworks" .=) <$> autoCreateSubnetworks - , Just ("subnetworks" .= subnetworks) - , ("IPv4Range" .=) <$> iPv4Range - , ("IPv6Range" .=) <$> iPv6Range - , ("gatewayIPv4" .=) <$> gatewayIPv4 - , ("mtu" .=) <$> mtu - , Just ("peerings" .= peerings ) - , Just ("selfLink" .= selfLink ) - , ("enableUlaInternalIpv6" .=) <$> enableUlaInternalIpv6 - , ("internalIpv6Range" .=) <$> internalIpv6Range - , ("networkFirewallPolicyEnforcementOrder" .=) <$> networkFirewallPolicyEnforcementOrder - ] + toJSON NetworkMeta {..} = + object $ + catMaybes + [ Just ("kind" .= kind) + , Just ("id" .= id_) + , Just ("creationTimestamp" .= creationTimestamp) + , Just ("name" .= name) + , ("description" .=) <$> description + , ("autoCreateSubnetworks" .=) <$> autoCreateSubnetworks + , Just ("subnetworks" .= subnetworks) + , ("IPv4Range" .=) <$> iPv4Range + , ("IPv6Range" .=) <$> iPv6Range + , ("gatewayIPv4" .=) <$> gatewayIPv4 + , ("mtu" .=) <$> mtu + , Just ("peerings" .= peerings) + , Just ("selfLink" .= selfLink) + , ("enableUlaInternalIpv6" .=) <$> enableUlaInternalIpv6 + , ("internalIpv6Range" .=) <$> internalIpv6Range + , ("networkFirewallPolicyEnforcementOrder" .=) <$> networkFirewallPolicyEnforcementOrder + ] -- | Network peering configuration data NetworkPeering = NetworkPeering { name :: Text - -- ^ Name of the peering + -- ^ Name of the peering , network :: Text - -- ^ URL of peer network + -- ^ URL of peer network , state :: Text - -- ^ Peering state (ACTIVE/INACTIVE) + -- ^ Peering state (ACTIVE/INACTIVE) , stateDetails :: Maybe Text - -- ^ Detailed state information + -- ^ Detailed state information , exchangeSubnetRoutes :: Maybe Bool - -- ^ Subnet route exchange + -- ^ Subnet route exchange , exportCustomRoutes :: Maybe Bool - -- ^ Custom route export + -- ^ Custom route export , importCustomRoutes :: Maybe Bool - -- ^ Custom route import - } deriving (Eq, Show) + -- ^ Custom route import + } + deriving (Eq, Show) instance FromJSON NetworkPeering where - parseJSON = withObject "NetworkPeering" $ \v -> NetworkPeering - <$> v .: "name" - <*> v .: "network" - <*> v .: "state" - <*> v .:? "stateDetails" - <*> v .:? "exchangeSubnetRoutes" - <*> v .:? "exportCustomRoutes" - <*> v .:? "importCustomRoutes" + parseJSON = withObject "NetworkPeering" $ \v -> + NetworkPeering + <$> v .: "name" + <*> v .: "network" + <*> v .: "state" + <*> v .:? "stateDetails" + <*> v .:? "exchangeSubnetRoutes" + <*> v .:? "exportCustomRoutes" + <*> v .:? "importCustomRoutes" instance ToJSON NetworkPeering where - toJSON NetworkPeering{..} = object $ catMaybes - [ Just ("name" .= name) - , Just ("network" .= network) - , Just ("state" .= state) - , ("stateDetails" .=) <$> stateDetails - , ("exchangeSubnetRoutes" .=) <$> exchangeSubnetRoutes - , ("exportCustomRoutes" .=) <$> exportCustomRoutes - , ("importCustomRoutes" .=) <$> importCustomRoutes - ] + toJSON NetworkPeering {..} = + object $ + catMaybes + [ Just ("name" .= name) + , Just ("network" .= network) + , Just ("state" .= state) + , ("stateDetails" .=) <$> stateDetails + , ("exchangeSubnetRoutes" .=) <$> exchangeSubnetRoutes + , ("exportCustomRoutes" .=) <$> exportCustomRoutes + , ("importCustomRoutes" .=) <$> importCustomRoutes + ] -- | Query parameters for listNetworks operation data ListNetworksQuery = ListNetworksQuery { filter_ :: Maybe String - -- ^ Filter expression + -- ^ Filter expression , maxResults :: Maybe Int - -- ^ Maximum results per page + -- ^ Maximum results per page , orderBy :: Maybe String - -- ^ Sort order + -- ^ Sort order , pageToken :: Maybe String - -- ^ Page token + -- ^ Page token , returnPartialSuccess :: Maybe Bool - -- ^ Partial success return - } deriving (Show) + -- ^ Partial success return + } + deriving (Show) -- | Default list networks query parameters defaultListNetworksQuery :: ListNetworksQuery -defaultListNetworksQuery = ListNetworksQuery - { filter_ = Nothing - , maxResults = Nothing - , orderBy = Nothing - , pageToken = Nothing - , returnPartialSuccess = Nothing - } +defaultListNetworksQuery = + ListNetworksQuery + { filter_ = Nothing + , maxResults = Nothing + , orderBy = Nothing + , pageToken = Nothing + , returnPartialSuccess = Nothing + } -- | List networks in a project listNetworks :: - String -- ^ GCP Project ID - -> Maybe ListNetworksQuery -- ^ Query parameters - -> IO (Either String NetworkList) + -- | GCP Project ID + String -> + -- | Query parameters + Maybe ListNetworksQuery -> + IO (Either String NetworkList) listNetworks project mbQuery = do let queryParams = maybe [] toQueryList mbQuery doRequestJSON @@ -222,16 +239,18 @@ , mbQueryParams = Just queryParams , mbReqBody = Nothing , mbReqHeaders = Nothing - , mbReqPath = Just $ toPath - [ "projects" - , project - , "global" - , "networks" - ] + , mbReqPath = + Just $ + toPath + [ "projects" + , project + , "global" + , "networks" + ] } where toQueryList :: ListNetworksQuery -> [(BS8.ByteString, Maybe BS8.ByteString)] - toQueryList ListNetworksQuery{..} = + toQueryList ListNetworksQuery {..} = catMaybes [ ("filter",) . Just . BS8.pack <$> filter_ , ("maxResults",) . Just . BS8.pack . show <$> maxResults diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,19 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -import Test.Hspec -import Google.Cloud.Compute.Disk as Disk -import Google.Cloud.Compute.Instance as Instance -import qualified Google.Cloud.Compute.Firewall as Firewall import Data.Aeson (decode, encode) -import Data.Maybe (isJust) import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Maybe (isJust) +import Google.Cloud.Compute.Common (googleComputeUrl) +import Google.Cloud.Compute.Disk as Disk +import qualified Google.Cloud.Compute.Firewall as Firewall +import Google.Cloud.Compute.Instance as Instance +import Test.Hspec main :: IO () main = hspec spec spec :: Spec spec = do + describe "Google.Cloud.Compute.Common" $ do + it "googleComputeUrl is v1 endpoint" $ do + googleComputeUrl `shouldBe` "https://compute.googleapis.com/compute/v1" describe "Google.Cloud.Compute.Disk" $ do context "DiskResponse JSON serialization" $ do it "successfully parses valid JSON to DiskResponse" $ do @@ -29,15 +33,15 @@ context "InsertDiskOps default" $ do it "creates a default InsertDiskOps" $ do let diskOps = defaultInsertOps "my-disk" "100" - (\InsertDiskOps{..} -> name) diskOps `shouldBe` "my-disk" - (\InsertDiskOps{..} -> sizeGb) diskOps `shouldBe` "100" - (\InsertDiskOps{..} -> description) diskOps `shouldBe` Nothing + (\InsertDiskOps {..} -> name) diskOps `shouldBe` "my-disk" + (\InsertDiskOps {..} -> sizeGb) diskOps `shouldBe` "100" + (\InsertDiskOps {..} -> description) diskOps `shouldBe` Nothing context "CreateSnapshotOps default" $ do it "creates a default CreateSnapshotOps" $ do let snapshotOps = defaultCreateSnapshotOps "my-snapshot" - (\CreateSnapshotOps{..} -> name) snapshotOps `shouldBe` "my-snapshot" - (\CreateSnapshotOps{..} -> description) snapshotOps `shouldBe` Nothing + (\CreateSnapshotOps {..} -> name) snapshotOps `shouldBe` "my-snapshot" + (\CreateSnapshotOps {..} -> description) snapshotOps `shouldBe` Nothing context "Warning JSON serialization" $ do it "serializes and deserializes Warning correctly" $ do @@ -52,7 +56,21 @@ result `shouldSatisfy` isJust it "successfully converts Operation to JSON" $ do - let operation = Operation (Just "123") (Just "operation-1") Nothing Nothing Nothing (Just "DONE") Nothing Nothing Nothing Nothing Nothing Nothing Nothing + let operation = + Operation + (Just "123") + (Just "operation-1") + Nothing + Nothing + Nothing + (Just "DONE") + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing let json = encode operation decode json `shouldBe` Just operation @@ -66,17 +84,18 @@ decode (encode action) `shouldBe` Just action it "correctly serializes and deserializes Scheduling" $ do - let scheduling = Scheduling { - onHostMaintenance = "MIGRATE", - automaticRestart = True, - preemptible = False, - nodeAffinities = [], - minNodeCpus = 1, - locationHint = "us-central1", - availabilityDomain = 0, - provisioningModel = "STANDARD", - instanceTerminationAction = RunDurationRunDuration (TerminationTime "2023-10-15T12:00:00Z") - } + let scheduling = + Scheduling + { onHostMaintenance = "MIGRATE" + , automaticRestart = True + , preemptible = False + , nodeAffinities = [] + , minNodeCpus = 1 + , locationHint = "us-central1" + , availabilityDomain = 0 + , provisioningModel = "STANDARD" + , instanceTerminationAction = RunDurationRunDuration (TerminationTime "2023-10-15T12:00:00Z") + } decode (encode scheduling) `shouldBe` Just scheduling describe "Default Query Constructors" $ do @@ -90,7 +109,7 @@ it "creates a default InsertInstanceOps with correct settings" $ do let ops = defaultInsertInstanceOps "my-project" "us-central1-a" "test-instance" "f1-micro" - (\InsertInstanceOps{..} -> name) ops `shouldBe` "test-instance" + (\InsertInstanceOps {..} -> name) ops `shouldBe` "test-instance" machineType ops `shouldBe` "zones/us-central1-a/machineTypes/f1-micro" isJust (disks ops) `shouldBe` True isJust (networkInterfaces ops) `shouldBe` True @@ -99,73 +118,98 @@ let rid = "request-123" let query = defaultRequestIdQuery rid requestId query `shouldBe` Just rid - - describe "Google.Cloud.Compute.Firewall" $ do - describe "JSON serialization/deserialization" $ do - it "should serialize and deserialize WarningData" $ do - let warningData = Firewall.WarningData "some_key" "some_value" - let json = encode warningData - decode json `shouldBe` Just warningData + describe "Google.Cloud.Compute.Firewall" $ do + describe "JSON serialization/deserialization" $ do + it "should serialize and deserialize WarningData" $ do + let warningData = Firewall.WarningData "some_key" "some_value" + let json = encode warningData + decode json `shouldBe` Just warningData - it "should serialize and deserialize Warning" $ do - let warning = Firewall.Warning "some_code" "some_message" Nothing - let json = encode warning - decode json `shouldBe` Just warning + it "should serialize and deserialize Warning" $ do + let warning = Firewall.Warning "some_code" "some_message" Nothing + let json = encode warning + decode json `shouldBe` Just warning - it "should serialize and deserialize LogConfig" $ do - let logConfig = Firewall.LogConfig True (Just "INCLUDE_ALL_METADATA") - let json = encode logConfig - decode json `shouldBe` Just logConfig + it "should serialize and deserialize LogConfig" $ do + let logConfig = Firewall.LogConfig True (Just "INCLUDE_ALL_METADATA") + let json = encode logConfig + decode json `shouldBe` Just logConfig - it "should serialize and deserialize AllowedFirewall" $ do - let allowedFirewall = Firewall.AllowedFirewall "tcp" (Just ["80", "443"]) - let json = encode allowedFirewall - decode json `shouldBe` Just allowedFirewall + it "should serialize and deserialize AllowedFirewall" $ do + let allowedFirewall = Firewall.AllowedFirewall "tcp" (Just ["80", "443"]) + let json = encode allowedFirewall + decode json `shouldBe` Just allowedFirewall - it "should serialize and deserialize DeniedFirewall" $ do - let deniedFirewall = Firewall.DeniedFirewall "tcp" (Just ["22"]) - let json = encode deniedFirewall - decode json `shouldBe` Just deniedFirewall + it "should serialize and deserialize DeniedFirewall" $ do + let deniedFirewall = Firewall.DeniedFirewall "tcp" (Just ["22"]) + let json = encode deniedFirewall + decode json `shouldBe` Just deniedFirewall - it "should serialize and deserialize FirewallMeta" $ do - let firewallMeta = Firewall.FirewallMeta (Just "compute#firewall") (Just "123456") (Just "2021-01-01T00:00:00Z") - (Just "test-firewall") (Just "A test firewall") - (Just "global/networks/default") (Just 1000) - (Just ["0.0.0.0/0"]) (Just ["tag1"]) (Just ["tag2"]) - (Just [Firewall.AllowedFirewall "tcp" (Just ["80"])]) - (Just [Firewall.DeniedFirewall "tcp" (Just ["22"])]) - (Just "INGRESS") (Just (Firewall.LogConfig True (Just "INCLUDE_ALL_METADATA"))) - (Just False) (Just "selfLink") - let json = encode firewallMeta - decode json `shouldBe` Just firewallMeta + it "should serialize and deserialize FirewallMeta" $ do + let firewallMeta = + Firewall.FirewallMeta + (Just "compute#firewall") + (Just "123456") + (Just "2021-01-01T00:00:00Z") + (Just "test-firewall") + (Just "A test firewall") + (Just "global/networks/default") + (Just 1000) + (Just ["0.0.0.0/0"]) + (Just ["tag1"]) + (Just ["tag2"]) + (Just [Firewall.AllowedFirewall "tcp" (Just ["80"])]) + (Just [Firewall.DeniedFirewall "tcp" (Just ["22"])]) + (Just "INGRESS") + (Just (Firewall.LogConfig True (Just "INCLUDE_ALL_METADATA"))) + (Just False) + (Just "selfLink") + let json = encode firewallMeta + decode json `shouldBe` Just firewallMeta - it "should serialize and deserialize FirewallList" $ do - let firewallList = Firewall.FirewallList (Just "compute#firewallList") (Just "12345") - (Just [Firewall.FirewallMeta (Just "compute#firewall") (Just "123456") - (Just "2021-01-01T00:00:00Z") (Just "test-firewall") - (Just "A test firewall") (Just "global/networks/default") - (Just 1000) (Just ["0.0.0.0/0"]) (Just ["tag1"]) - (Just ["tag2"]) (Just [Firewall.AllowedFirewall "tcp" (Just ["80"])] ) - (Just [Firewall.DeniedFirewall "tcp" (Just ["22"])] ) - (Just "INGRESS") (Just (Firewall.LogConfig True (Just "INCLUDE_ALL_METADATA"))) - (Just False) (Just "selfLink")]) - (Just "nextPageToken") (Just "selfLink") - (Just (Firewall.Warning "some_code" "some_message" Nothing)) - let json = encode firewallList - decode json `shouldBe` Just firewallList + it "should serialize and deserialize FirewallList" $ do + let firewallList = + Firewall.FirewallList + (Just "compute#firewallList") + (Just "12345") + ( Just + [ Firewall.FirewallMeta + (Just "compute#firewall") + (Just "123456") + (Just "2021-01-01T00:00:00Z") + (Just "test-firewall") + (Just "A test firewall") + (Just "global/networks/default") + (Just 1000) + (Just ["0.0.0.0/0"]) + (Just ["tag1"]) + (Just ["tag2"]) + (Just [Firewall.AllowedFirewall "tcp" (Just ["80"])]) + (Just [Firewall.DeniedFirewall "tcp" (Just ["22"])]) + (Just "INGRESS") + (Just (Firewall.LogConfig True (Just "INCLUDE_ALL_METADATA"))) + (Just False) + (Just "selfLink") + ] + ) + (Just "nextPageToken") + (Just "selfLink") + (Just (Firewall.Warning "some_code" "some_message" Nothing)) + let json = encode firewallList + decode json `shouldBe` Just firewallList - it "should create default CreateFirewallOps" $ do - let defaultOps = Firewall.defaultCreateFirewallOps "test-firewall" - (\Firewall.CreateFirewallOps{..} -> name) defaultOps `shouldBe` "test-firewall" - (\Firewall.CreateFirewallOps{..} -> description) defaultOps `shouldBe` Nothing - (\Firewall.CreateFirewallOps{..} -> network) defaultOps `shouldBe` Nothing - (\Firewall.CreateFirewallOps{..} -> priority) defaultOps `shouldBe` Nothing - (\Firewall.CreateFirewallOps{..} -> sourceRanges) defaultOps `shouldBe` Nothing - (\Firewall.CreateFirewallOps{..} -> sourceTags) defaultOps `shouldBe` Nothing - (\Firewall.CreateFirewallOps{..} -> targetTags) defaultOps `shouldBe` Nothing - (\Firewall.CreateFirewallOps{..} -> allowed) defaultOps `shouldBe` Nothing - (\Firewall.CreateFirewallOps{..} -> denied) defaultOps `shouldBe` Nothing - (\Firewall.CreateFirewallOps{..} -> direction) defaultOps `shouldBe` Nothing - (\Firewall.CreateFirewallOps{..} -> logConfig) defaultOps `shouldBe` Nothing - (\Firewall.CreateFirewallOps{..} -> disabled) defaultOps `shouldBe` Nothing + it "should create default CreateFirewallOps" $ do + let defaultOps = Firewall.defaultCreateFirewallOps "test-firewall" + (\Firewall.CreateFirewallOps {..} -> name) defaultOps `shouldBe` "test-firewall" + (\Firewall.CreateFirewallOps {..} -> description) defaultOps `shouldBe` Nothing + (\Firewall.CreateFirewallOps {..} -> network) defaultOps `shouldBe` Nothing + (\Firewall.CreateFirewallOps {..} -> priority) defaultOps `shouldBe` Nothing + (\Firewall.CreateFirewallOps {..} -> sourceRanges) defaultOps `shouldBe` Nothing + (\Firewall.CreateFirewallOps {..} -> sourceTags) defaultOps `shouldBe` Nothing + (\Firewall.CreateFirewallOps {..} -> targetTags) defaultOps `shouldBe` Nothing + (\Firewall.CreateFirewallOps {..} -> allowed) defaultOps `shouldBe` Nothing + (\Firewall.CreateFirewallOps {..} -> denied) defaultOps `shouldBe` Nothing + (\Firewall.CreateFirewallOps {..} -> direction) defaultOps `shouldBe` Nothing + (\Firewall.CreateFirewallOps {..} -> logConfig) defaultOps `shouldBe` Nothing + (\Firewall.CreateFirewallOps {..} -> disabled) defaultOps `shouldBe` Nothing