hdo 0.4 → 0.5

raw patch · 20 files changed

+617/−123 lines, 20 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hdo.cabal +3/−2
• main/hdo.hs +16/−5
• src/Network/DO.hs +52/−27
• src/Network/DO/Commands.hs +12/−12
• src/Network/DO/Domain/Commands.hs +12/−12
• src/Network/DO/Domain/Net.hs +10/−10
• src/Network/DO/Droplets/Commands.hs +9/−9
• src/Network/DO/Droplets/Net.hs +9/−9
• src/Network/DO/IP/Commands.hs +6/−6
• src/Network/DO/IP/Net.hs +7/−7
• src/Network/DO/Net.hs +6/−2
• src/Network/DO/Net/Common.hs +26/−10
• src/Network/DO/Pairing.hs +8/−0
• src/Network/DO/Pretty.hs +12/−0
• src/Network/DO/Tags.hs +6/−0
• src/Network/DO/Tags/Commands.hs +70/−0
• src/Network/DO/Tags/Net.hs +107/−0
• src/Network/DO/Types.hs +240/−6
• src/Network/REST/Commands.hs +3/−3
• src/Network/REST/Conduit.hs +3/−3

@@ -1,5 +1,5 @@ Name: hdo-Version: 0.4+Version: 0.5 Cabal-Version: >= 1.18 Maintainer: Arnaud Bailly <arnaud.oqube@gmail.com> Author: Arnaud Bailly@@ -26,9 +26,10 @@                  , Network.DO.Droplets.Commands, Network.DO.Droplets.Net, Network.DO.Droplets.Utils                  , Network.DO.IP, Network.DO.IP.Commands, Network.DO.IP.Net                  , Network.DO.Domain, Network.DO.Domain.Commands, Network.DO.Domain.Net+                 , Network.DO.Tags, Network.DO.Tags.Commands, Network.DO.Tags.Net                  , Network.DO.Names, Network.DO.Pairing                  , Network.REST, Network.DO.Pretty-                 +   exposed-modules: Network.DO   Build-Depends: aeson                , base >= 4 && < 5

@@ -97,24 +97,28 @@                                                          = showDroplet (P.read dropletId) >>= outputResult parseCommandOptions ("droplets":"ssh":dropletIdOrName:[])                                                          =  (do-                                                                droplets <- findByIdOrName dropletIdOrName <$> listDroplets-                                                                case droplets of-                                                                 (did:_) -> dropletConsole did-                                                                 []      -> return (error $ "no droplet with id or name " <> dropletIdOrName)+                                                               droplets <- fmap (findByIdOrName dropletIdOrName) <$> listDroplets+                                                               case droplets of+                                                                 Right (did:_) -> dropletConsole did+                                                                 Right []      -> return $ error ("no droplet with id or name " <> dropletIdOrName)+                                                                 Left err      -> return $ Left err                                                             ) >>= outputResult+ parseCommandOptions ("images":"list":_)                  = listImages >>= outputResult parseCommandOptions ("regions":"list":_)                 = listRegions >>= outputResult parseCommandOptions ("keys":"list":_)                    = listKeys >>= outputResult parseCommandOptions ("sizes":"list":_)                   = listSizes >>= outputResult+ parseCommandOptions ("ips":"list":_)                     = listFloatingIPs >>= outputResult parseCommandOptions ("ips":"create":dropletOrRegion:[])  = do-  regions <- listRegions+  regions <- either (const []) id <$> listRegions   outputResult =<< if dropletOrRegion `elem` map regionSlug regions     then createFloatingIP (TargetRegion dropletOrRegion)     else createFloatingIP (TargetDroplet $ read dropletOrRegion) parseCommandOptions ("ips":"delete":ip:[])     = deleteFloatingIP (P.read ip) >>= outputResult parseCommandOptions ("ips":ip:"assign":did:[]) = assignFloatingIP (P.read ip) (P.read did) >>= outputResult parseCommandOptions ("ips":ip:"unassign": [])  = unassignFloatingIP (P.read ip) >>= outputResult+ parseCommandOptions ("dns":"list":_)             = listDomains >>= outputResult parseCommandOptions ("dns":"create":name:ip:[])  = createDomain (P.read name) (P.read ip) >>= outputResult parseCommandOptions ("dns":"delete":name:[])     = deleteDomain (P.read name) >>= outputResult@@ -124,4 +128,11 @@     Left (Error e) -> fail e     Right r        -> createRecord (P.read name) r >>= outputResult parseCommandOptions ("dns":name:"delete":rid:[]) = deleteRecord (P.read name) (P.read rid) >>= outputResult++parseCommandOptions ("tags":"list":_) = listTags >>= outputResult+parseCommandOptions ("tags":"create":name:[]) = createTag name >>= outputResult+parseCommandOptions ("tags":"delete":name:[]) = deleteTag name >>= outputResult+parseCommandOptions ("tags":"tag":name:rid:rtype:[]) = tagResources name (TagPairs [TagPair (P.read rid) (P.read rtype)]) >>= outputResult+parseCommandOptions ("tags":"untag":name:rid:rtype:[]) = untagResources name (TagPairs [TagPair (P.read rid) (P.read rtype)]) >>= outputResult+ parseCommandOptions e                          = fail $ "I don't know how to interpret commands " ++ unwords e ++ "\n" ++ usage

