hetzner 0.1.0.0 → 0.1.1.0

raw patch · 4 files changed

+175/−9 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changelog.md +6/−0
• hetzner.cabal +3/−2
• readme.md +14/−0
• src/Hetzner/Cloud.hs +152/−7

@@ -0,0 +1,6 @@+## 0.1.1.0+* Added support for volumes.+* Fixed parsing of HTTP 204 responses.++## 0.1.0.0+* Initial release.

@@ -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

@@ -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.

@@ -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