diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +## 0.1.2.0 +* New function: `getTokenFromEnv`. This function allows the user + to obtain a token from the `HETZNER_API_TOKEN` environment variable. +* Support for (private) networks. +* New instances for the `Token` type: `IsString`, `Show`, `Eq`, `Ord`. + ## 0.1.1.0 * Added support for volumes. * Fixed parsing of HTTP 204 responses. diff --git a/hetzner.cabal b/hetzner.cabal --- a/hetzner.cabal +++ b/hetzner.cabal @@ -2,7 +2,7 @@ category: Cloud synopsis: Hetzner Cloud client library. description: Hetzner Cloud client library. Check the readme and documentation for more details. -version: 0.1.1.0 +version: 0.1.2.0 cabal-version: >= 1.10 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 @@ -1,6 +1,12 @@ # Hetzner Cloud Haskell Library +[![Build Status](https://img.shields.io/github/actions/workflow/status/Daniel-Diaz/hetzner/build.yml?branch=dev&style=for-the-badge)](https://github.com/Daniel-Diaz/hetzner/actions/workflows/build.yml) + +## Distributions + [![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) +[![Stackage Nightly](http://stackage.org/package/hetzner/badge/nightly)](http://stackage.org/nightly/package/hetzner) ## Description diff --git a/src/Hetzner/Cloud.hs b/src/Hetzner/Cloud.hs --- a/src/Hetzner/Cloud.hs +++ b/src/Hetzner/Cloud.hs @@ -37,6 +37,7 @@ module Hetzner.Cloud ( -- * Tokens Token (..) + , getTokenFromEnv -- * Server metadata , Metadata (..) , getMetadata @@ -71,12 +72,27 @@ , Image (..) , getImages , getImage + -- ** Load Balancers + , LoadBalancerID (..) -- ** Locations , City (..) , LocationID (..) , Location (..) , getLocations , getLocation + -- ** Networks + , NetworkID (..) + , Route (..) + , SubnetType (..) + , Subnet (..) + , Network (..) + , NewNetwork (..) + , defaultNewNetwork + , getNetworks + , getNetwork + , createNetwork + , deleteNetwork + , updateNetwork -- ** Pricing , Price (..) , PriceInLocation (..) @@ -159,15 +175,16 @@ import Control.Concurrent (threadDelay) import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import Data.Proxy -import Data.String (fromString) +import Data.String (IsString, fromString) import GHC.Fingerprint (Fingerprint (..)) import Data.Void import Control.Applicative (liftA2) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Foldable (forM_) import Data.Maybe (isNothing, fromMaybe) +import System.Environment qualified as System -- ip -import Net.IPv4 (IPv4) +import Net.IPv4 (IPv4, IPv4Range) import Net.IPv6 (IPv6, IPv6Range) -- bytestring import Data.ByteString (ByteString) @@ -208,8 +225,15 @@ -- will have as scope the project where the token was made. -- -- You can obtain one through the [Hetzner Cloud Console](https://console.hetzner.cloud). -newtype Token = Token ByteString +newtype Token = Token ByteString deriving (Show, Eq, Ord) +instance IsString Token where + fromString = Token . fromString + +-- | Lookup 'Token' from the environment variable @HETZNER_API_TOKEN@. +getTokenFromEnv :: IO (Maybe Token) +getTokenFromEnv = fmap fromString <$> System.lookupEnv "HETZNER_API_TOKEN" + -- | An error returned by Hetzner. data Error = Error { -- | Error code. @@ -533,7 +557,7 @@ instance (KnownSymbol key, FromJSON a) => FromJSON (WithKey key a) where parseJSON = let key = symbolVal (Proxy @key) - in JSON.withObject ("WithKey " ++ key) $ \o -> + in JSON.withObject ("WithKey:" ++ key) $ \o -> WithKey <$> o .: fromString key -- | A value together with response metadata. @@ -828,6 +852,13 @@ cloudQuery "GET" ("/images/" <> fromString (show i)) noBody token Nothing ---------------------------------------------------------------------------------------------------- +-- Load Balancers +---------------------------------------------------------------------------------------------------- + +-- | Load balancer identifier +newtype LoadBalancerID = LoadBalancerID Int deriving (Eq, Ord, Show, FromJSON, ToJSON) + +---------------------------------------------------------------------------------------------------- -- Locations ---------------------------------------------------------------------------------------------------- @@ -884,6 +915,162 @@ getLocation :: Token -> LocationID -> IO Location getLocation token (LocationID i) = withoutKey @"location" <$> cloudQuery "GET" ("/locations/" <> fromString (show i)) noBody token Nothing + +---------------------------------------------------------------------------------------------------- +-- Networks +---------------------------------------------------------------------------------------------------- + +-- | Network identifier. +newtype NetworkID = NetworkID Int deriving (Eq, Ord, Show, FromJSON, ToJSON) + +-- | A route that sends all packets for a given destination to +-- a given gateway. +data Route = Route + { routeDestination :: IPv4Range + , routeGateway :: IPv4 + } deriving Show + +instance FromJSON Route where + parseJSON = JSON.withObject "Route" $ \o -> Route + <$> o .: "destination" + <*> o .: "gateway" + +instance ToJSON Route where + toJSON route = JSON.object + [ "destination" .= routeDestination route + , "gateway" .= routeGateway route + ] + +-- | Types of subnetworks. +data SubnetType = SubnetCloud | SubnetServer | SubnetVSwitch deriving (Eq, Show) + +instance FromJSON SubnetType where + parseJSON = JSON.withText "SubnetType" $ \t -> case t of + "cloud" -> pure SubnetCloud + "server" -> pure SubnetServer + "vswitch" -> pure SubnetVSwitch + _ -> fail $ "Invalid subnet type: " ++ Text.unpack t + +instance ToJSON SubnetType where + toJSON t = case t of + SubnetCloud -> "cloud" + SubnetServer -> "server" + SubnetVSwitch -> "vswitch" + +-- | Subnets divide the IP range of a parent 'Network'. +data Subnet = Subnet + { subnetGateway :: IPv4 + , subnetIPRange :: IPv4Range + , subnetRegion :: Region + , subnetType :: SubnetType + } deriving Show + +instance FromJSON Subnet where + parseJSON = JSON.withObject "Subnet" $ \o -> Subnet + <$> o .: "gateway" + <*> o .: "ip_range" + <*> o .: "network_zone" + <*> o .: "type" + +instance ToJSON Subnet where + toJSON subnet = JSON.object + [ "gateway" .= subnetGateway subnet + , "ip_range" .= subnetIPRange subnet + , "network_zone" .= subnetRegion subnet + , "type" .= subnetType subnet + ] + +-- | A private network. +data Network = Network + { networkCreated :: ZonedTime + , networkID :: NetworkID + , networkIPRange :: IPv4Range + , networkLabels :: LabelMap + , networkLoadBalancers :: [LoadBalancerID] + , networkName :: Text + , networkRoutes :: [Route] + , networkServers :: [ServerID] + , networkSubnets :: [Subnet] + } deriving Show + +instance FromJSON Network where + parseJSON = JSON.withObject "Network" $ \o -> Network + <$> o .: "created" + <*> o .: "id" + <*> o .: "ip_range" + <*> o .: "labels" + <*> o .: "load_balancers" + <*> o .: "name" + <*> o .: "routes" + <*> o .: "servers" + <*> o .: "subnets" + +-- | Network creation configuration to be used with 'createNetwork'. +data NewNetwork = NewNetwork + { newNetworkIPRange :: IPv4Range + , newNetworkLabels :: [Label] + , newNetworkName :: Text + , newNetworkRoutes :: [Route] + , newNetworkSubnets :: [Subnet] + } + +instance ToJSON NewNetwork where + toJSON nnetwork = JSON.object + [ "ip_range" .= newNetworkIPRange nnetwork + , "labels" .= toLabelMap (newNetworkLabels nnetwork) + , "name" .= newNetworkName nnetwork + , "routes" .= newNetworkRoutes nnetwork + , "subnets" .= newNetworkSubnets nnetwork + ] + +-- | Default network configuration for new networks. +defaultNewNetwork + :: Text -- ^ Network name. + -> IPv4Range -- ^ IP range of the network. + -> NewNetwork +defaultNewNetwork name iprange = NewNetwork + { newNetworkIPRange = iprange + , newNetworkLabels = [] + , newNetworkName = name + , newNetworkRoutes = [] + , newNetworkSubnets = [] + } + +-- | Get networks. +getNetworks + :: Token + -> Maybe Int -- ^ Page. + -> IO (WithMeta "networks" [Network]) +getNetworks = cloudQuery "GET" "/networks" noBody + +-- | Get a single network. +getNetwork :: Token -> NetworkID -> IO Network +getNetwork token (NetworkID i) = withoutKey @"network" <$> + cloudQuery "GET" ("/networks/" <> fromString (show i)) noBody token Nothing + +-- | Create a new network. +createNetwork :: Token -> NewNetwork -> IO Network +createNetwork token new = withoutKey @"network" <$> + cloudQuery "POST" "/networks" (Just new) token Nothing + +-- | Delete a network. +deleteNetwork :: Token -> NetworkID -> IO () +deleteNetwork token (NetworkID i) = + cloudQuery "DELETE" ("/networks/" <> fromString (show i)) noBody token Nothing + +-- | Update name and labels of a network. +updateNetwork + :: Token + -> NetworkID -- ^ Network to update. + -> Text -- ^ New name for the network. + -> [Label] -- ^ New labels for the network. + -> IO Network +updateNetwork token (NetworkID i) name labels = withoutKey @"network" <$> + let body = JSON.object + [ "labels" .= toLabelMap labels + , "name" .= name + ] + in cloudQuery "PUT" ("/networks/" <> fromString (show i)) (Just body) token Nothing ---------------------------------------------------------------------------------------------------- -- Pricing