@@ -14,6 +14,9 @@   -- * Domains Commands   listDomains, createDomain, deleteDomain,   listRecords, createRecord, deleteRecord,+  -- * Tags Commands+  listTags, createTag, retrieveTag, deleteTag,+  tagResources, untagResources,   -- * Utilities   runDOEnv, runDO, runDODebug, getAuthFromEnv, outputResult,   generateName,@@ -22,41 +25,43 @@ import           Control.Exception            (catch, throw) import           Control.Monad.Trans.Free import           Data.IP-import qualified Network.DO.Commands          as C-import qualified Network.DO.Domain            as C-import qualified Network.DO.Droplets.Commands as C import           Network.DO.Droplets.Utils-import qualified Network.DO.IP.Commands       as C import           Network.DO.Names import           Network.DO.Net import           Network.DO.Pairing import           Network.DO.Pretty-import           Network.DO.Types+import           Network.DO.Types             hiding(name, tagResources) import           Network.REST import           System.Environment           (getEnv) import           System.IO.Error              (isDoesNotExistError)+import qualified Network.DO.Commands          as C+import qualified Network.DO.Domain            as C+import qualified Network.DO.Droplets.Commands as C+import qualified Network.DO.IP.Commands       as C+import qualified Network.DO.Tags.Commands     as C -type Command w a = FreeT (C.DO :+: C.DropletCommands :+: C.IPCommands :+: C.DomainCommands) (RESTT w) a+type Command w a = FreeT (C.DO :+: C.DropletCommands :+: C.IPCommands :+: C.DomainCommands :+: C.TagsCommands) (RESTT w) a -listKeys :: (Monad w) => Command w [Key]++listKeys :: (Monad w) => Command w (Result [Key]) listKeys = injl C.listKeys -listSizes :: (Monad w) => Command w [Size]+listSizes :: (Monad w) => Command w (Result [Size]) listSizes = injl C.listSizes -listImages  :: (Monad w) => Command w  [Image]+listImages  :: (Monad w) => Command w  (Result [Image]) listImages = injl C.listImages -listRegions :: (Monad w) => Command w [Region]+listRegions :: (Monad w) => Command w (Result [Region]) listRegions = injl C.listRegions -listFloatingIPs :: (Monad w) => Command w [FloatingIP]+listFloatingIPs :: (Monad w) => Command w (Result [FloatingIP]) listFloatingIPs = injrrl C.listFloatingIPs  createFloatingIP :: (Monad w) => FloatingIPTarget -> Command w (Result FloatingIP) createFloatingIP = injrrl . C.createFloatingIP -deleteFloatingIP :: (Monad w) => IP -> Command w (Maybe String)+deleteFloatingIP :: (Monad w) => IP -> Command w (Result ()) deleteFloatingIP = injrrl . C.deleteFloatingIP  assignFloatingIP :: (Monad w) => IP -> Id -> Command w (Result (ActionResult IPActionType))@@ -65,34 +70,34 @@ unassignFloatingIP :: (Monad w) => IP -> Command w (Result (ActionResult IPActionType)) unassignFloatingIP ip = injrrl $ C.floatingIPAction ip UnassignIP -listDomains :: (Monad w) => Command w [Domain]-listDomains = injrrr C.listDomains+listDomains :: (Monad w) => Command w (Result [Domain])+listDomains = injrrrl C.listDomains  createDomain :: (Monad w) => DomainName -> IP -> Command w (Result Domain)-createDomain dname ip = injrrr $ C.createDomain dname ip+createDomain dname ip = injrrrl $ C.createDomain dname ip -deleteDomain :: (Monad w) => DomainName -> Command w (Maybe String)-deleteDomain = injrrr . C.deleteDomain+deleteDomain :: (Monad w) => DomainName -> Command w (Result ())+deleteDomain = injrrrl . C.deleteDomain -listRecords :: (Monad w) => DomainName -> Command w [DomainRecord]-listRecords = injrrr . C.listRecords+listRecords :: (Monad w) => DomainName -> Command w (Result [DomainRecord])+listRecords = injrrrl . C.listRecords  createRecord :: (Monad w) => DomainName -> DomainRecord -> Command w (Result DomainRecord)-createRecord dname ip = injrrr $ C.createRecord dname ip+createRecord dname ip = injrrrl $ C.createRecord dname ip -deleteRecord :: (Monad w) => DomainName -> Id -> Command w (Maybe String)-deleteRecord dname rid = injrrr $ C.deleteRecord dname rid+deleteRecord :: (Monad w) => DomainName -> Id -> Command w (Result ())+deleteRecord dname rid = injrrrl $ C.deleteRecord dname rid -listDroplets :: (Monad w) => Command w [Droplet]+listDroplets :: (Monad w) => Command w (Result [Droplet]) listDroplets = injrl C.listDroplets -createDroplet :: (Monad w) => BoxConfiguration -> Command w (Either Error Droplet)+createDroplet :: (Monad w) => BoxConfiguration -> Command w (Result Droplet) createDroplet = injrl . C.createDroplet -showDroplet :: (Monad w) => Integer -> Command w (Either Error Droplet)+showDroplet :: (Monad w) => Integer -> Command w (Result Droplet) showDroplet = injrl . C.showDroplet -destroyDroplet :: (Monad w) => Integer -> Command w (Maybe String)+destroyDroplet :: (Monad w) => Integer -> Command w (Result ()) destroyDroplet = injrl . C.destroyDroplet  dropletAction :: (Monad w) => Id -> Action -> Command w (Result (ActionResult DropletActionType))@@ -104,8 +109,28 @@ getAction :: (Monad w) => Id -> Id -> Command w (Result (ActionResult DropletActionType)) getAction  did = injrl . C.getAction did -listDropletSnapshots :: (Monad w) => Id -> Command w [Image]+listDropletSnapshots :: (Monad w) => Id -> Command w (Result [Image]) listDropletSnapshots = injrl . C.listDropletSnapshots++listTags :: (Monad w) => Command w (Result [Tag])+listTags = injrrrr C.listTags++createTag :: (Monad w) => TagName -> Command w (Result Tag)+createTag = injrrrr . C.createTag++retrieveTag :: (Monad w) => TagName -> Command w (Result Tag)+retrieveTag = injrrrr . C.retrieveTag++deleteTag :: (Monad w) => TagName -> Command w (Result ())+deleteTag = injrrrr . C.deleteTag++tagResources :: (Monad w) => TagName -> TagPairs -> Command w (Result ())+tagResources name = injrrrr . C.tagResources name++untagResources :: (Monad w) => TagName -> TagPairs -> Command w (Result ())+untagResources name = injrrrr . C.untagResources name++  -- | Run DO actions, extracting authentication token from environment variable `AUTH_TOKEN`. runDOEnv :: Command IO a -> IO a

