diff --git a/apps/Docs.hs b/apps/Docs.hs --- a/apps/Docs.hs +++ b/apps/Docs.hs @@ -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" diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/hetzner.cabal b/hetzner.cabal --- a/hetzner.cabal +++ b/hetzner.cabal @@ -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) diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -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 diff --git a/src/Hetzner/Cloud.hs b/src/Hetzner/Cloud.hs --- a/src/Hetzner/Cloud.hs +++ b/src/Hetzner/Cloud.hs @@ -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" diff --git a/src/Hetzner/Cloud/Fingerprint.hs b/src/Hetzner/Cloud/Fingerprint.hs --- a/src/Hetzner/Cloud/Fingerprint.hs +++ b/src/Hetzner/Cloud/Fingerprint.hs @@ -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