{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} module Network.DigitalOcean.Types where ----------------------------------------------------------------- import GHC.Generics import Data.Aeson import Data.Time.Clock import Control.Monad.State import Control.Monad.Identity import Control.Lens import Control.Monad import Control.Monad.Reader import Control.Monad.Except import qualified Data.Text as T import qualified Data.ByteString as BS import System.FilePath.Posix (()) ----------------------------------------------------------------- import Data.Monoid import Data.List import qualified Data.Set as Set ----------------------------------------------------------------- type QueryParams = [(String, String)] data RequestMethod = Get | Post | Put | Delete instance Show RequestMethod where show Get = "GET" show Post = "POST" show Put = "PUT" show Delete = "DELETE" showQueryParams :: QueryParams -> String showQueryParams = \case [] -> "" ls -> "?" <> (intercalate "&" . map (\(k, v) -> k <> "=" <> v) $ ls) class (FromJSON a, Show a, FromJSON (PaginationState a)) => Paginatable a data PaginationState a = PaginationState { curr :: [a] , page :: Int , nextUrl :: Maybe String , total :: Maybe Int , isLast :: Bool } deriving (Show) data PaginationConfig = PaginationConfig { pageSize :: Int , resultLimit :: Int } -- https://developers.digitalocean.com/documentation/v2/#links defaultPaginationConfig :: PaginationConfig defaultPaginationConfig = PaginationConfig 25 100 newtype DO a = DO { runDO :: ReaderT Client (ExceptT DoErr IO) a } deriving (Functor, Applicative, Monad, MonadIO, MonadError DoErr, MonadReader Client) newtype Client = Client { apiKey :: BS.ByteString } data DoErrType = HttpError | JSONConversionError | InternalError | ActionNotAllowed | AuthenticationError | UnknownError deriving Show data DoErr = DoErr { errType :: DoErrType , errTitle :: T.Text , errBody :: T.Text } deriving Show newtype Response a = Response { unResponse :: a } deriving (Generic, Show) class (ToJSON a) => Payload a data EmptyPayload = EmptyPayload instance Payload EmptyPayload where instance ToJSON EmptyPayload where toJSON EmptyPayload = object [] instance FromJSON (Response ()) where parseJSON _ = return $ Response () data Endpoint = AccountEndpoint | ActionsEndpoint | ActionEndpoint ActionId | RegionsEndpoint | VolumesEndpoint | SnapshotsEndpoint | DomainsEndpoint | ImagesEndpoint | SizesEndpoint | DropletsEndpoint | RecordsEndpoint | KernelsEndpoint | BackupsEndpoint | NeighborsEndpoint | FloatingIpsEndpoint | DropletsNeighborsEndpoint | TagsEndpoint | RulesEndpoint | FirewallsEndpoint | LoadBalancersEndpoint | ForwardingRulesEndpoint | KeysEndpoint | SSHKeysEndpoint | VolumeEndpoint VolumeId | SnapshotEndpoint SnapshotId | VolumeSnapshotsEndpoint VolumeId | VolumesActionsEndpoint | VolumeActionEndpoint VolumeId ActionId | VolumeActionsEndpoint VolumeId | CertificateEndpoint CertificateId | CertificatesEndpoint | DomainEndpoint DomainName | DomainRecordsEndpoint DomainName | DomainRecordEndpoint DomainName DomainRecordId | ImageActionsEndpoint ImageId | ImageActionEndpoint ImageId ActionId | ImageEndpoint ImageId | ImageBySlugEndpoint String | DropletEndpoint DropletId | DropletKernelsEndpoint DropletId | DropletSnapshotsEndpoint DropletId | DropletBackupsEndpoint DropletId | DropletActionsEndpoint DropletId | DropletNeighborsEndpoint DropletId | DropletsActionsEndpoint | DropletActionEndpoint DropletId ActionId | FloatingIpEndpoint IpAddress | FloatingIpActionsEndpoint IpAddress | FloatingIpActionEndpoint IpAddress ActionId | FirewallEndpoint FirewallId | FirewallDropletsEndpoint FirewallId | FirewallTagsEndpoint FirewallId | FirewallRulesEndpoint FirewallId | LoadBalancerEndpoint LoadBalancerId | LoadBalancerDropletsEndpoint LoadBalancerId | LoadBalancerForwardingRulesEndpoint LoadBalancerId | SSHKeyEndpoint SSHKeyId | SSHKeyWithFingerprintEndpoint String instance Show Endpoint where show AccountEndpoint = "account" show ActionsEndpoint = "actions" show RegionsEndpoint = "regions" show VolumesEndpoint = "volumes" show SnapshotsEndpoint = "snapshots" show CertificatesEndpoint = "certificates" show DomainsEndpoint = "domains" show ImagesEndpoint = "images" show SizesEndpoint = "sizes" show DropletsEndpoint = "droplets" show RecordsEndpoint = "records" show KernelsEndpoint = "kernels" show BackupsEndpoint = "backups" show NeighborsEndpoint = "neighbors" show DropletsNeighborsEndpoint = "reports/droplet_neighbors" show FloatingIpsEndpoint = "floating_ips" show TagsEndpoint = "tags" show RulesEndpoint = "rules" show FirewallsEndpoint = "firewalls" show LoadBalancersEndpoint = "load_balancers" show ForwardingRulesEndpoint = "forwarding_rules" show KeysEndpoint = "keys" show SSHKeysEndpoint = show AccountEndpoint show KeysEndpoint show (ActionEndpoint id') = show ActionsEndpoint show id' show (VolumeEndpoint id') = show VolumesEndpoint id' show (SnapshotEndpoint id') = show SnapshotsEndpoint id' show (VolumeSnapshotsEndpoint id') = show VolumesEndpoint id' show SnapshotsEndpoint show VolumesActionsEndpoint = show VolumesEndpoint show SnapshotsEndpoint show (VolumeActionsEndpoint vId) = show VolumesEndpoint vId show ActionsEndpoint show (VolumeActionEndpoint vId aId) = show VolumesEndpoint vId show ActionsEndpoint show aId show (CertificateEndpoint id') = show CertificatesEndpoint id' show (DomainEndpoint name') = show DomainsEndpoint name' show (DomainRecordsEndpoint name') = show (DomainEndpoint name') show RecordsEndpoint show (DomainRecordEndpoint d' dr') = show (DomainEndpoint d') show RecordsEndpoint show dr' show (ImageActionsEndpoint id') = show ImagesEndpoint show id' show ActionsEndpoint show (ImageActionEndpoint iId aId) = show ImagesEndpoint show iId show ActionsEndpoint show aId show (ImageEndpoint id') = show ImagesEndpoint show id' show (ImageBySlugEndpoint name') = show ImagesEndpoint name' show (DropletEndpoint id') = show DropletsEndpoint show id' show (DropletKernelsEndpoint id') = show DropletsEndpoint show id' show KernelsEndpoint show (DropletSnapshotsEndpoint id') = show DropletsEndpoint show id' show SnapshotsEndpoint show (DropletBackupsEndpoint id') = show DropletsEndpoint show id' show BackupsEndpoint show (DropletActionsEndpoint id') = show DropletsEndpoint show id' show ActionsEndpoint show (DropletNeighborsEndpoint id') = show DropletsEndpoint show id' show NeighborsEndpoint show DropletsActionsEndpoint = show DropletsEndpoint show ActionsEndpoint show (DropletActionEndpoint dId aId) = show DropletsEndpoint show dId show ActionsEndpoint show aId show (FloatingIpEndpoint ipAddr) = show FloatingIpsEndpoint ipAddr show (FloatingIpActionsEndpoint ipAddr) = show FloatingIpsEndpoint ipAddr show ActionsEndpoint show (FloatingIpActionEndpoint ipAddr aId) = show FloatingIpsEndpoint ipAddr show ActionsEndpoint show aId show (FirewallEndpoint id') = show FirewallsEndpoint id' show (FirewallDropletsEndpoint id') = show FirewallsEndpoint id' show DropletsEndpoint show (FirewallTagsEndpoint id') = show FirewallsEndpoint id' show TagsEndpoint show (FirewallRulesEndpoint id') = show FirewallsEndpoint id' show RulesEndpoint show (LoadBalancerEndpoint id') = show FirewallsEndpoint id' show (LoadBalancerDropletsEndpoint id') = show FirewallsEndpoint id' show DropletsEndpoint show (LoadBalancerForwardingRulesEndpoint id') = show FirewallsEndpoint id' show ForwardingRulesEndpoint show (SSHKeyEndpoint id') = show SSHKeysEndpoint show id' show (SSHKeyWithFingerprintEndpoint f) = show SSHKeysEndpoint f type VolumeId = String type ActionId = Int type CertificateId = String type SnapshotId = String type DomainName = String type DomainRecordId = Int type DropletId = Int type RegionSlug = String type ImageId = Int type DropletName = String type IpAddress = String type FirewallId = String type LoadBalancerId = String type SSHKeyId = Int