@@ -10,33 +10,33 @@ import           Prelude                      as P  -- functor for DO DSL-data DO a = ListKeys ([Key] -> a)-          | ListSizes ([Size] -> a)-          | ListImages ([Image] -> a)-          | ListRegions ([Region] -> a)+data DO a = ListKeys (Result [Key] -> a)+          | ListSizes (Result [Size] -> a)+          | ListImages (Result [Image] -> a)+          | ListRegions (Result [Region] -> a)           deriving (Functor)  -- free transformer to embed effects type DOT = FreeT DO  -- smart constructors-listKeys :: DO [Key]+listKeys :: DO (Result [Key]) listKeys = ListKeys P.id -listSizes :: DO [Size]+listSizes :: DO (Result [Size]) listSizes = ListSizes P.id -listImages  :: DO [Image]+listImages  :: DO (Result [Image]) listImages = ListImages P.id -listRegions :: DO [Region]+listRegions :: DO (Result [Region]) listRegions = ListRegions P.id  -- dual type, for creating interpreters-data CoDO m k = CoDO { listKeysH    :: (m [Key], k)-                     , listSizesH   :: (m [Size], k)-                     , listImagesH  :: (m [Image], k)-                     , listRegionsH :: (m [Region], k)+data CoDO m k = CoDO { listKeysH    :: (m (Result [Key]), k)+                     , listSizesH   :: (m (Result [Size]), k)+                     , listImagesH  :: (m (Result [Image]), k)+                     , listRegionsH :: (m (Result [Region]), k)                      } deriving Functor  -- Cofree closure of CoDO functor

@@ -10,43 +10,43 @@ import           Network.DO.Types import           Prelude                      as P -data DomainCommands a = ListDomains ([Domain] -> a)+data DomainCommands a = ListDomains (Result [Domain] -> a)                       | CreateDomain DomainName IP (Result Domain -> a)-                      | DeleteDomain DomainName (Maybe String -> a)-                      | ListRecords DomainName ([DomainRecord] -> a)+                      | DeleteDomain DomainName (Result () -> a)+                      | ListRecords DomainName (Result [DomainRecord] -> a)                       | CreateRecord DomainName DomainRecord (Result DomainRecord -> a)-                      | DeleteRecord DomainName Id (Maybe String -> a)+                      | DeleteRecord DomainName Id (Result () -> a)                       deriving (Functor)  type DomainCommandsT = FreeT DomainCommands  -- smart constructors-listDomains :: DomainCommands [Domain]+listDomains :: DomainCommands (Result [Domain]) listDomains = ListDomains P.id  createDomain :: DomainName -> IP -> DomainCommands (Result Domain) createDomain dname ip = CreateDomain dname ip P.id -deleteDomain :: DomainName -> DomainCommands (Maybe String)+deleteDomain :: DomainName -> DomainCommands (Result ()) deleteDomain ip = DeleteDomain ip P.id -listRecords :: DomainName -> DomainCommands [DomainRecord]+listRecords :: DomainName -> DomainCommands (Result [DomainRecord]) listRecords n = ListRecords n P.id  createRecord :: DomainName -> DomainRecord -> DomainCommands (Result DomainRecord) createRecord dname record = CreateRecord dname record P.id -deleteRecord :: DomainName -> Id -> DomainCommands (Maybe String)+deleteRecord :: DomainName -> Id -> DomainCommands (Result ()) deleteRecord dname rid = DeleteRecord dname rid P.id  -- dual type, for creating interpreters data CoDomainCommands m k =-  CoDomainCommands { listDomainsH  :: (m [Domain], k)+  CoDomainCommands { listDomainsH  :: (m (Result [Domain]), k)                    , createDomainH :: DomainName -> IP -> (m (Result Domain), k)-                   , deleteDomainH :: DomainName -> (m (Maybe String), k)-                   , listRecordsH  :: DomainName -> (m [DomainRecord], k)+                   , deleteDomainH :: DomainName -> (m (Result ()), k)+                   , listRecordsH  :: DomainName -> (m (Result [DomainRecord]), k)                    , createRecordH :: DomainName -> DomainRecord -> (m (Result DomainRecord), k)-                   , deleteRecordH :: DomainName -> Id -> (m (Maybe String), k)+                   , deleteRecordH :: DomainName -> Id -> (m (Result ()), k)                    } deriving Functor  -- Cofree closure of CoDomainCommands functor

@@ -32,7 +32,7 @@   listField _    = "domains"  doCreateDomain :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> DomainName -> IP -> (RESTT m (Result Domain), w a)-doCreateDomain w name ip = maybe (return $ error "no authentication token defined", w)+doCreateDomain w name ip = maybe (errMissingToken, w)   runQuery   (authToken (ask w))   where@@ -43,21 +43,21 @@       where         config = DomainConfig name ip -doDeleteDomain :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> DomainName -> (RESTT m (Maybe String), w a)-doDeleteDomain w name = maybe (return $ Just "no authentication token defined", w)-                  (\ t -> let r = deleteJSONWith (authorisation t) (toURI $ domainsEndpoint </> show name) >> return Nothing+doDeleteDomain :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> DomainName -> (RESTT m (Result ()), w a)+doDeleteDomain w name = maybe (errMissingToken, w)+                  (\ t -> let r = deleteJSONWith (authorisation t) (toURI $ domainsEndpoint </> show name) (toJSON ()) >> return (Right ())                           in (r, w))                   (authToken (ask w)) -doListRecords :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> DomainName -> (RESTT m [DomainRecord], w a)-doListRecords w name = maybe (return [], w)+doListRecords :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> DomainName -> (RESTT m (Result [DomainRecord]), w a)+doListRecords w name = maybe (errMissingToken, w)                        (\ t -> let records = toList "domain_records" <$> getJSONWith (authorisation t) (toURI $ domainsEndpoint </> show name </> "records")                          in (records, w))                        (authToken (ask w))  doCreateRecord :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> DomainName -> DomainRecord -> (RESTT m (Result DomainRecord), w a) doCreateRecord w name record =-  maybe (return $ error "no authentication token defined", w)+  maybe (errMissingToken,  w)   runQuery   (authToken (ask w))   where@@ -65,10 +65,10 @@                      domain = postJSONWith opts (toURI $ domainsEndpoint </> show name </> "records") (toJSON record) >>= return . fromResponse "domain_record"                  in (domain, w) -doDeleteRecord :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> DomainName -> Id -> (RESTT m (Maybe String), w a)+doDeleteRecord :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> DomainName -> Id -> (RESTT m (Result ()), w a) doDeleteRecord w name rid =-  maybe (return $ Just "no authentication token defined", w)-  (\ t -> let r = deleteJSONWith (authorisation t) (toURI $ domainsEndpoint </> show name </> "records" </> show rid ) >> return Nothing+  maybe (errMissingToken, w)+  (\ t -> let r = deleteJSONWith (authorisation t) (toURI $ domainsEndpoint </> show name </> "records" </> show rid ) (toJSON ()) >> return (Right ())           in (r, w))   (authToken (ask w)) 

@@ -15,12 +15,12 @@ import           Prelude                      as P  -- | Available commands for droplets-data DropletCommands a = ListDroplets ([Droplet] -> a)+data DropletCommands a = ListDroplets (Result [Droplet] -> a)                        | CreateDroplet BoxConfiguration (Result Droplet -> a)-                       | DestroyDroplet Id (Maybe String -> a)+                       | DestroyDroplet Id (Result () -> a)                        | DropletAction Id Action (Result (ActionResult DropletActionType) -> a)                        | GetAction Id Id (Result (ActionResult DropletActionType) -> a)-                       | ListSnapshots Id ([Image] -> a)+                       | ListSnapshots Id (Result [Image] -> a)                        | Console Droplet (Result () -> a)                        | ShowDroplet Id (Result Droplet -> a)                        deriving (Functor)@@ -29,7 +29,7 @@ type DropletCommandsT = FreeT DropletCommands  -- smart constructors-listDroplets :: DropletCommands [Droplet]+listDroplets :: DropletCommands (Result [Droplet]) listDroplets = ListDroplets P.id  createDroplet :: BoxConfiguration -> DropletCommands (Result Droplet)@@ -38,7 +38,7 @@ showDroplet :: Id -> DropletCommands (Result Droplet) showDroplet did = ShowDroplet did P.id -destroyDroplet :: Id -> DropletCommands (Maybe String)+destroyDroplet :: Id -> DropletCommands (Result ()) destroyDroplet did = DestroyDroplet did P.id  dropletAction :: Id -> Action -> DropletCommands (Result (ActionResult DropletActionType))@@ -50,17 +50,17 @@ getAction :: Id -> Id -> DropletCommands (Result (ActionResult DropletActionType)) getAction did actId = GetAction did actId P.id -listDropletSnapshots :: Id -> DropletCommands [Image]+listDropletSnapshots :: Id -> DropletCommands (Result [Image]) listDropletSnapshots did = ListSnapshots did P.id   -- | Comonadic interpreter for @DropletCommands@-data CoDropletCommands m k = CoDropletCommands { listDropletsH   :: (m [Droplet], k)+data CoDropletCommands m k = CoDropletCommands { listDropletsH   :: (m (Result [Droplet]), k)                                                , createDropletH  :: BoxConfiguration -> (m (Result Droplet), k)-                                               , destroyDropletH :: Id -> (m (Maybe String), k)+                                               , destroyDropletH :: Id -> (m (Result ()), k)                                                , actionDropletH  :: Id -> Action -> (m (Result (ActionResult DropletActionType)), k)                                                , getActionH      :: Id -> Id -> (m (Result (ActionResult DropletActionType)), k)-                                               , listSnapshotsH  :: Id -> (m [Image], k)+                                               , listSnapshotsH  :: Id -> (m (Result [Image]), k)                                                , consoleH        :: Droplet -> (m (Result ()), k)                                                , showDropletH    :: Id -> (m (Result Droplet), k)                                                } deriving Functor

@@ -28,15 +28,15 @@   listEndpoint _ = dropletsEndpoint   listField _    = "droplets" -doListSnapshots :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> (RESTT m [Image], w a)+doListSnapshots :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> (RESTT m (Result [Image]), w a) doListSnapshots w dropletId =-  maybe (return [], w)+  maybe (errMissingToken, w)   (\ t -> let snapshots = toList "snapshots" <$> getJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId </> "snapshots")           in (snapshots, w))   (authToken (ask w))  doCreate :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> BoxConfiguration -> (RESTT m (Result Droplet), w a)-doCreate w config = maybe (return $ error "no authentication token defined", w)+doCreate w config = maybe (errMissingToken, w)   runQuery   (authToken (ask w))   where@@ -49,28 +49,28 @@                        err      -> return err                  in (droplets, w) -doDestroyDroplet :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> (RESTT m (Maybe String), w a)-doDestroyDroplet w dropletId = maybe (return $ Just "no authentication token defined", w)-                               (\ t -> let r = deleteJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId) >> return Nothing+doDestroyDroplet :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> (RESTT m (Result ()), w a)+doDestroyDroplet w dropletId = maybe (errMissingToken, w)+                               (\ t -> let r = deleteJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId) (toJSON ()) >> return (Right ())                                        in (r, w))                                (authToken (ask w))  doAction :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> Action -> (RESTT m (Result (ActionResult DropletActionType)), w a)-doAction w dropletId action = maybe (return $ error "no authentication token defined", w)+doAction w dropletId action = maybe (errMissingToken, w)                               (\ t -> let r = postJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId </> "actions") (toJSON action)                                               >>= return . fromResponse "action"                                       in (r, w))                               (authToken (ask w))  doGetAction :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> Id -> (RESTT m (Result (ActionResult DropletActionType)), w a)-doGetAction w dropletId actionId = maybe (return $ error "no authentication token defined", w)+doGetAction w dropletId actionId = maybe (errMissingToken, w)                                    (\ t -> let r = getJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId </> "actions" </> show actionId)                                                    >>= return . fromResponse "action" . Right                                            in (r, w))                                    (authToken (ask w))  doShowDroplet  :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> (RESTT m (Result Droplet), w a)-doShowDroplet w dropletId = maybe (return $ error "no authentication token defined", w)+doShowDroplet w dropletId = maybe (errMissingToken, w)                             (\ t -> let r = fromResponse "droplet" . Right <$> getJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId)                                     in (r, w))                             (authToken (ask w))

