module Net.DigitalOcean.Droplets (
Network
, Kernel
, Droplet
, Snapshot
, Backup
, DropletAction(..)
, DropletCreationOpts
, createDroplet
, getDroplet
, getDroplets
, getDropletKernels
, getDropletSnapshots
, getDropletBackups
, getDropletActions
, deleteDroplet
, performDropletAction
, defaultDCO
, netProto
, netIpAddr
, netNetmask
, netGateway
, netType
, krnId
, krnName
, krnVersion
, drpId
, drpName
, drpMemory
, drpVCPUs
, drpDisk
, drpLocked
, drpCreatedAt
, drpStatus
, drpBackupIds
, drpSnapshotIds
, drpFeatures
, drpRegion
, drpImage
, drpNetworks
, drpKernel
, snpId
, snpName
, snpDist
, snpSlug
, snpPublic
, snpRegions
, bckId
, bckName
, bckDist
, bckSlug
, bckPublic
, bckRegions
, dcoName
, dcoRegion
, dcoSize
, dcoImage
, dcoSSHKeys
, dcoBackups
, dcoIpv6
, dcoPrivateNetworking
, dcoUserData
) where
import qualified Data.Text as T
import qualified Data.HashMap.Strict as HM
import qualified Data.Vector as V
import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), (.:), (.=), object, Value)
import Data.Maybe (catMaybes)
import Control.Lens hiding ((.=), Action)
import Control.Applicative
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Error.Class (MonadError, Error)
import Net.DigitalOcean.Request (get, post, delete)
import Net.DigitalOcean.Config (Config)
import Net.DigitalOcean.Regions (Region)
import Net.DigitalOcean.Images (Image)
import Net.DigitalOcean.Actions (Action)
data Network = Network
{ _netProto :: !T.Text
, _netIpAddr :: !T.Text
, _netNetmask :: !T.Text
, _netGateway :: !T.Text
, _netType :: !T.Text
} deriving (Show, Eq)
makeLenses ''Network
instance FromJSON [Network] where
parseJSON (Object obj) = sequence . concat $ mapM parseEntry (HM.toList obj)
where parseEntry (ty, Array vals) = map (parseNetwork ty) (V.toList vals)
parseEntry _ = error "network list must be arr"
parseNetwork ty (Object n) =
Network ty <$>
n .: "ip_address" <*>
n .: "netmask" <*>
n .: "gateway" <*>
n .: "type"
parseNetwork _ _ = error "network must be object"
parseJSON _ = error "network must be object"
data Kernel = Kernel
{ _krnId :: !Int
, _krnName :: !T.Text
, _krnVersion :: !T.Text
} deriving (Show, Eq)
makeLenses ''Kernel
instance FromJSON Kernel where
parseJSON (Object x) = Kernel <$>
x .: "id" <*>
x .: "name" <*>
x .: "version"
parseJSON _ = error "kernel must be object"
data Droplet = Droplet
{ _drpId :: !Int
, _drpName :: !T.Text
, _drpMemory :: !Int
, _drpVCPUs :: !Int
, _drpDisk :: !Int
, _drpLocked :: !Bool
, _drpCreatedAt :: !T.Text
, _drpStatus :: !T.Text
, _drpBackupIds :: ![T.Text]
, _drpSnapshotIds :: ![T.Text]
, _drpFeatures :: ![T.Text]
, _drpRegion :: Maybe Region
, _drpImage :: Maybe Image
, _drpNetworks :: [Network]
, _drpKernel :: Kernel
} deriving (Show, Eq)
makeLenses ''Droplet
instance FromJSON Droplet where
parseJSON (Object x) = Droplet <$>
x .: "id" <*>
x .: "name" <*>
x .: "memory" <*>
x .: "vcpus" <*>
x .: "disk" <*>
x .: "locked" <*>
x .: "created_at" <*>
x .: "status" <*>
x .: "backup_ids" <*>
x .: "snapshot_ids" <*>
x .: "features" <*>
x .: "region" <*>
x .: "image" <*>
x .: "networks" <*>
x .: "kernel"
parseJSON _ = error "droplet must be object"
data Snapshot = Snapshot
{ _snpId :: !Int
, _snpName :: !T.Text
, _snpDist :: !T.Text
, _snpSlug :: Maybe T.Text
, _snpPublic :: !Bool
, _snpRegions :: ![T.Text]
} deriving (Show, Eq)
makeLenses ''Snapshot
instance FromJSON Snapshot where
parseJSON (Object x) = Snapshot <$>
x .: "id" <*>
x .: "name" <*>
x .: "dist" <*>
x .: "slug" <*>
x .: "public" <*>
x .: "regions"
parseJSON _ = error "snapshot must be object"
data Backup = Backup
{ _bckId :: !Int
, _bckName :: !T.Text
, _bckDist :: !T.Text
, _bckSlug :: Maybe T.Text
, _bckPublic :: !Bool
, _bckRegions :: ![T.Text]
} deriving (Show, Eq)
makeLenses ''Backup
instance FromJSON Backup where
parseJSON (Object x) = Backup <$>
x .: "id" <*>
x .: "name" <*>
x .: "dist" <*>
x .: "slug" <*>
x .: "public" <*>
x .: "regions"
parseJSON _ = error "backup must be object"
data DropletCreationOpts = DropletCreationOpts
{ _dcoName :: !T.Text
, _dcoRegion :: !T.Text
, _dcoSize :: !T.Text
, _dcoImage :: !T.Text
, _dcoSSHKeys :: Maybe [T.Text]
, _dcoBackups :: !Bool
, _dcoIpv6 :: !Bool
, _dcoPrivateNetworking :: !Bool
, _dcoUserData :: Maybe T.Text
} deriving (Show, Eq)
makeLenses ''DropletCreationOpts
instance ToJSON DropletCreationOpts where
toJSON d = object (base ++ catMaybes opts)
where base = [ "name" .= (d ^. dcoName)
, "region" .= (d ^. dcoRegion)
, "size" .= (d ^. dcoSize)
, "image" .= (d ^. dcoImage)
, "backups" .= (d ^. dcoBackups)
, "ipv6" .= (d ^. dcoIpv6)
, "private_networking" .= (d ^. dcoPrivateNetworking)]
opts = [ fmap ("user_data" .=) (d ^. dcoUserData)
, fmap ("ssh_keys" .=) (d ^. dcoSSHKeys)
]
defaultDCO :: T.Text -> T.Text -> T.Text -> T.Text -> DropletCreationOpts
defaultDCO n r s i = DropletCreationOpts n r s i Nothing False True True Nothing
dropletsEndpoint :: String
dropletsEndpoint = "/v2/droplets/"
dropletEndpoint :: T.Text -> String
dropletEndpoint = (++) dropletsEndpoint . T.unpack
createDroplet :: (Error e, MonadError e m, MonadIO m) =>
DropletCreationOpts -> Config -> m Droplet
createDroplet = post dropletsEndpoint "droplet"
getDroplet :: (Error e, MonadError e m, MonadIO m) =>
T.Text -> Config -> m Droplet
getDroplet n = get (dropletEndpoint n) "droplet"
getDroplets ::(Error e, MonadError e m, MonadIO m) =>
Config -> m [Droplet]
getDroplets = get dropletsEndpoint "droplets"
getDropletKernels :: (Error e, MonadError e m, MonadIO m) =>
T.Text -> Config -> m [Kernel]
getDropletKernels n = get (dropletEndpoint n ++ "/kernels") "kernels"
getDropletSnapshots :: (Error e, MonadError e m, MonadIO m) =>
T.Text -> Config -> m [Snapshot]
getDropletSnapshots n = get (dropletEndpoint n ++ "/snapshots") "snapshots"
getDropletBackups :: (Error e, MonadError e m, MonadIO m) =>
T.Text -> Config -> m [Backup]
getDropletBackups n = get (dropletEndpoint n ++ "/backups") "backups"
getDropletActions :: (Error e, MonadError e m, MonadIO m) =>
T.Text -> Config -> m [Action]
getDropletActions n = get (dropletEndpoint n ++ "/actions") "actions"
deleteDroplet :: (Error e, MonadError e m, MonadIO m) =>
T.Text -> Config -> m ()
deleteDroplet = delete . dropletEndpoint
data DropletAction
= DisableBackups
| Reboot
| PowerCycle
| Shutdown
| PowerOff
| PowerOn
| Restore
| PasswordReset
| Resize !T.Text
| Rebuild !T.Text
| Rename !T.Text
| ChangeKernel !Int
| EnableIpv6
| EnablePrivateNetworking
| SnapshotDrp !T.Text
| Upgrade
mType :: T.Text -> [(T.Text, Value)] -> Value
mType t rst = toJSON . HM.fromList $ ("type", toJSON t):rst
instance ToJSON DropletAction where
toJSON DisableBackups = mType "disable_backups" []
toJSON Reboot = mType "reboot" []
toJSON PowerCycle = mType "power_cycle" []
toJSON Shutdown = mType "shutdown" []
toJSON PowerOff = mType "power_off" []
toJSON PowerOn = mType "power_on" []
toJSON Restore = mType "restore" []
toJSON PasswordReset = mType "password_reset" []
toJSON (Resize s) = mType "resize" [("size", toJSON s)]
toJSON (Rebuild i) = mType "rebuild" [("image", toJSON i)]
toJSON (Rename n) = mType "rename" [("name", toJSON n)]
toJSON (ChangeKernel i) = mType "change_kernel" [("kernel", toJSON i)]
toJSON EnableIpv6 = mType "enable_ipv6" []
toJSON EnablePrivateNetworking = mType "enable_private_networking" []
toJSON (SnapshotDrp n) = mType "snapshot" [("snapshot", toJSON n)]
toJSON Upgrade = mType "migrate_droplet" []
performDropletAction :: (Error e, MonadError e m, MonadIO m) =>
T.Text -> DropletAction -> Config -> m Action
performDropletAction n = post (dropletEndpoint n ++ "/actions") "action"