diff --git a/DOH.cabal b/DOH.cabal new file mode 100644 --- /dev/null +++ b/DOH.cabal @@ -0,0 +1,84 @@ +-- Initial DO.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: DOH +version: 0.1.0.0 +synopsis: A complete API wrapper for DigitalOcean API V2 +description: A complete API wrapper for DigitalOcean API V2 + . + To get started, see @Network.DigitalOcean@ module below. +license: MIT +license-file: LICENSE +author: Yiğit Özkavcı +maintainer: yigitozkavci8@gmail.com +-- copyright: +category: Network +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/inzva/DigitalOcean.hs +library + exposed-modules: Network.DigitalOcean + Network.DigitalOcean.Http, + Network.DigitalOcean.Types, + Network.DigitalOcean.Utils.Actions, + Network.DigitalOcean.Utils.Pagination, + Network.DigitalOcean.Services, + Network.DigitalOcean.Services.Account, + Network.DigitalOcean.Services.Action, + Network.DigitalOcean.Services.Certificate, + Network.DigitalOcean.Services.Domain, + Network.DigitalOcean.Services.DomainRecord, + Network.DigitalOcean.Services.Droplet, + Network.DigitalOcean.Services.Firewall, + Network.DigitalOcean.Services.FloatingIp, + Network.DigitalOcean.Services.Image, + Network.DigitalOcean.Services.LoadBalancer, + Network.DigitalOcean.Services.Region, + Network.DigitalOcean.Services.Size, + Network.DigitalOcean.Services.Snapshot, + Network.DigitalOcean.Services.SSHKey, + Network.DigitalOcean.Services.Volume + -- other-modules: + -- other-extensions: + build-depends: base >=4.9 && <4.10, + mtl, + text, + http-client, + http-types, + http-client-tls, + bytestring, + uri, + aeson, + aeson-casing, + time, + lens, + containers, + filepath, + unordered-containers + hs-source-dirs: src + default-language: Haskell2010 + +test-suite do-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-depends: base >=4.9 && <4.10, + mtl, + text, + http-client, + http-types, + http-client-tls, + bytestring, + uri, + aeson, + time, + aeson-casing, + lens, + QuickCheck, + quickcheck-instances, + interpolatedstring-perl6, + filepath + hs-source-dirs: src, test diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,2 @@ +# DigitalOcean.hs +Haskell bindings for DigitalOcean API v2 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Network/DigitalOcean.hs b/src/Network/DigitalOcean.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean.hs @@ -0,0 +1,413 @@ +{-| +Module : DigitalOcean +Description : This module is where user shall interract with the whole API +Copyright : (c) Yiğit Özkavcı, 2017 +License : MIT +Maintainer : yigitozkavci8@gmail.com +Stability : beta +Portability : POSIX + +Every computation within this module should be assessed via `DO` monad. + +An example usage: + +@ +{-\# LANGUAGE OverloadedStrings \#-} + +module Main where + +import 'Network.DigitalOcean' +import Control.Monad.Except +import Control.Monad.Reader + +client :: 'Client' +client = 'Client' \"my api key\" + +main :: IO () +main = do + result <- runExceptT $ (runReaderT $ \"runDO\" doActions) client + case result of + Left err -> print err + Right _ -> return () + +createViaSshKeys :: 'DO' () +createViaSshKeys = do + -- Read a public key from a key pair and create ssh keys on DigitalOcean with it + pubKey <- liftIO $ readFile \"\/Users\/yigitozkavci\/.ssh\/do_api_rsa.pub\" + sshKey <- 'createSSHKey' ('SSHKeyPayload' \"my ssh key\" pubKey) + + -- Create 2 droplets with our newly uploaded ssh keys + let dropletPayload = 'IDropletPayload' \"nyc3\" \"512mb\" \"ubuntu-14-04-x64\" (Just [sshkeyFingerprint sshKey]) Nothing Nothing Nothing Nothing Nothing Nothing Nothing + droplets <- map dropletId <$\> 'createDroplets' ["droplet-1", "droplet-2"] dropletPayload + + -- Take snapshot of our newly created droplets + forM_ droplets $ \dropletId -> 'performDropletAction' dropletId ('TakeSnapshot' (Just "bulk snapshot")) +@ +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Network.DigitalOcean where + +----------------------------------------------------------------- +import Data.Maybe (maybe) +import Data.Monoid ((<>)) +import Control.Lens +import Data.List (intercalate) +import Control.Monad +import Control.Monad.Reader +import Control.Monad.Except +import Data.Bool (bool) +import qualified Data.Set as Set +----------------------------------------------------------------- +import Network.DigitalOcean.Types +import Network.DigitalOcean.Http +import Network.DigitalOcean.Utils.Pagination +import Network.DigitalOcean.Services +----------------------------------------------------------------- + +-- * Account +getAccounts :: DO Account +getAccounts = unResponse <$> get' AccountEndpoint + +-- * Actions +getActions :: Maybe PaginationConfig -> DO [Action] +getActions config = getPaginated config ActionsEndpoint Nothing + +getAction :: ActionId -> DO Action +getAction id' = + unResponse <$> get' (ActionEndpoint id') + +-- * Regions +getRegions :: DO [Region] +getRegions = + unResponse <$> get' RegionsEndpoint + +-- * Volumes +getVolumes :: DO [Volume] +getVolumes = + unResponse <$> get' VolumesEndpoint + +getVolume :: VolumeId -> DO Volume +getVolume id' = + unResponse <$> get' (VolumeEndpoint id') + +createVolume :: VolumePayload -> DO Volume +createVolume = + fmap unResponse . post VolumesEndpoint Nothing + +getVolumesByName :: String -> String -> DO [Volume] +getVolumesByName region name = + let queryParams = Just [("name", name), ("region", region)] in + unResponse <$> get VolumesEndpoint queryParams + +deleteVolume :: VolumeId -> DO () +deleteVolume id' = + delete' (VolumeEndpoint id') + +deleteVolumeByName :: String -> String -> DO () +deleteVolumeByName region name = + delete VolumesEndpoint (Just [("name", name), ("region", region)]) EmptyPayload + +performSingleVolumeAction :: VolumeId -> VolumeAction -> DO Action +performSingleVolumeAction volumeId action = + unResponse <$> post (VolumeActionsEndpoint volumeId) Nothing action + +performListVolumeAction :: VolumeAction -> DO Action +performListVolumeAction action = + unResponse <$> post VolumesActionsEndpoint Nothing action + +performVolumeAction :: VolumeAction -> DO Action +performVolumeAction action@(Attach volumeId _ _) = performSingleVolumeAction volumeId action +performVolumeAction action@(Detach volumeId _ _) = performSingleVolumeAction volumeId action +performVolumeAction action@(ResizeVolume volumeId _ _) = performSingleVolumeAction volumeId action +performVolumeAction action@AttachByName {} = performListVolumeAction action +performVolumeAction action@DetachByName {} = performListVolumeAction action + +getVolumeActions :: VolumeId -> DO [Action] +getVolumeActions volumeId = + unResponse <$> get' (VolumeActionsEndpoint volumeId) + +getVolumeAction :: VolumeId -> ActionId -> DO Action +getVolumeAction volumeId actionId = + unResponse <$> get' (VolumeActionEndpoint volumeId actionId) + +-- * Snapshots +data ResourceType = VolumeResource + | DropletResource + +instance Show ResourceType where + show VolumeResource = "volume" + show DropletResource = "droplet" + +getSnapshots :: Maybe ResourceType -> DO [Snapshot] +getSnapshots resourceType = do + let queryParams = ((:[]) . ("resource_type",) . show) <$> resourceType + unResponse <$> get SnapshotsEndpoint queryParams + +getSnapshot :: SnapshotId -> DO Snapshot +getSnapshot id' = + unResponse <$> get' (SnapshotEndpoint id') + +deleteSnapshot :: SnapshotId -> DO () +deleteSnapshot id' = + delete' (SnapshotEndpoint id') + +getSnapshotsOfVolume :: VolumeId -> DO [Snapshot] +getSnapshotsOfVolume volumeId = + unResponse <$> get' (VolumeSnapshotsEndpoint volumeId) + +createSnapshotOfVolume :: VolumeId -> SnapshotPayload -> DO Snapshot +createSnapshotOfVolume volumeId = + fmap unResponse . post (VolumeSnapshotsEndpoint volumeId) Nothing + +-- * Certificates +createCertificate :: Certificatepayload -> DO Certificate +createCertificate = fmap unResponse . post CertificatesEndpoint Nothing + +getCertificate :: CertificateId -> DO Certificate +getCertificate id' = + unResponse <$> get' (CertificateEndpoint id') + +getCertificates :: Maybe PaginationConfig -> DO [Certificate] +getCertificates config = getPaginated config CertificatesEndpoint Nothing + +deleteCertificate :: CertificateId -> DO () +deleteCertificate id' = delete' (CertificateEndpoint id') + +-- * Domains +getDomains :: DO [Domain] +getDomains = + unResponse <$> get' DomainsEndpoint + +getDomain :: DomainName -> DO Domain +getDomain name' = + unResponse <$> get' (DomainEndpoint name') + +createDomain :: DomainPayload -> DO Domain +createDomain = fmap unResponse . post DomainsEndpoint Nothing + +deleteDomain :: DomainName -> DO () +deleteDomain name' = delete' (DomainEndpoint name') + +-- * Domain Records +getDomainRecords :: DomainName -> DO [DomainRecord] +getDomainRecords domainName' = + unResponse <$> get' (DomainRecordsEndpoint domainName') + +createDomainRecord :: DomainName -> DomainRecordPayload -> DO DomainRecord +createDomainRecord domainName' = + fmap unResponse . post (DomainRecordsEndpoint domainName') Nothing + +getDomainRecord :: DomainName -> DomainRecordId -> DO DomainRecord +getDomainRecord dn' drid' = + unResponse <$> get' (DomainRecordEndpoint dn' drid') + +updateDomainRecord :: DomainName -> DomainRecordId -> DomainRecordPayload -> DO DomainRecord +updateDomainRecord dn' drid' = + fmap unResponse . put (DomainRecordEndpoint dn' drid') Nothing + +deleteDomainRecord :: DomainName -> DomainRecordId -> DO () +deleteDomainRecord dn' drid' = + delete' (DomainRecordEndpoint dn' drid') + +-- * Images +getImages :: Maybe PaginationConfig -> ImageOptions -> DO [Image] +getImages config ImageOptions {..} = + getPaginated config ImagesEndpoint (Just queryParams) + where + queryParams = + maybe [] ((:[]) . ("type",) . show) imageType' ++ + bool [] [("private", "true")] isPrivate + +getImageActions :: ImageId -> DO [Action] +getImageActions id' = + unResponse <$> get' (ImageActionsEndpoint id') + +getImageAction :: ImageId -> ActionId -> DO Action +getImageAction imageId actionId = unResponse <$> get' (ImageActionEndpoint imageId actionId) + +getImage :: ImageId -> DO [Image] +getImage id' = + unResponse <$> get' (ImageEndpoint id') + +getImageBySlug :: String -> DO [Image] +getImageBySlug slug = unResponse <$> get' (ImageBySlugEndpoint slug) + +updateImage :: ImageId -> ImagePayload -> DO Image +updateImage id' = fmap unResponse . put (ImageEndpoint id') Nothing + +deleteImage :: ImageId -> DO () +deleteImage id' = delete' (ImageEndpoint id') + +performImageAction :: ImageId -> ImageAction -> DO Action +performImageAction id' = fmap unResponse . post (ImageActionsEndpoint id') Nothing + +-- * Sizes +getSizes :: DO [Size] +getSizes = unResponse <$> get' SizesEndpoint + +-- * Droplets +getDroplets :: Maybe PaginationConfig -> DO [Droplet] +getDroplets config = getPaginated config DropletsEndpoint Nothing + +createDroplet :: DropletName -> IDropletPayload -> DO Droplet +createDroplet name payload = unResponse <$> post DropletsEndpoint Nothing (SingleDropletPayload name payload) + +createDroplets :: [DropletName] -> IDropletPayload -> DO [Droplet] +createDroplets names payload = unResponse <$> post DropletsEndpoint Nothing (MultipleDropletPayload names payload) + +getDroplet :: DropletId -> DO Droplet +getDroplet id' = unResponse <$> get' (DropletEndpoint id') + +getDropletsByTag :: String -> DO [Droplet] +getDropletsByTag tag = unResponse <$> get DropletsEndpoint (Just [("tag_name", tag)]) + +getDropletKernels :: DropletId -> DO [Kernel] +getDropletKernels id' = unResponse <$> get' (DropletKernelsEndpoint id') + +getDropletSnapshots :: DropletId -> DO [Snapshot] +getDropletSnapshots id' = unResponse <$> get' (DropletSnapshotsEndpoint id') + +getDropletBackups :: DropletId -> DO [Backup] +getDropletBackups id' = unResponse <$> get' (DropletBackupsEndpoint id') + +getDropletActions :: DropletId -> DO [Action] +getDropletActions id' = unResponse <$> get' (DropletActionsEndpoint id') + +deleteDroplet :: DropletId -> DO () +deleteDroplet id' = delete' (DropletEndpoint id') + +deleteDropletByTag :: String -> DO () +deleteDropletByTag tag = delete DropletsEndpoint (Just [("tag_name", tag)]) EmptyPayload + +getDropletNeighbors :: DropletId -> DO [Droplet] +getDropletNeighbors id' = unResponse <$> get' (DropletNeighborsEndpoint id') + +getNeighbors :: DO Neighbors +getNeighbors = unResponse <$> get' DropletsNeighborsEndpoint + +performDropletAction :: DropletId -> DropletAction -> DO Action +performDropletAction id' = fmap unResponse . post (DropletActionsEndpoint id') Nothing + +{- Warning! Currently has issue with the response format, see: + - https://github.com/digitalocean/api-v2/issues/164 + -} +performDropletActionOnTag :: String -> DropletAction -> DO [Action] +performDropletActionOnTag tag action = do + unless (actionAllowedAsBulk action) $ + throwError $ + "Action " ++ show action ++ " not allowed as bulk. See \ + \https://developers.digitalocean.com/documentation/v2/#acting-on-tagged-droplets" + unResponse <$> post DropletsActionsEndpoint (Just [("tag_name", tag)]) action + +getDropletAction :: DropletId -> ActionId -> DO Action +getDropletAction dropletId actionId = unResponse <$> get' (DropletActionEndpoint dropletId actionId) + +-- * Floating IPs +getFloatingIps :: DO [FloatingIp] +getFloatingIps = unResponse <$> get' FloatingIpsEndpoint + +createFloatingIp :: FloatingIpPayload -> DO FloatingIp +createFloatingIp = fmap unResponse . post FloatingIpsEndpoint Nothing + +getFloatingIp :: IpAddress -> DO FloatingIp +getFloatingIp ip = unResponse <$> get' (FloatingIpEndpoint ip) + +deleteFloatingIp :: IpAddress -> DO () +deleteFloatingIp ip = delete' (FloatingIpEndpoint ip) + +performFloatingIpAction :: IpAddress -> FloatingIpAction -> DO Action +performFloatingIpAction ip = fmap unResponse . post (FloatingIpActionsEndpoint ip) Nothing + +getFloatingIpActions :: IpAddress -> DO [Action] +getFloatingIpActions ip = unResponse <$> get' (FloatingIpActionsEndpoint ip) + +getFloatingIpAction :: IpAddress -> ActionId -> DO Action +getFloatingIpAction ip aId = unResponse <$> get' (FloatingIpActionEndpoint ip aId) + +-- * Firewalls +createFirewall :: FirewallPayload -> DO Firewall +createFirewall = fmap unResponse . post FirewallsEndpoint Nothing + +getFirewall :: FirewallId -> DO Firewall +getFirewall id' = unResponse <$> get' (FirewallEndpoint id') + +getFirewalls :: DO [Firewall] +getFirewalls = unResponse <$> get' FirewallsEndpoint + +updateFirewall :: FirewallId -> FirewallPayload -> DO Firewall +updateFirewall id' = fmap unResponse . put (FirewallEndpoint id') Nothing + +deleteFirewall :: FirewallId -> DO () +deleteFirewall id' = delete' (FirewallEndpoint id') + +addDropletsToFirewall :: FirewallId -> DropletsPayload -> DO () +addDropletsToFirewall id' = fmap unResponse . post (FirewallDropletsEndpoint id') Nothing + +removeDropletsFromFirewall :: FirewallId -> DropletsPayload -> DO () +removeDropletsFromFirewall id' = delete (FirewallDropletsEndpoint id') Nothing + +addTagsToFirewall :: FirewallId -> TagsPayload -> DO () +addTagsToFirewall id' = fmap unResponse . post (FirewallTagsEndpoint id') Nothing + +removeTagsFromFirewall :: FirewallId -> TagsPayload -> DO () +removeTagsFromFirewall id' = delete (FirewallTagsEndpoint id') Nothing + +addRulesToFirewall :: FirewallId -> FirewallRulesPayload -> DO () +addRulesToFirewall id' = fmap unResponse . post (FirewallRulesEndpoint id') Nothing + +removeRulesFromFirewall :: FirewallId -> FirewallRulesPayload -> DO () +removeRulesFromFirewall id' = delete (FirewallRulesEndpoint id') Nothing + +-- * Load Balancers +createLoadBalancer :: LoadBalancerPayload -> DO LoadBalancer +createLoadBalancer = fmap unResponse . post LoadBalancersEndpoint Nothing + +getLoadBalancer :: LoadBalancerId -> DO LoadBalancer +getLoadBalancer id' = unResponse <$> get' (LoadBalancerEndpoint id') + +getLoadBalancers :: DO [LoadBalancer] +getLoadBalancers = unResponse <$> get' LoadBalancersEndpoint + +updateLoadBalancer :: LoadBalancerPayload -> DO LoadBalancer +updateLoadBalancer = fmap unResponse . put LoadBalancersEndpoint Nothing + +deleteLoadBalancer :: LoadBalancerId -> DO () +deleteLoadBalancer id' = delete' (LoadBalancerEndpoint id') + +addDropletsToLoadBalancer :: LoadBalancerId -> DropletsPayload -> DO () +addDropletsToLoadBalancer id' = post (LoadBalancerDropletsEndpoint id') Nothing + +removeDropletsFromLoadBalancer :: LoadBalancerId -> DropletsPayload -> DO () +removeDropletsFromLoadBalancer id' = delete (LoadBalancerDropletsEndpoint id') Nothing + +addForwardingRulesToLoadBalancer :: LoadBalancerId -> [ForwardingRule] -> DO () +addForwardingRulesToLoadBalancer id' = post (LoadBalancerForwardingRulesEndpoint id') Nothing + +removeForwardingRulesFromLoadBalancer :: LoadBalancerId -> [ForwardingRule] -> DO () +removeForwardingRulesFromLoadBalancer id' = delete (LoadBalancerForwardingRulesEndpoint id') Nothing + +-- * SSH Keys +getSSHKeys :: DO [SSHKey] +getSSHKeys = unResponse <$> get' SSHKeysEndpoint + +createSSHKey :: SSHKeyPayload -> DO SSHKey +createSSHKey = fmap unResponse . post SSHKeysEndpoint Nothing + +getSSHKey :: Either SSHKeyId String -> DO SSHKey +getSSHKey idn = get' $ case idn of + Left id' -> SSHKeyEndpoint id' + Right fingerprint -> SSHKeyWithFingerprintEndpoint fingerprint + +updateSSHKey :: Either SSHKeyId String -> String -> DO SSHKey +updateSSHKey idn name = + unResponse <$> + put (either SSHKeyEndpoint SSHKeyWithFingerprintEndpoint idn) Nothing (SSHKeyNamePayload name) + +destroySSHKey :: Either SSHKeyId String -> DO () +destroySSHKey = delete' . either SSHKeyEndpoint SSHKeyWithFingerprintEndpoint diff --git a/src/Network/DigitalOcean/Http.hs b/src/Network/DigitalOcean/Http.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Http.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Network.DigitalOcean.Http where + +----------------------------------------------------------------- +import qualified Data.Text as T +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as LBS +import Network.HTTP.Client hiding (Proxy) +import Network.HTTP.Client.TLS +import System.FilePath (()) +import Data.Aeson +import Data.Proxy +import Data.Monoid +import Data.Bool (bool) +import Control.Monad +import Control.Monad.Reader +import Control.Monad.Except +import Data.Maybe +import Network.HTTP.Types.Status (statusCode) +import Text.URI +----------------------------------------------------------------- +import Network.DigitalOcean.Types +import Network.DigitalOcean.Utils.Pagination +----------------------------------------------------------------- + +baseURI :: String +baseURI = "https://api.digitalocean.com/v2" + +type ReqWithPayload a = forall p. (Payload p) => Endpoint -> Maybe QueryParams -> p -> DO a +type ReqWithoutPayload a = Endpoint -> Maybe QueryParams -> DO a + +makeRequest :: forall proxy p a. (FromJSON a, Payload p) => RequestMethod -> String -> Maybe QueryParams -> Maybe p -> DO a +makeRequest method uri queryParams mbPayload = do + client <- ask + let uri' = uri <> maybe mempty showQueryParams queryParams + when (isNothing $ parseURI uri') $ throwError $ "URI cannot be parsed: " <> uri' + manager <- liftIO newTlsManager + initialRequest <- liftIO $ parseRequest uri' + let request = initialRequest { method = BSC.pack $ show method + , requestHeaders = [ ("Authorization", "Bearer " `BS.append` apiKey client) + , ("Content-Type", "application/json") + ] + } + let request' = maybe request (\payload -> request { requestBody = RequestBodyLBS (encode payload) }) mbPayload + response <- liftIO $ httpLbs request' manager + let respStatus = statusCode $ responseStatus response + when (respStatus < 200 || respStatus > 300) $ throwError $ "Non-success response: " <> show respStatus <> "Body:" <> show (responseBody response) + let body = bool (responseBody response) "[]" (respStatus == 204) + case (eitherDecode body :: Either String a) of + Left err -> throwError $ "Error occured for response body:" <> BSC.unpack (LBS.toStrict $ responseBody response) <> err + Right resource -> return resource + +{- `get` that is working with absolute uris -} +getA :: forall a. FromJSON a => String -> Maybe QueryParams -> DO a +getA uri queryParams = makeRequest Get uri queryParams (Just EmptyPayload) + +get :: FromJSON a => ReqWithoutPayload a +get endp = getA (baseURI show endp) + +get' :: FromJSON a => Endpoint -> DO a +get' endp = get endp Nothing + +post :: forall a. (FromJSON a) => ReqWithPayload a +post endp q' payload = makeRequest Post (baseURI show endp) q' (Just payload) + +delete :: ReqWithPayload () +delete endp q' payload = makeRequest Delete (baseURI show endp) q' (Just payload) + +delete' :: Endpoint -> DO () +delete' endp = delete endp Nothing EmptyPayload + +put :: forall a. (FromJSON a) => ReqWithPayload a +put endp q' payload = makeRequest Put (baseURI show endp) q' (Just payload) + +getPaginated :: forall a. Paginatable a => Maybe PaginationConfig -> ReqWithoutPayload [a] +getPaginated config endp q' = do + let queryParams = paginationQueryParams config ++ + fromMaybe [] q' + pagination <- get endp (Just queryParams) + curr <$> paginateUntil (fromMaybe defaultPaginationConfig config) pagination (\url -> getA (addPaginationParam url) Nothing) + where + addPaginationParam = (<> maybe mempty (<> "&page_size=") (show . pageSize <$> config)) diff --git a/src/Network/DigitalOcean/Services.hs b/src/Network/DigitalOcean/Services.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services.hs @@ -0,0 +1,33 @@ +module Network.DigitalOcean.Services ( + module Network.DigitalOcean.Services.Region + , module Network.DigitalOcean.Services.Action + , module Network.DigitalOcean.Services.Account + , module Network.DigitalOcean.Services.Volume + , module Network.DigitalOcean.Services.Snapshot + , module Network.DigitalOcean.Services.Certificate + , module Network.DigitalOcean.Services.Domain + , module Network.DigitalOcean.Services.DomainRecord + , module Network.DigitalOcean.Services.Image + , module Network.DigitalOcean.Services.Size + , module Network.DigitalOcean.Services.Droplet + , module Network.DigitalOcean.Services.FloatingIp + , module Network.DigitalOcean.Services.Firewall + , module Network.DigitalOcean.Services.LoadBalancer + , module Network.DigitalOcean.Services.SSHKey +) where + +import Network.DigitalOcean.Services.Region +import Network.DigitalOcean.Services.Action +import Network.DigitalOcean.Services.Account +import Network.DigitalOcean.Services.Volume +import Network.DigitalOcean.Services.Snapshot +import Network.DigitalOcean.Services.Certificate +import Network.DigitalOcean.Services.Domain +import Network.DigitalOcean.Services.DomainRecord +import Network.DigitalOcean.Services.Image +import Network.DigitalOcean.Services.Size +import Network.DigitalOcean.Services.Droplet +import Network.DigitalOcean.Services.FloatingIp +import Network.DigitalOcean.Services.Firewall +import Network.DigitalOcean.Services.LoadBalancer +import Network.DigitalOcean.Services.SSHKey diff --git a/src/Network/DigitalOcean/Services/Account.hs b/src/Network/DigitalOcean/Services/Account.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/Account.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.DigitalOcean.Services.Account where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +----------------------------------------------------------------- + +data Account = Account + { accountDropletLimit :: Int + , accountFloatingIpLimit :: Int + , accountEmail :: String + , accountUuid :: String + , accountEmailVerified :: Bool + , accountStatus :: String + , accountStatusMessage :: String + } deriving (Show, Generic) + +instance FromJSON (Response Account) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "account") + +instance FromJSON Account where + parseJSON = genericParseJSON $ aesonPrefix snakeCase diff --git a/src/Network/DigitalOcean/Services/Action.hs b/src/Network/DigitalOcean/Services/Action.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/Action.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} + +module Network.DigitalOcean.Services.Action where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import Data.Time.Clock +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +import Network.DigitalOcean.Utils.Pagination +----------------------------------------------------------------- + +data Action = Action + { actionId :: ActionId + , actionStatus :: String -- TODO: Make a type + , actionType :: String + , actionStartedAt :: UTCTime + , actionCompletedAt :: Maybe UTCTime + , actionResourceId :: Int + , actionResourceType :: String -- TODO: Make a type + , actionRegionSlug :: Maybe String + } deriving (Show, Generic) + +instance FromJSON (Response Action) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "action") + +instance FromJSON (Response [Action]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "actions") + +instance FromJSON Action where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance FromJSON (PaginationState Action) where + parseJSON (Object v) = parsePaginationState v "actions" + +instance Paginatable Action where diff --git a/src/Network/DigitalOcean/Services/Certificate.hs b/src/Network/DigitalOcean/Services/Certificate.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/Certificate.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} + +module Network.DigitalOcean.Services.Certificate where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import Data.Time.Clock +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +import Network.DigitalOcean.Utils.Pagination +import Network.DigitalOcean.Services.Action +----------------------------------------------------------------- + +data Certificate = Certificate + { certificateId :: CertificateId + , certificateName :: String + , certificateNotAfter :: String + , certificateSha1Fingerprint :: String + , certificateCreatedAt :: UTCTime + } deriving (Show, Generic) + +instance FromJSON (Response Certificate) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "certificate") + +instance FromJSON (Response [Certificate]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "certificates") + +instance FromJSON Certificate where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance FromJSON (PaginationState Certificate) where + parseJSON (Object v) = parsePaginationState v "certificates" + +instance Paginatable Certificate where + +data Certificatepayload = Certificatepayload + { certificatepayloadName :: String + , certificatepayloadPrivateKey :: String + , certificatepayloadLeafCertificate :: String + , certificatepayloadCertificateChain :: Maybe String + } deriving (Show, Generic) + +instance ToJSON Certificatepayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload Certificatepayload diff --git a/src/Network/DigitalOcean/Services/Domain.hs b/src/Network/DigitalOcean/Services/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/Domain.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} + +module Network.DigitalOcean.Services.Domain where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import Data.Time.Clock +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +import Network.DigitalOcean.Utils.Pagination +import Network.DigitalOcean.Services.Action +----------------------------------------------------------------- + +data Domain = Domain + { domainName :: String + , domainTtl :: String + , domainZoneFile :: String + } deriving (Show, Generic) + +instance FromJSON (Response Domain) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "domain") + +instance FromJSON (Response [Domain]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "domains") + +instance FromJSON Domain where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance FromJSON (PaginationState Domain) where + parseJSON (Object v) = parsePaginationState v "domains" + +instance Paginatable Domain + +data DomainPayload = DomainPayload + { domainpayloadName :: String + , domainpayloadIpAddress :: String + } deriving (Show, Generic) + +instance ToJSON DomainPayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload DomainPayload diff --git a/src/Network/DigitalOcean/Services/DomainRecord.hs b/src/Network/DigitalOcean/Services/DomainRecord.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/DomainRecord.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} + +module Network.DigitalOcean.Services.DomainRecord where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +import Network.DigitalOcean.Utils.Pagination +import Network.DigitalOcean.Services.Action +----------------------------------------------------------------- + +data DomainRecord = DomainRecord + { domainrecordId :: Int + , domainrecordType :: String + , domainrecordName :: String + , domainrecordData :: String + , domainrecordPriority :: Maybe Int + , domainrecordPort :: Maybe Int + , domainrecordTtl :: Int + , domainrecordWeight :: Maybe Int + } deriving (Show, Generic) + +instance FromJSON (Response DomainRecord) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "domain_record") + +instance FromJSON (Response [DomainRecord]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "domain_records") + +instance FromJSON DomainRecord where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance FromJSON (PaginationState DomainRecord) where + parseJSON (Object v) = parsePaginationState v "domain_records" + +instance Paginatable DomainRecord + +data DomainRecordPayload = DomainRecordPayload + { domainrecordpayloadType :: String + , domainrecordpayloadName :: Maybe String + , domainrecordpayloadData :: Maybe String + , domainrecordpayloadPriority :: Maybe Int + , domainrecordpayloadPort :: Maybe Int + , domainrecordpayloadTtl :: Maybe Int + , domainrecordpayloadWeight :: Maybe Int + } deriving (Show, Generic) + +instance ToJSON DomainRecordPayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload DomainRecordPayload + diff --git a/src/Network/DigitalOcean/Services/Droplet.hs b/src/Network/DigitalOcean/Services/Droplet.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/Droplet.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} + +module Network.DigitalOcean.Services.Droplet where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import GHC.Generics +import Data.Time.Clock +import Data.Map +import qualified Data.HashMap.Lazy as HML +----------------------------------------------------------------- +import Network.DigitalOcean.Types +import Network.DigitalOcean.Utils.Pagination +import Network.DigitalOcean.Utils.Actions +import Network.DigitalOcean.Services.Region +import Network.DigitalOcean.Services.Image +import Network.DigitalOcean.Services.Size +----------------------------------------------------------------- + +data Kernel = Kernel + { kernelId :: Int + , kernelName :: String + , kernelVersion :: String + } deriving (Show, Generic) + +instance FromJSON Kernel where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance FromJSON (Response [Kernel]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "kernels") + +----------------------------------------------------------------- + +data DropletStatus = + New + | Active + | Off + | Archive + deriving (Show, Generic) + +instance FromJSON DropletStatus where + parseJSON "new" = return New + parseJSON "active" = return Active + parseJSON "off" = return Off + parseJSON "archive" = return Archive + +----------------------------------------------------------------- + +data Network = Network + { networkIpAddress :: IpAddress + , networkNetmask :: IpAddress + , networkGateway :: IpAddress + , networkType :: String -- ^ Whether there is another type of network is available is not documented in DO API. + } deriving (Show, Generic) + +instance FromJSON Network where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +data Networks = Networks + { v4 :: [Network] + , v6 :: [Network] + } deriving (Show) + +instance FromJSON Networks where + parseJSON (Object v) = Networks + <$> v .: "v4" + <*> v .: "v6" + +----------------------------------------------------------------- + +newtype Backup = Backup Image + deriving Show + +instance FromJSON Backup where + parseJSON v = Backup <$> parseJSON v + +instance FromJSON (Response [Backup]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "backups") + +----------------------------------------------------------------- + +newtype Neighbors = Neighbors [[Droplet]] + deriving Show + +instance FromJSON Neighbors where + parseJSON v = Neighbors <$> parseJSON v + +instance FromJSON (Response Neighbors) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "neighbors") + +----------------------------------------------------------------- + +data Droplet = Droplet + { dropletId :: DropletId + , dropletName :: String + , dropletMemory :: Int + , dropletVcpus :: Int + , dropletDisk :: Int + , dropletLocked :: Bool + , dropletCreatedAt :: UTCTime + , dropletStatus :: DropletStatus + , dropletBackupIds :: [Int] + , dropletSnapshotIds :: [SnapshotId] + , dropletFeatures :: [String] + , dropletRegion :: Region + , dropletImage :: Image + , dropletSize :: Size + , dropletSizeSlug :: String + , dropletNetworks :: Networks + , dropletKernel :: Maybe Kernel + --droplet , nextBackupWindow :: Maybe BackupWindow -- No example for this yet + , dropletTags :: [String] + , dropletVolumeIds :: Maybe [VolumeId] + } deriving (Show, Generic) + +instance FromJSON (Response Droplet) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "droplet") + +instance FromJSON (Response [Droplet]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "droplets") + +instance FromJSON Droplet where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance FromJSON (PaginationState Droplet) where + parseJSON (Object v) = parsePaginationState v "droplets" + +instance Paginatable Droplet + +data DropletPayload = + SingleDropletPayload String IDropletPayload + | MultipleDropletPayload [String] IDropletPayload + +{- https://developers.digitalocean.com/documentation/v2/#create-a-new-droplet -} +data IDropletPayload = IDropletPayload + { dropletpayloadRegion :: String + , dropletpayloadSize :: String + , dropletpayloadImage :: String -- ^ number (if using an image ID), or String (if using a public image slug) + , dropletpayloadSshKeys :: Maybe [String] + , dropletpayloadBackups :: Maybe Bool + , dropletpayloadIpv6 :: Maybe Bool + , dropletpayloadPrivateNetworking :: Maybe Bool + , dropletpayloadUserData :: Maybe String + , dropletpayloadMonitoring :: Maybe Bool + , dropletpayloadVolumes :: Maybe [String] + , dropletpayloadTags :: Maybe [String] + } deriving (Show, Generic) + +instance ToJSON IDropletPayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +mergeAeson :: Value -> Value -> Value +mergeAeson (Object x) (Object y) = Object $ HML.unions [x, y] + +instance ToJSON DropletPayload where + toJSON (SingleDropletPayload name payload) = + object [ "name" .= name ] `mergeAeson` toJSON payload + toJSON (MultipleDropletPayload names payload) = + object [ "names" .= names ] `mergeAeson` toJSON payload + +instance Payload DropletPayload + +----------------------------------------------------------------- + +data DropletAction = + EnableBackups + | DisableBackups + | Reboot + | PowerCycle + | Shutdown + | PowerOff + | PowerOn + | Restore String + | PasswordReset + | ResizeDroplet (Maybe Bool) String + | Rebuild String + | Rename String + | ChangeKernel Int + | EnableIpV6 + | EnablePrivateNetworking + | TakeSnapshot (Maybe String) + deriving (Eq, Show) + +{- Reference: + - https://developers.digitalocean.com/documentation/v2/#acting-on-tagged-droplets + -} +actionAllowedAsBulk :: DropletAction -> Bool +actionAllowedAsBulk PowerCycle = True +actionAllowedAsBulk PowerOn = True +actionAllowedAsBulk PowerOff = True +actionAllowedAsBulk Shutdown = True +actionAllowedAsBulk EnablePrivateNetworking = True +actionAllowedAsBulk EnableIpV6 = True +actionAllowedAsBulk EnableBackups = True +actionAllowedAsBulk DisableBackups = True +actionAllowedAsBulk TakeSnapshot {} = True +actionAllowedAsBulk _ = False + +instance ToJSON DropletAction where + toJSON EnableBackups = object [ actionType' "enable_backups" ] + toJSON DisableBackups = object [ actionType' "disable_backups" ] + toJSON Reboot = object [ actionType' "reboot" ] + toJSON PowerCycle = object [ actionType' "power_cycle" ] + toJSON Shutdown = object [ actionType' "shutdown" ] + toJSON PowerOff = object [ actionType' "power_off" ] + toJSON PowerOn = object [ actionType' "power_on" ] + toJSON (Restore imgId) = object [ actionType' "restore", "image" .= imgId ] + toJSON PasswordReset = object [ actionType' "password_reset" ] + toJSON (ResizeDroplet disk size) = object [ actionType' "resize", "disk" .= disk, "size" .= size ] + toJSON (Rebuild imgId) = object [ actionType' "rebuild", "image" .= imgId ] + toJSON (Rename name) = object [ actionType' "rename", "name" .= name ] + toJSON (ChangeKernel id') = object [ actionType' "change_kernel", "kernel" .= id' ] + toJSON EnableIpV6 = object [ actionType' "enable_ipv6" ] + toJSON EnablePrivateNetworking = object [ actionType' "enable_private_networking" ] + toJSON (TakeSnapshot name) = object [ actionType' "snapshot", "name" .= name ] + +instance Payload DropletAction + diff --git a/src/Network/DigitalOcean/Services/Firewall.hs b/src/Network/DigitalOcean/Services/Firewall.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/Firewall.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} + +module Network.DigitalOcean.Services.Firewall where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import Data.Time.Clock +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +import Network.DigitalOcean.Utils.Pagination +----------------------------------------------------------------- + +data PendingChange = PendingChange + { pendingchangeDropletId :: DropletId + , pendingchangeRemoving :: Bool + , pendingchangeStatus :: String + } deriving (Show, Generic) + +instance FromJSON PendingChange where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +----------------------------------------------------------------- + +data Protocol = + Tcp + | Udp + | Icmp + deriving Show + +instance FromJSON Protocol where + parseJSON (String s) = return $ + case s of + "tcp" -> Tcp + "udp" -> Udp + "icmp" -> Icmp + +instance ToJSON Protocol where + toJSON Tcp = String "tcp" + toJSON Udp = String "udp" + toJSON Icmp = String "icmp" + +----------------------------------------------------------------- + +data Channel = Channel + { channelAddresses :: Maybe [String] + , channelDropletIds :: Maybe [DropletId] + , channelLoadBalancerUids :: Maybe [String] + , channelTags :: Maybe [String] + } deriving (Show, Generic) + +instance FromJSON Channel where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance ToJSON Channel where + toJSON = genericToJSON $ aesonPrefix snakeCase + +data InboundRule = InboundRule + { inboundruleProtocol :: Protocol + , inboundrulePorts :: String + , inboundruleSources :: Channel + } deriving (Show, Generic) + +instance FromJSON InboundRule where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance ToJSON InboundRule where + toJSON = genericToJSON $ aesonPrefix snakeCase + +data OutboundRule = OutboundRule + { outboundruleProtocol :: Protocol + , outboundrulePorts :: String + , outboundruleDestinations :: Channel + } deriving (Show, Generic) + +instance FromJSON OutboundRule where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance ToJSON OutboundRule where + toJSON = genericToJSON $ aesonPrefix snakeCase + +----------------------------------------------------------------- + +data Firewall = Firewall + { firewallId :: FirewallId + , firewallStatus :: String + , firewallCreatedAt :: UTCTime + , firewallPendingChanges :: [PendingChange] + , firewallName :: String + , firewallInboundRules :: [InboundRule] + , firewallOutboundRules :: [OutboundRule] + , firewallDropletIds :: [DropletId] + , firewallTags :: [String] + } deriving (Show, Generic) + +instance FromJSON (Response Firewall) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "firewall") + +instance FromJSON (Response [Firewall]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "firewalls") + +instance FromJSON Firewall where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance FromJSON (PaginationState Firewall) where + parseJSON (Object v) = parsePaginationState v "domains" + +instance Paginatable Firewall + +----------------------------------------------------------------- + +data FirewallPayload = FirewallPayload + { firewallpayloadName :: String + , firewallpayloadInboundRules :: [InboundRule] + , firewallpayloadOutboundRules :: [OutboundRule] + , firewallpayloadDropletIds :: Maybe [DropletId] + , firewallpayloadTags :: Maybe [String] + } deriving (Show, Generic) + +instance ToJSON FirewallPayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload FirewallPayload + +----------------------------------------------------------------- + +data DropletsPayload = DropletsPayload + { dropletspayloadDropletIds :: [DropletId] + } deriving (Show, Generic) + +instance ToJSON DropletsPayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload DropletsPayload + +----------------------------------------------------------------- + +data TagsPayload = TagsPayload + { tagspayloadTags :: [DropletId] + } deriving (Show, Generic) + +instance ToJSON TagsPayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload TagsPayload + +----------------------------------------------------------------- + +data FirewallRulesPayload = FirewallRulesPayload + { inboundRules :: [InboundRule] + , outboundRules :: [OutboundRule] + } deriving (Show, Generic) + +instance ToJSON FirewallRulesPayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload FirewallRulesPayload diff --git a/src/Network/DigitalOcean/Services/FloatingIp.hs b/src/Network/DigitalOcean/Services/FloatingIp.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/FloatingIp.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} + +module Network.DigitalOcean.Services.FloatingIp where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import Data.Time.Clock +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +import Network.DigitalOcean.Utils.Pagination +import Network.DigitalOcean.Utils.Actions +import Network.DigitalOcean.Services.Region +import Network.DigitalOcean.Services.Droplet +----------------------------------------------------------------- + +data FloatingIp = FloatingIp + { floatingipIp :: IpAddress + , floatingipRegion :: Region + , floatingipDroplet :: Droplet + } deriving (Show, Generic) + +instance FromJSON (Response FloatingIp) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "floating_ip") + +instance FromJSON (Response [FloatingIp]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "floating_ips") + +instance FromJSON FloatingIp where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance FromJSON (PaginationState FloatingIp) where + parseJSON (Object v) = parsePaginationState v "floating_ips" + +instance Paginatable FloatingIp + +data FloatingIpPayload = + FloatingIpRegionPayload RegionSlug + | FloatingIpDropletPayload DropletId + deriving Show + +instance ToJSON FloatingIpPayload where + toJSON (FloatingIpRegionPayload regionSlug) = object [ "region" .= regionSlug ] + toJSON (FloatingIpDropletPayload dropletId) = object [ "droplet_id" .= dropletId ] + +instance Payload FloatingIpPayload + +data FloatingIpAction = + AssignToDroplet DropletId + | Unassign + deriving Show + +instance ToJSON FloatingIpAction where + toJSON (AssignToDroplet dropletId) = object [ actionType' "assign", "droplet_id" .= dropletId ] + toJSON Unassign = object [ actionType' "unassign" ] + +instance Payload FloatingIpAction diff --git a/src/Network/DigitalOcean/Services/Image.hs b/src/Network/DigitalOcean/Services/Image.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/Image.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} + +module Network.DigitalOcean.Services.Image where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import Data.Time.Clock +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +import Network.DigitalOcean.Utils.Pagination +import Network.DigitalOcean.Utils.Actions +----------------------------------------------------------------- + +data Image = Image + { imageId :: ImageId + , imageName :: String + , imageType :: String + , imageDistribution :: String + , imageSlug :: Maybe String + , imagePublic :: Bool + , imageRegions :: [String] + , imageMinDiskSize :: Int + , imageSizeGigabytes :: Double + , imageCreatedAt :: UTCTime + } deriving (Show, Generic) + +instance FromJSON (Response Image) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "image") + +instance FromJSON (Response [Image]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "images") + +instance FromJSON Image where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance FromJSON (PaginationState Image) where + parseJSON (Object v) = parsePaginationState v "images" + +instance Paginatable Image + +data ImageType = + DistributionImage + | ApplicationImage + +instance Show ImageType where + show DistributionImage = "distribution" + show ApplicationImage = "application" + +data ImageOptions = ImageOptions + { imageType' :: Maybe ImageType -- ^ Reference: https://developers.digitalocean.com/documentation/v2/#images + , isPrivate :: Bool -- ^ If True, only user's images will be returned. + } + +data ImagePayload = ImagePayload + { imagepayloadName :: String + } deriving (Show, Generic) + +instance Payload ImagePayload + +instance ToJSON ImagePayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +data ImageAction = + Transfer + | ConvertToSnapshot + +instance ToJSON ImageAction where + toJSON Transfer = object [ actionType' "transfer" ] + toJSON ConvertToSnapshot = object [ actionType' "convert" ] + +instance Payload ImageAction diff --git a/src/Network/DigitalOcean/Services/LoadBalancer.hs b/src/Network/DigitalOcean/Services/LoadBalancer.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/LoadBalancer.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} + +module Network.DigitalOcean.Services.LoadBalancer where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import Data.Time.Clock +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +import Network.DigitalOcean.Utils.Pagination +import Network.DigitalOcean.Services.Region +----------------------------------------------------------------- + +data LoadBalancerAlgorithm = + RoundRobin + | LeastConnections + deriving (Show, Generic) + +instance FromJSON LoadBalancerAlgorithm where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance ToJSON LoadBalancerAlgorithm where + toJSON = genericToJSON $ aesonPrefix snakeCase + +----------------------------------------------------------------- + +data ForwardingRule = ForwardingRule + { forwardingrulesEntryProtocol :: String + , forwardingrulesEntryPort :: Int + , forwardingrulesTargetProtocol :: String + , forwardingrulesTargetPort :: Int + , forwardingrulesCertificateId :: Maybe String + , forwardingrulesTlsPassthrough :: Maybe Bool + } deriving (Show, Generic) + +instance FromJSON ForwardingRule where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance ToJSON ForwardingRule where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload [ForwardingRule] + +----------------------------------------------------------------- + +data HealthCheck = HealthCheck + { healthcheckProtocol :: String + , healthcheckPort :: Int + , healthcheckPath :: Maybe String + , healthcheckCheckIntervalSeconds :: Maybe Int + , healthcheckResponseTimeoutSeconds :: Maybe Int + , healthcheckUnhealthyThreshold :: Maybe Int + , healthcheckHealthyThreshold :: Maybe Int + } deriving (Show, Generic) + +instance FromJSON HealthCheck where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance ToJSON HealthCheck where + toJSON = genericToJSON $ aesonPrefix snakeCase + +----------------------------------------------------------------- + +data StickySessions = StickySessions + { stickysessionsType :: String + , stickysessionsCookieName :: String + , stickysessionsCookieTtlSeconds :: String + } deriving (Show, Generic) + +instance FromJSON StickySessions where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance ToJSON StickySessions where + toJSON = genericToJSON $ aesonPrefix snakeCase + +----------------------------------------------------------------- + +data LoadBalancer = LoadBalancer + { loadbalancerId :: String + , loadbalancerName :: String + , loadbalancerIp :: IpAddress + , loadbalancerAlgorithm :: LoadBalancerAlgorithm + , loadbalancerStatus :: String -- Make this a new type + , loadbalancerCreatedAt :: UTCTime + , loadbalancerForwardingRules :: [ForwardingRule] + , loadbalancerHealthCheck :: HealthCheck + , loadbalancerStickySessions :: StickySessions + , loadbalancerRegion :: Region + , loadbalancerTag :: String + , loadbalancerDropletIds :: [DropletId] + , loadbalancerRedirectHttpToHttps :: Bool + } deriving (Show, Generic) + +instance FromJSON LoadBalancer where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance ToJSON LoadBalancer where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance FromJSON (Response LoadBalancer) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "load_balancer") + +instance FromJSON (Response [LoadBalancer]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "load_balancers") + +instance FromJSON (PaginationState LoadBalancer) where + parseJSON (Object v) = parsePaginationState v "load_balancers" + +instance Paginatable LoadBalancer + +----------------------------------------------------------------- + +data LoadBalancerPayload = LoadBalancerPayload + { loadbalancerpayloadName :: String + , loadbalancerpayloadAlgorithm :: Maybe String + , loadbalancerpayloadRegion :: String + , loadbalancerpayloadForwardingRules :: [ForwardingRule] + , loadbalancerpayloadHealthCheck :: Maybe HealthCheck + , loadbalancerpayloadStickySessions :: Maybe StickySessions + , loadbalancerpayloadRedirectHttpToHttps :: Maybe Bool + , loadbalancerpayloadDropletIds :: Maybe [Int] + , loadbalancerpayloadTag :: String -- https://developers.digitalocean.com/documentation/v2/#create-a-new-load-balancer-with-droplet-tag + } deriving (Show, Generic) + +instance ToJSON LoadBalancerPayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload LoadBalancerPayload diff --git a/src/Network/DigitalOcean/Services/Region.hs b/src/Network/DigitalOcean/Services/Region.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/Region.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} + +module Network.DigitalOcean.Services.Region where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +----------------------------------------------------------------- + +data Region = Region + { regionSlug :: String + , regionName :: String + , regionSizes :: [String] -- TODO: Make a type + , regionAvailable :: Bool + , regionFeatures :: [String] -- TODO: Make a type + } deriving (Show, Generic) + +instance FromJSON (Response [Region]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "regions") + +instance FromJSON Region where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance ToJSON Region where + toJSON = genericToJSON $ aesonPrefix snakeCase diff --git a/src/Network/DigitalOcean/Services/SSHKey.hs b/src/Network/DigitalOcean/Services/SSHKey.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/SSHKey.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} + +module Network.DigitalOcean.Services.SSHKey where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +----------------------------------------------------------------- + +data SSHKey = SSHKey + { sshkeyId :: SSHKeyId + , sshkeyFingerprint :: String + , sshkeyPublicKey :: String + , sshkeyName :: String + } deriving (Show, Generic) + +instance FromJSON SSHKey where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +instance ToJSON SSHKey where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance FromJSON (Response SSHKey) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "ssh_key") + +instance FromJSON (Response [SSHKey]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "ssh_keys") + +----------------------------------------------------------------- + +data SSHKeyPayload = SSHKeyPayload + { sshkeypayloadName :: String + , sshkeypayloadPublicKey :: String + } deriving (Show, Generic) + +instance ToJSON SSHKeyPayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload SSHKeyPayload + +----------------------------------------------------------------- + +data SSHKeyNamePayload = SSHKeyNamePayload + { sshkeynamepayloadName :: String + } deriving (Show, Generic) + +instance ToJSON SSHKeyNamePayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload SSHKeyNamePayload diff --git a/src/Network/DigitalOcean/Services/Size.hs b/src/Network/DigitalOcean/Services/Size.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/Size.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} + +module Network.DigitalOcean.Services.Size where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +----------------------------------------------------------------- + +data Size = Size + { sizeSlug :: String + , sizeAvailable :: Bool + , sizeTransfer :: Double + , sizePriceMonthly :: Double + , sizePriceHourly :: Double + , sizeMemory :: Int + , sizeVcpus :: Int + , sizeDisk :: Int + -- , sizeRegions :: [String] + } deriving (Show, Generic) + +instance FromJSON (Response [Size]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "sizes") + +instance FromJSON Size where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + diff --git a/src/Network/DigitalOcean/Services/Snapshot.hs b/src/Network/DigitalOcean/Services/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/Snapshot.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} + +module Network.DigitalOcean.Services.Snapshot where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import Data.Time.Clock +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Types +----------------------------------------------------------------- + +data Snapshot = Snapshot + { snapshotId :: String + , snapshotName :: String + , snapshotCreatedAt :: UTCTime + , snapshotRegions :: [String] + , snapshotResourceId :: String + , snapshotResourceType :: String + , snapshotMinDiskSize :: Double + , snapshotSizeGigabytes :: Double + } deriving (Show, Generic) + +instance FromJSON (Response [Snapshot]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "snapshots") + +instance FromJSON (Response Snapshot) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "snapshot") + +instance FromJSON Snapshot where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +newtype SnapshotPayload = SnapshotPayload + { snapshotpayloadName :: String + } deriving (Show, Generic) + +instance ToJSON SnapshotPayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload SnapshotPayload where diff --git a/src/Network/DigitalOcean/Services/Volume.hs b/src/Network/DigitalOcean/Services/Volume.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Services/Volume.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveGeneric #-} + +module Network.DigitalOcean.Services.Volume where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Casing +import Data.Time.Clock +import GHC.Generics +----------------------------------------------------------------- +import Network.DigitalOcean.Services.Region +import Network.DigitalOcean.Types +----------------------------------------------------------------- + +data Volume = Volume + { volumeId :: String + , volumeRegion :: Region + , volumeDropletIds :: [Int] + , volumeName :: String + , volumeDescription :: String + , volumeSizeGigabytes :: Double + , volumeCreatedAt :: UTCTime + } deriving (Show, Generic) + +instance FromJSON (Response [Volume]) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "volumes") + +instance FromJSON (Response Volume) where + parseJSON (Object v) = + fmap Response $ parseJSON =<< (v .: "volume") + +instance FromJSON Volume where + parseJSON = genericParseJSON $ aesonPrefix snakeCase + +data VolumePayload = VolumePayload + { volumepayloadSizeGigabytes :: Int + , volumepayloadName :: String + , volumepayloadDescripton :: String + , volumepayloadRegion :: String + , volumepayloadSnapshotId :: String + } deriving (Show, Generic) + +instance ToJSON VolumePayload where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Payload VolumePayload + +type VolumeName = String + +data VolumeAction = + Attach VolumeId DropletId (Maybe RegionSlug) + | Detach VolumeId DropletId (Maybe RegionSlug) + | ResizeVolume VolumeId Int (Maybe RegionSlug) + | AttachByName VolumeName DropletId (Maybe RegionSlug) + | DetachByName VolumeName DropletId (Maybe RegionSlug) + +instance Payload VolumeAction where +instance ToJSON VolumeAction where + toJSON (Attach _ dropletId region) = + object [ "droplet_id".= dropletId + , "region" .= region + , "type" .= ("attach" :: String) + ] + toJSON (Detach _ dropletId region) = + object [ "droplet_id" .= dropletId + , "region" .= region + , "type" .= ("detach" :: String) + ] + toJSON (ResizeVolume _ size region) = + object [ "size" .= size + , "region" .= region + , "type" .= ("resize" :: String) + ] + toJSON (AttachByName volumeName dropletId region) = + object [ "droplet_id" .= dropletId + , "region" .= region + , "volume_name".= volumeName + , "type" .= ("attach" :: String) + ] + toJSON (DetachByName volumeName dropletId region) = + object [ "droplet_id" .= dropletId + , "region" .= region + , "volume_name".= volumeName + , "type" .= ("detach" :: String) + ] diff --git a/src/Network/DigitalOcean/Types.hs b/src/Network/DigitalOcean/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Types.hs @@ -0,0 +1,220 @@ +{-# 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 where + +data Paginatable a => 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 String IO) a } + deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader Client) + +newtype Client = Client { apiKey :: BS.ByteString } + +type DoErr = T.Text + +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 diff --git a/src/Network/DigitalOcean/Utils/Actions.hs b/src/Network/DigitalOcean/Utils/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Utils/Actions.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.DigitalOcean.Utils.Actions (actionType') where + +import Data.Aeson + +actionType' :: KeyValue kv => String -> kv +actionType' = (.=) "type" diff --git a/src/Network/DigitalOcean/Utils/Pagination.hs b/src/Network/DigitalOcean/Utils/Pagination.hs new file mode 100644 --- /dev/null +++ b/src/Network/DigitalOcean/Utils/Pagination.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TupleSections #-} + +module Network.DigitalOcean.Utils.Pagination where + +----------------------------------------------------------------- +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Text as T +import qualified Data.Text as T +----------------------------------------------------------------- +import Network.DigitalOcean.Types +import qualified Data.Set as Set +----------------------------------------------------------------- + +paginate + :: (Paginatable a, FromJSON (PaginationState a)) + => (String -> DO (PaginationState a)) + -> PaginationState a + -> DO (PaginationState a) +paginate f s = + case nextUrl s of + Just url -> do + newState <- f url + return $ newState { curr = curr s ++ curr newState } + Nothing -> return s { isLast = True } + +paginationQueryParams :: Maybe PaginationConfig -> QueryParams +paginationQueryParams Nothing = [] +paginationQueryParams (Just (PaginationConfig pageSize _)) = [("per_page", show pageSize)] + +paginateUntil + :: (Paginatable a, FromJSON (PaginationState a)) + => PaginationConfig + -> PaginationState a + -> (String -> DO (PaginationState a)) + -> DO (PaginationState a) +paginateUntil config@PaginationConfig {..} state@PaginationState {..} f = + if length curr >= resultLimit || isLast + then + return state + else do + newState <- paginate f state + paginateUntil config newState f + +-- Taken from: https://stackoverflow.com/questions/28368980/composing-optional-aeson-parsers +(/?) :: FromJSON a => Parser (Maybe Object) -> T.Text -> Parser (Maybe a) +maybeParser /? key = maybeParser >>= maybe (return Nothing) (.:? key) + +parsePaginationState :: Paginatable a => Object -> T.Text -> Parser (PaginationState a) +parsePaginationState v key = do + values <- v .: key + (next, total) <- parse_meta + let page = 1 + return $ PaginationState values page next total False + where + parse_meta :: Parser (Maybe String, Maybe Int) + parse_meta = + (,) + <$> v .:? "links" /? "pages" /? "next" + <*> (v .:? "meta" /? "total") diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Main where + +import Control.Monad.Reader +import Control.Monad.Except +import Network.DigitalOcean +import Network.DigitalOcean.Types +import Network.DigitalOcean.Services +import Test.QuickCheck +import Test.QuickCheck.Monadic +import Test.QuickCheck.Instances +import Test.QuickCheck.Property +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBSC +import Data.Aeson +import Data.Aeson.Casing +-- import Text.RawString.QQ +import Text.InterpolatedString.Perl6 (qc) +import Data.Maybe +import Data.String +import GHC.Generics +import Data.Proxy + +----------------------------------------------------------------- + +prop_Response :: forall proxy service. (FromJSON service) => proxy service -> LBS.ByteString -> Property +prop_Response _ resp = + let result = eitherDecode resp :: Either String service in + case result of + Left err -> error err + Right acc -> label "wow" True + +----------------------------------------------------------------- + +instance Arbitrary Account where + arbitrary = + Account + <$> choose (1, 100) + <*> choose (1, 10) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> oneof (return <$> ["active", "warning", "locked"]) + <*> arbitrary + +instance ToJSON Account where + toJSON = genericToJSON $ aesonPrefix snakeCase + +prop_Account :: Account -> Property +prop_Account account = prop_Response (Proxy :: Proxy Account) (encode account) + +----------------------------------------------------------------- + +instance Arbitrary Action where + arbitrary = + Action + <$> choose (1, 100000000) + <*> oneof (return <$> ["in-progress", "completed", "errored"]) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> choose (1, 100000000) + <*> arbitrary + <*> arbitrary + +instance ToJSON Action where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Arbitrary (Response Action) where + arbitrary = Response <$> arbitrary + +instance ToJSON (Response Action) where + toJSON (Response action) = object [ "action" .= action] + +instance Arbitrary (Response [Action]) where + arbitrary = Response <$> arbitrary + +instance ToJSON (Response [Action]) where + toJSON (Response actions) = object [ "actions" .= actions] + +prop_Action :: Action -> Response Action -> Response [Action] -> Property +prop_Action v v' v'' = prop_Response (Proxy :: Proxy Action) (encode v) + .&&. prop_Response (Proxy :: Proxy (Response Action)) (encode v') + .&&. prop_Response (Proxy :: Proxy (Response [Action])) (encode v'') + +----------------------------------------------------------------- + +instance Arbitrary Certificate where + arbitrary = + Certificate + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance ToJSON Certificate where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Arbitrary (Response Certificate) where + arbitrary = Response <$> arbitrary + +instance ToJSON (Response Certificate) where + toJSON (Response certificate) = object [ "certificate" .= certificate] + +instance Arbitrary (Response [Certificate]) where + arbitrary = Response <$> arbitrary + +instance ToJSON (Response [Certificate]) where + toJSON (Response certificates) = object [ "certificates" .= certificates] + +prop_Certificate :: Certificate -> Response Certificate -> Response [Certificate] -> Property +prop_Certificate v v' v'' = prop_Response (Proxy :: Proxy Certificate) (encode v) + .&&. prop_Response (Proxy :: Proxy (Response Certificate)) (encode v') + .&&. prop_Response (Proxy :: Proxy (Response [Certificate])) (encode v'') + +----------------------------------------------------------------- + +instance Arbitrary Region where + arbitrary = + Region + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance ToJSON Region where + toJSON = genericToJSON $ aesonPrefix snakeCase + +prop_Region :: Region -> Property +prop_Region = prop_Response (Proxy :: Proxy Region) . encode + +instance Arbitrary (Response [Region]) where + arbitrary = Response <$> arbitrary + +instance ToJSON (Response [Region]) where + toJSON (Response regions) = object [ "regions" .= regions] + +prop_RegionsResponse :: Response [Region] -> Property +prop_RegionsResponse = prop_Response (Proxy :: Proxy (Response [Region])) . encode + +----------------------------------------------------------------- + +instance Arbitrary Snapshot where + arbitrary = + Snapshot + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance ToJSON Snapshot where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Arbitrary (Response Snapshot) where + arbitrary = Response <$> arbitrary + +instance ToJSON (Response Snapshot) where + toJSON (Response snapshot) = object [ "snapshot" .= snapshot] + +instance Arbitrary (Response [Snapshot]) where + arbitrary = Response <$> arbitrary + +instance ToJSON (Response [Snapshot]) where + toJSON (Response snapshots) = object [ "snapshots" .= snapshots] + +prop_Snapshot :: Snapshot -> Response Snapshot -> Response [Snapshot] -> Property +prop_Snapshot v v' v'' = prop_Response (Proxy :: Proxy Snapshot) (encode v) + .&&. prop_Response (Proxy :: Proxy (Response Snapshot)) (encode v') + .&&. prop_Response (Proxy :: Proxy (Response [Snapshot])) (encode v'') + +----------------------------------------------------------------- + +instance Arbitrary Volume where + arbitrary = + Volume + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance ToJSON Volume where + toJSON = genericToJSON $ aesonPrefix snakeCase + +instance Arbitrary (Response Volume) where + arbitrary = Response <$> arbitrary + +instance ToJSON (Response Volume) where + toJSON (Response volume) = object [ "volume" .= volume] + +instance Arbitrary (Response [Volume]) where + arbitrary = Response <$> arbitrary + +instance ToJSON (Response [Volume]) where + toJSON (Response volumes) = object [ "volumes" .= volumes] + +prop_Volume :: Volume -> Response Volume -> Response [Volume] -> Property +prop_Volume v v' v'' = prop_Response (Proxy :: Proxy Volume) (encode v) + .&&. prop_Response (Proxy :: Proxy (Response Volume)) (encode v') + .&&. prop_Response (Proxy :: Proxy (Response [Volume])) (encode v'') + +----------------------------------------------------------------- + +runTests = quickCheck . withMaxSuccess 100 $ prop_Account + .&&. prop_Action + .&&. prop_Certificate + .&&. prop_Region + .&&. prop_RegionsResponse + .&&. prop_Snapshot + .&&. prop_Volume + +main :: IO () +main = return ()