@@ -11,9 +11,9 @@ import           Prelude                      as P  -- functor for DO DSL-data IPCommands a = ListFloatingIPs ([FloatingIP] -> a)+data IPCommands a = ListFloatingIPs (Result [FloatingIP] -> a)                   | CreateIP FloatingIPTarget (Result FloatingIP -> a)-                  | DeleteIP IP (Maybe String -> a)+                  | DeleteIP IP (Result () -> a)                   | ActionIP IP IPAction (Result (ActionResult IPActionType) -> a)           deriving (Functor) @@ -21,13 +21,13 @@ type IPCommandsT = FreeT IPCommands  -- smart constructors-listFloatingIPs :: IPCommands [FloatingIP]+listFloatingIPs :: IPCommands (Result [FloatingIP]) listFloatingIPs = ListFloatingIPs P.id  createFloatingIP :: FloatingIPTarget -> IPCommands (Result FloatingIP) createFloatingIP target = CreateIP target P.id -deleteFloatingIP :: IP -> IPCommands (Maybe String)+deleteFloatingIP :: IP -> IPCommands (Result ()) deleteFloatingIP ip = DeleteIP ip P.id  floatingIPAction :: IP -> IPAction -> IPCommands (Result (ActionResult IPActionType))@@ -35,9 +35,9 @@  -- dual type, for creating interpreters data CoIPCommands m k =-  CoIPCommands { listFloatingIPsH  :: (m [FloatingIP], k)+  CoIPCommands { listFloatingIPsH  :: (m (Result [FloatingIP]), k)                , createFloatingIPH :: FloatingIPTarget -> (m (Result FloatingIP), k)-               , deleteIPH         :: IP -> (m (Maybe String), k)+               , deleteIPH         :: IP -> (m (Result ()), k)                , actionIPH         :: IP -> IPAction -> (m (Result (ActionResult IPActionType)), k)                } deriving Functor 

@@ -32,22 +32,22 @@   listField _    = "floating_ips"  doCreateIP :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> FloatingIPTarget -> (RESTT m (Result FloatingIP), w a)-doCreateIP w config = maybe (return $ error "no authentication token defined", w)+doCreateIP w config = maybe (errMissingToken, w)   runQuery   (authToken (ask w))   where-    runQuery t = let opts             = authorisation t-                     ip               = postJSONWith opts (toURI floatingIpsEndpoint) (toJSON config) >>= return . fromResponse "floating_ip"+    runQuery t = let opts = authorisation t+                     ip   = postJSONWith opts (toURI floatingIpsEndpoint) (toJSON config) >>= return . fromResponse "floating_ip"                  in (ip, w) -doDeleteIP :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> IP -> (RESTT m (Maybe String), w a)-doDeleteIP w ip = maybe (return $ Just "no authentication token defined", w)-                  (\ t -> let r = deleteJSONWith (authorisation t) (toURI $ floatingIpsEndpoint </> show ip) >> return Nothing+doDeleteIP :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> IP -> (RESTT m (Result ()), w a)+doDeleteIP w ip = maybe (errMissingToken, w)+                  (\ t -> let r = deleteJSONWith (authorisation t) (toURI $ floatingIpsEndpoint </> show ip) (toJSON ()) >> return (Right ())                           in (r, w))                   (authToken (ask w))  doAction :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> IP -> IPAction -> (RESTT m (Result (ActionResult IPActionType)), w a)-doAction w ip action = maybe (return $ error "no authentication token defined", w)+doAction w ip action = maybe (errMissingToken, w)                        (\ t -> let r = postJSONWith (authorisation t) (toURI $ floatingIpsEndpoint </> show ip </> "actions") (toJSON action)                                        >>= return . fromResponse "action"                                in (r, w))

@@ -23,6 +23,7 @@ import           Network.DO.Droplets.Commands import           Network.DO.Droplets.Net import           Network.DO.IP+import           Network.DO.Tags import           Network.DO.Net.Common import           Network.DO.Pairing import           Network.DO.Types             as DO hiding (URI)@@ -79,7 +80,7 @@                   <*> queryList (Proxy :: Proxy Region)  mkDOClient :: (MonadIO m) => ToolConfiguration-           -> CofreeT (CoDO (RESTT m) :*: CoDropletCommands (RESTT m) :*: CoIPCommands (RESTT m) :*: CoDomainCommands (RESTT m)) (Env ToolConfiguration) (RESTT m ())+           -> CofreeT (CoDO (RESTT m) :*: CoDropletCommands (RESTT m) :*: CoIPCommands (RESTT m) :*: CoDomainCommands (RESTT m) :*: CoTagsCommands (RESTT m)) (Env ToolConfiguration) (RESTT m ()) mkDOClient config = coiterT next start   where     next = Pair@@ -88,7 +89,10 @@                  <$> dropletCommandsInterpreter                  <*> (Pair                       <$> ipCommandsInterpreter-                      <*> dnsCommandsInterpreter+                      <*> (Pair+                           <$> dnsCommandsInterpreter+                           <*> tagsCommandsInterpreter+                          )                      )                )     start = env config (return ())

@@ -27,22 +27,38 @@ toURI :: String -> URI toURI s = maybe (P.error $ "cannot parse URI from " ++ s) id $ parseURI s -toList :: (FromJSON a) => Text -> Value -> [a]-toList k (Object o) = let Array boxes = o  H.! k-                      in mapMaybe (A.parseMaybe parseJSON) (V.toList boxes)-toList _  _         = []+toList :: (FromJSON a) => Text -> Value -> Result [a]+toList k (Object o) = if H.member "message" o+  then error . show $ o H.! "message"+  else case H.lookup k o of+    Just (Array boxes) ->+      Right $ mapMaybe (A.parseMaybe parseJSON) (V.toList boxes)+    _ ->+      error $ "cannot decode JSON value to a list of " ++ show k +toList k  _         =+  error $ "cannot decode JSON value to a list of " ++ show k+ class Listable a where   listEndpoint :: Proxy a -> String   listField :: Proxy a -> Text -queryList :: (ComonadEnv ToolConfiguration w, Monad m, Listable b, FromJSON b) => Proxy b -> w a -> (RESTT m [b], w a)-queryList p w = maybe (return [], w)-                (\ t -> let droplets = toList (listField p) <$> getJSONWith (authorisation t) (toURI (listEndpoint p))-                        in (droplets, w))+queryList :: (ComonadEnv ToolConfiguration w, Monad m, Listable b, FromJSON b) => Proxy b -> w a -> (RESTT m (Result [b]), w a)+queryList p w = maybe (errMissingToken, w)+                (\ t -> let resources = toList (listField p) <$> getJSONWith (authorisation t) (toURI (listEndpoint p))+                        in (resources, w))                 (authToken (ask w)) +errMissingToken :: (Monad m) => m (Result a)+errMissingToken = return $ error "no authentication token defined"+ -- |Extract a typed result from a JSON output fromResponse :: (FromJSON a) => Text -> Either String Value -> Result a-fromResponse key (Right (Object b)) = either error (Right . id) $ A.parseEither parseJSON (b H.! key)-fromResponse _   v                  = error $ "cannot decode JSON value to a FloatingIP " ++ show v+fromResponse key (Right (Object b)) = if H.member "message" b+  then error . show $ (b H.! "message")+  else case H.lookup key b of+    Just val -> either error Right $ A.parseEither parseJSON val+    _        -> error $ "cannot decode JSON value to a " ++ show key ++ ": " ++ show b++fromResponse key v =+  error $ "cannot decode JSON value to a " ++ show key ++ ": " ++ show v

@@ -19,6 +19,7 @@                , injr, injl                , injrl, injrr                , injrrl, injrrr+               , injrrrl, injrrrr                ) where  import           Control.Comonad              (Comonad, extract)@@ -80,6 +81,13 @@  injrrr :: (Monad m, Functor f, Functor g, Functor h, Functor k) => k a -> FreeT (f :+: g :+: h :+: k) m a injrrr = liftF . InR . InR . InR++injrrrl :: (Monad m, Functor f, Functor g, Functor h, Functor k, Functor l) => k a -> FreeT (f :+: g :+: h :+: k :+: l) m a+injrrrl = liftF . InR . InR . InR . InL++injrrrr :: (Monad m, Functor f, Functor g, Functor h, Functor k, Functor l) => l a -> FreeT (f :+: g :+: h :+: k :+: l) m a+injrrrr = liftF . InR . InR . InR . InR+  pairEffect :: (Pairing f g, Comonad w, Monad m)            => (a -> b -> r) -> CofreeT f w a -> FreeT g m b -> m r

