hetzner 0.4.0.1 → 0.5.0.0

raw patch · 6 files changed

+494/−39 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• apps/Docs.hs +3/−0
• changelog.md +7/−0
• hetzner.cabal +1/−1
• readme.md +1/−1
• src/Hetzner/Cloud.hs +472/−33
• src/Hetzner/Cloud/Fingerprint.hs +10/−4

@@ -47,6 +47,7 @@           H.th "Cores"           H.th "Memory"           H.th "Disk"+          H.th "Included Traffic (TB)"           H.th "CPU Type"           H.th "Max Monthly Price"         forM_ serverTypes $ \serverType -> H.tr $ do@@ -56,6 +57,8 @@           H.td $ toHtml $ Hetzner.serverCores serverType           H.td $ toHtml $ show (Hetzner.serverMemory serverType) ++ " GB"           H.td $ toHtml $ show (Hetzner.serverDisk serverType) ++ " GB"+          let terabyte = 1024 ^ (4 :: Int)+          H.td $ toHtml $ show (Hetzner.serverIncludedTraffic serverType `div` terabyte) ++ " TB"           H.td $ toHtml $ case Hetzner.serverCPUType serverType of             Hetzner.SharedCPU -> "Shared" :: String             Hetzner.DedicatedCPU -> "Dedicated"

@@ -1,3 +1,10 @@+## 0.5.0.0+* Do not export internal fingerprint parser.+* Wrap `Fingerprint` with a newtype to provide custom+  `FromJSON` instance.+* Firewall support.+* Fix label parsing and rendering.+ ## 0.4.0.1 * Update links in documentation. 

@@ -2,7 +2,7 @@ category: Cloud synopsis: Hetzner Cloud and DNS library. description: Hetzner Cloud and DNS library. Check the readme and documentation for more details.-version: 0.4.0.1+version: 0.5.0.0 cabal-version: 1.18 build-type: Simple author: Daniel Casanueva (daniel.casanueva `at` proton.me)

