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-compute` + +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-compute + +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 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-compute.cabal b/google-cloud-compute.cabal new file mode 100644 --- /dev/null +++ b/google-cloud-compute.cabal @@ -0,0 +1,68 @@ +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-compute +version: 0.1.0.0 +synopsis: GCP Client for Haskell +description: GCP Compute 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 +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.Compute.Common + Google.Cloud.Compute.Disk + Google.Cloud.Compute.Firewall + Google.Cloud.Compute.Instance + Google.Cloud.Compute.Network + other-modules: + Paths_google_cloud_compute + 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 + , containers >=0.6 && <1 + , google-cloud-common + , http-conduit >=2.2 && <2.4 + , text >=1.2 && <3 + default-language: Haskell2010 + +test-suite google-cloud-compute-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_google_cloud_compute + 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 + , containers >=0.6 && <1 + , google-cloud-common + , google-cloud-compute + , hspec >=1.3 + , http-conduit >=2.2 && <2.4 + , text >=1.2 && <3 + default-language: Haskell2010 diff --git a/src/Google/Cloud/Compute/Common.hs b/src/Google/Cloud/Compute/Common.hs new file mode 100644 --- /dev/null +++ b/src/Google/Cloud/Compute/Common.hs @@ -0,0 +1,4 @@ +module Google.Cloud.Compute.Common (googleComputeUrl) where + +googleComputeUrl :: String +googleComputeUrl = "https://compute.googleapis.com/compute/v1" diff --git a/src/Google/Cloud/Compute/Disk.hs b/src/Google/Cloud/Compute/Disk.hs new file mode 100644 --- /dev/null +++ b/src/Google/Cloud/Compute/Disk.hs @@ -0,0 +1,627 @@ +{-| +Module : Google.Cloud.Compute.Disk +Copyright : (c) 2025 +License : MIT +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 + , DiskResponse (..) + , InsertDiskOps (..) + , InsertDiskResponse + , Operation (..) + , deleteDisk + , createDiskSnapshot + , CreateSnapshotResp + , CreateSnapshotOps (..) + , Warning (..) + , WarningData (..) + , defaultCreateSnapshotOps + , defaultInsertOps + ) where + +import Data.Aeson +import qualified Data.ByteString.Char8 as BS +import Data.Map (Map) +import Google.Cloud.Common.Core +import Google.Cloud.Compute.Common +import Network.HTTP.Simple + +-- | 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 + } + 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 + } + 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 + } + 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 + } + deriving (Show, Eq) + +-- | Guest OS features enabled on the disk +data 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 + } + 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 + } + deriving (Show, Eq) + +-- | Error information from failed operations +data 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 + } + 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 + } + deriving (Show, Eq) + +-- | Alias for operation response from disk insertion +type InsertDiskResponse = Operation + +-- | 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 + } + deriving (Show, Eq) + +-- | Alias for operation response from snapshot creation +type CreateSnapshotResp = Operation + +data ListDisksQuery = ListDisksQuery + { filter_ :: Maybe String + , maxResults :: Maybe Int + , pageToken :: Maybe String + , orderBy :: Maybe String + } + deriving (Show, Eq) + +-- | Query parameters for insertDisk +data InsertDiskQuery = InsertDiskQuery + { sourceImage :: Maybe String + , sourceImageEncryptionKey :: Maybe EncryptionKey + } + deriving (Show, Eq) + +-- | Query parameters for deleteDisk +data DeleteDiskQuery = DeleteDiskQuery + { force :: Maybe Bool + } + deriving (Show, Eq) + +-- | Query parameters for createDiskSnapshot +data CreateSnapshotQuery = CreateSnapshotQuery + { guestFlush :: Maybe Bool + } + deriving (Show, Eq) + +-- JSON Instances + +instance FromJSON WarningData where + parseJSON = withObject "WarningData" $ \v -> + WarningData + <$> v .: "key" + <*> v .: "value" + +instance ToJSON WarningData where + toJSON (WarningData key value) = + object + [ "key" .= key + , "value" .= value + ] + +instance FromJSON Warning where + parseJSON = withObject "Warning" $ \v -> + Warning + <$> v .: "code" + <*> v .: "message" + <*> v .:? "data" + +instance ToJSON Warning where + toJSON (Warning code message data_) = + object + [ "code" .= code + , "message" .= message + , "data" .= data_ + ] + +instance FromJSON GuestOsFeature where + parseJSON = withObject "GuestOsFeature" $ \v -> + GuestOsFeature + <$> v .: "type" + +instance ToJSON GuestOsFeature where + toJSON (GuestOsFeature type_) = + object + [ "type" .= type_ + ] + +instance FromJSON EncryptionKey where + parseJSON = withObject "EncryptionKey" $ \v -> + EncryptionKey + <$> v .:? "rawKey" + <*> v .:? "rsaEncryptedKey" + <*> v .:? "sha256" + +instance ToJSON EncryptionKey where + toJSON (EncryptionKey rawKey rsaEncryptedKey sha256) = + object + [ "rawKey" .= rawKey + , "rsaEncryptedKey" .= rsaEncryptedKey + , "sha256" .= sha256 + ] + +instance FromJSON DiskItem where + parseJSON = withObject "DiskItem" $ \v -> + DiskItem + <$> v .:? "kind" + <*> v .:? "id" + <*> v .:? "creationTimestamp" + <*> v .:? "name" + <*> v .:? "description" + <*> v .:? "sizeGb" + <*> v .:? "zone" + <*> v .:? "status" + <*> v .:? "sourceSnapshot" + <*> v .:? "sourceSnapshotId" + <*> v .:? "sourceImage" + <*> v .:? "sourceImageId" + <*> v .:? "type" + <*> v .:? "labels" + <*> v .:? "labelFingerprint" + <*> v .:? "licenses" + <*> v .:? "users" + <*> v .:? "guestOsFeatures" + <*> v .:? "diskEncryptionKey" + <*> v .:? "sourceDisk" + <*> v .:? "sourceDiskId" + <*> v .:? "physicalBlockSizeBytes" + <*> v .:? "provisionedIops" + <*> v .:? "resourcePolicies" + <*> v .:? "selfLink" + +instance ToJSON DiskItem where + toJSON + ( DiskItem + kind + id_ + creationTimestamp + name + description + sizeGb + zone + status + sourceSnapshot + sourceSnapshotId + sourceImage + sourceImageId + type_ + labels + labelFingerprint + licenses + users + guestOsFeatures + diskEncryptionKey + sourceDisk + sourceDiskId + physicalBlockSizeBytes + provisionedIops + resourcePolicies + selfLink + ) = + object + [ "kind" .= kind + , "id" .= id_ + , "creationTimestamp" .= creationTimestamp + , "name" .= name + , "description" .= description + , "sizeGb" .= sizeGb + , "zone" .= zone + , "status" .= status + , "sourceSnapshot" .= sourceSnapshot + , "sourceSnapshotId" .= sourceSnapshotId + , "sourceImage" .= sourceImage + , "sourceImageId" .= sourceImageId + , "type" .= type_ + , "labels" .= labels + , "labelFingerprint" .= labelFingerprint + , "licenses" .= licenses + , "users" .= users + , "guestOsFeatures" .= guestOsFeatures + , "diskEncryptionKey" .= diskEncryptionKey + , "sourceDisk" .= sourceDisk + , "sourceDiskId" .= sourceDiskId + , "physicalBlockSizeBytes" .= physicalBlockSizeBytes + , "provisionedIops" .= provisionedIops + , "resourcePolicies" .= resourcePolicies + , "selfLink" .= selfLink + ] + +instance FromJSON DiskResponse where + parseJSON = withObject "DiskResponse" $ \v -> + DiskResponse + <$> v .:? "kind" + <*> v .:? "id" + <*> v .:? "items" + <*> v .:? "nextPageToken" + <*> v .:? "selfLink" + <*> v .:? "warning" + +instance ToJSON DiskResponse where + toJSON (DiskResponse kind id_ items nextPageToken selfLink warning) = + object + [ "kind" .= kind + , "id" .= id_ + , "items" .= items + , "nextPageToken" .= nextPageToken + , "selfLink" .= selfLink + , "warning" .= warning + ] + +instance FromJSON ErrorDetail where + parseJSON = withObject "ErrorDetail" $ \v -> + ErrorDetail + <$> v .: "code" + <*> v .: "message" + <*> v .:? "location" + +instance ToJSON ErrorDetail where + toJSON (ErrorDetail code message location) = + object + [ "code" .= code + , "message" .= message + , "location" .= location + ] + +instance FromJSON OperationError where + parseJSON = withObject "OperationError" $ \v -> + OperationError + <$> v .: "errors" + +instance ToJSON OperationError where + toJSON (OperationError errors) = + object + [ "errors" .= errors + ] + +instance FromJSON Operation where + parseJSON = withObject "Operation" $ \v -> + Operation + <$> v .:? "id" + <*> v .:? "name" + <*> v .:? "zone" + <*> v .:? "operationType" + <*> v .:? "targetLink" + <*> v .:? "status" + <*> v .:? "progress" + <*> v .:? "insertTime" + <*> v .:? "startTime" + <*> v .:? "endTime" + <*> v .:? "error" + <*> v .:? "warnings" + <*> v .:? "selfLink" + +instance ToJSON Operation where + toJSON + ( Operation + id_ + name + zone + operationType + targetLink + status + progress + insertTime + startTime + endTime + error_ + warnings + selfLink + ) = + object + [ "id" .= id_ + , "name" .= name + , "zone" .= zone + , "operationType" .= operationType + , "targetLink" .= targetLink + , "status" .= status + , "progress" .= progress + , "insertTime" .= insertTime + , "startTime" .= startTime + , "endTime" .= endTime + , "error" .= error_ + , "warnings" .= warnings + , "selfLink" .= selfLink + ] + +instance ToJSON InsertDiskOps where + toJSON + ( InsertDiskOps + name + sizeGb + description + type_ + sourceImage + sourceSnapshot + labels + guestOsFeatures + diskEncryptionKey + ) = + object + [ "name" .= name + , "sizeGb" .= sizeGb + , "description" .= description + , "type" .= type_ + , "sourceImage" .= sourceImage + , "sourceSnapshot" .= sourceSnapshot + , "labels" .= labels + , "guestOsFeatures" .= guestOsFeatures + , "diskEncryptionKey" .= diskEncryptionKey + ] + +instance ToJSON CreateSnapshotOps where + toJSON (CreateSnapshotOps name description labels storageLocations snapshotEncryptionKey) = + object + [ "name" .= name + , "description" .= description + , "labels" .= labels + , "storageLocations" .= storageLocations + , "snapshotEncryptionKey" .= snapshotEncryptionKey + ] + +-- 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} +listDisks project zone_ mbQuery = do + let queryParams = maybe [] queryToList mbQuery + doRequestJSON + RequestOptions + { reqMethod = GET + , reqUrl = googleComputeUrl + , mbQueryParams = Just queryParams + , mbReqBody = Nothing + , mbReqHeaders = Nothing + , mbReqPath = Just $ "/projects/" <> project <> "/zones/" <> zone_ <> "/disks" + } + where + queryToList :: ListDisksQuery -> Query + queryToList ListDisksQuery {..} = + [ maybe mempty (\x -> ("filter", Just $ BS.pack x)) filter_ + , maybe mempty (\x -> ("maxResults", Just . BS.pack $ show x)) maxResults + , maybe mempty (\x -> ("pageToken", Just $ BS.pack x)) pageToken + , 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} +insertDisk project zone_ insertDiskOps mbQuery = do + let queryParams = maybe [] queryToList mbQuery + doRequestJSON + RequestOptions + { reqMethod = POST + , reqUrl = googleComputeUrl + , mbQueryParams = Just queryParams + , mbReqBody = Just $ encode insertDiskOps + , mbReqHeaders = Nothing + , mbReqPath = Just $ "/projects/" <> project <> "/zones/" <> zone_ <> "/disks" + } + where + queryToList :: InsertDiskQuery -> Query + queryToList InsertDiskQuery {sourceImage, sourceImageEncryptionKey} = + [ maybe mempty (\x -> ("sourceImage", Just $ BS.pack x)) sourceImage + , maybe + mempty + (\x -> ("sourceImageEncryptionKey", Just . BS.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 +deleteDisk project zone_ diskName mbQuery = do + let queryParams = maybe [] queryToList mbQuery + doRequestJSON + RequestOptions + { reqMethod = DELETE + , reqUrl = googleComputeUrl + , mbQueryParams = Just queryParams + , mbReqBody = Nothing + , mbReqHeaders = Nothing + , mbReqPath = Just $ "/projects/" <> project <> "/zones/" <> zone_ <> "/disks/" <> diskName + } + where + queryToList :: DeleteDiskQuery -> Query + queryToList q = + [ 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 +createDiskSnapshot project zone_ diskName createSnapshotOps mbQuery = do + let queryParams = maybe [] queryToList mbQuery + doRequestJSON + RequestOptions + { reqMethod = POST + , reqUrl = googleComputeUrl + , mbQueryParams = Just queryParams + , mbReqBody = Just $ encode createSnapshotOps + , mbReqHeaders = Nothing + , mbReqPath = + Just $ "/projects/" <> project <> "/zones/" <> zone_ <> "/disks/" <> diskName <> "/createSnapshot" + } + where + queryToList :: CreateSnapshotQuery -> Query + queryToList q = + [ 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" } +defaultInsertOps :: String -> String -> InsertDiskOps +defaultInsertOps diskName diskSizeGb = + InsertDiskOps + { name = diskName + , sizeGb = diskSizeGb + , description = Nothing + , type_ = Nothing + , sourceImage = Nothing + , sourceSnapshot = Nothing + , labels = Nothing + , guestOsFeatures = Nothing + , 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" } +defaultCreateSnapshotOps :: String -> CreateSnapshotOps +defaultCreateSnapshotOps snapshotName = + CreateSnapshotOps + { name = snapshotName + , description = Nothing + , labels = Nothing + , storageLocations = Nothing + , snapshotEncryptionKey = Nothing + } diff --git a/src/Google/Cloud/Compute/Firewall.hs b/src/Google/Cloud/Compute/Firewall.hs new file mode 100644 --- /dev/null +++ b/src/Google/Cloud/Compute/Firewall.hs @@ -0,0 +1,585 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +{- | +Module : Google.Cloud.Compute.Firewall +Copyright : (c) 2025 +License : MIT +Maintainer : +Stability : experimental + +This module provides a Haskell client for Google Cloud Compute Engine Firewall operations. +-} +module Google.Cloud.Compute.Firewall + ( listFirewalls + , FirewallList (..) + , FirewallMeta (..) + , AllowedFirewall (..) + , createFirewall + , CreateFirewallOps (..) + , CreateFirewallResp + , Operation (..) + , Warning (..) + , WarningData (..) + , LogConfig (..) + , DeniedFirewall (..) + , defaultCreateFirewallOps + ) where + +import Data.Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Maybe +import Google.Cloud.Common.Core +import Google.Cloud.Compute.Common + +-- | Represents a warning object in API responses +data Warning = 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 + } + deriving (Show, Eq) + +-- | Response format for firewall listing operations +data FirewallList = FirewallList + { kind :: Maybe String + -- ^ Type identifier ("compute#firewallList") + , id :: Maybe String + -- ^ Unique identifier for the resource + , items :: Maybe [FirewallMeta] + -- ^ List of firewall rules + , 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 Firewall Rule +data FirewallMeta = FirewallMeta + { kind :: Maybe String + -- ^ Type identifier ("compute#firewall") + , id :: Maybe String + -- ^ Unique numeric ID + , creationTimestamp :: Maybe String + -- ^ ISO 8601 creation timestamp + , name :: Maybe String + -- ^ User-provided firewall name + , description :: Maybe String + -- ^ Optional rule description + , network :: Maybe String + -- ^ Network URL the rule applies to + , priority :: Maybe Int + -- ^ Rule priority (0-65535, lower=higher) + , sourceRanges :: Maybe [String] + -- ^ Allowed source IP ranges (CIDR) + , sourceTags :: Maybe [String] + -- ^ Source instance tags + , targetTags :: Maybe [String] + -- ^ Target instance tags + , allowed :: Maybe [AllowedFirewall] + -- ^ Allow rules + , denied :: Maybe [DeniedFirewall] + -- ^ Deny rules + , direction :: Maybe String + -- ^ Traffic direction (INGRESS/EGRESS) + , logConfig :: Maybe LogConfig + -- ^ Logging configuration + , disabled :: Maybe Bool + -- ^ Whether rule is disabled + , selfLink :: Maybe String + -- ^ Server-defined URL for the rule + } + deriving (Show, Eq) + +-- | Allow rule specification +data AllowedFirewall = AllowedFirewall + { iPProtocol :: String + -- ^ Protocol name (e.g., "tcp", "udp", "icmp") + , ports :: Maybe [String] + -- ^ Optional port numbers/ranges (e.g., "80", "8000-8080") + } + deriving (Show, Eq) + +-- | Deny rule specification +data DeniedFirewall = DeniedFirewall + { iPProtocol :: String + -- ^ Protocol name (e.g., "tcp", "udp") + , ports :: Maybe [String] + -- ^ Optional port numbers/ranges to block + } + deriving (Show, Eq) + +-- | Firewall rule logging configuration +data LogConfig = LogConfig + { enable :: Bool + -- ^ Whether to enable logging + , metadata :: Maybe String + -- ^ Log metadata level (EXCLUDE_ALL_METADATA or INCLUDE_ALL_METADATA) + } + deriving (Show, Eq) + +-- | Long-running operation resource +data Operation = Operation + { id :: Maybe String + -- ^ Unique operation ID + , name :: Maybe String + -- ^ Operation name + , 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 + } + 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 + } + deriving (Show, Eq) + +-- | Firewall creation options +data CreateFirewallOps = CreateFirewallOps + { name :: String + -- ^ Required firewall rule name + , description :: Maybe String + -- ^ Optional description + , network :: Maybe String + -- ^ Network URL (default: "global/networks/default") + , priority :: Maybe Int + -- ^ Priority (default: 1000) + , sourceRanges :: Maybe [String] + -- ^ Source IP ranges (CIDR format) + , sourceTags :: Maybe [String] + -- ^ Source instance tags + , targetTags :: Maybe [String] + -- ^ Target instance tags + , allowed :: Maybe [AllowedFirewall] + -- ^ Traffic allow rules + , denied :: Maybe [DeniedFirewall] + -- ^ Traffic deny rules + , direction :: Maybe String + -- ^ Traffic direction (default: INGRESS) + , logConfig :: Maybe LogConfig + -- ^ Logging configuration + , disabled :: Maybe Bool + -- ^ Initial disabled state (default: False) + } + deriving (Show, Eq) + +-- | Alias for operation response from firewall creation +type CreateFirewallResp = Operation + +-- JSON Instances + +instance FromJSON WarningData where + parseJSON = withObject "WarningData" $ \v -> + WarningData + <$> v .: "key" + <*> v .: "value" + +instance ToJSON WarningData where + toJSON (WarningData k v) = + object + [ "key" .= k + , "value" .= v + ] + +instance FromJSON Warning where + parseJSON = withObject "Warning" $ \v -> + Warning + <$> v .: "code" + <*> v .: "message" + <*> v .:? "data" + +instance ToJSON Warning where + toJSON (Warning c m d) = + object + [ "code" .= c + , "message" .= m + , "data" .= d + ] + +instance FromJSON LogConfig where + parseJSON = withObject "LogConfig" $ \v -> + LogConfig + <$> v .: "enable" + <*> v .:? "metadata" + +instance ToJSON LogConfig where + toJSON (LogConfig e m) = + object + [ "enable" .= e + , "metadata" .= m + ] + +instance FromJSON AllowedFirewall where + parseJSON = withObject "AllowedFirewall" $ \v -> + AllowedFirewall + <$> v .: "IPProtocol" + <*> v .:? "ports" + +instance ToJSON AllowedFirewall where + toJSON (AllowedFirewall i p) = + object + [ "IPProtocol" .= i + , "ports" .= p + ] + +instance FromJSON DeniedFirewall where + parseJSON = withObject "DeniedFirewall" $ \v -> + DeniedFirewall + <$> v .: "IPProtocol" + <*> v .:? "ports" + +instance ToJSON DeniedFirewall where + toJSON (DeniedFirewall i p) = + object + [ "IPProtocol" .= i + , "ports" .= p + ] + +instance FromJSON FirewallMeta where + parseJSON = withObject "FirewallMeta" $ \v -> + FirewallMeta + <$> v .:? "kind" + <*> v .:? "id" + <*> v .:? "creationTimestamp" + <*> v .:? "name" + <*> v .:? "description" + <*> v .:? "network" + <*> v .:? "priority" + <*> v .:? "sourceRanges" + <*> v .:? "sourceTags" + <*> v .:? "targetTags" + <*> v .:? "allowed" + <*> v .:? "denied" + <*> v .:? "direction" + <*> v .:? "logConfig" + <*> v .:? "disabled" + <*> v .:? "selfLink" + +instance ToJSON FirewallMeta where + toJSON + ( FirewallMeta + k + i + c + name_ + description_ + network_ + priority_ + sourceRanges_ + sourceTags_ + targetTags_ + allowed_ + denied_ + direction_ + logConfig_ + disabled_ + selfLink_ + ) = + object + [ "kind" .= k + , "id" .= i + , "creationTimestamp" .= c + , "name" .= name_ + , "description" .= description_ + , "network" .= network_ + , "priority" .= priority_ + , "sourceRanges" .= sourceRanges_ + , "sourceTags" .= sourceTags_ + , "targetTags" .= targetTags_ + , "allowed" .= allowed_ + , "denied" .= denied_ + , "direction" .= direction_ + , "logConfig" .= logConfig_ + , "disabled" .= disabled_ + , "selfLink" .= selfLink_ + ] + +instance FromJSON FirewallList where + parseJSON = withObject "FirewallList" $ \v -> + FirewallList + <$> v .:? "kind" + <*> v .:? "id" + <*> v .:? "items" + <*> v .:? "nextPageToken" + <*> v .:? "selfLink" + <*> v .:? "warning" + +instance ToJSON FirewallList where + toJSON (FirewallList kind_ id_ items_ nextPageToken_ selfLink_ warning_) = + object + [ "kind" .= kind_ + , "id" .= id_ + , "items" .= items_ + , "nextPageToken" .= nextPageToken_ + , "selfLink" .= selfLink_ + , "warning" .= warning_ + ] + +instance FromJSON ErrorDetail where + parseJSON = withObject "ErrorDetail" $ \v -> + ErrorDetail + <$> v .: "code" + <*> v .: "message" + <*> v .:? "location" + +instance ToJSON ErrorDetail where + toJSON (ErrorDetail code_ message_ location_) = + object + [ "code" .= code_ + , "message" .= message_ + , "location" .= location_ + ] + +instance FromJSON OperationError where + parseJSON = withObject "OperationError" $ \v -> + OperationError + <$> v .: "errors" + +instance ToJSON OperationError where + toJSON (OperationError errors_) = + object + [ "errors" .= errors_ + ] + +instance FromJSON Operation where + parseJSON = withObject "Operation" $ \v -> + Operation + <$> v .:? "id" + <*> v .:? "name" + <*> v .:? "operationType" + <*> v .:? "targetLink" + <*> v .:? "status" + <*> v .:? "progress" + <*> v .:? "insertTime" + <*> v .:? "startTime" + <*> v .:? "endTime" + <*> v .:? "error" + <*> v .:? "warnings" + <*> v .:? "selfLink" + +instance ToJSON Operation where + toJSON + ( Operation + id_ + name_ + operationType_ + targetLink_ + status_ + progress_ + insertTime_ + startTime_ + endTime_ + error1 + warnings_ + selfLink_ + ) = + object + [ "id" .= id_ + , "name" .= name_ + , "operationType" .= operationType_ + , "targetLink" .= targetLink_ + , "status" .= status_ + , "progress" .= progress_ + , "insertTime" .= insertTime_ + , "startTime" .= startTime_ + , "endTime" .= endTime_ + , "error" .= error1 + , "warnings" .= warnings_ + , "selfLink" .= selfLink_ + ] + +instance ToJSON CreateFirewallOps where + toJSON + ( CreateFirewallOps + name_ + description_ + network_ + priority_ + sourceRanges_ + sourceTags_ + targetTags_ + allowed_ + denied_ + direction_ + logConfig_ + disabled_ + ) = + object + [ "name" .= name_ + , "description" .= description_ + , "network" .= network_ + , "priority" .= priority_ + , "sourceRanges" .= sourceRanges_ + , "sourceTags" .= sourceTags_ + , "targetTags" .= targetTags_ + , "allowed" .= allowed_ + , "denied" .= denied_ + , "direction" .= direction_ + , "logConfig" .= logConfig_ + , "disabled" .= disabled_ + ] + +-- | Query parameters for listFirewalls +data ListFirewallsQuery = ListFirewallsQuery + { filter0 :: Maybe String + , maxResults :: Maybe Int + , pageToken :: Maybe String + , orderBy :: Maybe String + } + deriving (Show, Eq) + +-- | Query parameters for createFirewall +data CreateFirewallQuery = CreateFirewallQuery + { requestId :: Maybe String + } + deriving (Show, Eq) + +-- Helper function to convert query to list of (ByteString, Maybe ByteString) +queryToList :: (a -> [(String, String)]) -> a -> [(BS.ByteString, Maybe BS.ByteString)] +queryToList f q = map (\(k, v) -> (BS8.pack k, Just $ BS8.pack v)) (f q) + +-- Functions + +{- | List firewall rules in a project + +Example: + +> listFirewalls "my-project" (Just ListFirewallsQuery { filter0 = Just "name=default-allow-*" }) +-} +listFirewalls :: + -- | GCP Project ID + String -> + -- | Optional query parameters + Maybe ListFirewallsQuery -> + -- | List result or error + IO (Either String FirewallList) +listFirewalls project mbQuery = do + let queryParams = maybe [] (queryToList queryToListFunc) mbQuery + doRequestJSON + RequestOptions + { reqMethod = GET + , reqUrl = googleComputeUrl + , mbQueryParams = Just queryParams + , mbReqBody = Nothing + , mbReqHeaders = Nothing + , mbReqPath = Just $ "/projects/" <> project <> "/global/firewalls" + } + where + queryToListFunc :: ListFirewallsQuery -> [(String, String)] + queryToListFunc q = + catMaybes + [ ("filter",) <$> filter0 q + , ("maxResults",) . show <$> maxResults q + , ("pageToken",) <$> pageToken q + , ("orderBy",) <$> orderBy q + ] + +{- | Create a new firewall rule + +Example: + +> createFirewall "my-project" +> (defaultCreateFirewallOps "allow-http" +> { allowed = Just [AllowedFirewall "tcp" (Just ["80"])] +> , sourceRanges = Just ["0.0.0.0/0"] +> }) Nothing +-} +createFirewall :: + -- | GCP Project ID + String -> + -- | Firewall configuration + CreateFirewallOps -> + -- | Optional request ID + Maybe CreateFirewallQuery -> + -- | Operation or error + IO (Either String CreateFirewallResp) +createFirewall project createFirewallOps mbQuery = do + let queryParams = maybe [] (queryToList queryToListFunc) mbQuery + doRequestJSON + RequestOptions + { reqMethod = POST + , reqUrl = googleComputeUrl + , mbQueryParams = Just queryParams + , mbReqBody = Just $ encode createFirewallOps + , mbReqHeaders = Nothing + , mbReqPath = Just $ "/projects/" <> project <> "/global/firewalls" + } + where + queryToListFunc :: CreateFirewallQuery -> [(String, String)] + queryToListFunc q = + 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"])] +-- > } +defaultCreateFirewallOps :: String -> CreateFirewallOps +defaultCreateFirewallOps firewallName = + CreateFirewallOps + { name = firewallName + , description = Nothing + , network = Nothing + , priority = Nothing + , sourceRanges = Nothing + , sourceTags = Nothing + , targetTags = Nothing + , allowed = Nothing + , denied = Nothing + , direction = Nothing + , logConfig = Nothing + , disabled = Nothing + } diff --git a/src/Google/Cloud/Compute/Instance.hs b/src/Google/Cloud/Compute/Instance.hs new file mode 100644 --- /dev/null +++ b/src/Google/Cloud/Compute/Instance.hs @@ -0,0 +1,1145 @@ +{-| +Module : Google.Cloud.Compute.Instance +Copyright : (c) 2025 Tushar +License : MIT +Maintainer : +Stability : experimental + +This module provides types and functions for interacting with Google Cloud Platform (GCP) +Compute Engine instances. It supports common operations such as listing, creating, deleting, +starting, and stopping instances, along with detailed configuration of instance properties. + +All functions communicate with the GCP Compute Engine API v1 and return either an error +message ('Left') or a parsed response object ('Right'). + +For more information on the underlying API, see: + +-} + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Google.Cloud.Compute.Instance + ( -- Data Types + InstanceMetadata (..) + , InstanceDeleteResp (..) + , InstanceStartResponse (..) + , RunDuration (..) + , OnInstanceTerminationAction (..) + , Scheduling (..) + , InstanceTerminationAction (..) + , NodeAffinity (..) + , Warning (..) + , GuestAccelerator (..) + , ReservationAffinity (..) + , DisplayDevice (..) + , ShieldedInstanceConfig (..) + , ShieldedInstanceIntegrityPolicy (..) + , UpdateAutoLearnPolicy (..) + , ConfidentialInstanceConfig (..) + , InstanceEncryptionKey (..) + , NetworkPerformanceConfig (..) + , ResourceStatus (..) + , InstanceList (..) + , Error_ (..) + , ErrorDetail (..) + , DetailedError (..) + , ErrorInfo (..) + , QuotaInfo (..) + , Help (..) + , Link (..) + , LocalizedMessage (..) + -- Query Parameter Types + , ListInstancesQuery (..) + , RequestIdQuery (..) + , InsertInstanceOps (..) + -- Functions + , listInstances + , deleteInstance + , startInstance + , stopInstance + , insertInstance + -- Default Query Constructors + , defaultListInstancesQuery + , defaultInsertInstanceOps + , defaultRequestIdQuery + ) +where + +import Data.Aeson +import qualified Data.ByteString as BS +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 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 + , maxResults :: Maybe Int + -- ^ Maximum number of results per page + , orderBy :: Maybe String + -- ^ Sort order for results + , pageToken :: Maybe String + -- ^ Page token for paginated results + , returnPartialSuccess :: Maybe Bool + -- ^ Whether to return partial success results + } + deriving (Show, Eq) + +-- Query parameters for operations with requestId (start, stop, delete) +data RequestIdQuery = RequestIdQuery + { requestId :: Maybe String + } + deriving (Show, Eq) + +-- ** Data Types with Custom JSON Instances** + +data RunDuration + = TerminationTime String + deriving (Show, Eq) + +instance FromJSON RunDuration where + parseJSON = withObject "RunDuration" $ \o -> TerminationTime <$> o .: "terminationTime" + +instance ToJSON RunDuration where + toJSON (TerminationTime t) = object ["terminationTime" .= t] + +data OnInstanceTerminationAction = DiscardLocalSsd {discardLocalSsd :: Bool} + deriving (Show, Eq) + +instance FromJSON OnInstanceTerminationAction where + parseJSON = withObject "OnInstanceTerminationAction" $ \o -> DiscardLocalSsd <$> o .: "discardLocalSsd" + +instance ToJSON OnInstanceTerminationAction where + toJSON (DiscardLocalSsd b) = object ["discardLocalSsd" .= b] + +data Scheduling = Scheduling + { onHostMaintenance :: String + , automaticRestart :: Bool + , preemptible :: Bool + , nodeAffinities :: [NodeAffinity] + , minNodeCpus :: Int + , locationHint :: String + , availabilityDomain :: Int + , provisioningModel :: String + , instanceTerminationAction :: InstanceTerminationAction + } + deriving (Show, Eq) + +instance FromJSON Scheduling where + parseJSON = withObject "Scheduling" $ \o -> + Scheduling + <$> o .: "onHostMaintenance" + <*> o .: "automaticRestart" + <*> o .: "preemptible" + <*> o .: "nodeAffinities" + <*> o .: "minNodeCpus" + <*> o .: "locationHint" + <*> o .: "availabilityDomain" + <*> o .: "provisioningModel" + <*> o .: "instanceTerminationAction" + +instance ToJSON Scheduling where + toJSON Scheduling {..} = + object + [ "onHostMaintenance" .= onHostMaintenance + , "automaticRestart" .= automaticRestart + , "preemptible" .= preemptible + , "nodeAffinities" .= nodeAffinities + , "minNodeCpus" .= minNodeCpus + , "locationHint" .= locationHint + , "availabilityDomain" .= availabilityDomain + , "provisioningModel" .= provisioningModel + , "instanceTerminationAction" .= instanceTerminationAction + ] + +data InstanceTerminationAction + = RunDurationRunDuration RunDuration + deriving (Show, Eq) + +instance FromJSON InstanceTerminationAction where + parseJSON v = RunDurationRunDuration <$> parseJSON v + +instance ToJSON InstanceTerminationAction where + toJSON (RunDurationRunDuration rd) = toJSON rd + +data NodeAffinity = NodeAffinity + { key :: String + , operator :: String + , values :: [String] + } + deriving (Show, Eq) + +instance FromJSON NodeAffinity where + parseJSON = withObject "NodeAffinity" $ \o -> + NodeAffinity + <$> o .: "key" + <*> o .: "operator" + <*> o .: "values" + +instance ToJSON NodeAffinity where + toJSON NodeAffinity {..} = + object + [ "key" .= key + , "operator" .= operator + , "values" .= values + ] + +data Warning = Warning + { code :: String + , message :: String + } + deriving (Show, Eq) + +instance FromJSON Warning where + parseJSON = withObject "Warning" $ \o -> + Warning + <$> o .: "code" + <*> o .: "message" + +instance ToJSON Warning where + toJSON Warning {..} = + object + [ "code" .= code + , "message" .= message + ] + +-- | Metadata representing a Compute Engine instance +data InstanceMetadata = InstanceMetadata + { cpuPlatform :: Maybe String + -- ^ The CPU platform used by this instance + , labelFingerprint :: Maybe Text + -- ^ Fingerprint of the label metadata + , instanceEncryptionKey :: Maybe InstanceEncryptionKey + -- ^ Encryption key configuration for the instance + , minCpuPlatform :: Maybe Text + -- ^ Minimum CPU platform required by the instance + , guestAccelerators :: Maybe [GuestAccelerator] + -- ^ List of guest accelerators attached to the instance + , startRestricted :: Maybe Bool + -- ^ Whether instance start is restricted due to storage issues + , deletionProtection :: Maybe Bool + -- ^ Whether deletion protection is enabled + , resourcePolicies :: Maybe [Text] + -- ^ Resource policies applied to the instance + , sourceMachineImage :: Maybe Text + -- ^ Source machine image used to create the instance + , reservationAffinity :: Maybe ReservationAffinity + -- ^ Reservation affinity configuration + , hostname :: Maybe Text + -- ^ Custom hostname assigned to the instance + , displayDevice :: Maybe DisplayDevice + -- ^ Display device configuration + , shieldedInstanceConfig :: Maybe ShieldedInstanceConfig + -- ^ Shielded VM configuration + , shieldedInstanceIntegrityPolicy :: Maybe ShieldedInstanceIntegrityPolicy + -- ^ Integrity policy for shielded instances + , sourceMachineImageEncryptionKey :: Maybe InstanceEncryptionKey + -- ^ Encryption key for source machine image + , confidentialInstanceConfig :: Maybe ConfidentialInstanceConfig + -- ^ Confidential computing configuration + , fingerprint :: Maybe Text + -- ^ Unique fingerprint for resource metadata + , privateIpv6GoogleAccess :: Maybe Text + -- ^ Private IPv6 Google access configuration + , lastStartTimestamp :: Maybe String + -- ^ Last start timestamp in RFC3339 format + , lastStopTimestamp :: Maybe String + -- ^ Last stop timestamp in RFC3339 format + , lastSuspendedTimestamp :: Maybe String + -- ^ Last suspension timestamp in RFC3339 format + , satisfiesPzs :: Maybe Bool + -- ^ Whether instance satisfies zone separation policy + , satisfiesPzi :: Maybe Bool + -- ^ Whether instance satisfies instance separation policy + , resourceStatus :: Maybe ResourceStatus + -- ^ Current resource status of the instance + , networkPerformanceConfig :: Maybe NetworkPerformanceConfig + -- ^ Network performance configuration + , keyRevocationActionType :: Maybe Text + -- ^ Type of key revocation action if applicable + } + deriving (Show, Eq) + +instance FromJSON InstanceMetadata where + parseJSON = withObject "InstanceMetadata" $ \o -> + InstanceMetadata + <$> o .:? "cpuPlatform" + <*> o .:? "labelFingerprint" + <*> o .:? "instanceEncryptionKey" + <*> o .:? "minCpuPlatform" + <*> o .:? "guestAccelerators" + <*> o .:? "startRestricted" + <*> o .:? "deletionProtection" + <*> o .:? "resourcePolicies" + <*> o .:? "sourceMachineImage" + <*> o .:? "reservationAffinity" + <*> o .:? "hostname" + <*> o .:? "displayDevice" + <*> o .:? "shieldedInstanceConfig" + <*> o .:? "shieldedInstanceIntegrityPolicy" + <*> o .:? "sourceMachineImageEncryptionKey" + <*> o .:? "confidentialInstanceConfig" + <*> o .:? "fingerprint" + <*> o .:? "privateIpv6GoogleAccess" + <*> o .:? "lastStartTimestamp" + <*> o .:? "lastStopTimestamp" + <*> o .:? "lastSuspendedTimestamp" + <*> o .:? "satisfiesPzs" + <*> o .:? "satisfiesPzi" + <*> o .:? "resourceStatus" + <*> o .:? "networkPerformanceConfig" + <*> o .:? "keyRevocationActionType" + +instance ToJSON InstanceMetadata where + toJSON im = + object $ + catMaybes + [ ("cpuPlatform" .=) <$> cpuPlatform im + , ("labelFingerprint" .=) <$> labelFingerprint im + , ("instanceEncryptionKey" .=) <$> instanceEncryptionKey im + , ("minCpuPlatform" .=) <$> minCpuPlatform im + , ("guestAccelerators" .=) <$> guestAccelerators im + , ("startRestricted" .=) <$> startRestricted im + , ("deletionProtection" .=) <$> deletionProtection im + , ("resourcePolicies" .=) <$> resourcePolicies im + , ("sourceMachineImage" .=) <$> sourceMachineImage im + , ("reservationAffinity" .=) <$> reservationAffinity im + , ("hostname" .=) <$> hostname im + , ("displayDevice" .=) <$> displayDevice im + , ("shieldedInstanceConfig" .=) <$> shieldedInstanceConfig im + , ("shieldedInstanceIntegrityPolicy" .=) <$> shieldedInstanceIntegrityPolicy im + , ("sourceMachineImageEncryptionKey" .=) <$> sourceMachineImageEncryptionKey im + , ("confidentialInstanceConfig" .=) <$> confidentialInstanceConfig im + , ("fingerprint" .=) <$> fingerprint im + , ("privateIpv6GoogleAccess" .=) <$> privateIpv6GoogleAccess im + , ("lastStartTimestamp" .=) <$> lastStartTimestamp im + , ("lastStopTimestamp" .=) <$> lastStopTimestamp im + , ("lastSuspendedTimestamp" .=) <$> lastSuspendedTimestamp im + , ("satisfiesPzs" .=) <$> satisfiesPzs im + , ("satisfiesPzi" .=) <$> satisfiesPzi im + , ("resourceStatus" .=) <$> resourceStatus im + , ("networkPerformanceConfig" .=) <$> networkPerformanceConfig im + , ("keyRevocationActionType" .=) <$> keyRevocationActionType im + ] + +data GuestAccelerator = GuestAccelerator + { acceleratorType :: Text + , acceleratorCount :: Int + } + deriving (Show, Eq) + +instance FromJSON GuestAccelerator where + parseJSON = withObject "GuestAccelerator" $ \o -> + GuestAccelerator + <$> o .: "acceleratorType" + <*> o .: "acceleratorCount" + +instance ToJSON GuestAccelerator where + toJSON ga = + object + [ "acceleratorType" .= acceleratorType ga + , "acceleratorCount" .= acceleratorCount ga + ] + +data ReservationAffinity = ReservationAffinity + { consumeReservationType :: Maybe Text + , key :: Maybe Text + , values :: Maybe [Text] + } + deriving (Show, Eq) + +instance FromJSON ReservationAffinity where + parseJSON = withObject "ReservationAffinity" $ \o -> + ReservationAffinity + <$> o .:? "consumeReservationType" + <*> o .:? "key" + <*> o .:? "values" + +instance ToJSON ReservationAffinity where + toJSON ReservationAffinity {..} = + object $ + catMaybes + [ ("consumeReservationType" .=) <$> consumeReservationType + , ("key" .=) <$> key + , ("values" .=) <$> values + ] + +data DisplayDevice = DisplayDevice + { enableDisplay :: Bool + } + deriving (Show, Eq) + +instance FromJSON DisplayDevice where + parseJSON = withObject "DisplayDevice" $ \o -> + DisplayDevice + <$> o .: "enableDisplay" + +instance ToJSON DisplayDevice where + toJSON dd = object ["enableDisplay" .= enableDisplay dd] + +data ShieldedInstanceConfig = ShieldedInstanceConfig + { enableSecureBoot :: Bool + , enableVtpm :: Bool + , enableIntegrityMonitoring :: Bool + } + deriving (Show, Eq) + +instance FromJSON ShieldedInstanceConfig where + parseJSON = withObject "ShieldedInstanceConfig" $ \o -> + ShieldedInstanceConfig + <$> o .: "enableSecureBoot" + <*> o .: "enableVtpm" + <*> o .: "enableIntegrityMonitoring" + +instance ToJSON ShieldedInstanceConfig where + toJSON sic = + object + [ "enableSecureBoot" .= enableSecureBoot sic + , "enableVtpm" .= enableVtpm sic + , "enableIntegrityMonitoring" .= enableIntegrityMonitoring sic + ] + +data ShieldedInstanceIntegrityPolicy = ShieldedInstanceIntegrityPolicy + { policy :: Maybe UpdateAutoLearnPolicy + } + deriving (Show, Eq) + +instance FromJSON ShieldedInstanceIntegrityPolicy where + parseJSON = withObject "ShieldedInstanceIntegrityPolicy" $ \o -> + ShieldedInstanceIntegrityPolicy + <$> o .:? "policy" + +instance ToJSON ShieldedInstanceIntegrityPolicy where + toJSON sip = + object $ + catMaybes + [("policy" .=) <$> policy sip] + +data UpdateAutoLearnPolicy = UpdateAutoLearnPolicy {updateAutoLearnPolicy :: Bool} + deriving (Show, Eq) + +instance FromJSON UpdateAutoLearnPolicy where + parseJSON = withObject "UpdateAutoLearnPolicy" $ \o -> + UpdateAutoLearnPolicy + <$> o .: "updateAutoLearnPolicy" + +instance ToJSON UpdateAutoLearnPolicy where + toJSON uap = object ["updateAutoLearnPolicy" .= updateAutoLearnPolicy uap] + +data ConfidentialInstanceConfig = ConfidentialInstanceConfig + { enableConfidentialCompute :: Maybe Bool + , confidentialInstanceType :: Maybe Text + } + deriving (Show, Eq) + +instance FromJSON ConfidentialInstanceConfig where + parseJSON = withObject "ConfidentialInstanceConfig" $ \o -> + ConfidentialInstanceConfig + <$> o .:? "enableConfidentialCompute" + <*> o .:? "confidentialInstanceType" + +instance ToJSON ConfidentialInstanceConfig where + toJSON cic = + object $ + catMaybes + [ ("enableConfidentialCompute" .=) <$> enableConfidentialCompute cic + , ("confidentialInstanceType" .=) <$> confidentialInstanceType cic + ] + +data InstanceEncryptionKey = InstanceEncryptionKey + { sha256 :: Maybe Text + , kmsKeyServiceAccount :: Maybe Text + , rawKey :: Maybe Text + , rsaEncryptedKey :: Maybe Text + , kmsKeyName :: Maybe Text + } + deriving (Show, Eq) + +instance FromJSON InstanceEncryptionKey where + parseJSON = withObject "InstanceEncryptionKey" $ \o -> + InstanceEncryptionKey + <$> o .:? "sha256" + <*> o .:? "kmsKeyServiceAccount" + <*> o .:? "rawKey" + <*> o .:? "rsaEncryptedKey" + <*> o .:? "kmsKeyName" + +instance ToJSON InstanceEncryptionKey where + toJSON iek = + object $ + catMaybes + [ ("sha256" .=) <$> sha256 iek + , ("kmsKeyServiceAccount" .=) <$> kmsKeyServiceAccount iek + , ("rawKey" .=) <$> rawKey iek + , ("rsaEncryptedKey" .=) <$> rsaEncryptedKey iek + , ("kmsKeyName" .=) <$> kmsKeyName iek + ] + +data NetworkPerformanceConfig = NetworkPerformanceConfig + { totalEgressBandwidthTier :: Text + } + deriving (Show, Eq) + +instance FromJSON NetworkPerformanceConfig where + parseJSON = withObject "NetworkPerformanceConfig" $ \o -> + NetworkPerformanceConfig + <$> o .: "totalEgressBandwidthTier" + +instance ToJSON NetworkPerformanceConfig where + toJSON npc = object ["totalEgressBandwidthTier" .= totalEgressBandwidthTier npc] + +data ResourceStatus = ResourceStatus + { onHostMaintenance :: String + , automaticRestart :: Bool + , preemptible :: Bool + , nodeAffinities :: [NodeAffinity] + , minNodeCpus :: Int + , locationHint :: String + , availabilityDomain :: Int + , provisioningModel :: String + , instanceTerminationAction :: InstanceTerminationAction + } + deriving (Show, Eq) + +instance FromJSON ResourceStatus where + parseJSON = withObject "ResourceStatus" $ \o -> + ResourceStatus + <$> o .: "onHostMaintenance" + <*> o .: "automaticRestart" + <*> o .: "preemptible" + <*> o .: "nodeAffinities" + <*> o .: "minNodeCpus" + <*> o .: "locationHint" + <*> o .: "availabilityDomain" + <*> o .: "provisioningModel" + <*> o .: "instanceTerminationAction" + +instance ToJSON ResourceStatus where + toJSON ResourceStatus {..} = + object + [ "onHostMaintenance" .= onHostMaintenance + , "automaticRestart" .= automaticRestart + , "preemptible" .= preemptible + , "nodeAffinities" .= nodeAffinities + , "minNodeCpus" .= minNodeCpus + , "locationHint" .= locationHint + , "availabilityDomain" .= availabilityDomain + , "provisioningModel" .= provisioningModel + , "instanceTerminationAction" .= instanceTerminationAction + ] + +data InstanceList = InstanceList + { kind :: String + , id_ :: String + , items :: Maybe [InstanceMetadata] + } + deriving (Show, Eq) + +instance FromJSON InstanceList where + parseJSON = withObject "InstanceList" $ \o -> + InstanceList + <$> o .: "kind" + <*> o .: "id" + <*> o .: "items" + +instance ToJSON InstanceList where + toJSON InstanceList {..} = + object + [ "kind" .= kind + , "id" .= id_ + , "items" .= items + ] + +-- | Response structure for delete instance operation +data InstanceDeleteResp = InstanceDeleteResp + { kind :: Maybe String + -- ^ Type of resource (always "compute#operation") + , id_ :: Maybe String + -- ^ Unique identifier for the operation + , creationTimestamp :: Maybe String + -- ^ Creation timestamp in RFC3339 format + , name :: Maybe String + , zone :: Maybe String + , clientOperationId :: Maybe String + , operationType :: Maybe String + , targetLink :: Maybe String + , targetId :: Maybe String + , status :: Maybe String + , statusMessage :: Maybe String + , user :: Maybe String + , progress :: Maybe Int + , insertTime :: Maybe String + , startTime :: Maybe String + , endTime :: Maybe String + , error_ :: Maybe Error_ + , warnings :: Maybe [Warning] + , httpErrorStatusCode :: Maybe Int + , httpErrorMessage :: Maybe String + , selfLink :: Maybe String + , region :: Maybe String + , description :: Maybe String + , operationGroupId :: Maybe String + } + deriving (Show, Eq) + +instance FromJSON InstanceDeleteResp where + parseJSON = withObject "InstanceDeleteResp" $ \o -> + InstanceDeleteResp + <$> o .:? "kind" + <*> o .:? "id" + <*> o .:? "creationTimestamp" + <*> o .:? "name" + <*> o .:? "zone" + <*> o .:? "clientOperationId" + <*> o .:? "operationType" + <*> o .:? "targetLink" + <*> o .:? "targetId" + <*> o .:? "status" + <*> o .:? "statusMessage" + <*> o .:? "user" + <*> o .:? "progress" + <*> o .:? "insertTime" + <*> o .:? "startTime" + <*> o .:? "endTime" + <*> o .:? "error" + <*> o .:? "warnings" + <*> o .:? "httpErrorStatusCode" + <*> o .:? "httpErrorMessage" + <*> o .:? "selfLink" + <*> o .:? "region" + <*> o .:? "description" + <*> o .:? "operationGroupId" + +instance ToJSON InstanceDeleteResp where + toJSON InstanceDeleteResp {..} = + object $ + catMaybes + [ ("kind" .=) <$> kind + , ("id" .=) <$> id_ + , ("creationTimestamp" .=) <$> creationTimestamp + , ("name" .=) <$> name + , ("zone" .=) <$> zone + , ("clientOperationId" .=) <$> clientOperationId + , ("operationType" .=) <$> operationType + , ("targetLink" .=) <$> targetLink + , ("targetId" .=) <$> targetId + , ("status" .=) <$> status + , ("statusMessage" .=) <$> statusMessage + , ("user" .=) <$> user + , ("progress" .=) <$> progress + , ("insertTime" .=) <$> insertTime + , ("startTime" .=) <$> startTime + , ("endTime" .=) <$> endTime + , ("error" .=) <$> error_ + , ("warnings" .=) <$> warnings + , ("httpErrorStatusCode" .=) <$> httpErrorStatusCode + , ("httpErrorMessage" .=) <$> httpErrorMessage + , ("selfLink" .=) <$> selfLink + , ("region" .=) <$> region + , ("description" .=) <$> description + , ("operationGroupId" .=) <$> operationGroupId + ] + +data Error_ = Error_ + { errors :: Maybe [ErrorDetail] + } + deriving (Show, Eq) + +instance FromJSON Error_ where + parseJSON = withObject "Error" $ \o -> Error_ <$> o .:? "errors" + +instance ToJSON Error_ where + toJSON e = object $ catMaybes [("errors" .=) <$> errors e] + +data ErrorDetail = ErrorDetail + { code :: Maybe String + , location :: Maybe String + , message :: Maybe String + , errorDetails :: Maybe [DetailedError] + } + deriving (Show, Eq) + +instance FromJSON ErrorDetail where + parseJSON = withObject "ErrorDetail" $ \o -> + ErrorDetail + <$> o .:? "code" + <*> o .:? "location" + <*> o .:? "message" + <*> o .:? "errorDetails" + +instance ToJSON ErrorDetail where + toJSON ErrorDetail {..} = + object $ + catMaybes + [ ("code" .=) <$> code + , ("location" .=) <$> location + , ("message" .=) <$> message + , ("errorDetails" .=) <$> errorDetails + ] + +data DetailedError = DetailedError + { errorInfo :: Maybe ErrorInfo + , quotaInfo :: Maybe QuotaInfo + , help :: Maybe Help + , localizedMessage :: Maybe LocalizedMessage + } + deriving (Show, Eq) + +instance FromJSON DetailedError where + parseJSON = withObject "DetailedError" $ \o -> + DetailedError + <$> o .:? "errorInfo" + <*> o .:? "quotaInfo" + <*> o .:? "help" + <*> o .:? "localizedMessage" + +instance ToJSON DetailedError where + toJSON de = + object $ + catMaybes + [ ("errorInfo" .=) <$> errorInfo de + , ("quotaInfo" .=) <$> quotaInfo de + , ("help" .=) <$> help de + , ("localizedMessage" .=) <$> localizedMessage de + ] + +data ErrorInfo = ErrorInfo + { reason :: Maybe String + , domain :: Maybe String + } + deriving (Show, Eq) + +instance FromJSON ErrorInfo where + parseJSON = withObject "ErrorInfo" $ \o -> + ErrorInfo + <$> o .:? "reason" + <*> o .:? "domain" + +instance ToJSON ErrorInfo where + toJSON ei = + object $ + catMaybes + [ ("reason" .=) <$> reason ei + , ("domain" .=) <$> domain ei + ] + +data QuotaInfo = QuotaInfo + { metricName :: Maybe String + , limitName :: Maybe String + , limit :: Maybe Double + , futureLimit :: Maybe Double + , rolloutStatus :: Maybe String + } + deriving (Show, Eq) + +instance FromJSON QuotaInfo where + parseJSON = withObject "QuotaInfo" $ \o -> + QuotaInfo + <$> o .:? "metricName" + <*> o .:? "limitName" + <*> o .:? "limit" + <*> o .:? "futureLimit" + <*> o .:? "rolloutStatus" + +instance ToJSON QuotaInfo where + toJSON qi = + object $ + catMaybes + [ ("metricName" .=) <$> metricName qi + , ("limitName" .=) <$> limitName qi + , ("limit" .=) <$> limit qi + , ("futureLimit" .=) <$> futureLimit qi + , ("rolloutStatus" .=) <$> rolloutStatus qi + ] + +data Help = Help + { links :: Maybe [Link] + } + deriving (Show, Eq) + +instance FromJSON Help where + parseJSON = withObject "Help" $ \o -> Help <$> o .:? "links" + +instance ToJSON Help where + toJSON h = object $ catMaybes [("links" .=) <$> links h] + +data Link = Link + { description :: Maybe String + , url :: Maybe String + } + deriving (Show, Eq) + +instance FromJSON Link where + parseJSON = withObject "Link" $ \o -> + Link + <$> o .:? "description" + <*> o .:? "url" + +instance ToJSON Link where + toJSON Link {..} = + object $ + catMaybes + [ ("description" .=) <$> description + , ("url" .=) <$> url + ] + +data LocalizedMessage = LocalizedMessage + { locale :: Maybe String + , message :: Maybe String + } + deriving (Show, Eq) + +instance FromJSON LocalizedMessage where + parseJSON = withObject "LocalizedMessage" $ \o -> + LocalizedMessage + <$> o .:? "locale" + <*> o .:? "message" + +instance ToJSON LocalizedMessage where + toJSON LocalizedMessage {..} = + object $ + catMaybes + [ ("locale" .=) <$> locale + , ("message" .=) <$> message + ] + +data InstanceStartResponse = InstanceStartResponse + { kind :: Maybe Text + , id_ :: Maybe Text + , creationTimestamp :: Maybe Text + , name :: Maybe Text + , zone :: Maybe Text + , clientOperationId :: Maybe Text + , operationType :: Maybe Text + , targetLink :: Maybe Text + , targetId :: Maybe Text + , status :: Maybe Text + , statusMessage :: Maybe Text + , user :: Maybe Text + } + deriving (Show, Eq) + +instance FromJSON InstanceStartResponse where + parseJSON = withObject "InstanceStartResponse" $ \o -> + InstanceStartResponse + <$> o .:? "kind" + <*> o .:? "id" + <*> o .:? "creationTimestamp" + <*> o .:? "name" + <*> o .:? "zone" + <*> o .:? "clientOperationId" + <*> o .:? "operationType" + <*> o .:? "targetLink" + <*> o .:? "targetId" + <*> o .:? "status" + <*> o .:? "statusMessage" + <*> o .:? "user" + +instance ToJSON InstanceStartResponse where + toJSON InstanceStartResponse {..} = + object $ + catMaybes + [ ("kind" .=) <$> kind + , ("id" .=) <$> id_ + , ("creationTimestamp" .=) <$> creationTimestamp + , ("name" .=) <$> name + , ("zone" .=) <$> zone + , ("clientOperationId" .=) <$> clientOperationId + , ("operationType" .=) <$> operationType + , ("targetLink" .=) <$> targetLink + , ("targetId" .=) <$> targetId + , ("status" .=) <$> status + , ("statusMessage" .=) <$> statusMessage + , ("user" .=) <$> user + ] + +data InsertInstanceOps = InsertInstanceOps + { name :: String + , machineType :: String + , disks :: Maybe [Disk] + , networkInterfaces :: Maybe [NetworkInterface] + } + deriving (Show, Eq) + +data NetworkInterface = NetworkInterface + { network :: String + } + deriving (Show, Eq) + +data InsertInstanceQuery = InsertInstanceQuery + { requestId :: Maybe String + , sourceInstanceTemplate :: Maybe String + } + deriving (Show, Eq) + +instance ToJSON InsertInstanceOps where + toJSON InsertInstanceOps {..} = + object + [ "name" .= name + , "machineType" .= machineType + , "disks" .= disks + , "networkInterfaces" .= networkInterfaces + ] + +instance ToJSON NetworkInterface where + toJSON ni = + object + [ "network" .= network ni + ] + +-- | Represents a disk attached to a Compute Engine instance +data Disk = Disk + { autoDelete :: Bool + -- ^ Whether disk should be auto-deleted when instance is deleted + , boot :: Bool + -- ^ Whether this is a boot disk + , deviceName :: String + -- ^ Unique device name visible to the guest OS + , initializeParams :: Maybe InitializeParams + -- ^ Initialization parameters for the disk + , mode :: String + -- ^ Access mode (READ_WRITE or READ_ONLY) + , type_ :: String + -- ^ 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) + , diskType :: String + -- ^ Full URL of disk type resource + , labels :: Map.Map String String + -- ^ Labels to apply to the disk + , sourceImage :: String + -- ^ 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 + ] + +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_ + +instance ToJSON InitializeParams where + 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" + + +-- ** 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 +listInstances :: + String -> String -> Maybe ListInstancesQuery -> IO (Either String InstanceList) +listInstances projectId zone_ mbQuery = do + let queryParams = maybe [] toQueryList mbQuery + doRequestJSON + RequestOptions + { reqMethod = GET + , reqUrl = googleComputeUrl + , mbQueryParams = Just queryParams + , mbReqBody = Nothing + , mbReqHeaders = Nothing + , mbReqPath = Just ("/projects/" <> projectId <> "/zones/" <> zone_ <> "/instances") + } + where + toQueryList :: ListInstancesQuery -> [(BS.ByteString, Maybe BS.ByteString)] + toQueryList q = + catMaybes + [ ("filter",) . Just . BS8.pack <$> filter_ q + , ("maxResults",) . Just . BS8.pack . show <$> maxResults q + , ("orderBy",) . Just . BS8.pack <$> orderBy q + , ("pageToken",) . Just . BS8.pack <$> pageToken q + , ("returnPartialSuccess",) . Just . BS8.pack . show <$> returnPartialSuccess q + ] + +deleteInstance :: + String -> String -> String -> Maybe RequestIdQuery -> IO (Either String InstanceDeleteResp) +deleteInstance project zone_ name_ mbQuery = do + let queryParams = maybe [] toQueryList mbQuery + doRequestJSON + RequestOptions + { reqMethod = DELETE + , reqUrl = googleComputeUrl + , mbQueryParams = Just queryParams + , mbReqBody = Nothing + , mbReqHeaders = Nothing + , mbReqPath = Just ("/projects/" <> project <> "/zones/" <> zone_ <> "/instances/" <> name_) + } + where + toQueryList :: RequestIdQuery -> [(BS.ByteString, Maybe BS.ByteString)] + toQueryList RequestIdQuery {..} = + catMaybes + [("requestId",) . Just . BS8.pack <$> requestId] + +startInstance :: + String -> + String -> + String -> + Maybe RequestIdQuery -> + IO (Either String InstanceStartResponse) +startInstance projectId zone_ instanceName mbQuery = do + let queryParams = maybe [] toQueryList mbQuery + doRequestJSON + RequestOptions + { reqMethod = POST + , reqUrl = googleComputeUrl + , mbQueryParams = Just queryParams + , mbReqBody = Nothing + , mbReqHeaders = Nothing + , mbReqPath = + Just ("/projects/" <> projectId <> "/zones/" <> zone_ <> "/instances/" <> instanceName <> "/start") + } + where + toQueryList :: RequestIdQuery -> [(BS.ByteString, Maybe BS.ByteString)] + toQueryList RequestIdQuery {..} = + catMaybes + [("requestId",) . Just . BS8.pack <$> requestId] + +stopInstance :: + String -> + String -> + String -> + Maybe RequestIdQuery -> + IO (Either String InstanceStartResponse) +stopInstance projectId zone_ instanceName mbQuery = do + let queryParams = maybe [] toQueryList mbQuery + doRequestJSON + RequestOptions + { reqMethod = POST + , reqUrl = googleComputeUrl + , mbQueryParams = Just queryParams + , mbReqBody = Nothing + , mbReqHeaders = Nothing + , mbReqPath = + Just ("/projects/" <> projectId <> "/zones/" <> zone_ <> "/instances/" <> instanceName <> "/stop") + } + where + toQueryList :: RequestIdQuery -> [(BS.ByteString, Maybe BS.ByteString)] + toQueryList RequestIdQuery {..} = + catMaybes + [("requestId",) . Just . BS8.pack <$> requestId] + +insertInstance :: + String -> + String -> + InsertInstanceOps -> + Maybe InsertInstanceQuery -> + IO (Either String InstanceStartResponse) +insertInstance projectId zone_ insertOps mbQuery = do + let queryParams = maybe [] toQueryList mbQuery + doRequestJSON + RequestOptions + { reqMethod = POST + , reqUrl = googleComputeUrl + , mbQueryParams = Just queryParams + , mbReqBody = Just $ encode insertOps + , mbReqHeaders = Nothing + , mbReqPath = Just $ "/projects/" <> projectId <> "/zones/" <> zone_ <> "/instances" + } + where + toQueryList :: InsertInstanceQuery -> [(BS.ByteString, Maybe BS.ByteString)] + toQueryList InsertInstanceQuery {..} = + catMaybes + [ ("requestId",) . Just . BS8.pack <$> requestId + , ("sourceInstanceTemplate",) . Just . BS8.pack <$> sourceInstanceTemplate + ] + +-- ** 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 = + ListInstancesQuery + { filter_ = Nothing + , maxResults = Nothing + , orderBy = Nothing + , pageToken = Nothing + , returnPartialSuccess = Nothing + } + +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 +defaultInsertInstanceOps :: String -> String -> String -> String -> InsertInstanceOps +defaultInsertInstanceOps projectId zone instanceName machineType = + InsertInstanceOps + { name = instanceName + , 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" + } diff --git a/src/Google/Cloud/Compute/Network.hs b/src/Google/Cloud/Compute/Network.hs new file mode 100644 --- /dev/null +++ b/src/Google/Cloud/Compute/Network.hs @@ -0,0 +1,241 @@ +{-| +Module : Google.Cloud.Compute.Network +Copyright : (c) 2025 Tushar +License : MIT +Maintainer : +Stability : experimental + +This module provides types and functions for interacting with Google Cloud Platform (GCP) +Compute Engine Network. It supports common operations as listing networks, +along with detailed configuration network properties. + +All functions communicate with the GCP Compute Engine API v1 and return either an error +message ('Left') or a parsed response object ('Right'). + +For more information on the underlying API, see: + +-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Google.Cloud.Compute.Network + ( -- * Network Operations + listNetworks + -- * Data Types + , NetworkList(..) + , NetworkMeta(..) + , NetworkPeering(..) + , ListNetworksQuery(..) + -- * Defaults + , defaultListNetworksQuery + ) where + +import Data.Aeson +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") + , id_ :: Text + -- ^ Unique identifier for the resource + , items :: [NetworkMeta] + -- ^ List of network resources + , nextPageToken :: Maybe Text + -- ^ Pagination token for next page + , selfLink :: Text + -- ^ 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" + +instance ToJSON NetworkList where + 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") + , id_ :: Text + -- ^ Unique identifier for the network + , creationTimestamp :: Text + -- ^ Creation timestamp in RFC3339 format + , name :: Text + -- ^ Name of the network + , description :: Maybe Text + -- ^ User-provided description + , autoCreateSubnetworks :: Maybe Bool + -- ^ Whether to auto-create subnetworks + , subnetworks :: [Text] + -- ^ List of subnetworks URLs in this network + , iPv4Range :: Maybe Text + -- ^ IPv4 range for legacy networks + , iPv6Range :: Maybe Text + -- ^ IPv6 range for legacy networks + , gatewayIPv4 :: Maybe Text + -- ^ Gateway IPv4 address + , mtu :: Maybe Int + -- ^ Maximum transmission unit + , peerings :: Maybe [NetworkPeering] + -- ^ List of network peerings + , selfLink :: Text + -- ^ Server-defined URL for the resource + , enableUlaInternalIpv6 :: Maybe Bool + -- ^ ULA internal IPv6 support + , internalIpv6Range :: Maybe Text + -- ^ Internal IPv6 range + , networkFirewallPolicyEnforcementOrder :: Maybe Text + -- ^ 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" + +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 + ] + +-- | Network peering configuration +data NetworkPeering = NetworkPeering + { name :: Text + -- ^ Name of the peering + , network :: Text + -- ^ URL of peer network + , state :: Text + -- ^ Peering state (ACTIVE/INACTIVE) + , stateDetails :: Maybe Text + -- ^ Detailed state information + , exchangeSubnetRoutes :: Maybe Bool + -- ^ Subnet route exchange + , exportCustomRoutes :: Maybe Bool + -- ^ Custom route export + , importCustomRoutes :: Maybe Bool + -- ^ 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" + +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 + ] + +-- | Query parameters for listNetworks operation +data ListNetworksQuery = ListNetworksQuery + { filter_ :: Maybe String + -- ^ Filter expression + , maxResults :: Maybe Int + -- ^ Maximum results per page + , orderBy :: Maybe String + -- ^ Sort order + , pageToken :: Maybe String + -- ^ Page token + , returnPartialSuccess :: Maybe Bool + -- ^ Partial success return + } deriving (Show) + +-- | Default list networks query parameters +defaultListNetworksQuery :: ListNetworksQuery +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) +listNetworks project mbQuery = do + let queryParams = maybe [] toQueryList mbQuery + doRequestJSON + RequestOptions + { reqMethod = GET + , reqUrl = googleComputeUrl + , mbQueryParams = Just queryParams + , mbReqBody = Nothing + , mbReqHeaders = Nothing + , mbReqPath = Just $ toPath + [ "projects" + , project + , "global" + , "networks" + ] + } + where + toQueryList :: ListNetworksQuery -> [(BS8.ByteString, Maybe BS8.ByteString)] + toQueryList ListNetworksQuery{..} = + catMaybes + [ ("filter",) . Just . BS8.pack <$> filter_ + , ("maxResults",) . Just . BS8.pack . show <$> maxResults + , ("orderBy",) . Just . BS8.pack <$> orderBy + , ("pageToken",) . Just . BS8.pack <$> pageToken + , ("returnPartialSuccess",) . Just . BS8.pack . show <$> returnPartialSuccess + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,171 @@ +{-# 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 + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Google.Cloud.Compute.Disk" $ do + context "DiskResponse JSON serialization" $ do + it "successfully parses valid JSON to DiskResponse" $ do + let json = "{\"kind\":\"compute#diskList\",\"items\":[],\"nextPageToken\":\"token\",\"selfLink\":\"link\"}" + let result = decode (BSL.pack json) :: Maybe DiskResponse + result `shouldSatisfy` isJust + + it "successfully converts DiskResponse to JSON" $ do + let diskResponse = DiskResponse (Just "compute#diskList") Nothing (Just []) (Just "token") (Just "link") Nothing + let json = encode diskResponse + decode json `shouldBe` Just diskResponse + + 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 + + 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 + + context "Warning JSON serialization" $ do + it "serializes and deserializes Warning correctly" $ do + let warning = Disk.Warning "NO_RESULTS" "No results found" (Just [WarningData "scope" "global"]) + let json = encode warning + decode json `shouldBe` Just warning + + context "Operation JSON serialization" $ do + it "successfully parses valid JSON to Operation" $ do + let json = "{\"id\":\"123\",\"name\":\"operation-1\",\"status\":\"DONE\"}" + let result = decode (BSL.pack json) :: Maybe Operation + 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 json = encode operation + decode json `shouldBe` Just operation + + describe "JSON Serialization" $ do + it "correctly serializes and deserializes RunDuration" $ do + let runDuration = TerminationTime "2023-10-15T10:00:00Z" + decode (encode runDuration) `shouldBe` Just runDuration + + it "correctly serializes and deserializes OnInstanceTerminationAction" $ do + let action = DiscardLocalSsd True + 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") + } + decode (encode scheduling) `shouldBe` Just scheduling + + describe "Default Query Constructors" $ do + it "creates a default ListInstancesQuery with all fields set to Nothing" $ do + let query = defaultListInstancesQuery + filter_ query `shouldBe` Nothing + maxResults query `shouldBe` Nothing + orderBy query `shouldBe` Nothing + pageToken query `shouldBe` Nothing + returnPartialSuccess query `shouldBe` Nothing + + 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" + machineType ops `shouldBe` "zones/us-central1-a/machineTypes/f1-micro" + isJust (disks ops) `shouldBe` True + isJust (networkInterfaces ops) `shouldBe` True + + it "creates a default RequestIdQuery with given requestId" $ do + 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 + + 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 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 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 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