diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,6 @@ +## 0.1.1.0 +* Added support for volumes. +* Fixed parsing of HTTP 204 responses. + +## 0.1.0.0 +* Initial release. diff --git a/hetzner.cabal b/hetzner.cabal --- a/hetzner.cabal +++ b/hetzner.cabal @@ -1,8 +1,8 @@ name: hetzner category: Cloud synopsis: Hetzner Cloud client library. -description: Hetzner Cloud client library. Check the readme for more details. -version: 0.1.0.0 +description: Hetzner Cloud client library. Check the readme and documentation for more details. +version: 0.1.1.0 cabal-version: >= 1.10 build-type: Simple author: Daniel Casanueva (daniel.casanueva `at` proton.me) @@ -10,6 +10,7 @@ bug-reports: https://github.com/Daniel-Diaz/hetzner/issues license: MIT license-file: license +extra-source-files: readme.md, changelog.md library default-language: Haskell2010 diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,14 @@ +# Hetzner Cloud Haskell Library + +[![Hackage](https://img.shields.io/hackage/v/hetzner?style=for-the-badge)](https://hackage.haskell.org/package/hetzner) + +## Description + +Client interface for the [Hetzner Cloud API](https://docs.hetzner.cloud/) written in the Haskell programming language. + +## Status + +This library is still in development, so expect missing funcionality. +If there's anything you would like to see added, feel free to +[open an issue](https://github.com/Daniel-Diaz/hetzner/issues/new). +Some breaking changes might also be introduced as the library matures. diff --git a/src/Hetzner/Cloud.hs b/src/Hetzner/Cloud.hs --- a/src/Hetzner/Cloud.hs +++ b/src/Hetzner/Cloud.hs @@ -108,6 +108,17 @@ , updateSSHKey -- ** Volumes , VolumeID (..) + , VolumeFormat (..) + , VolumeStatus (..) + , Volume (..) + , AttachToServer (..) + , NewVolume (..) + , CreatedVolume (..) + , getVolumes + , getVolume + , createVolume + , deleteVolume + , updateVolume -- * Exceptions , Error (..) , CloudException (..) @@ -170,6 +181,7 @@ , FromJSONKey, ToJSONKey ) import Data.Aeson qualified as JSON +import Data.Aeson.Types qualified as JSON import Data.Aeson.Key qualified as JSONKey import Data.Aeson.Encoding qualified as JSONEncoding -- yaml @@ -471,10 +483,12 @@ $ HTTP.defaultRequest resp <- HTTP.httpBS req let body = HTTP.getResponseBody resp - case div (HTTP.getResponseStatusCode resp) 100 of - 2 -> case JSON.eitherDecodeStrict body of - Left err -> throwIO $ JSONError resp err - Right x -> pure x + case divMod (HTTP.getResponseStatusCode resp) 100 of + (2,m) -> + let body' = if m == 4 then "{}" else body + in case JSON.eitherDecodeStrict body' of + Left err -> throwIO $ JSONError resp err + Right x -> pure x _ -> case JSON.eitherDecodeStrict body of Left err -> throwIO $ JSONError resp err Right x -> throwIO $ CloudError $ withoutKey @"error" x @@ -514,7 +528,7 @@ fmap f (WithKey x) = WithKey (f x) instance Foldable (WithKey key) where - foldMap f (WithKey x) = f x + foldMap f = f . withoutKey instance (KnownSymbol key, FromJSON a) => FromJSON (WithKey key a) where parseJSON = @@ -600,6 +614,8 @@ data ResourceID = -- | Server ID. ResourceServerID ServerID + -- | Volume ID. + | ResourceVolumeID VolumeID deriving Show instance FromJSON ResourceID where @@ -607,6 +623,7 @@ t <- o .: "type" case t :: Text of "server" -> ResourceServerID <$> o .: "id" + "volume" -> ResourceVolumeID <$> o .: "id" _ -> fail $ "Unknown resource type: " ++ Text.unpack t -- | Action. @@ -1213,8 +1230,8 @@ -> SSHKeyID -> Text -- ^ New name for the key. -> [Label] -- ^ New labels for the key. - -> IO () -updateSSHKey token (SSHKeyID i) name labels = + -> IO SSHKey -- ^ Updated SSH key. +updateSSHKey token (SSHKeyID i) name labels = withoutKey @"ssh_key" <$> let body = JSON.object [ "labels" .= toLabelMap labels , "name" .= name @@ -1227,3 +1244,131 @@ -- | Volume identifier. newtype VolumeID = VolumeID Int deriving (Eq, Ord, Show, FromJSON, ToJSON) + +-- | Volume format. +data VolumeFormat = EXT4 | XFS deriving (Eq, Show) + +instance FromJSON VolumeFormat where + parseJSON = JSON.withText "VolumeFormat" $ \t -> case t of + "ext4" -> pure EXT4 + "xfs" -> pure XFS + _ -> fail $ "Invalid volume format: " ++ Text.unpack t + +instance ToJSON VolumeFormat where + toJSON EXT4 = JSON.String "ext4" + toJSON XFS = JSON.String "xfs" + +-- | Volume status. +data VolumeStatus = VolumeCreating | VolumeAvailable deriving (Eq, Show) + +instance FromJSON VolumeStatus where + parseJSON = JSON.withText "VolumeStatus" $ \t -> case t of + "creating" -> pure VolumeCreating + "available" -> pure VolumeAvailable + _ -> fail $ "Invalid volume status: " ++ Text.unpack t + +-- | A volume that can be attached to a server. +data Volume = Volume + { volumeCreated :: ZonedTime + -- | Volume format. It returns 'Nothing' if the volume hasn't been formatted yet. + , volumeFormat :: Maybe VolumeFormat + , volumeID :: VolumeID + , volumeLabels :: LabelMap + -- | Device path on the file system for the volume. + , volumePath :: FilePath + , volumeLocation :: Location + , volumeName :: Text + -- | ID of the server the volume is attached to, if any. + , volumeServer :: Maybe ServerID + -- | Size of the volume in GB. + , volumeSize :: Int + , volumeStatus :: VolumeStatus + } deriving Show + +instance FromJSON Volume where + parseJSON = JSON.withObject "Volume" $ \o -> Volume + <$> o .: "created" + <*> o .: "format" + <*> o .: "id" + <*> o .: "labels" + <*> o .: "linux_device" + <*> o .: "location" + <*> o .: "name" + <*> o .: "server" + <*> o .: "size" + <*> o .: "status" + +-- | Attach a volume to a server. The boolean parameter +-- indicates whether the volume will be auto-mounted. +data AttachToServer = AttachToServer ServerID Bool + +-- | Volume creation configuration to be used with 'createVolume'. +data NewVolume = NewVolume + { -- | If specified, volume will be formatted according + -- to the given format. + newVolumeFormat :: Maybe VolumeFormat + , newVolumeLabels :: [Label] + -- | You can either create a volume in a location or + -- directly attach the volume to a server. + , newVolumeLocation :: Either LocationID AttachToServer + , newVolumeName :: Text + -- | Size of the volume in GB. It must be at least 10. + , newVolumeSize :: Int + } + +instance ToJSON NewVolume where + toJSON nvolume = JSON.object $ mconcat + [ maybe mempty (pure . ("format".=)) $ newVolumeFormat nvolume + , pure $ "labels" .= toLabelMap (newVolumeLabels nvolume) + , let f :: AttachToServer -> [JSON.Pair] + f (AttachToServer i b) = [ "server" .= i, "automount" .= b ] + in either (pure . ("location".=)) f $ newVolumeLocation nvolume + , pure $ "name" .= newVolumeName nvolume + , pure $ "size" .= newVolumeSize nvolume + ] + +-- | A volume created with 'createVolume'. +data CreatedVolume = CreatedVolume + { createdVolumeAction :: Action + , createdVolumeNextActions :: [Action] + , createdVolume :: Volume + } deriving Show + +instance FromJSON CreatedVolume where + parseJSON = JSON.withObject "CreatedVolume" $ \o -> CreatedVolume + <$> o .: "action" + <*> o .: "next_actions" + <*> o .: "volume" + +-- | Get volumes. +getVolumes :: Token -> Maybe Int -> IO (WithMeta "volumes" [Volume]) +getVolumes = cloudQuery "GET" "/volumes" noBody + +-- | Get a single volume. +getVolume :: Token -> VolumeID -> IO Volume +getVolume token (VolumeID i) = withoutKey @"volume" <$> + cloudQuery "GET" ("/volumes/" <> fromString (show i)) noBody token Nothing + +-- | Create a new volume. +createVolume :: Token -> NewVolume -> IO CreatedVolume +createVolume token nvolume = + cloudQuery "POST" "/volumes" (Just nvolume) token Nothing + +-- | Delete a volume. +deleteVolume :: Token -> VolumeID -> IO () +deleteVolume token (VolumeID i) = + cloudQuery "DELETE" ("/volumes/" <> fromString (show i)) noBody token Nothing + +-- | Update name and labels of a volume. +updateVolume + :: Token + -> VolumeID + -> Text -- ^ New name for the volume. + -> [Label] -- ^ New labels for the volume. + -> IO Volume -- ^ Updated volume. +updateVolume token (VolumeID i) name labels = withoutKey @"volume" <$> + let body = JSON.object + [ "labels" .= toLabelMap labels + , "name" .= name + ] + in cloudQuery "PUT" ("/volumes/" <> fromString (show i)) (Just body) token Nothing