@@ -10,7 +10,7 @@  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).+[open an issue](https://gitlab.com/daniel-casanueva/haskell/hetzner/-/issues/new). Some breaking changes might also be introduced as the library matures.  ## Documentation

@@ -62,6 +62,24 @@   , getDatacenter     -- ** Firewalls   , FirewallID (..)+  , TrafficDirection (..)+  , PortRange (..)+  , FirewallRuleProtocol (..)+  , FirewallRule (..)+  , anyIPv4+  , anyIPv6+  , Firewall (..)+  , NewFirewall (..)+  , defaultNewFirewall+  , CreatedFirewall (..)+  , getFirewalls+  , getFirewall+  , createFirewall+  , deleteFirewall+  , updateFirewall+    -- *** Firewall actions+  , applyFirewall+  , removeFirewall     -- ** Floating IPs   , FloatingIPID (..)     -- ** Images@@ -157,6 +175,7 @@   , toLabelMap   , fromLabelMap   , LabelSelector (..)+  , LabelSelectorAll (..)     -- * Other types     -- ** Regions   , Region (..)@@ -181,7 +200,7 @@   , Pagination (..)     ) where -import Hetzner.Cloud.Fingerprint (Fingerprint)+import Hetzner.Cloud.Fingerprint (Fingerprint, fingerprint) -- base import Control.Exception (Exception, throwIO) import Control.Concurrent (threadDelay)@@ -189,16 +208,22 @@ import Data.Proxy import Data.String (IsString, fromString) import Data.Void+import Data.Either (partitionEithers) #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) #endif+import Control.Applicative ((<|>)) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Foldable (forM_)+import Data.Traversable (forM) import Data.Maybe (isNothing, fromMaybe) import System.Environment qualified as System+import Data.List.NonEmpty (NonEmpty ((:|))) -- ip import Net.IPv4 (IPv4, IPv4Range)+import Net.IPv4 qualified as IPv4 import Net.IPv6 (IPv6, IPv6Range)+import Net.IPv6 qualified as IPv6 -- bytestring import Data.ByteString (ByteString) -- text@@ -224,6 +249,7 @@ import Country (Country) -- megaparsec import Text.Megaparsec qualified as Parser+import Text.Megaparsec.Char qualified as Parser import Text.Megaparsec.Char.Lexer qualified as Parser -- containers import Data.Map (Map)@@ -272,16 +298,36 @@  type Parser = Parser.Parsec Void Text +labelKeyPrefixParser :: Parser Text+labelKeyPrefixParser = do+  xs <- Parser.sepBy1 (Text.pack <$> Parser.some Parser.alphaNumChar) (Parser.single '.')+  _ <- Parser.single '/'+  pure $ Text.intercalate "." xs++labelKeyNameParser :: Parser Text+labelKeyNameParser = do+  x <- Parser.alphaNumChar+  let loop :: Bool -> Parser [Char]+      loop afterSymbol = Parser.choice+        [ (:) <$> Parser.alphaNumChar <*> loop False+        , (:) <$> Parser.single '-' <*> loop True+        , (:) <$> Parser.single '_' <*> loop True+        , (:) <$> Parser.single '.' <*> loop True+        , if afterSymbol+             then fail "Label key name must end in alphanumeric character."+             else pure []+          ]+  xs <- loop False+  pure $ Text.pack $ x : xs+ labelKeyParser :: Parser LabelKey labelKeyParser = do-  prefix <- fmap Text.pack $ Parser.some $ Parser.anySingleBut '/'-  atEnd <- Parser.atEnd-  if atEnd-     then pure $ LabelKey Nothing prefix-     else LabelKey (Just prefix) <$> (Parser.single '/' *> Parser.takeRest)+  prefix <- Parser.optional $ Parser.try labelKeyPrefixParser+  name <- labelKeyNameParser+  pure $ LabelKey prefix name -renderKeyParser :: LabelKey -> Text-renderKeyParser k = case labelKeyPrefix k of+labelKeyRender :: LabelKey -> Text+labelKeyRender k = case labelKeyPrefix k of   Just prefix -> Text.concat [ prefix, "/", labelKeyName k ]   _ -> labelKeyName k @@ -291,18 +337,18 @@       Parser.runParser labelKeyParser "JSON" t  instance ToJSON LabelKey where-   toJSON = JSON.String . renderKeyParser+   toJSON = JSON.String . labelKeyRender  instance FromJSONKey LabelKey where   fromJSONKey = JSON.FromJSONKeyTextParser $ \t ->     either (fail . Parser.errorBundlePretty) pure $-      Parser.runParser labelKeyParser "JSON key" t+      Parser.runParser (labelKeyParser <* Parser.eof) "JSON key" t  instance ToJSONKey LabelKey where   toJSONKey =     JSON.ToJSONKeyText-      (JSONKey.fromText . renderKeyParser)-      (JSONEncoding.text . renderKeyParser)+      (JSONKey.fromText . labelKeyRender)+      (JSONEncoding.text . labelKeyRender)  -- | Labels are key-value pairs that can be attached to all resources. data Label = Label@@ -310,6 +356,23 @@   , labelValue :: Text     } deriving (Eq, Show) +labelValueParser :: Parser Text+labelValueParser = do+  let loop :: Bool -> Parser [Char]+      loop afterSymbol = Parser.choice+        [ (:) <$> Parser.alphaNumChar <*> loop False+        , (:) <$> Parser.single '-' <*> loop True+        , (:) <$> Parser.single '_' <*> loop True+        , (:) <$> Parser.single '.' <*> loop True+        , if afterSymbol+             then fail "Label value must end in alphanumeric character."+             else pure []+          ]+  mx <- Parser.optional Parser.alphaNumChar+  case mx of+    Just x -> Text.pack . (:) x <$> loop False+    _ -> pure mempty+ -- | A label map maps label keys to values. type LabelMap = Map LabelKey Text @@ -321,7 +384,7 @@ fromLabelMap :: LabelMap -> [Label] fromLabelMap = Map.foldrWithKey (\k v xs -> Label k v : xs) [] --- | Label selectors can be used to filter results.+-- | Label selectors can be used to filter resources. data LabelSelector =     -- | Select when label is equal.     LabelEqual Label@@ -335,26 +398,63 @@   | KeyValueIn LabelKey [Text]     -- | Select when label has none of the values.   | KeyValueNotIn LabelKey [Text]-    -- | Select only when all selectors succeed.-  | LabelAll [LabelSelector]+    deriving Show --- | Semigroup under /\"and\"/ operation.-instance Semigroup LabelSelector where-  LabelAll xs <> LabelAll ys = LabelAll (xs ++ ys)-  LabelAll xs <> s =-    case xs of-      [] -> s-      _  -> LabelAll (xs ++ [s])-  s <> LabelAll xs =-    case xs of-      [] -> s-      _  -> LabelAll (s : xs)-  s <> s' = LabelAll [s,s']+-- | Label selector parser.+labelSelectorParser :: Parser LabelSelector+labelSelectorParser = Parser.choice+  [ Parser.single '!' *> (KeyNotPresent <$> labelKeyParser)+  , do k <- labelKeyParser+       Parser.choice+         [ do _ <- Parser.single '='+              _ <- Parser.optional $ Parser.single '='+              v <- labelValueParser+              pure $ LabelEqual $ Label k v+         , do _ <- Parser.single '!'+              _ <- Parser.single '='+              v <- labelValueParser+              pure $ LabelNotEqual $ Label k v+         , do _ <- Parser.single ' '+              Parser.choice+                [ do _ <- Parser.chunk "in ("+                     vs <- Parser.sepBy1 labelValueParser $ Parser.single ','+                     _ <- Parser.single ')'+                     pure $ KeyValueIn k vs+                , do _ <- Parser.chunk "notin ("+                     vs <- Parser.sepBy1 labelValueParser $ Parser.single ','+                     _ <- Parser.single ')'+                     pure $ KeyValueNotIn k vs+                  ]+         , pure $ KeyPresent k+           ]+    ] --- | Neutral element is a selector that always succeeds.-instance Monoid LabelSelector where-  mempty = LabelAll []+renderLabelSelector :: LabelSelector -> Text+renderLabelSelector (LabelEqual l) =+  labelKeyRender (labelKey l) <> "==" <> labelValue l+renderLabelSelector (LabelNotEqual l) =+  labelKeyRender (labelKey l) <> "!=" <> labelValue l+renderLabelSelector (KeyPresent k) = labelKeyRender k+renderLabelSelector (KeyNotPresent k) = "!" <> labelKeyRender k+renderLabelSelector (KeyValueIn k vs) =+  labelKeyRender k <> " in (" <> Text.intercalate "," vs <> ")"+renderLabelSelector (KeyValueNotIn k vs) =+  labelKeyRender k <> " notin (" <> Text.intercalate "," vs <> ")" +-- | Combine a list of label selectors, giving you a selector that+--   selects labels that match /all/ selectors in the list.+newtype LabelSelectorAll = LabelSelectorAll [LabelSelector] deriving Show++instance FromJSON LabelSelectorAll where+  parseJSON = JSON.withText "LabelSelector" $ \t ->+    either (fail . Parser.errorBundlePretty) pure $+      let parser = fmap LabelSelectorAll $ Parser.sepBy1 labelSelectorParser $ Parser.single ','+      in  Parser.runParser (parser <* Parser.eof) "JSON" t++instance ToJSON LabelSelectorAll where+  toJSON (LabelSelectorAll xs) = JSON.String $+    Text.intercalate "," $ fmap renderLabelSelector xs+ -- | Pagination information. data Pagination = Pagination   { currentPage :: Int@@ -623,6 +723,27 @@   parseJSON = JSON.withObject "ResponseMeta" $ \o ->     ResponseMeta <$> o .: "pagination" +-- | Equivalent to 'Either', but with a different json serialization.+data EitherParser a b = LeftParser a | RightParser b++-- | Equivalent of 'either' for 'EitherParser'.+eitherParser :: (a -> c) -> (b -> c) -> EitherParser a b -> c+eitherParser f _ (LeftParser a) = f a+eitherParser _ g (RightParser b) = g b++instance (FromJSON a, FromJSON b) => FromJSON (EitherParser a b) where+  parseJSON v = fmap LeftParser (JSON.parseJSON v) <|> fmap RightParser (JSON.parseJSON v)++instance (ToJSON a, ToJSON b) => ToJSON (EitherParser a b) where+  toJSON (LeftParser a) = JSON.toJSON a+  toJSON (RightParser b) = JSON.toJSON b++toEitherParser :: Either a b -> EitherParser a b+toEitherParser = either LeftParser RightParser++fromEitherParser :: EitherParser a b -> Either a b+fromEitherParser = eitherParser Left Right+ ---------------------------------------------------------------------------------------------------- -- Actions ----------------------------------------------------------------------------------------------------@@ -681,6 +802,8 @@   | ResourceVolumeID VolumeID     -- | Primary IP ID.   | ResourcePrimaryIPID PrimaryIPID+    -- | Firewall ID.+  | ResourceFirewallID FirewallID     deriving Show  instance FromJSON ResourceID where@@ -690,6 +813,7 @@       "server" -> ResourceServerID <$> o .: "id"       "volume" -> ResourceVolumeID <$> o .: "id"       "primary_ip" -> ResourcePrimaryIPID <$> o .: "id"+      "firewall" -> ResourceFirewallID <$> o .: "id"       _ -> fail $ "Unknown resource type: " ++ Text.unpack t  -- | Action.@@ -730,7 +854,7 @@     go :: IO ZonedTime     go = do action <- getAction token i             case actionStatus action of-              ActionRunning _ -> threadDelay 200000 *> go+              ActionRunning _ -> threadDelay 250000 *> go               ActionSuccess t -> pure t               ActionError _ err -> throwIO $ CloudError err @@ -800,6 +924,317 @@ -- | Firewall identifier. newtype FirewallID = FirewallID Int deriving (Eq, Ord, Show, FromJSON, ToJSON) +-- | Traffic direction, whether incoming ('TrafficIn') or outgoing ('TrafficOut').+data TrafficDirection = TrafficIn | TrafficOut deriving (Eq, Show)++instance FromJSON TrafficDirection where+  parseJSON = JSON.withText "TrafficDirection" $ \t ->+    case t of+      "in" -> pure TrafficIn+      "out" -> pure TrafficOut+      _ -> fail $ "Invalid traffic direction: " ++ Text.unpack t++instance ToJSON TrafficDirection where+  toJSON TrafficIn = JSON.String "in"+  toJSON TrafficOut = JSON.String "out"++-- | A port range. It can contain only one port if both ends are the same.+data PortRange = PortRange Int Int deriving Show++-- | A port range containing a single port.+singlePort :: Int -> PortRange+singlePort p = PortRange p p++portRangeParser :: Parser PortRange+portRangeParser = do+  p1 <- Parser.decimal+  hasSecondPart <- (Parser.single '-' *> pure True) <|> pure False+  if hasSecondPart+     then PortRange p1 <$> Parser.decimal+     else pure $ PortRange p1 p1++instance FromJSON PortRange where+  parseJSON = JSON.withText "PortRange" $ \t ->+    either (fail . Parser.errorBundlePretty) pure $+      Parser.runParser (portRangeParser <* Parser.eof) "JSON" t++instance ToJSON PortRange where+  toJSON (PortRange p1 p2) = fromString $+    if p1 == p2+       then show p1+       else show p1 ++ "-" ++ show p2++-- | Protocol used in a 'FirewallRule'.+data FirewallRuleProtocol =+    -- | TCP protocol on the given port range.+    FirewallRuleTCP PortRange+    -- | UDP protocol on the given port range.+  | FirewallRuleUDP PortRange+    -- | ICMP protocol.+  | FirewallRuleICMP+    -- | ESP protocol.+  | FirewallRuleESP+    -- | GRE protocol.+  | FirewallRuleGRE+    deriving Show++-- | A firewall rule.+data FirewallRule = FirewallRule+  { -- | Optional description of the rule.+    firewallRuleDescription :: Maybe Text+    -- | Traffic direction the rule applies to.+  , firewallRuleDirection :: TrafficDirection+    -- | IPs the rule applies to. You can use 'anyIPv4' and/or+    --   'anyIPv6' to allow any IPs.+  , firewallRuleIPs :: NonEmpty (Either IPv4Range IPv6Range)+    -- | Protocol the rule applies to.+  , firewallRuleProtocol :: FirewallRuleProtocol+    } deriving Show++instance FromJSON FirewallRule where+  parseJSON = JSON.withObject "FirewallRule" $ \o -> do+    dir <- o .: "direction"+    ips <-+      case dir of+        TrafficIn -> o .: "source_ips"+        TrafficOut -> o .: "destination_ips"+    protocolType <- o .: "protocol"+    protocol <-+      case protocolType of+        "tcp" -> FirewallRuleTCP <$> o .: "port"+        "udp" -> FirewallRuleUDP <$> o .: "port"+        "icmp" -> pure FirewallRuleICMP+        "esp" -> pure FirewallRuleESP+        "gre" -> pure FirewallRuleGRE+        _ -> fail $ "Invalid protocol: " ++ Text.unpack protocolType+    FirewallRule+      <$> o .:? "description"+      <*> pure dir+      <*> pure (fmap fromEitherParser ips)+      <*> pure protocol++instance ToJSON FirewallRule where+  toJSON rule =+    let dir = firewallRuleDirection rule+        ips = fmap toEitherParser $ firewallRuleIPs rule+    in  JSON.object $+          maybe [] (\t -> pure $ "description" .= t) (firewallRuleDescription rule)+            ++ [ "direction" .= dir+               , case dir of+                   TrafficIn -> "source_ips" .= ips+                   TrafficOut -> "destination_ips" .= ips+                 ]+            ++ (case firewallRuleProtocol rule of+                  FirewallRuleTCP r ->+                    [ "protocol" .= ("tcp" :: Text)+                    , "port" .= r+                      ]+                  FirewallRuleUDP r ->+                    [ "protocol" .= ("udp" :: Text)+                    , "port" .= r+                      ]+                  FirewallRuleICMP -> [ "protocol" .= ("icmp" :: Text) ]+                  FirewallRuleESP -> [ "protocol" .= ("esp" :: Text) ]+                  FirewallRuleGRE -> [ "protocol" .= ("gre" :: Text) ]+                 )++-- | A firewall that can be applied to other resources, via 'applyFirewall'+--   or directly on creation.+data Firewall = Firewall+  { firewallID :: FirewallID+    -- | The firewall's name.+  , firewallName :: Text+    -- | Time the firewall was created.+  , firewallCreated :: ZonedTime+    -- | Servers the firewall has been applied to.+  , firewallServers :: [ServerID]+    -- | Label selectors used to apply the firewall automatically to+    --   matching resources.+  , firewallLabelSelectors :: [LabelSelectorAll]+    -- | Firewall rules.+  , firewallRules :: [FirewallRule]+    -- | Labels attached to the firewall.+  , firewallLabels :: LabelMap+    } deriving Show++instance FromJSON Firewall where+  parseJSON = JSON.withObject "Firewall" $ \o -> do+    xs <- o .: "applied_to"+    ys <- forM xs $ \v ->+            let f o' = do+                  t <- o' .: "type"+                  case t of+                    "server" -> do+                       v' <- o' .: "server"+                       Left <$> JSON.withObject "Server" (.: "id") v'+                    "label_selector" -> do+                       v' <- o' .: "label_selector"+                       Right <$> JSON.withObject "LabelSelector" (.: "selector") v'+                    _ -> fail $ "Invalid applied_to type: " ++ Text.unpack t+            in  JSON.withObject "AppliedTo" f v+    let (servers, labels) = partitionEithers ys+    Firewall+      <$> o .: "id"+      <*> o .: "name"+      <*> o .: "created"+      <*> pure servers+      <*> pure labels+      <*> o .: "rules"+      <*> o .: "labels"++-- | Information used to create a new firewall with 'createFirewall'.+data NewFirewall = NewFirewall+  { -- | The firewall's name.+    newFirewallName :: Text+    -- | Labels to attach to the firewall on creation.+  , newFirewallLabels :: [Label]+    -- | Firewall rules.+  , newFirewallRules :: [FirewallRule]+    -- | List of servers to apply the firewall to on creation.+  , newFirewallServers :: [ServerID]+    -- | Label selectors to apply the firewall to matching resources.+  , newFirewallLabelSelectors :: [LabelSelectorAll]+    }++-- | IPv4 range containing every IP.+anyIPv4 :: IPv4Range+anyIPv4 = IPv4.range IPv4.any 0++-- | IPv6 range containing every IP.+anyIPv6 :: IPv6Range+anyIPv6 = IPv6.range IPv6.any 0++-- | Default firewall with two rules:+--+-- * Allow SSH on default port 22 from any address.+-- * Allow ICMP from any address.+--+defaultNewFirewall+  :: Text -- ^ Firewall name.+  -> NewFirewall+defaultNewFirewall name = NewFirewall+  { newFirewallName = name+  , newFirewallLabels = []+  , newFirewallRules =+      [ FirewallRule+          { firewallRuleDescription = Just "SSH"+          , firewallRuleDirection = TrafficIn+          , firewallRuleIPs = Left anyIPv4 :| [Right anyIPv6]+          , firewallRuleProtocol = FirewallRuleTCP $ singlePort 22+            }+      , FirewallRule+          { firewallRuleDescription = Just "ICMP"+          , firewallRuleDirection = TrafficIn+          , firewallRuleIPs = Left anyIPv4 :| [Right anyIPv6]+          , firewallRuleProtocol = FirewallRuleICMP+            }+        ]+  , newFirewallServers = []+  , newFirewallLabelSelectors = []+    }++-- | Result of creating a firewall with 'createFirewall'.+data CreatedFirewall = CreatedFirewall+  { -- | Actions associated with the firewall's creation.+    createdFirewallActions :: [Action]+    -- | The firewall just created.+  , createdFirewall :: Firewall+    } deriving Show++instance FromJSON CreatedFirewall where+  parseJSON = JSON.withObject "CreatedFirewall" $ \o ->+    CreatedFirewall <$> o .: "actions" <*> o .: "firewall"++-- | Get all firewalls in a project.+getFirewalls :: Token -> Maybe Int -> IO (WithMeta "firewalls" [Firewall])+getFirewalls = cloudQuery "GET" "/firewalls" noBody++-- | Get a single firewall.+getFirewall :: Token -> FirewallID -> IO Firewall+getFirewall token (FirewallID i) = withoutKey @"firewall" <$>+  cloudQuery "GET" ("/firewalls/" <> fromString (show i)) noBody token Nothing++-- | Create a firewall.+createFirewall :: Token -> NewFirewall -> IO CreatedFirewall+createFirewall token nfirewall =+  let servers = fmap (\i -> JSON.object [ "server" .= i ])+              $ newFirewallServers nfirewall+      selectors = fmap (\s -> JSON.object [ "selector" .= s ])+                $ newFirewallLabelSelectors nfirewall+      applyTo =+        fmap (\v -> JSON.object [ "type" .= ("server" :: Text)+                                , "server" .= v ]) servers+          ++ fmap (\v -> JSON.object [ "type" .= ("label_selector" :: Text)+                                     , "label_selector" .= v ]) selectors++      body = JSON.object+        [ "name" .= newFirewallName nfirewall+        , "labels" .= toLabelMap (newFirewallLabels nfirewall)+        , "rules" .= newFirewallRules nfirewall+        , "apply_to" .= applyTo+          ]+  in  cloudQuery "POST" "/firewalls" (Just body) token Nothing++-- | Delete a firewall.+deleteFirewall :: Token -> FirewallID -> IO ()+deleteFirewall token (FirewallID i) =+  cloudQuery "DELETE" ("/firewalls/" <> fromString (show i)) noBody token Nothing++-- | Update name and labels of a firewall.+updateFirewall+  :: Token+  -> FirewallID -- ^ Firewall to update.+  -> Text -- ^ New name for the firewall.+  -> [Label] -- ^ New labels for the firewall.+  -> IO Firewall+updateFirewall token (FirewallID i) name labels = withoutKey @"firewall" <$>+  let body = JSON.object+        [ "labels" .= toLabelMap labels+        , "name" .= name+          ]+  in  cloudQuery "PUT" ("/firewalls/" <> fromString (show i)) (Just body) token Nothing++-- | Apply a firewall to resources.+applyFirewall+  :: Token+  -> FirewallID -- ^ Firewall to apply.+  -> [ServerID] -- ^ Servers to apply the firewall to.+  -> [LabelSelectorAll] -- ^ Label selectors to apply.+  -> IO [Action]+applyFirewall token (FirewallID i) servers selectors = withoutKey @"actions" <$>+  let path = "/firewalls/" <> fromString (show i) <> "/actions/apply_to_resources"+      serverf server = JSON.object+        [ "type" .= ("server" :: Text)+        , "server" .= JSON.object [ "id" .= server ] ]+      selectorf selector = JSON.object+        [ "type" .= ("label_selector" :: Text)+        , "label_selector" .= JSON.object [ "selector" .= selector ] ]+      body = JSON.object+        [ "apply_to" .= (fmap serverf servers ++ fmap selectorf selectors)+          ]+  in  cloudQuery "POST" path (Just body) token Nothing++-- | Remove a firewall from the given resources. The firewall itself is not deleted.+--   For that, use 'deleteFirewall'.+removeFirewall+  :: Token+  -> FirewallID -- ^ Firewall to remove.+  -> [ServerID] -- ^ Servers to remove the firewall from.+  -> [LabelSelectorAll] -- ^ Label selectors to remove from the firewall.+  -> IO [Action]+removeFirewall token (FirewallID i) servers selectors = withoutKey @"actions" <$>+  let path = "/firewalls/" <> fromString (show i) <> "/actions/remove_from_resources"+      serverf server = JSON.object+        [ "type" .= ("server" :: Text)+        , "server" .= JSON.object [ "id" .= server ] ]+      selectorf selector = JSON.object+        [ "type" .= ("label_selector" :: Text)+        , "label_selector" .= JSON.object [ "selector" .= selector ] ]+      body = JSON.object+        [ "remove_from" .= (fmap serverf servers ++ fmap selectorf selectors)+          ]+  in  cloudQuery "POST" path (Just body) token Nothing+ ---------------------------------------------------------------------------------------------------- -- Floating IPs ----------------------------------------------------------------------------------------------------@@ -1316,7 +1751,8 @@   toJSON nserver = JSON.object $ mconcat     [ pure $ "automount" .= (newServerAutomount nserver && not (null $ newServerVolumes nserver))     , maybe mempty (pure . either ("datacenter".=) ("location".=)) $ newServerLocation nserver-    , pure $ "firewalls" .= newServerFirewalls nserver+    , pure $ "firewalls" .=+        fmap (\fwid -> JSON.object [ "firewall" .= fwid ]) (newServerFirewalls nserver)     , pure $ "image" .= newServerImage nserver     , pure $ "labels" .= toLabelMap (newServerLabels nserver)     , pure $ "name" .= newServerName nserver@@ -1495,6 +1931,8 @@   , serverTypeName :: Text   , serverPricing :: [PriceInLocation]   , serverStorageType :: StorageType+    -- | Outgoing traffic included (in bytes).+  , serverIncludedTraffic :: Int     } deriving Show  instance FromJSON ServerType where@@ -1510,6 +1948,7 @@     <*> o .: "name"     <*> o .: "prices"     <*> o .: "storage_type"+    <*> o .: "included_traffic"  -- | Get all server types. --@@ -1538,7 +1977,7 @@ instance FromJSON SSHKey where   parseJSON = JSON.withObject "SSHKey" $ \o -> SSHKey     <$> o .: "created"-    <*> o .: "fingerprint"+    <*> (fingerprint <$> o .: "fingerprint")     <*> o .: "id"     <*> o .: "labels"     <*> o .: "name"