@@ -111,6 +111,18 @@  instance Pretty DNSType +instance Pretty Tag where+  pretty Tag{..} = text tagName $$+                   nest 5 (text "droplets" <+> (brackets $ int $ tagDropletsCount $ tagDroplets tagResources)) $$+                   nest 10 (maybe (text "<none>") pretty (tagDropletsLastTagged $ tagDroplets tagResources)) $$+                   nest 5 (text "volumes" <+> (brackets $ int $ tagVolumesCount $ tagVolumes tagResources))    $$+                   nest 10 (maybe (text "<none>") pretty (tagVolumesLastTagged $ tagVolumes tagResources))++instance Pretty Volume where+  pretty Volume{..} = integer volumeId $$+                      nest 5 (text volumeName <+> brackets (int volumeSizeGigaBytes <> text "GiB") <+> pretty volumeRegion) $$+                      nest 5 (hcat $ punctuate (char ',') $ integer <$> volumeDropletIds)+ outputResult :: (Pretty a, MonadIO m) => a -> m  () outputResult = liftIO . putStrLn . render . pretty 

@@ -0,0 +1,6 @@+module Network.DO.Tags(module Network.DO.Tags.Commands+                      ,module Network.DO.Tags.Net+                      ) where++import           Network.DO.Tags.Commands+import           Network.DO.Tags.Net

