hdo 0.2 → 0.3

raw patch · 23 files changed

+947/−231 lines, 23 filesdep +case-insensitivedep +http-conduitdep +parsecdep −wreqdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: case-insensitive, http-conduit, parsec

Dependencies removed: wreq

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.md +167/−27
• hdo.cabal +10/−5
• main/hdo.hs +45/−44
• src/Network/DO.hs +119/−0
• src/Network/DO/Commands.hs +7/−7
• src/Network/DO/Domain.hs +4/−0
• src/Network/DO/Domain/Commands.hs +62/−0
• src/Network/DO/Domain/Net.hs +83/−0
• src/Network/DO/Droplets/Commands.hs +6/−6
• src/Network/DO/Droplets/Net.hs +10/−26
• src/Network/DO/IP.hs +9/−0
• src/Network/DO/IP/Commands.hs +52/−0
• src/Network/DO/IP/Net.hs +62/−0
• src/Network/DO/Net.hs +13/−2
• src/Network/DO/Net/Common.hs +8/−13
• src/Network/DO/Pairing.hs +40/−11
• src/Network/DO/Pretty.hs +28/−2
• src/Network/DO/Types.hs +145/−23
• src/Network/REST.hs +4/−6
• src/Network/REST/Commands.hs +9/−4
• src/Network/REST/Conduit.hs +63/−0
• src/Network/REST/Wreq.hs +0/−54
• stack.yaml +1/−1

