DOH (empty) → 0.1.0.0

raw patch · 26 files changed

+2308/−0 lines, 26 filesdep +QuickCheckdep +aesondep +aeson-casingsetup-changed

Dependencies added: QuickCheck, aeson, aeson-casing, base, bytestring, containers, filepath, http-client, http-client-tls, http-types, interpolatedstring-perl6, lens, mtl, quickcheck-instances, text, time, unordered-containers, uri

Files

DOH.cabal +84/−0
LICENSE +21/−0
README.md +2/−0
Setup.hs +2/−0
src/Network/DigitalOcean.hs +413/−0
src/Network/DigitalOcean/Http.hs +87/−0
src/Network/DigitalOcean/Services.hs +33/−0
src/Network/DigitalOcean/Services/Account.hs +30/−0
src/Network/DigitalOcean/Services/Action.hs +42/−0
src/Network/DigitalOcean/Services/Certificate.hs +52/−0
src/Network/DigitalOcean/Services/Domain.hs +48/−0
src/Network/DigitalOcean/Services/DomainRecord.hs +58/−0
src/Network/DigitalOcean/Services/Droplet.hs +226/−0
src/Network/DigitalOcean/Services/Firewall.hs +162/−0
src/Network/DigitalOcean/Services/FloatingIp.hs +62/−0
src/Network/DigitalOcean/Services/Image.hs +77/−0
src/Network/DigitalOcean/Services/LoadBalancer.hs +134/−0
src/Network/DigitalOcean/Services/Region.hs +31/−0
src/Network/DigitalOcean/Services/SSHKey.hs +57/−0
src/Network/DigitalOcean/Services/Size.hs +33/−0
src/Network/DigitalOcean/Services/Snapshot.hs +45/−0
src/Network/DigitalOcean/Services/Volume.hs +89/−0
src/Network/DigitalOcean/Types.hs +220/−0
src/Network/DigitalOcean/Utils/Actions.hs +8/−0
src/Network/DigitalOcean/Utils/Pagination.hs +64/−0
test/Spec.hs +228/−0

+ DOH.cabal view

@@ -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

+ LICENSE view

@@ -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.

+ README.md view

@@ -0,0 +1,2 @@+# DigitalOcean.hs+Haskell bindings for DigitalOcean API v2

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ src/Network/DigitalOcean.hs view

@@ -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:++@+{&#45;\# LANGUAGE OverloadedStrings \#&#45;}++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

+ src/Network/DigitalOcean/Http.hs view

@@ -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))

+ src/Network/DigitalOcean/Services.hs view

@@ -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

+ src/Network/DigitalOcean/Services/Account.hs view

@@ -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

+ src/Network/DigitalOcean/Services/Action.hs view

@@ -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

+ src/Network/DigitalOcean/Services/Certificate.hs view

@@ -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

+ src/Network/DigitalOcean/Services/Domain.hs view

@@ -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

+ src/Network/DigitalOcean/Services/DomainRecord.hs view

@@ -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+

+ src/Network/DigitalOcean/Services/Droplet.hs view

@@ -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+

+ src/Network/DigitalOcean/Services/Firewall.hs view

@@ -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

+ src/Network/DigitalOcean/Services/FloatingIp.hs view

@@ -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

+ src/Network/DigitalOcean/Services/Image.hs view

@@ -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

+ src/Network/DigitalOcean/Services/LoadBalancer.hs view

@@ -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

+ src/Network/DigitalOcean/Services/Region.hs view

@@ -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

+ src/Network/DigitalOcean/Services/SSHKey.hs view

@@ -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

+ src/Network/DigitalOcean/Services/Size.hs view

@@ -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+

+ src/Network/DigitalOcean/Services/Snapshot.hs view

@@ -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

+ src/Network/DigitalOcean/Services/Volume.hs view

@@ -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)+           ]

+ src/Network/DigitalOcean/Types.hs view

@@ -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

+ src/Network/DigitalOcean/Utils/Actions.hs view

@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DigitalOcean.Utils.Actions (actionType') where++import Data.Aeson++actionType' :: KeyValue kv => String -> kv+actionType' = (.=) "type"

@@ -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")

+ test/Spec.hs view

@@ -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 ()