@@ -0,0 +1,70 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Network.DO.Tags.Commands(TagsCommands,+                                TagsCommandsT, CoTagsCommandsT,+                                CoTagsCommands(..),+                                TagName,+                                createTag, retrieveTag, listTags,+                                tagResources, untagResources,+                                deleteTag) where++import Prelude++import Control.Comonad.Trans.Cofree+import Control.Monad.Trans.Free+import Network.DO.Pairing+import Network.DO.Types hiding (TagResources, tagResources, name)++-- | Available commands for tags+data TagsCommands a = CreateTag TagName (Result Tag -> a)+                    | RetrieveTag TagName (Result Tag -> a)+                    | DeleteTag TagName (Result () -> a)+                    | ListTags (Result [Tag] -> a)+                    | TagResources TagName TagPairs (Result () -> a)+                    | UntagResources TagName TagPairs (Result () -> a)+                    deriving (Functor)++-- | free transformer to embed effects+type TagsCommandsT = FreeT TagsCommands++-- smart constructors+createTag :: TagName -> TagsCommands (Result Tag)+createTag name = CreateTag name Prelude.id++retrieveTag :: TagName -> TagsCommands (Result Tag)+retrieveTag name = RetrieveTag name Prelude.id++deleteTag :: TagName -> TagsCommands (Result ())+deleteTag name = DeleteTag name Prelude.id++listTags :: TagsCommands (Result [Tag])+listTags = ListTags Prelude.id++tagResources :: TagName -> TagPairs -> TagsCommands (Result ())+tagResources name pairs = TagResources name pairs Prelude.id++untagResources :: TagName -> TagPairs -> TagsCommands (Result ())+untagResources name pairs = TagResources name pairs Prelude.id++-- | Comonadic interpreter for @Tagscommands@+data CoTagsCommands m k = CoTagsCommands { createTagH      :: TagName -> (m (Result Tag), k)+                                         , retrieveTagH    :: TagName -> (m (Result Tag), k)+                                         , deleteTagH      :: TagName -> (m (Result ()), k)+                                         , listTagsH       :: (m (Result [Tag]), k)+                                         , tagResourcesH   :: TagName -> TagPairs -> (m (Result ()), k)+                                         , untagResourcesH :: TagName -> TagPairs -> (m (Result ()), k)+                                         } deriving Functor++-- | Cofree closure of CoTagsCommands functor+type CoTagsCommandsT m = CofreeT (CoTagsCommands m)++-- Pair DSL with interpreter within some monadic context+instance (Monad m) => PairingM (CoTagsCommands m) TagsCommands m where+  pairM f (CoTagsCommands create _ _ _ _ _)   (CreateTag name k)       = pairM f (create name) k+  pairM f (CoTagsCommands _ retrieve _ _ _ _) (RetrieveTag name k)     = pairM f (retrieve name) k+  pairM f (CoTagsCommands _ _ delete _ _ _)   (DeleteTag name k)       = pairM f (delete name) k+  pairM f (CoTagsCommands _ _ _ list _ _)     (ListTags k)             = pairM f list k+  pairM f (CoTagsCommands _ _ _ _ tag _)      (TagResources name pairs k)   = pairM f (tag name pairs) k+  pairM f (CoTagsCommands _ _ _ _ _ untag)    (UntagResources name pairs k) = pairM f (untag name pairs) k

@@ -0,0 +1,107 @@+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Network interpreter for Tags specific API+module Network.DO.Tags.Net(tagsCommandsInterpreter) where++import Prelude                      as P hiding (error)++import Control.Comonad.Env.Class    (ComonadEnv, ask)+import Control.Monad.Trans          (MonadIO)+import Data.Aeson                   as A hiding (Result, pairs)+import Data.Proxy+import Network.DO.Tags.Commands+import Network.DO.Net.Common+import Network.DO.Types             as DO hiding (URI, name)+import Network.REST+++-- | Resource identifier for tags+tagsURI :: String+tagsURI = "tags"++-- | Root endpoint for tags+tagsEndpoint :: String+tagsEndpoint = rootURI </> apiVersion </> tagsURI+++-- Derive the listTags endpoint for free, see @Network.DO.Net.Common@+--+-- https://developers.digitalocean.com/documentation/v2/#list-all-tags+--+instance Listable Tag where+  listEndpoint _ = tagsEndpoint+  listField    _ = "tags"++-- | Create a new Tag+--+-- https://developers.digitalocean.com/documentation/v2/#create-a-new-tag+--+doCreateTag :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> TagName -> (RESTT m (Result Tag), w a)+doCreateTag w name = maybe (errMissingToken, w) runQuery (authToken (ask w))+  where+    runQuery t = let opts  = authorisation t+                     body  = toJSON . object $ ["name" .= name]+                     query = fromResponse "tag" <$> postJSONWith opts (toURI tagsEndpoint) body+                 in (query, w)++-- | Retrieve a Tag+--+-- https://developers.digitalocean.com/documentation/v2/#retrieve-a-tag+--+doRetrieveTag :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> TagName -> (RESTT m (Result Tag), w a)+doRetrieveTag w name = maybe (errMissingToken, w) runQuery (authToken (ask w))+  where+    runQuery t = let opts  = authorisation t+                     query = fromResponse "tag" . Right <$> getJSONWith opts (toURI $ tagsEndpoint </> name)+                 in (query, w)++-- | Delete a Tag+--+-- https://developers.digitalocean.com/documentation/v2/#delete-a-tag+--+doDeleteTag :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> TagName -> (RESTT m (Result ()), w a)+doDeleteTag w name = maybe (errMissingToken, w) runQuery (authToken (ask w))+  where+    runQuery t = let opts  = authorisation t+                     body  = toJSON ()+                     query = Right () <$ deleteJSONWith opts (toURI $ tagsEndpoint </> name) body+                 in (query, w)++-- | Tag one or several other resources+--+-- https://developers.digitalocean.com/documentation/v2/#tag-a-resource+--+doTagResources :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> TagName -> TagPairs-> (RESTT m (Result ()), w a)+doTagResources w name pairs = maybe (errMissingToken, w) runQuery (authToken (ask w))+  where+    runQuery t = let opts  = authorisation t+                     body  = toJSON pairs+                     query = Right () <$ postJSONWith opts (toURI $ tagsEndpoint </> name </> "resources") body+                 in (query, w)++-- | Untag one or several other resources+--+-- https://developers.digitalocean.com/documentation/v2/#untag-a-resource+--+doUntagResources :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> TagName -> TagPairs -> (RESTT m (Result ()), w a)+doUntagResources w name pairs = maybe (errMissingToken, w) runQuery (authToken (ask w))+  where+    runQuery t = let opts  = authorisation t+                     body  = toJSON pairs+                     query = Right () <$ deleteJSONWith opts (toURI $ tagsEndpoint </> name </> "resources") body+                 in (query, w)+++-- | DSL Interpreter for TagsCommands into IO via the REST DSL+tagsCommandsInterpreter :: (MonadIO m, ComonadEnv ToolConfiguration w) => w a -> CoTagsCommands (RESTT m) (w a)+tagsCommandsInterpreter = CoTagsCommands+                          <$> doCreateTag+                          <*> doRetrieveTag+                          <*> doDeleteTag+                          <*> queryList (Proxy :: Proxy Tag)+                          <*> doTagResources+                          <*> doUntagResources