@@ -2,40 +2,180 @@  [![Build Status](https://travis-ci.org/capital-match/hdo.svg?branch=master)](https://travis-ci.org/capital-match/hdo) -**WARNING** This implementation still covers only a small subset of DO API- This is a [Digital Ocean](https://www.digitalocean.com/) client written in [Haskell](http://haskell.org). It can be used either as a library or as command-line utility. +# Build -## Compile-`stack setup`-`stack build`+*hdo* is built with [stack](https://github.com/commercialhaskell/stack/), using [Stackage LTS-7.7](https://www.stackage.org/lts-7.7) dependencies. To build, follow the standard instructions: -## Usage-First export the AUTH_TOKEN:-`export AUTH_TOKEN=2342342341234eaf`+Install the correct GHC version: -List existing droplets:-`stack exec docean -- droplets list`+> stack setup  -List existing regions:-`stack exec docean -- regions list`+Build and install the package locally, possibly making executable `docean` available from `PATH`: -## Implemented commands:+> stack install++# Usage++## Command-line Tool ++Command-line tool is named `docean`. If it's been installed, it should be available in your PATH. Otherwise, you can run it from the source directory using `stack exec docean -- <args>`. `docean` expects authentication token to be available from environment variable `AUTH_TOKEN`, see [Digital Ocean API](https://developers.digitalocean.com/documentation/v2/#authentication) for details on how to get that authentication token.++> export AUTH_TOKEN=2342342341234eaf++## Available Commands++**NOTE**: Not all the available APIs from DO are implemented (yet).++### Droplets++#### Creating a Droplet++This is the most complex command, as creating a droplet can use a lot of different options.+ ```-droplets create-droplets destroy <dropletId>-droplets list-droplets power_off <dropletId>-droplets power_on  <dropletId>-droplets snapshot  <dropletId> <snapshotName>-droplets action    <dropletId> <actionId>-droplets <dropletId> snapshots-droplets <dropletId>-droplets ssh <dropletId or Name>-images list-regions list-keys list-sizes list+$ docean droplets create -r ams2 -s 1gb -i ubuntu-16-04-x64 -n deploy-test -k '[2436510]'+waiting for droplet deploy-test to become Active: 60s+waiting for droplet deploy-test to become Active: 59s+waiting for droplet deploy-test to become Active: 58s+waiting for droplet deploy-test to become Active: 57s+waiting for droplet deploy-test to become Active: 56s+waiting for droplet deploy-test to become Active: 55s+waiting for droplet deploy-test to become Active: 54s+waiting for droplet deploy-test to become Active: 53s+waiting for droplet deploy-test to become Active: 52s+30876135+     deploy-test [Active] ams2: Amsterdam 2+     1024M/30G/1 cores+     IPv4+       95.85.44.239/255.255.255.0 [Public]+     IPv6 ```++The available parameters are:++* `-r|--region`: Sets the region where droplet is created, using the *region slug*+* `-s|--size`: Sets the size of the droplet, from `512mb` to `96gb`+* `-n|--name`: Name of the newly created droplet+* `-i|--image`: Slug of the image to use as base image for droplet+* `-k|--keys`: List (in the form readable by Haskell to convert to type `[Int]`) of keys to add for accessing the droplet+* `-b|--background`: Create droplet in the background, returning only the identifier of action to be checked later. If not set, creation is *synchronous*: The client will check wait for droplet to be up for 60s.++When successfully created, the main characteristics of the droplet are printed to the console.++#### Other Droplet Operations++Destroy an existing droplet:++```+$ droplets destroy 30876135+-+```++List all created droplets:++```+$ docean droplets list+21002433+     droplet-01 [Active] sgp1: Singapore 1+     1024M/30G/1 cores+     IPv4+       1.2.3.4/255.255.240.0 [Public]+     IPv6+26082279+     droplet-02 [Active] sgp1: Singapore 1+     512M/20G/1 cores+     IPv4+       1.2.3.5/255.255.240.0 [Public]+     IPv6+31114780+     droplet-03 [Active] ams2: Amsterdam 2+     2048M/40G/2 cores+     IPv4+       5.6.7.8/255.255.240.0 [Public]+     IPv6+```++Shutdown/startup a droplet:++```+$ docean droplets power_off 31166171+[163908062] 2016-11-01 21:08:46 UTC -> -+     31166171 PowerOff: InProgress+```++```+$ docean droplets power_on 31166171+[163908350] 2016-11-01 21:10:16 UTC -> -+     31166171 PowerOn: InProgress+```++Retrieve status of an action initiated on the droplet (usually related to power on/off or snapshots):++```+$ docean droplets action 31166171 163908062+[163908062] 2016-11-01 21:08:46 UTC -> 2016-11-01 21:08:58 UTC+     31166171 PowerOff: Completed+```++Take a snapshot of an existing droplet (must be powered off):++```+$ docean droplets snapshot 31166171 mysnapshot+[163908530] 2016-11-01 21:11:19 UTC -> -+     31166171 MakeSnapshot: InProgress+```++List existing snapshots for droplet:++```+$ docean droplets 31166171 snapshots+20648640 mysnapshot Ubuntu+```++Connect to the droplet through SSH (can be given a name or a droplet ID):++```+$ docean droplets ssh 31166171+The authenticity of host '1.2.3.4 (1.2.3.4)' can't be established.+RSA key fingerprint is 3f:16:4f:f4:25:85:85:77:1e:90:bd:8c:6b:90:48:eb.+Are you sure you want to continue connecting (yes/no)? yes+Warning: Permanently added '1.2.3.4' (RSA) to the list of known hosts.+Welcome to Ubuntu 16.04.1 LTS (GNU/Linux 4.4.0-45-generic x86_64)++ * Documentation:  https://help.ubuntu.com+ * Management:     https://landscape.canonical.com+ * Support:        https://ubuntu.com/advantage++0 packages can be updated.+0 updates are security updates.++++The programs included with the Ubuntu system are free software;+the exact distribution terms for each program are described in the+individual files in /usr/share/doc/*/copyright.++Ubuntu comes with ABSOLUTELY NO WARRANTY, to the extent permitted by+applicable law.++root@droplet:~# +```++### Images++### Regions++### Keys++### Sizes++### Floating IPs++### Domains++## Library++TBD

@@ -1,5 +1,5 @@ Name: hdo-Version: 0.2+Version: 0.3 Cabal-Version: >= 1.18 Maintainer: Arnaud Bailly <arnaud.oqube@gmail.com> Author: Arnaud Bailly@@ -20,24 +20,30 @@   Default-Language:   Haskell2010   GHC-Options:  -Wall -fno-warn-orphans   Hs-Source-Dirs:  src-  Other-Modules:  Network.REST.Commands, Network.REST.Wreq, Network.SSH-  exposed-modules: Network.DO.Commands-                 , Network.DO.Types+  Other-Modules:   Network.REST.Commands, Network.REST.Conduit, Network.SSH, Network.DO.Types                  , Network.DO.Net, Network.DO.Net.Common+                 , Network.DO.Commands                  , 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.Names, Network.DO.Pairing                  , Network.REST, Network.DO.Pretty+                 +  exposed-modules: Network.DO   Build-Depends: aeson                , base >= 4 && < 5                , bytestring+               , case-insensitive                , comonad                , data-default                , free+               , http-conduit                , iproute                , lens                , pretty                , mtl                , network-uri+               , parsec                , random                , text                , tagged@@ -46,7 +52,6 @@                , unix, process                , unordered-containers                , vector-               , wreq  Executable docean   Default-Language:   Haskell2010

@@ -1,30 +1,16 @@-{-# LANGUAGE DoAndIfThenElse       #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE DoAndIfThenElse, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, ScopedTypeVariables #-} module Main where -import           Control.Exception            (catch, throw)-import           Control.Monad.IO.Class       (MonadIO (..))-import           Control.Monad.Trans.Free     (FreeT)-import           Data.Functor.Sum+import           Control.Exception      (catch, throw)+import           Control.Monad.IO.Class (MonadIO (..)) import           Data.Maybe-import           Data.Monoid                  ((<>))-import           Prelude                      as P hiding (error)+import           Data.Monoid            ((<>))+import           Network.DO+import           Prelude                as P hiding (error) import           System.Console.GetOpt import           System.Environment import           System.IO-import           System.IO.Error              (isDoesNotExistError)-import           Network.DO.Commands-import           Network.DO.Droplets.Commands-import           Network.DO.Droplets.Utils-import           Network.DO.Names-import           Network.DO.Net-import           Network.DO.Pairing-import           Network.DO.Pretty            (outputResult)-import           Network.DO.Types             as DO-import           Network.REST+import           System.IO.Error        (isDoesNotExistError)  generalOptions :: [OptDescr (ToolConfiguration -> ToolConfiguration)] generalOptions = [ Option ['t'] ["auth-token"]@@ -56,16 +42,13 @@                          "add a key to access box (default: '[]')"                        ] -getAuthFromEnv :: IO (Maybe AuthToken)-getAuthFromEnv = (Just `fmap` getEnv "AUTH_TOKEN") `catch` (\ (e :: IOError) -> if isDoesNotExistError e then return Nothing else throw e)- getSlackUriFromEnv :: IO (Maybe URI) getSlackUriFromEnv = (Just `fmap` getEnv "SLACK_URI") `catch` (\ (e :: IOError) -> if isDoesNotExistError e then return Nothing else throw e)  defaultBox :: IO BoxConfiguration defaultBox = do   name <- generateName-  return $ BoxConfiguration name (RegionSlug "ams2") G4 defaultImage [429079] False+  return $ BoxConfiguration name (RegionSlug "ams2") G4 defaultImage [] False  defaultTool :: IO ToolConfiguration defaultTool = do@@ -89,38 +72,56 @@ main = do   hSetBuffering stdin NoBuffering   args <- getArgs-  (opts, cmds) <- parseOptions args-  runWreq $ pairEffectM (\ _ b -> return b) (mkDOClient opts) (parseCommandOptions cmds)+  (_, cmds) <- parseOptions args+  runDOEnv (parseCommandOptions cmds) -parseCommandOptions :: (MonadIO m) => [String] -> FreeT (Sum DO DropletCommands) (RESTT m) ()+parseCommandOptions :: (MonadIO m) => [String] -> Command m () parseCommandOptions ("droplets":"create":args) = do   b <- liftIO defaultBox   case getOpt Permute createDropletOptions args of-   (c,[],[])  -> injr (createDroplet (foldl (flip P.id) b c)) >>= outputResult+   (c,[],[])  -> createDroplet (foldl (flip P.id) b c) >>= outputResult    (_,_,errs) -> liftIO $ ioError (userError (concat errs  ++ usage))-parseCommandOptions ("droplets":"destroy":dropletId:[]) = injr ( destroyDroplet (P.read dropletId) ) >>= outputResult-parseCommandOptions ("droplets":"list":_)               = injr ( listDroplets ) >>= outputResult+parseCommandOptions ("droplets":"destroy":dropletId:[]) = destroyDroplet (P.read dropletId) >>= outputResult+parseCommandOptions ("droplets":"list":_)               = listDroplets >>= outputResult parseCommandOptions ("droplets":"power_off":dropletId:[])-                                                         = injr ( dropletAction (P.read dropletId) DoPowerOff) >>= outputResult+                                                         = dropletAction (P.read dropletId) DoPowerOff >>= outputResult parseCommandOptions ("droplets":"power_on":dropletId:[])-                                                         = injr ( dropletAction (P.read dropletId) DoPowerOn) >>= outputResult+                                                         = dropletAction (P.read dropletId) DoPowerOn >>= outputResult parseCommandOptions ("droplets":"snapshot":dropletId:snapshotName:[])-                                                         = injr ( dropletAction (P.read dropletId) (CreateSnapshot snapshotName)) >>= outputResult+                                                         = dropletAction (P.read dropletId) (CreateSnapshot snapshotName) >>= outputResult parseCommandOptions ("droplets":"action":dropletId:actionId:[])-                                                         = injr ( getAction (P.read dropletId)  (P.read actionId)) >>= outputResult+                                                         = getAction (P.read dropletId)  (P.read actionId) >>= outputResult parseCommandOptions ("droplets":dropletId:"snapshots":[])-                                                         = injr ( listDropletSnapshots (P.read dropletId)) >>= outputResult+                                                         = listDropletSnapshots (P.read dropletId) >>= outputResult parseCommandOptions ("droplets":dropletId:[])-                                                         = injr ( showDroplet (P.read dropletId)) >>= outputResult+                                                         = showDroplet (P.read dropletId) >>= outputResult parseCommandOptions ("droplets":"ssh":dropletIdOrName:[])                                                          =  (do-                                                                droplets <- injr $ (findByIdOrName dropletIdOrName) <$> listDroplets+                                                                droplets <- findByIdOrName dropletIdOrName <$> listDroplets                                                                 case droplets of-                                                                 (did:_) -> injr $ dropletConsole did+                                                                 (did:_) -> dropletConsole did                                                                  []      -> return (error $ "no droplet with id or name " <> dropletIdOrName)                                                             ) >>= outputResult-parseCommandOptions ("images":"list":_)                  = injl listImages >>= outputResult-parseCommandOptions ("regions":"list":_)                 = injl listRegions >>= outputResult-parseCommandOptions ("keys":"list":_)                    = injl listKeys >>= outputResult-parseCommandOptions ("sizes":"list":_)                   = injl listSizes >>= outputResult-parseCommandOptions e                                    = fail $ "I don't know how to interpret commands " ++ unwords e ++ "\n" ++ usage+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+  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+parseCommandOptions ("dns":name:"list":_)        = listRecords (P.read name) >>= outputResult+parseCommandOptions ("dns":name:"create":rest)   =+  case (parseRecord $ unwords rest) of+    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 e                          = fail $ "I don't know how to interpret commands " ++ unwords e ++ "\n" ++ usage

@@ -0,0 +1,119 @@+{-# LANGUAGE ScopedTypeVariables, TypeOperators #-}+module Network.DO(+  -- * Types+  Command,+  module Network.DO.Types,+  -- * Generic Commands+  listKeys, listSizes, listRegions, listImages,+  -- * Droplets Commands+  listDroplets, createDroplet, showDroplet, destroyDroplet,+  dropletAction, dropletConsole, getAction, listDropletSnapshots,+  -- * Floating IPs Commands+  listFloatingIPs, createFloatingIP, deleteFloatingIP, assignFloatingIP, unassignFloatingIP,+  -- * Domains Commands+  listDomains, createDomain, deleteDomain,+  listRecords, createRecord, deleteRecord,+  -- * Utilities+  runDOEnv, runDO, getAuthFromEnv, outputResult,+  generateName,+  module Network.DO.Droplets.Utils) where++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.REST+import           System.Environment           (getEnv)+import           System.IO.Error              (isDoesNotExistError)++type Command w a = FreeT (C.DO :+: C.DropletCommands :+: C.IPCommands :+: C.DomainCommands) (RESTT w) a++listKeys :: (Monad w) => Command w [Key]+listKeys = injl C.listKeys++listSizes :: (Monad w) => Command w [Size]+listSizes = injl C.listSizes++listImages  :: (Monad w) => Command w  [Image]+listImages = injl C.listImages++listRegions :: (Monad w) => Command w [Region]+listRegions = injl C.listRegions++listFloatingIPs :: (Monad w) => Command w [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 = injrrl . C.deleteFloatingIP++assignFloatingIP :: (Monad w) => IP -> Id -> Command w (Result (ActionResult IPActionType))+assignFloatingIP ip did = injrrl $ C.floatingIPAction ip (AssignIP did)++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++createDomain :: (Monad w) => DomainName -> IP -> Command w (Result Domain)+createDomain dname ip = injrrr $ C.createDomain dname ip++deleteDomain :: (Monad w) => DomainName -> Command w (Maybe String)+deleteDomain = injrrr . C.deleteDomain++listRecords :: (Monad w) => DomainName -> Command w [DomainRecord]+listRecords = injrrr . C.listRecords++createRecord :: (Monad w) => DomainName -> DomainRecord -> Command w (Result DomainRecord)+createRecord dname ip = injrrr $ C.createRecord dname ip++deleteRecord :: (Monad w) => DomainName -> Id -> Command w (Maybe String)+deleteRecord dname rid = injrrr $ C.deleteRecord dname rid++listDroplets :: (Monad w) => Command w [Droplet]+listDroplets = injrl C.listDroplets++createDroplet :: (Monad w) => BoxConfiguration -> Command w (Either Error Droplet)+createDroplet = injrl . C.createDroplet++showDroplet :: (Monad w) => Integer -> Command w (Either Error Droplet)+showDroplet = injrl . C.showDroplet++destroyDroplet :: (Monad w) => Integer -> Command w (Maybe String)+destroyDroplet = injrl . C.destroyDroplet++dropletAction :: (Monad w) => Id -> Action -> Command w (Result (ActionResult DropletActionType))+dropletAction did = injrl . C.dropletAction did++dropletConsole :: (Monad w) => Droplet -> Command w (Result ())+dropletConsole = injrl . C.dropletConsole++getAction :: (Monad w) => Id -> Id -> Command w (Result (ActionResult DropletActionType))+getAction  did = injrl . C.getAction did++listDropletSnapshots :: (Monad w) => Id -> Command w [Image]+listDropletSnapshots = injrl . C.listDropletSnapshots++-- | Run DO actions, extracting authentication token from environment variable `AUTH_TOKEN`.+runDOEnv :: Command IO a -> IO a+runDOEnv actions = getAuthFromEnv >>= runDO actions++-- | Run DO actions, passing a built authentication token.+runDO :: Command IO a -> Maybe AuthToken -> IO a+runDO actions token =  runConduit $ pairEffectM (\ _ b -> return b) (mkDOClient $ Tool Nothing token False) actions+++getAuthFromEnv :: IO (Maybe AuthToken)+getAuthFromEnv = (Just `fmap` getEnv "AUTH_TOKEN") `catch` (\ (e :: IOError) -> if isDoesNotExistError e then return Nothing else throw e)

@@ -33,9 +33,9 @@ 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)+data CoDO m k = CoDO { listKeysH    :: (m [Key], k)+                     , listSizesH   :: (m [Size], k)+                     , listImagesH  :: (m [Image], k)                      , listRegionsH :: (m [Region], k)                      } deriving Functor @@ -44,7 +44,7 @@  -- pair DSL with interpreter within some monadic context instance (Monad m) => PairingM (CoDO m) DO m where-  pairM f (CoDO ks _  _ _)  (ListKeys k)   = pairM f ks k-  pairM f (CoDO _ szs _ _)  (ListSizes k)  = pairM f szs k-  pairM f (CoDO _ _ imgs _)  (ListImages k) = pairM f imgs k-  pairM f (CoDO _ _ _ rgns)  (ListRegions k) = pairM f rgns k+  pairM f (CoDO ks _  _ _ )  (ListKeys k)   = pairM f ks k+  pairM f (CoDO _ szs _ _ )  (ListSizes k)  = pairM f szs k+  pairM f (CoDO _ _ imgs _ )  (ListImages k) = pairM f imgs k+  pairM f (CoDO _ _ _ rgns )  (ListRegions k) = pairM f rgns k

@@ -0,0 +1,4 @@+module Network.DO.Domain(module C) where++import           Network.DO.Domain.Commands as C+import           Network.DO.Domain.Net      as C

@@ -0,0 +1,62 @@+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Network.DO.Domain.Commands where++import           Control.Comonad.Trans.Cofree+import           Control.Monad.Trans.Free+import           Data.IP+import           Network.DO.Pairing+import           Network.DO.Types+import           Prelude                      as P++data DomainCommands a = ListDomains ([Domain] -> a)+                      | CreateDomain DomainName IP (Result Domain -> a)+                      | DeleteDomain DomainName (Maybe String -> a)+                      | ListRecords DomainName ([DomainRecord] -> a)+                      | CreateRecord DomainName DomainRecord (Result DomainRecord -> a)+                      | DeleteRecord DomainName Id (Maybe String -> a)+                      deriving (Functor)++type DomainCommandsT = FreeT DomainCommands++-- smart constructors+listDomains :: DomainCommands [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 ip = DeleteDomain ip P.id++listRecords :: DomainName -> DomainCommands [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 dname rid = DeleteRecord dname rid P.id++-- dual type, for creating interpreters+data CoDomainCommands m k =+  CoDomainCommands { listDomainsH  :: (m [Domain], k)+                   , createDomainH :: DomainName -> IP -> (m (Result Domain), k)+                   , deleteDomainH :: DomainName -> (m (Maybe String), k)+                   , listRecordsH  :: DomainName -> (m [DomainRecord], k)+                   , createRecordH :: DomainName -> DomainRecord -> (m (Result DomainRecord), k)+                   , deleteRecordH :: DomainName -> Id -> (m (Maybe String), k)+                   } deriving Functor++-- Cofree closure of CoDomainCommands functor+type CoDomainCommandsT m = CofreeT (CoDomainCommands m)++-- pair DSL with interpreter within some monadic context+instance (Monad m) => PairingM (CoDomainCommands m) DomainCommands m where+  pairM f (CoDomainCommands ks _ _ _ _ _)    (ListDomains k)      = pairM f ks k+  pairM f (CoDomainCommands _  tgt _ _ _ _)  (CreateDomain n i k) = pairM f (tgt n i) k+  pairM f (CoDomainCommands _  _  del _ _ _) (DeleteDomain n k)   = pairM f (del n) k+  pairM f (CoDomainCommands _ _ _ ks _ _)    (ListRecords n k)    = pairM f (ks n) k+  pairM f (CoDomainCommands _  _ _ _ tgt _)  (CreateRecord n r k) = pairM f (tgt n r) k+  pairM f (CoDomainCommands _  _  _ _ _ del) (DeleteRecord n i k) = pairM f (del n i) k

@@ -0,0 +1,83 @@+{-# LANGUAGE DoAndIfThenElse       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}++-- | Network interpreter for Floating Domains specific API+module Network.DO.Domain.Net(dnsCommandsInterpreter) where++import           Control.Applicative+import           Control.Comonad.Env.Class  (ComonadEnv, ask)+import           Control.Monad.Trans        (MonadIO)+import           Data.Aeson                 as A hiding (Result)+import           Data.IP+import           Data.Maybe+import           Data.Proxy+import           Network.DO.Domain.Commands+import           Network.DO.Net.Common+import           Network.DO.Types           as DO hiding (URI)+import           Network.REST+import           Prelude                    as P hiding (error)++domainsURI :: String+domainsURI = "domains"++domainsEndpoint :: String+domainsEndpoint = rootURI </> apiVersion </> domainsURI++instance Listable Domain where+  listEndpoint _ = domainsEndpoint+  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)+  runQuery+  (authToken (ask w))+  where+    runQuery t = let opts   = authorisation t+                     domain = postJSONWith opts (toURI domainsEndpoint) (toJSON config) >>= return . fromResponse "domain"+                 in (domain, w)++      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+                          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)+                       (\ 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)+  runQuery+  (authToken (ask w))+  where+    runQuery t = let opts   = authorisation t+                     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 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+          in (r, w))+  (authToken (ask w))++dnsCommandsInterpreter :: (MonadIO m, ComonadEnv ToolConfiguration w) => w a -> CoDomainCommands (RESTT m) (w a)+dnsCommandsInterpreter = CoDomainCommands+                        <$> queryList (Proxy :: Proxy Domain)+                        <*> doCreateDomain+                        <*> doDeleteDomain+                        <*> doListRecords+                        <*> doCreateRecord+                        <*> doDeleteRecord+

@@ -18,8 +18,8 @@ data DropletCommands a = ListDroplets ([Droplet] -> a)                        | CreateDroplet BoxConfiguration (Result Droplet -> a)                        | DestroyDroplet Id (Maybe String -> a)-                       | DropletAction Id Action (Result ActionResult -> a)-                       | GetAction Id Id (Result ActionResult -> a)+                       | DropletAction Id Action (Result (ActionResult DropletActionType) -> a)+                       | GetAction Id Id (Result (ActionResult DropletActionType) -> a)                        | ListSnapshots Id ([Image] -> a)                        | Console Droplet (Result () -> a)                        | ShowDroplet Id (Result Droplet -> a)@@ -41,13 +41,13 @@ destroyDroplet :: Id -> DropletCommands (Maybe String) destroyDroplet did = DestroyDroplet did P.id -dropletAction :: Id -> Action -> DropletCommands (Result ActionResult)+dropletAction :: Id -> Action -> DropletCommands (Result (ActionResult DropletActionType)) dropletAction did action = DropletAction did action P.id  dropletConsole :: Droplet -> DropletCommands (Result ()) dropletConsole droplet = Console droplet P.id -getAction :: Id -> Id -> DropletCommands (Result ActionResult)+getAction :: Id -> Id -> DropletCommands (Result (ActionResult DropletActionType)) getAction did actId = GetAction did actId P.id  listDropletSnapshots :: Id -> DropletCommands [Image]@@ -58,8 +58,8 @@ data CoDropletCommands m k = CoDropletCommands { listDropletsH   :: (m [Droplet], k)                                                , createDropletH  :: BoxConfiguration -> (m (Result Droplet), k)                                                , destroyDropletH :: Id -> (m (Maybe String), k)-                                               , actionDropletH  :: Id -> Action -> (m (Result ActionResult), k)-                                               , getActionH      :: Id -> Id -> (m (Result ActionResult), k)+                                               , actionDropletH  :: Id -> Action -> (m (Result (ActionResult DropletActionType)), k)+                                               , getActionH      :: Id -> Id -> (m (Result (ActionResult DropletActionType)), k)                                                , listSnapshotsH  :: Id -> (m [Image], k)                                                , consoleH        :: Droplet -> (m (Result ()), k)                                                , showDropletH    :: Id -> (m (Result Droplet), k)

@@ -1,9 +1,4 @@-{-# LANGUAGE DoAndIfThenElse       #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE DoAndIfThenElse, FlexibleContexts, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}  -- | Network interpreter for Droplets specific API module Network.DO.Droplets.Net(dropletCommandsInterpreter) where@@ -13,8 +8,6 @@ import           Control.Exception            (IOException) import           Control.Monad.Trans          (MonadIO) import           Data.Aeson                   as A hiding (Result)-import qualified Data.Aeson.Types             as A-import qualified Data.HashMap.Strict          as H import           Data.Maybe import           Data.Monoid                  ((<>)) import           Data.Proxy@@ -23,7 +16,6 @@ import           Network.DO.Net.Common import           Network.DO.Types             as DO hiding (URI) import           Network.REST-import           Network.Wreq                 hiding (Proxy) import           Prelude                      as P hiding (error)  dropletsURI :: String@@ -43,10 +35,6 @@           in (snapshots, w))   (authToken (ask w)) -dropletFromResponse :: Either String Value -> Result Droplet-dropletFromResponse (Right (Object b)) = either error (Right . id) $ A.parseEither parseJSON (b H.! "droplet")-dropletFromResponse v                  = error $ "cannot decode JSON value to a droplet " ++ show v- 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)   runQuery@@ -54,7 +42,7 @@   where     runQuery t = let opts             = authorisation t                      droplets         = postJSONWith opts (toURI dropletsEndpoint) (toJSON config) >>= handleResponse-                     handleResponse d = case dropletFromResponse d of+                     handleResponse d = case fromResponse "droplet" d of                        Right b  -> if (not $ backgroundCreate config)                                   then waitForBoxToBeUp opts 60 b                                   else return (Right b)@@ -67,27 +55,23 @@                                        in (r, w))                                (authToken (ask w)) -actionResult :: Either String Value -> Result ActionResult-actionResult (Right (Object r)) = either error (Right . id) $ A.parseEither parseJSON (r H.! "action")-actionResult e                  = error $ "cannot extract action result from " ++ show e--doAction :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> Action -> (RESTT m (Result ActionResult), w a)+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)                               (\ t -> let r = postJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId </> "actions") (toJSON action)-                                              >>= return . actionResult+                                              >>= return . fromResponse "action"                                       in (r, w))                               (authToken (ask w)) -doGetAction :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> Id -> (RESTT m (Result ActionResult), w a)+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)                                    (\ t -> let r = getJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId </> "actions" </> show actionId)-                                                   >>= return . actionResult . Right+                                                   >>= 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)-                            (\ t -> let r = dropletFromResponse . Right <$> getJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId)+                            (\ t -> let r = fromResponse "droplet" . Right <$> getJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId)                                     in (r, w))                             (authToken (ask w)) @@ -96,8 +80,8 @@                                      (\ip -> do                                          s <- ssh ["root@" <> show ip ]                                          case s of-                                          Left (e :: IOException)  -> return $ error (show e)-                                          Right () -> return $ Right ()+                                          Left (e :: IOException) -> return $ error (show e)+                                          Right ()                -> return $ Right ()                                      )                                      (publicIP droplet)                              in (r, w)@@ -107,7 +91,7 @@ waitForBoxToBeUp opts n box  = do   waitFor 1000000 ("waiting for droplet " ++ name box ++ " to become Active: " ++ show (n) ++ "s")   b <- getJSONWith opts (toURI $ dropletsEndpoint </> show (dropletId box))-  case dropletFromResponse (Right b) of+  case fromResponse "droplet" (Right b) of    Right box'-> if status box' == Active                 then return (Right box')                 else waitForBoxToBeUp opts (n-1) box'

@@ -0,0 +1,9 @@+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Network.DO.IP(module Network.DO.IP.Commands+                    ,module Network.DO.IP.Net+                    ) where++import           Network.DO.IP.Commands+import           Network.DO.IP.Net

@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Network.DO.IP.Commands where++import           Control.Comonad.Trans.Cofree+import           Control.Monad.Trans.Free+import           Data.IP+import           Network.DO.Pairing+import           Network.DO.Types+import           Prelude                      as P++-- functor for DO DSL+data IPCommands a = ListFloatingIPs ([FloatingIP] -> a)+                  | CreateIP FloatingIPTarget (Result FloatingIP -> a)+                  | DeleteIP IP (Maybe String -> a)+                  | ActionIP IP IPAction (Result (ActionResult IPActionType) -> a)+          deriving (Functor)++-- free transformer to embed effects+type IPCommandsT = FreeT IPCommands++-- smart constructors+listFloatingIPs :: IPCommands [FloatingIP]+listFloatingIPs = ListFloatingIPs P.id++createFloatingIP :: FloatingIPTarget -> IPCommands (Result FloatingIP)+createFloatingIP target = CreateIP target P.id++deleteFloatingIP :: IP -> IPCommands (Maybe String)+deleteFloatingIP ip = DeleteIP ip P.id++floatingIPAction :: IP -> IPAction -> IPCommands (Result (ActionResult IPActionType))+floatingIPAction ip action = ActionIP ip action P.id++-- dual type, for creating interpreters+data CoIPCommands m k =+  CoIPCommands { listFloatingIPsH  :: (m [FloatingIP], k)+               , createFloatingIPH :: FloatingIPTarget -> (m (Result FloatingIP), k)+               , deleteIPH         :: IP -> (m (Maybe String), k)+               , actionIPH         :: IP -> IPAction -> (m (Result (ActionResult IPActionType)), k)+               } deriving Functor++-- Cofree closure of CoIPCommands functor+type CoIPCommandsT m = CofreeT (CoIPCommands m)++-- pair DSL with interpreter within some monadic context+instance (Monad m) => PairingM (CoIPCommands m) IPCommands m where+  pairM f (CoIPCommands ks _ _ _)    (ListFloatingIPs k)   = pairM f ks k+  pairM f (CoIPCommands _  tgt _ _)  (CreateIP i k)        = pairM f (tgt i) k+  pairM f (CoIPCommands _  _  del _) (DeleteIP i k)        = pairM f (del i) k+  pairM f (CoIPCommands _  _  _ act) (ActionIP i a k)      = pairM f (act i a) k

@@ -0,0 +1,62 @@+{-# LANGUAGE DoAndIfThenElse       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}++-- | Network interpreter for Floating IPs specific API+module Network.DO.IP.Net(ipCommandsInterpreter) where++import           Control.Applicative+import           Control.Comonad.Env.Class (ComonadEnv, ask)+import           Control.Monad.Trans       (MonadIO)+import           Data.Aeson                as A hiding (Result)+import           Data.IP+import           Data.Maybe+import           Data.Proxy+import           Network.DO.IP.Commands+import           Network.DO.Net.Common+import           Network.DO.Types          as DO hiding (URI)+import           Network.REST+import           Prelude                   as P hiding (error)++floatingIpsURI :: String+floatingIpsURI = "floating_ips"++floatingIpsEndpoint :: String+floatingIpsEndpoint = rootURI </> apiVersion </> floatingIpsURI++instance Listable FloatingIP where+  listEndpoint _ = floatingIpsEndpoint+  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)+  runQuery+  (authToken (ask w))+  where+    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+                          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)+                       (\ t -> let r = postJSONWith (authorisation t) (toURI $ floatingIpsEndpoint </> show ip </> "actions") (toJSON action)+                                       >>= return . fromResponse "action"+                               in (r, w))+                       (authToken (ask w))++ipCommandsInterpreter :: (MonadIO m, ComonadEnv ToolConfiguration w) => w a -> CoIPCommands (RESTT m) (w a)+ipCommandsInterpreter = CoIPCommands+                        <$> queryList (Proxy :: Proxy FloatingIP)+                        <*> doCreateIP+                        <*> doDeleteIP+                        <*> doAction+

@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}  -- | Interpreter for accessing DO API through the web using [wreq http://www.serpentine.com/wreq]. module Network.DO.Net(mkDOClient) where@@ -18,9 +19,12 @@ import           Prelude                      as P  import           Network.DO.Commands+import           Network.DO.Domain import           Network.DO.Droplets.Commands import           Network.DO.Droplets.Net+import           Network.DO.IP import           Network.DO.Net.Common+import           Network.DO.Pairing import           Network.DO.Types             as DO hiding (URI) import           Network.REST @@ -74,10 +78,17 @@                   <*> queryList (Proxy :: Proxy Image)                   <*> queryList (Proxy :: Proxy Region) -mkDOClient :: (MonadIO m) => ToolConfiguration -> CofreeT (Product (CoDO (RESTT m)) (CoDropletCommands (RESTT m))) (Env ToolConfiguration) (RESTT m ())+mkDOClient :: (MonadIO m) => ToolConfiguration+           -> CofreeT (CoDO (RESTT m) :*: CoDropletCommands (RESTT m) :*: CoIPCommands (RESTT m) :*: CoDomainCommands (RESTT m)) (Env ToolConfiguration) (RESTT m ()) mkDOClient config = coiterT next start   where     next = Pair            <$> genericCommands-           <*> dropletCommandsInterpreter+           <*> (Pair+                 <$> dropletCommandsInterpreter+                 <*> (Pair+                      <$> ipCommandsInterpreter+                      <*> dnsCommandsInterpreter+                     )+               )     start = env config (return ())

@@ -1,23 +1,17 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, OverloadedStrings #-} module Network.DO.Net.Common where  import           Control.Comonad.Env.Class (ComonadEnv, ask)-import           Control.Lens              ((&), (.~))-import           Data.Aeson                as A+import           Data.Aeson                as A hiding (Result) import qualified Data.Aeson.Types          as A-import           Data.ByteString.Char8     (pack) import qualified Data.HashMap.Strict       as H import           Data.Maybe-import           Data.Monoid import           Data.Proxy import           Data.Text                 (Text) import qualified Data.Vector               as V-import           Network.DO.Types          as DO hiding (URI)+import           Network.DO.Types          as DO hiding (URI, error) import           Network.REST import           Network.URI               (URI, parseURI)-import           Network.Wreq              hiding (Proxy) import           Prelude                   as P  rootURI :: String@@ -31,16 +25,13 @@ s </> s'        = s ++ "/" ++ s'  toURI :: String -> URI-toURI = fromJust . parseURI+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 _  _         = [] -authorisation :: String -> Options-authorisation t = defaults & header "Authorization" .~ ["Bearer " <> pack t]- class Listable a where   listEndpoint :: Proxy a -> String   listField :: Proxy a -> Text@@ -51,3 +42,7 @@                         in (droplets, w))                 (authToken (ask w)) +-- |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

@@ -1,25 +1,42 @@-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE KindSignatures         #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE FunctionalDependencies    #-}+{-# LANGUAGE InstanceSigs              #-}+{-# LANGUAGE KindSignatures            #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PolyKinds                 #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE UndecidableInstances      #-} module Network.DO.Pairing (Pairing(..)                , PairingM(..)+               , (:+:), (:*:)                , pairEffect                , pairEffectM                , pairEffect'                , injr, injl+               , injrl, injrr+               , injrrl, injrrr                ) where  import           Control.Comonad              (Comonad, extract) import           Control.Comonad.Trans.Cofree (CofreeT, unwrap) import           Control.Monad.Trans.Free     (FreeF (..), FreeT, liftF,                                                runFreeT)-import           Data.Functor.Sum import           Data.Functor.Identity        (Identity (..)) import           Data.Functor.Product+import           Data.Functor.Sum +type a :+: b = Sum a b++infixr 1 :+:++type a :*: b = Product a b++infixr 2 :*:+ class (Functor f, Functor g) => Pairing f g where   pair :: (a -> b -> r) -> f a -> g b -> r @@ -38,19 +55,31 @@ instance (Monad m) => PairingM ((,) (m a)) ((->) a) m where   pairM p (ma, b) g = ma >>= \ a -> p b (g a) -instance (Monad m, PairingM f h m, PairingM g k m) => PairingM (Sum f g) (Product h k) m where+instance (Monad m, PairingM f h m, PairingM g k m) => PairingM (f :+: g) (h :*: k) m where   pairM p (InL f) (Pair h _)  = pairM p f h   pairM p (InR g) (Pair _ k) = pairM p g k -instance (Monad m, PairingM h f m, PairingM k g m) => PairingM (Product h k) (Sum f g) m where+instance (Monad m, PairingM h f m, PairingM k g m) => PairingM (h :*: k) (f :+: g) m where   pairM p (Pair h _) (InL f)  = pairM p h f   pairM p (Pair _ k) (InR g) = pairM p k g -injl :: (Monad m, Functor f, Functor g) => f a -> FreeT (Sum f g) m a+injl :: (Monad m, Functor f, Functor g) => f a -> FreeT (f :+: g) m a injl = liftF . InL -injr :: (Monad m, Functor f, Functor g) => g a -> FreeT (Sum f g) m a+injr :: (Monad m, Functor f, Functor g) => g a -> FreeT (f :+: g) m a injr = liftF . InR++injrl :: (Monad m, Functor f, Functor g, Functor h) => g a -> FreeT (f :+: g :+: h) m a+injrl = liftF . InR . InL++injrr :: (Monad m, Functor f, Functor g, Functor h) => h a -> FreeT (f :+: g :+: h) m a+injrr = liftF . InR . InR++injrrl :: (Monad m, Functor f, Functor g, Functor h, Functor k) => h a -> FreeT (f :+: g :+: h :+: k) m a+injrrl = liftF . InR . InR . InL++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  pairEffect :: (Pairing f g, Comonad w, Monad m)            => (a -> b -> r) -> CofreeT f w a -> FreeT g m b -> m r

@@ -81,9 +81,35 @@                     nest 5 (pretty szPrice_Hourly <> text "$/h, " <> pretty szPrice_Monthly <> text "$/mo" ) $$                     nest 5 (hcat $ punctuate (char ',') $ map pretty szRegions) -instance Pretty ActionResult where+instance (Pretty r) => Pretty (ActionResult r) where   pretty ActionResult{..} = brackets (integer actionId) <+> pretty actionStartedAt <+> text "->" <+> pretty actionCompletedAt $$-                            (nest 5 $ integer actionResourceId <+> text (show actionType) <> char ':' <+> text (show actionStatus))+                            (nest 5 $ integer actionResourceId <+> pretty actionType <> char ':' <+> text (show actionStatus))++instance Pretty DropletActionType++instance Pretty FloatingIP where+  pretty FloatingIP{..} =+    case floatingDroplet of+      Nothing -> ipAndRegion <+> text "?"+      Just d  -> ipAndRegion <+> integer (dropletId d) <> char '/' <> text (name d)+    where+      ipAndRegion = pretty floatingIp <> text "/" <>  text (regionSlug floatingRegion) <+> text "->"++instance Pretty IPActionType++instance Pretty Domain where+  pretty Domain{..} = text (domain domainName) $$+                      maybe mempty (nest 5 . vcat . map text .lines) zone_file++instance Pretty DomainRecord where+  pretty DomainRecord{..} = brackets (integer recordId) <+> pretty recordType <+> text recordName <+> text recordData+                            <+> prettyInt recordPriority+                            <+> prettyInt recordPort+                            <+> prettyInt recordWeight+    where+      prettyInt = maybe (char '-') int++instance Pretty DNSType  outputResult :: (Pretty a, MonadIO m) => a -> m  () outputResult = liftIO . putStrLn . render . pretty

@@ -17,10 +17,10 @@ import           Data.IP import           Data.List         (elemIndex) import           Data.Monoid       ((<>))-import           Data.Text         (unpack)+import           Data.Text         (pack, unpack) import           Data.Time         (UTCTime) import           GHC.Generics-+import qualified Text.Parsec       as P  type AuthToken = String @@ -73,7 +73,6 @@                         ", regionAvailable = " <> show regionAvailable <>                         "}" - instance FromJSON Region where   parseJSON (String s) = return $ RegionSlug (unpack s)   parseJSON (Object o) = if H.null o@@ -85,7 +84,6 @@                               <*> o .: "available"   parseJSON e          = failParse e - -- | String representation of size slugs -- This maps to corresponding expected JSON string value. sizeSlugs :: [String]@@ -201,6 +199,9 @@   parseJSON (String s) = return $ read $ unpack s   parseJSON e          = fail $ "cannot parse IP " <> show e +instance ToJSON IP where+  toJSON = String . pack . show+ instance FromJSON NetType where   parseJSON (String s) = case s of                           "public" -> return Public@@ -370,23 +371,22 @@    parseJSON e          = failParse e - -- * Droplets Actions  -- | Type of action status -- This is returned when action is initiated or when status of some action is requested -data ActionResult = ActionResult { actionId           :: Id-                                 , actionStatus       :: ActionStatus-                                 , actionType         :: ActionType-                                 , actionStartedAt    :: Maybe Date-                                 , actionCompletedAt  :: Maybe Date-                                 , actionResourceId   :: Id-                                 , actionResourceType :: String-                                 , actionRegionSlug   :: Region-                                 } deriving (Show)+data ActionResult result = ActionResult { actionId           :: Id+                                        , actionStatus       :: ActionStatus+                                        , actionType         :: result+                                        , actionStartedAt    :: Maybe Date+                                        , actionCompletedAt  :: Maybe Date+                                        , actionResourceId   :: Id+                                        , actionResourceType :: String+                                        , actionRegionSlug   :: Region+                                        } deriving (Show) -instance FromJSON ActionResult where+instance (FromJSON r) => FromJSON (ActionResult r) where   parseJSON (Object o) = ActionResult                          <$> o .: "id"                          <*> o .: "status"@@ -411,12 +411,12 @@                           _             -> fail $ "unknown action status " ++ show s   parseJSON v          = fail $ "cannot parse action status " ++ show v -data ActionType = PowerOff+data DropletActionType = PowerOff                 | PowerOn                 | MakeSnapshot                 deriving (Show) -instance FromJSON ActionType where+instance FromJSON DropletActionType where   parseJSON (String s) = case s of                           "power_off" -> return PowerOff                           "power_on"  -> return PowerOn@@ -424,7 +424,7 @@                           _           -> fail $ "unknown action type " ++ show s   parseJSON v          = fail $ "cannot parse action type " ++ show v -instance ToJSON ActionType where+instance ToJSON DropletActionType where   toJSON PowerOff = String "power_off"   toJSON PowerOn  = String "power_on"   toJSON MakeSnapshot = String "snapshot"@@ -444,9 +444,25 @@ -- |Type of Domain zones -- -- https://developers.digitalocean.com/documentation/v2/#domains-data Domain = Domain { domainName :: String-                     , domainTTL  :: Int-                     , zone_file  :: String++newtype DomainName = DomainName { domain :: String }++instance Show DomainName where+  show = domain++instance Read DomainName where+  readsPrec _ s = [(DomainName s,[])]++instance FromJSON DomainName where+  parseJSON (String s) = pure $ DomainName $ unpack s+  parseJSON e          = failParse e++instance ToJSON DomainName where+  toJSON (DomainName n) = String (pack n)++data Domain = Domain { domainName :: DomainName+                     , domainTTL  :: Maybe Int+                     , zone_file  :: Maybe String                      } deriving (Show)  instance FromJSON Domain where@@ -457,6 +473,13 @@    parseJSON e          = failParse e +data DomainConfig = DomainConfig DomainName IP++instance ToJSON DomainConfig where+  toJSON (DomainConfig name ip) = object [ "name" .= name+                                         , "ip_address" .= ip+                                         ]+ -- | Enumeration of possible DNS records types data DNSType = A | CNAME | TXT | PTR | SRV | NS | AAAA | MX              deriving (Show, Read, Generic)@@ -471,9 +494,9 @@                                  , recordType     :: DNSType                                  , recordName     :: String                                  , recordData     :: String-                                 , recordPriority :: Maybe Double+                                 , recordPriority :: Maybe Int                                  , recordPort     :: Maybe Int-                                 , recordWeight   :: Maybe Double+                                 , recordWeight   :: Maybe Int                                  } deriving (Show)  @@ -488,6 +511,105 @@                          <*> o .: "weight"    parseJSON e          = failParse e++instance ToJSON DomainRecord where+  toJSON DomainRecord{..} = object [ "type" .= recordType+                                   , "name" .= recordName+                                   , "data" .= recordData+                                   , "priority" .= recordPriority+                                   , "port" .= recordPort+                                   , "weight" .= recordWeight+                                   ]++parseRecord :: String -> Result DomainRecord+parseRecord s =+  case P.parse recordParser "" s of+    Left e  -> Left (Error $ show e)+    Right r -> Right r+  where+    recordParser :: P.Parsec String s DomainRecord+    recordParser = do+      t <- typeParser+      P.spaces+      n <- nameParser+      P.spaces+      d <- dataParser+      (prio, port, wei) <- recordAttributes t+      return $ DomainRecord 0 t n d prio port wei++    typeParser :: P.Parsec String s DNSType+    typeParser = P.choice [ rtype A , rtype CNAME , rtype TXT , rtype PTR , rtype SRV , rtype NS , rtype AAAA , rtype MX ]++    rtype :: DNSType -> P.Parsec String s DNSType+    rtype t = P.string (show t) >> return t++    nameParser :: P.Parsec String s String+    nameParser = P.many1 (P.lower P.<|> P.char '.')++    dataParser :: P.Parsec String s String+    dataParser = P.many1 (P.alphaNum P.<|> P.oneOf [ '.' ])++    recordAttributes :: DNSType -> P.Parsec String s (Maybe Int, Maybe Int, Maybe Int)+    recordAttributes SRV =  (,,) <$>+                            (Just <$> number) <*>+                            (Just <$> number) <*>+                            (Just <$> number)+    recordAttributes MX  =  (,,) <$>+                            (Just <$> number) <*>+                            pure Nothing <*>+                            pure Nothing+    recordAttributes _   = (,,) <$>+                           pure Nothing <*>+                           pure Nothing <*>+                           pure Nothing+    number :: P.Parsec String s Int+    number = P.spaces >> read <$> P.many1 P.digit++-- | Floating IPs+-- https://developers.digitalocean.com/documentation/v2/#floating-ips++data FloatingIP = FloatingIP { floatingIp      :: IP+                             , floatingDroplet :: Maybe Droplet+                             , floatingRegion  :: Region+                             } deriving (Show)++instance FromJSON FloatingIP where+  parseJSON (Object o) = FloatingIP+                         <$> o .: "ip"+                         <*> o .:? "droplet"+                         <*> o .: "region"++  parseJSON e          = failParse e++data FloatingIPTarget = TargetRegion Slug+                      | TargetDroplet Id+                        deriving (Show)++instance ToJSON FloatingIPTarget where+  toJSON (TargetRegion r)  = object [ "region" .= r ]+  toJSON (TargetDroplet i) = object [ "droplet_id" .= i ]++data IPAction = AssignIP Id+              | UnassignIP+  deriving (Show, Read)++instance ToJSON IPAction where+  toJSON (AssignIP did) = object [ "type" .= ("assign" :: String)+                                 , "droplet_id" .= did+                                 ]+  toJSON UnassignIP     = object [ "type" .= ("unassign" :: String)]++data IPActionType = Assign+                  | Unassign+                deriving (Show)++instance FromJSON IPActionType where+  parseJSON (String s) = case s of+                          "assign_ip" -> return Assign+                          "unassign_ip"  -> return Unassign+                          _           -> fail $ "unknown action type " ++ show s+  parseJSON v          = failParse v+  failParse :: (Show a1, Monad m) => a1 -> m a failParse e = fail $ "cannot parse " <> show e

@@ -1,11 +1,9 @@-{-# LANGUAGE DeriveFunctor       #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor, ScopedTypeVariables #-} -- | Functor and low-level mechanism to interact with a server using Wreq and JSON values.-module Network.REST(module Network.REST.Commands-                   ,module Network.REST.Wreq+module Network.REST(module M                    ,ssh) where -import           Network.REST.Commands-import           Network.REST.Wreq+import           Network.REST.Commands as M+import           Network.REST.Conduit  as M -- TODO temporary kludge import           Network.SSH

@@ -1,8 +1,7 @@-{-# LANGUAGE DeriveFunctor       #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor, OverloadedStrings, ScopedTypeVariables #-} -- | Functor and low-level mechanism to interact with a server using "REST" API. ----- This module exposes @Net@ functor which can be implemented using various stack.+-- This module exposes @REST@ functor which can be implemented using various stack. -- In particular, we provide @Network.REST.Wreq@ module as a wreq-based implementation -- and a test-only implementation which is used to check correctness of higher-level -- code, in particular in relation with JSON serialization.@@ -10,8 +9,14 @@  import           Control.Monad.Trans.Free (FreeT (..), liftF) import           Data.Aeson               (Value)+import           Data.Monoid+import           Data.Text                (Text, pack) import           Network.URI              (URI)-import           Network.Wreq             (Options)++data Options = Header Text [ Text ]++authorisation :: String -> Options+authorisation t = Header "Authorization" [ "Bearer " <> pack t]  data REST a = Get URI (Value -> a)            | Post URI Value (Maybe Value -> a)

@@ -0,0 +1,63 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | Implementation of @REST@ interface based on <https://haskell-lang.org/library/http-client http-conduit>+-- standard library+module Network.REST.Conduit where++import           Control.Concurrent       (threadDelay)+import           Control.Monad.Trans.Free+import           Data.Aeson               (Value, decode, eitherDecode)+import           Data.CaseInsensitive     (mk)+import           Data.Functor             (void)+import           Data.Text.Encoding       (encodeUtf8)+import           Network.HTTP.Simple+import           Network.REST.Commands+import           Network.URI++-- | An implementation of @REST@ functor based on http-client and @IO@+runConduit :: RESTT IO r -> IO r+runConduit r = do+  mr <- runFreeT r+  step mr+    where+      asString :: URI -> String+      asString = ($ "") . uriToString id++      step (Pure value)       = return value++      step (Free (WaitFor delay message k))  = do+        putStrLn message+        threadDelay delay+        runConduit k++      step (Free (Get uri k)) = do+        request <- parseRequest $ "GET " ++ asString uri+        response <- httpJSON request+        let value = getResponseBody response :: Value+        runConduit (k value)++      step (Free (GetWith opts uri k)) = do+        request <- parseRequest $ "GET " ++ asString uri+        response <- httpJSON $ options opts request+        let value = getResponseBody response :: Value+        runConduit (k value)++      step (Free (DeleteWith opts uri k)) = do+        request <- parseRequest $ "DELETE " ++ asString uri+        void $ httpLBS $ options opts request+        runConduit k++      step (Free (Post uri val k)) = do+        request <- parseRequest $ "POST " ++ asString uri+        response <- httpLbs $ setRequestBodyJSON val request+        let value = decode $ getResponseBody response+        runConduit (k value)++      step (Free (PostWith opts uri val k)) = do+        request <- parseRequest $ "POST " ++ asString uri+        response <- httpLbs $ options opts $ setRequestBodyJSON val request+        let value :: Either String Value = eitherDecode $ getResponseBody response+        runConduit (k value)+++options :: Options -> Request -> Request+options (Header h c) = setRequestHeader (mk $ encodeUtf8 h) (map encodeUtf8 c)

@@ -1,54 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- | Implementation of @Net@ interface based on <http://wreq.io wreq>-module Network.REST.Wreq where--import           Control.Concurrent       (threadDelay)-import           Control.Lens             ((^.))-import           Control.Monad.Trans.Free-import           Data.Aeson               (Value, decode, eitherDecode)-import           Data.ByteString.Lazy     (ByteString)-import           Network.REST.Commands-import           Network.URI-import           Network.Wreq---- | An implementation of @Net@ functor based on wreq and @IO@-runWreq :: RESTT IO r -> IO r-runWreq r = do-  mr <- runFreeT r-  step mr-    where-      asString :: URI -> String-      asString = ($ "") . uriToString id--      step (Pure value)       = return value--      step (Free (WaitFor delay message k))  = do-        putStrLn message-        threadDelay delay-        runWreq k--      step (Free (Get uri k)) = do-        b <- asJSON =<< get (asString uri) :: IO (Response Value)-        let value = b ^. responseBody-        runWreq (k value)--      step (Free (GetWith opts uri k)) = do-        b <- asJSON =<< getWith opts (asString uri) :: IO (Response Value)-        let value = b ^. responseBody-        runWreq (k value)--      step (Free (DeleteWith opts uri k)) = do-        _ <- deleteWith opts (asString uri) :: IO (Response ByteString)-        runWreq k--      step (Free (Post uri val k)) = do-        resp <- post (asString uri) val :: IO (Response ByteString)-        let value :: Maybe Value = decode $ resp ^. responseBody-        runWreq (k value)--      step (Free (PostWith opts uri val k)) = do-        resp <- postWith opts (asString uri) val :: IO (Response ByteString)-        let value :: Either String Value = eitherDecode $ resp ^. responseBody-        runWreq (k value)--

@@ -1,4 +1,4 @@ flags: {} packages: - '.'-resolver: lts-7.3+resolver: lts-8.8