diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +## 0.2.1.0 +* Add support for primary IPs. +* Add function to set reverse DNS for a primary IP. +* Add test. + ## 0.2.0.0 * Allow to attach servers to networks on creation. * Modify `streamPages` to cover more cases. 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.2.0.0 +version: 0.2.1.0 cabal-version: >= 1.10 build-type: Simple author: Daniel Casanueva (daniel.casanueva `at` proton.me) @@ -19,6 +19,7 @@ Hetzner.Cloud Hetzner.Cloud.Fingerprint Hetzner.DNS + ghc-options: -Wall -Wunused-packages default-extensions: ImportQualifiedPost , OverloadedStrings @@ -27,9 +28,17 @@ , ScopedTypeVariables , GeneralizedNewtypeDeriving , TypeApplications - ghc-options: -Wall -Wunused-packages build-depends: base >= 4.16 && < 4.18 , text, aeson, containers, conduit , http-conduit, bytestring, yaml, time , country, ip, megaparsec, scientific + +test-suite hetzner-test + default-language: Haskell2010 + hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: Main.hs + ghc-options: -Wall -Wunused-packages + default-extensions: ImportQualifiedPost, OverloadedStrings + build-depends: base, hetzner diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -2,7 +2,7 @@ [![Build Status](https://img.shields.io/github/actions/workflow/status/Daniel-Diaz/hetzner/build.yml?branch=main&style=for-the-badge)](https://github.com/Daniel-Diaz/hetzner/actions/workflows/build.yml) -## Distributions +## Distribution [![Hackage](https://img.shields.io/hackage/v/hetzner?style=for-the-badge)](https://hackage.haskell.org/package/hetzner) [![Stackage LTS](http://stackage.org/package/hetzner/badge/lts)](http://stackage.org/lts/package/hetzner) diff --git a/src/Hetzner/Cloud.hs b/src/Hetzner/Cloud.hs --- a/src/Hetzner/Cloud.hs +++ b/src/Hetzner/Cloud.hs @@ -80,6 +80,12 @@ , Location (..) , getLocations , getLocation + -- ** Primary IPs + , PrimaryIPID (..) + , PrimaryIP (..) + , getPrimaryIPs + , getPrimaryIP + , setReverseDNS -- ** Networks , NetworkID (..) , Route (..) @@ -169,14 +175,13 @@ , Pagination (..) ) where -import Hetzner.Cloud.Fingerprint () +import Hetzner.Cloud.Fingerprint (Fingerprint) -- base import Control.Exception (Exception, throwIO) import Control.Concurrent (threadDelay) import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import Data.Proxy import Data.String (IsString, fromString) -import GHC.Fingerprint (Fingerprint (..)) import Data.Void import Control.Applicative (liftA2) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -421,6 +426,8 @@ in HTTP.httpBS req >>= Yaml.decodeThrow . HTTP.getResponseBody -- | Obtain metadata from running server. +-- It doesn't need a 'Token' but must be +-- run from a server in Hetzner Cloud. getMetadata :: IO Metadata getMetadata = metadataQuery mempty @@ -459,6 +466,18 @@ <$> o .: "dns_ptr" <*> o .: "ip" +instance (ToJSON dnsptr, ToJSON ip) => ToJSON (PublicIPInfo dnsptr ip) where + toJSON (PublicIPInfo dns ip) = JSON.object [ "dns_ptr" .= dns, "ip" .= ip ] + +instance Functor (PublicIPInfo dnsptr) where + fmap f (PublicIPInfo dns ip) = PublicIPInfo dns (f ip) + +instance Foldable (PublicIPInfo dnsptr) where + foldMap f (PublicIPInfo _ ip) = f ip + +instance Traversable (PublicIPInfo dnsptr) where + traverse f (PublicIPInfo dns ip) = PublicIPInfo dns <$> f ip + -- | Public network information associated with a 'Server'. data PublicNetwork = PublicNetwork { publicNetworkFirewalls :: [FirewallStatus] @@ -623,6 +642,7 @@ | ApplyFirewall | CreateVolume | AttachVolume + | ChangeDNSPtr deriving Show instance FromJSON ActionCommand where @@ -635,6 +655,7 @@ "apply_firewall" -> pure ApplyFirewall "create_volume" -> pure CreateVolume "attach_volume" -> pure AttachVolume + "change_dns_ptr" -> pure ChangeDNSPtr _ -> fail $ "Unknown action command " ++ Text.unpack t -- | Action identifier. @@ -646,6 +667,8 @@ ResourceServerID ServerID -- | Volume ID. | ResourceVolumeID VolumeID + -- | Primary IP ID. + | ResourcePrimaryIPID PrimaryIPID deriving Show instance FromJSON ResourceID where @@ -654,6 +677,7 @@ case t :: Text of "server" -> ResourceServerID <$> o .: "id" "volume" -> ResourceVolumeID <$> o .: "id" + "primary_ip" -> ResourcePrimaryIPID <$> o .: "id" _ -> fail $ "Unknown resource type: " ++ Text.unpack t -- | Action. @@ -921,6 +945,82 @@ getLocation :: Token -> LocationID -> IO Location getLocation token (LocationID i) = withoutKey @"location" <$> cloudQuery "GET" ("/locations/" <> fromString (show i)) noBody token Nothing + +---------------------------------------------------------------------------------------------------- +-- Primary IPs +---------------------------------------------------------------------------------------------------- + +-- | Primary IP identifier. +newtype PrimaryIPID = PrimaryIPID Int deriving (Eq, Ord, Show, FromJSON, ToJSON) + +-- | Primary IP. +data PrimaryIP = PrimaryIP + { -- | Resource the primary IP is assigned to. + primaryIPAssignee :: ResourceID + -- | This primary IP is deleted when the resource it is assigned to is deleted. + , primaryIPAutoDelete :: Bool + , primaryIPIsBlocked :: Bool + -- | Point in time where the primary IP was created. + , primaryIPCreated :: ZonedTime + , primaryIPDatacenter :: Datacenter + , primaryIPID :: PrimaryIPID + -- | Primary IP together with reverse DNS information. + , primaryIP :: Either (PublicIPInfo Text IPv4) (PublicIPInfo [PublicIPInfo Text IPv6] IPv6Range) + , primaryIPLabels :: LabelMap + , primaryIPName :: Text + } deriving Show + +instance FromJSON PrimaryIP where + parseJSON = JSON.withObject "PrimaryIP" $ \o -> do + aid <- o .: "assignee_id" :: JSON.Parser Int + atype <- o .: "assignee_type" :: JSON.Parser Text + iptype <- o .: "type" + PrimaryIP + <$> JSON.parseJSON (JSON.object [ "id" .= aid, "type" .= atype ]) + <*> o .: "auto_delete" + <*> o .: "blocked" + <*> o .: "created" + <*> o .: "datacenter" + <*> o .: "id" + <*> (case iptype :: Text of + "ipv4" -> Left <$> (o .: "dns_ptr" >>= JSON.parseJSON . head) + "ipv6" -> Right <$> JSON.parseJSON (JSON.Object o) + _ -> fail $ "Invalid ip type: " ++ Text.unpack iptype + ) + <*> o .: "labels" + <*> o .: "name" + +-- | Get primary IPs. +getPrimaryIPs + :: Token + -> Maybe Int -- ^ Page. + -> IO (WithMeta "primary_ips" [PrimaryIP]) +getPrimaryIPs = cloudQuery "GET" "/primary_ips" noBody + +-- | Get a single primary IP. +getPrimaryIP :: Token -> PrimaryIPID -> IO PrimaryIP +getPrimaryIP token (PrimaryIPID i) = withoutKey @"primary_ip" <$> + cloudQuery "GET" ("/primary_ips" <> fromString (show i)) noBody token Nothing + +-- | Set reverse DNS for a primary IP. +-- +-- * If the primary IP corresponds to an IPv4, the reverse DNS setting's +-- IP /must/ coincide with the primary IP's IPv4. +-- +-- * If the primary IP corresponds to an IPv6, the reverse DNS setting's +-- IP /must/ be within the primary IP's IPv6 range. +-- +setReverseDNS + :: Token + -- | Primary IP to set reverse DNS for. + -> PrimaryIPID + -- | Reverse DNS settings. + -> PublicIPInfo Text (Either IPv4 IPv6) + -> IO Action +setReverseDNS token (PrimaryIPID i) (PublicIPInfo dns ip) = withoutKey @"action" <$> + cloudQuery "POST" ("/primary_ips/" <> fromString (show i) <> "/actions/change_dns_ptr") + (Just $ either (JSON.toJSON . PublicIPInfo dns) (JSON.toJSON . PublicIPInfo dns) ip) + token Nothing ---------------------------------------------------------------------------------------------------- -- Networks diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,26 @@ + +-- | If the environment variable @HETZNER_API_TOKEN@ isn't set, this test succeeds without +-- doing anything. If it is set to a valid Hetzner token, this test will create and destroy +-- resources in Hetzner Cloud, which carries some cost, albeit small. +module Main (main) where + +import Hetzner.Cloud qualified as Hetzner +import Control.Monad (void) + +main :: IO () +main = do + mtoken <- Hetzner.getTokenFromEnv + case mtoken of + Nothing -> putStrLn "Environment variable HETZNER_API_TOKEN not provided. Skipping test." + Just token -> do + putStrLn "Creating test server..." + cserver <- Hetzner.createServer token $ Hetzner.defaultNewServer "test" + mapM_ (Hetzner.waitForAction token) $ + fmap Hetzner.actionID $ + Hetzner.createdServerAction cserver : Hetzner.createdServerNextActions cserver + let server = Hetzner.createdServer cserver + putStrLn "Server created:" + print server + putStrLn "Deleting test server..." + void $ Hetzner.deleteServer token (Hetzner.serverID server) + >>= Hetzner.waitForAction token . Hetzner.actionID