@@ -13,9 +13,10 @@ import           Data.Aeson        as A hiding (Error, Result) import           Data.Aeson.Types  as A hiding (Error, Result) import           Data.Default+import           Data.Maybe        (isNothing) import qualified Data.HashMap.Lazy as H import           Data.IP-import           Data.List         (elemIndex)+import           Data.List         (elemIndex, concat) import           Data.Monoid       ((<>)) import           Data.Text         (pack, unpack) import           Data.Time         (UTCTime)@@ -156,12 +157,19 @@   parseJSON (Number n) = jsonBytes (truncate n)   parseJSON e          = failParse e +instance ToJSON (Bytes a) where+  toJSON Bytes{..} = toJSON bytesSize++ newtype Date = Date { theDate :: UTCTime } deriving Show  instance FromJSON Date where   parseJSON d@(String _) = Date <$> parseJSON d   parseJSON e            = failParse e +instance ToJSON Date where+  toJSON Date{..} = toJSON theDate+ data Status = New             | Active             | Off@@ -170,13 +178,20 @@  instance FromJSON Status where   parseJSON (String s) = case s of-                          "new" -> return New-                          "active" -> return Active-                          "off" -> return Off-                          "archive" -> return Archive-                          _        -> fail $ "cannot parse " <> unpack s+                          "new"      -> return New+                          "active"   -> return Active+                          "off"      -> return Off+                          "archive"  -> return Archive+                          _          -> fail $ "cannot parse " <> unpack s   parseJSON e          = failParse e +instance ToJSON Status where+  toJSON New     = "new"+  toJSON Active  = "active"+  toJSON Off     = "off"+  toJSON Archive = "archive"++ data NetType = Public | Private deriving (Show, Eq)  -- | Type of a single Network definition@@ -209,6 +224,10 @@                           e         -> failParse e   parseJSON e          = failParse e +instance ToJSON NetType where+  toJSON Public  = "public"+  toJSON Private = "private"+ data V4 data V6 @@ -219,15 +238,30 @@                   <*> (n .: "gateway")                   <*> (n .: "type") +toJsonNetwork :: (ToJSON netmask) => IP -> netmask -> IP -> NetType -> Value+toJsonNetwork ip_address netmask gateway netType = object [ "ip_address" .= ip_address+                                                          , "netmask"    .= netmask+                                                          , "gateway"    .= gateway+                                                          , "type"       .= netType+                                                          ]+ instance FromJSON (Network V4) where   parseJSON (Object n) = jsonNetwork NetworkV4 n   parseJSON e          = failParse e +instance ToJSON (Network V4) where+  toJSON NetworkV4{..} = toJsonNetwork ip_address netmask gateway netType+  toJSON NetworkV6{..} = toJsonNetwork ip_address netmask_v6 gateway netType+ instance FromJSON (Network V6) where   parseJSON (Object n) = jsonNetwork NetworkV6 n   parseJSON e          = fail $ "cannot parse network v6 " <> show e +instance ToJSON (Network V6) where+  toJSON NetworkV4{..} = toJsonNetwork ip_address netmask gateway netType+  toJSON NetworkV6{..} = toJsonNetwork ip_address netmask_v6 gateway netType + -- | Type of Networks configured for a @Droplet@ -- -- A network is either a list of IPv4 and IPv6 NICs definitions, or no network. We need this@@ -246,6 +280,12 @@                               <*> (n .: "v6")   parseJSON e          = fail $ "cannot parse network v6 " <> show e +instance ToJSON Networks where+  toJSON NoNetworks = Null+  toJSON Networks{..} = object [ "v4" .= v4+                               , "v6" .= v6+                               ]+ -- | (Partial) Type of Droplets -- -- https://developers.digitalocean.com/documentation/v2/#droplets@@ -281,7 +321,23 @@                          <*> o .: "networks"   parseJSON e          = fail $ "cannot parse network v6 " <> show e +instance ToJSON Droplet where+  toJSON Droplet{..} = object [ "id"           .= dropletId+                              , "name"         .= name+                              , "memory"       .= memory+                              , "vcpus"        .= vcpus+                              , "disk"         .= disk+                              , "locked"       .= locked+                              , "created_at"   .= created_at+                              , "status"       .= status+                              , "backup_ids"   .= backup_ids+                              , "snapshot_ids" .= snapshot_ids+                              , "region"       .= region+                              , "size_slug"    .= size_slug+                              , "networks"     .= networks+                              ] + data ImageType = Snapshot                | Temporary                | Backup@@ -611,5 +667,183 @@   parseJSON v          = failParse v  +-- | Type of Resources+data ResourceType+  = ResourceDroplet+  | ResourceVolume+  | ResourceBackend+  deriving (Eq, Ord, Enum)++resourceTypes :: [String]+resourceTypes = ["droplet", "volume", "backend"]++instance Show ResourceType where+  show r = resourceTypes !! fromEnum r++instance Read ResourceType where+  readsPrec _ sz = case elemIndex sz resourceTypes of+                    Just i  -> return (toEnum i, "")+                    Nothing -> fail $ "cannot parse " <> sz++instance FromJSON ResourceType where+  parseJSON (String v) =+    case elemIndex (unpack v) resourceTypes of+      Just i ->+        return $ toEnum i+      Nothing ->+        failParse ("cannot parse " <> v)++  parseJSON e = failParse e++instance ToJSON ResourceType where+  toJSON = toJSON . show++-- | Type of Block Storage (Volume)+--+-- https://developers.digitalocean.com/documentation/v2/#block-storage+data Volume = Volume+  { volumeId            :: Id      -- ^ The unique identifier for the Block Storage Volume.+  , volumeRegion        :: Region  -- ^ The region that the Block Storage Volume is located in.+  , volumeDropletIds    :: [Id]    -- ^ An array containing the IDs of the Droplets the volume is attached to.+  , volumeName          :: String  -- ^ A human-redable name for the Block Storage Volume.+  , volumeDescription   :: String  -- ^ An optional free-form text field to describe a Block Storage Volume.+  , volumeSizeGigaBytes :: Int     -- ^ The size of the Block Storage Volume in GiB (1024^3)+  , volumeCreatedAt     :: Date    -- ^ A time value that represents when the Block Storage Volume was created.+  } deriving (Show)++instance FromJSON Volume where+  parseJSON (Object o) = Volume+                         <$> o .: "id"+                         <*> o .: "region"+                         <*> o .: "droplet_ids"+                         <*> o .: "name"+                         <*> o .: "description"+                         <*> o .: "size_gigabytes"+                         <*> o .: "created_at"++  parseJSON e          = failParse e++instance ToJSON Volume where+  toJSON Volume{..} = object [ "id"             .= volumeId+                             , "region"         .= volumeRegion+                             , "droplet_ids"    .= volumeDropletIds+                             , "name"           .= volumeName+                             , "description"    .= volumeDescription+                             , "size_gigabytes" .= volumeSizeGigaBytes+                             , "created_at"     .= volumeSizeGigaBytes+                             ]+++-- | Type of Tags+--+-- https://developers.digitalocean.com/documentation/v2/#tags++type TagName = String++data Tag = Tag+  { tagName      :: TagName       -- ^ The tag name+  , tagResources :: TagResources  -- ^ An embedded object containing key value pairs of resource type and resource statistics+  } deriving (Show)++data TagResources = TagResources+  { tagDroplets :: TagDroplets  -- ^ Statistics about the droplets resources+  , tagVolumes  :: TagVolumes   -- ^ Statistics about the volumes resources+  -- NOTE backend resources seem to exist too but I can't find any representation of them :|+  } deriving (Show)++data TagDroplets = TagDroplets+  { tagDropletsCount      :: Int            -- ^ The number of tagged droplets+  , tagDropletsLastTagged :: Maybe Droplet  -- ^ The last tagged droplet+  } deriving (Show)++data TagVolumes = TagVolumes+  { tagVolumesCount      :: Int           -- ^ The number of tagged volumes+  , tagVolumesLastTagged :: Maybe Volume  -- ^ The last tagged volume+  } deriving (Show)++data TagPairs = TagPairs+  { tagPairsResources :: [TagPair] -- ^ An array of objects containing resource_id and resource_type attributes+  } deriving (Show)++data TagPair = TagPair+  { tagPairResourceId   :: Id            -- ^ The identifier of a resource+  , tagPairResourceType :: ResourceType  -- ^ The type of the resource+  } deriving (Show)+++instance FromJSON Tag where+  parseJSON (Object o) = Tag+                         <$> o .: "name"+                         <*> o .: "resources"++  parseJSON e          = failParse e++instance FromJSON TagResources where+  parseJSON (Object o) = TagResources+                         <$> o .:? "droplets" .!= TagDroplets 0 Nothing+                         <*> o .:? "volumes"  .!= TagVolumes  0 Nothing++  parseJSON e          = failParse e++instance FromJSON TagDroplets where+  parseJSON (Object o) = TagDroplets+                         <$> o .:  "count"+                         <*> o .:? "last_tagged"++  parseJSON e          = failParse e++instance FromJSON TagVolumes where+  parseJSON (Object o) = TagVolumes+                         <$> o .:  "count"+                         <*> o .:? "last_tagged"++  parseJSON e          = failParse e++instance FromJSON TagPairs where+  parseJSON (Object o) = TagPairs+                         <$> o .: "resources"++  parseJSON e         = failParse e++instance FromJSON TagPair where+  parseJSON (Object o) = TagPair+                         <$> o .: "resource_id"+                         <*> o .: "resource_type"++  parseJSON e          = failParse e++instance ToJSON Tag where+  toJSON Tag{..} = object [ "name"      .= tagName+                          , "resources" .= tagResources+                          ]++instance ToJSON TagResources where+  toJSON TagResources{..} = object $ concat+    [ if isNothing (tagDropletsLastTagged tagDroplets) then [] else ["droplets" .= tagDroplets]+    , if isNothing (tagVolumesLastTagged tagVolumes)   then [] else ["volumes"  .= tagVolumes]+    ]++instance ToJSON TagDroplets where+  toJSON TagDroplets{..} = object [ "count"       .= tagDropletsCount+                                  , "last_tagged" .= tagDropletsLastTagged+                                  ]++instance ToJSON TagVolumes where+  toJSON TagVolumes{..} = object [ "count"       .= tagVolumesCount+                                 , "last_tagged" .= tagVolumesLastTagged+                                 ]++instance ToJSON TagPairs where+  toJSON TagPairs{..} = object [ "resouces" .= tagPairsResources+                               ]++instance ToJSON TagPair where+  toJSON TagPair{..} = object [ "resource_id"   .= tagPairResourceId+                              , "resource_type" .= tagPairResourceType+                              ]+++-- Utility+-- failParse :: (Show a1, Monad m) => a1 -> m a failParse e = fail $ "cannot parse " <> show e