@@ -1,9 +1,11 @@-{-# OPTIONS_GHC -Wno-orphans #-}  -- | Parsers for the 'Fingerprint' type.+--+--   This is an internal module that's not needed for the+--   normal use of the library. module Hetzner.Cloud.Fingerprint (     Fingerprint-  , fingerprintParser+  , FingerprintText (..)   ) where  -- base@@ -27,6 +29,7 @@  type Parser = Parser.Parsec Void Text +-- | Text-based 'Fingerprint' parser. fingerprintParser :: Parser Fingerprint fingerprintParser = do   bs0 <- liftA2 (:) Parser.hexadecimal $@@ -38,7 +41,10 @@       combineBytes = foldl' f 0 . zip [0..]   pure $ Fingerprint (combineBytes bs0) (combineBytes bs1) -instance FromJSON Fingerprint where+-- | A wrapper of 'Fingerprint' with a custom 'FromJSON' instance.+newtype FingerprintText = FingerprintText { fingerprint :: Fingerprint }++instance FromJSON FingerprintText where   parseJSON = JSON.withText "Fingerprint" $ \t ->-    either (fail . Parser.errorBundlePretty) pure $+    either (fail . Parser.errorBundlePretty) (pure . FingerprintText) $       Parser.runParser (fingerprintParser <* Parser.eof) "JSON input" t