@@ -23,7 +23,7 @@            | WaitFor Int String a            | GetWith Options URI (Value -> a)            | PostWith Options URI Value (Either String Value -> a)-           | DeleteWith Options URI a+           | DeleteWith Options URI Value a            deriving (Functor)  type RESTT = FreeT REST@@ -41,8 +41,8 @@ postJSONWith :: (Monad m) => Options ->  URI -> Value -> RESTT m (Either String Value) postJSONWith opts uri json = liftF $ PostWith opts uri json id -deleteJSONWith :: (Monad m) => Options -> URI -> RESTT m ()-deleteJSONWith opts uri = liftF $ DeleteWith opts uri ()+deleteJSONWith :: (Monad m) => Options -> URI -> Value -> RESTT m ()+deleteJSONWith opts uri json = liftF $ DeleteWith opts uri json ()  waitFor :: (Monad m) => Int -> String -> RESTT m () waitFor delay message = liftF $ WaitFor delay message ()

@@ -70,10 +70,10 @@         let value = getResponseBody response :: Value         runConduit debug (k value) -      step (Free (DeleteWith opts uri k)) = do+      step (Free (DeleteWith opts uri val k)) = do         request <- parseRequest $ "DELETE " ++ asString uri-        debugRequest debug (RequestLog request)-        void $ httpLBS $ options opts request+        debugRequest debug (RequestLogWithBody request (Body val))+        void $ httpLBS $ options opts $ setRequestBodyJSON val request         runConduit debug k        step (Free (Post uri val k)) = do