module Network.DO.Types where
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, concat)
import Data.Monoid ((<>))
import Data.Text (pack, unpack)
import Data.Time (UTCTime)
import GHC.Generics
import qualified Text.Parsec as P
type AuthToken = String
type Slug = String
type URI = String
newtype Error = Error { msg :: String } deriving (Eq, Show, Read)
type Result a = Either Error a
error :: String -> Result a
error = Left . Error
data ToolConfiguration = Tool { slackUri :: Maybe URI
, authToken :: Maybe AuthToken
, quiet :: Bool
} deriving (Show,Read)
instance Default ToolConfiguration where
def = Tool Nothing Nothing False
data Region = Region { regionName :: String
, regionSlug :: Slug
, regionSizes :: [ SizeSlug ]
, regionAvailable :: Bool
}
| RegionSlug Slug
| NoRegion
instance ToJSON Region where
toJSON (RegionSlug s) = toJSON s
toJSON NoRegion = object []
toJSON Region{..} = object [ "name" .= regionName
, "slug" .= regionSlug
, "sizes" .= regionSizes
, "available" .= regionAvailable
]
instance Show Region where
show (RegionSlug s) = s
show NoRegion = "NoRegion"
show Region{..} = "Region { regionName = " <> show regionName <>
", regionSlug = " <> show regionSlug <>
", regionSizes = " <> show regionSizes <>
", regionAvailable = " <> show regionAvailable <>
"}"
instance FromJSON Region where
parseJSON (String s) = return $ RegionSlug (unpack s)
parseJSON (Object o) = if H.null o
then return NoRegion
else Region
<$> o .: "name"
<*> o .: "slug"
<*> o .: "sizes"
<*> o .: "available"
parseJSON e = failParse e
sizeSlugs :: [String]
sizeSlugs = [ "512mb", "1gb", "2gb", "4gb", "8gb", "16gb", "32gb", "48gb", "64gb", "96gb" ]
data SizeSlug = M512 | G1 | G2 | G4 | G8 | G16 | G32 | G48 | G64 | G96
deriving (Enum,Ord,Eq)
instance Show SizeSlug where
show sz = sizeSlugs !! fromEnum sz
instance Read SizeSlug where
readsPrec _ sz = case elemIndex sz sizeSlugs of
Just i -> return (toEnum i, "")
Nothing -> fail $ "cannot parse " <> sz
instance ToJSON SizeSlug where
toJSON sz = toJSON $ sizeSlugs !! fromEnum sz
instance FromJSON SizeSlug where
parseJSON (String s) = case elemIndex (unpack s) sizeSlugs of
Just i -> return $ toEnum i
Nothing -> fail $ "cannot parse " <> unpack s
parseJSON e = failParse e
type ImageSlug = String
type KeyId = Int
defaultImage :: ImageSlug
defaultImage = "ubuntu-14-04-x64"
data BoxConfiguration = BoxConfiguration { configName :: String
, boxRegion :: Region
, size :: SizeSlug
, configImageSlug :: ImageSlug
, keys :: [KeyId]
, backgroundCreate :: Bool
} deriving (Show)
instance ToJSON BoxConfiguration where
toJSON BoxConfiguration{..} = object [ "name" .= configName
, "region" .= boxRegion
, "size" .= size
, "image" .= configImageSlug
, "ssh_keys" .= keys
, "backups" .= False
, "ipv6" .= False
, "private_networking" .= False
]
type Id = Integer
data Mega
data Giga
newtype Bytes a = Bytes { bytesSize :: Int } deriving Show
jsonBytes :: Int -> Parser (Bytes a)
jsonBytes = return . Bytes
instance FromJSON (Bytes Mega) where
parseJSON (Number n) = jsonBytes (truncate n)
parseJSON e = failParse e
instance FromJSON (Bytes Giga) where
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
| Archive
deriving (Eq,Show)
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
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)
data Network a = NetworkV4 { ip_address :: IP
, netmask :: IP
, gateway :: IP
, netType :: NetType
}
| NetworkV6 { ip_address :: IP
, netmask_v6 :: Int
, gateway :: IP
, netType :: NetType
} deriving Show
instance FromJSON IP where
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
"private" -> return Private
e -> failParse e
parseJSON e = failParse e
instance ToJSON NetType where
toJSON Public = "public"
toJSON Private = "private"
data V4
data V6
jsonNetwork :: (FromJSON a3, FromJSON a2, FromJSON a1, FromJSON a) => (a3 -> a2 -> a1 -> a -> b) -> Object -> Parser b
jsonNetwork f n = f
<$> (n .: "ip_address")
<*> (n .: "netmask")
<*> (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
data Networks = Networks { v4 :: [ Network V4 ]
, v6 :: [ Network V6 ]
}
| NoNetworks
deriving (Generic, Show)
instance FromJSON Networks where
parseJSON (Object n) = if H.null n
then return NoNetworks
else Networks
<$> (n .: "v4")
<*> (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
]
data Droplet = Droplet { dropletId :: Id
, name :: String
, memory :: Bytes Mega
, vcpus :: Int
, disk :: Bytes Giga
, locked :: Bool
, created_at :: Date
, status :: Status
, backup_ids :: [ Id ]
, snapshot_ids :: [ Id ]
, region :: Region
, size_slug :: SizeSlug
, networks :: Networks
} deriving (Show)
instance FromJSON Droplet where
parseJSON (Object o) = Droplet
<$> o .: "id"
<*> o .: "name"
<*> o .: "memory"
<*> o .: "vcpus"
<*> o .: "disk"
<*> o .: "locked"
<*> o .: "created_at"
<*> o .: "status"
<*> o .: "backup_ids"
<*> o .: "snapshot_ids"
<*> o .: "region"
<*> o .: "size_slug"
<*> 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
deriving Show
instance FromJSON ImageType where
parseJSON (String s) = case s of
"snapshot" -> return Snapshot
"temporary" -> return Temporary
"backup" -> return Backup
_ -> fail $ "cannot parse " <> unpack s
parseJSON e = failParse e
data Image = Image { imageId :: Id
, imageName :: String
, distribution :: String
, imageSlug :: Maybe Slug
, publicImage :: Bool
, imageRegions :: [ Region ]
, min_disk_size :: Bytes Giga
, image_created_at :: Date
, imageType :: ImageType
} deriving Show
instance FromJSON Image where
parseJSON (Object o) = Image
<$> o .: "id"
<*> o .: "name"
<*> o .: "distribution"
<*> o .:? "slug"
<*> o .: "public"
<*> o .: "regions"
<*> o .: "min_disk_size"
<*> o .: "created_at"
<*> o .: "type"
parseJSON e = failParse e
--https://developers.digitalocean.com/documentation/v2/#ssh-keys
data Key = Key { keyId :: Id
, keyFingerprint :: String
, publicKey :: String
, keyName :: String
} deriving Show
instance FromJSON Key where
parseJSON (Object o) = Key
<$> o .: "id"
<*> o .: "fingerprint"
<*> o .: "public_key"
<*> o .: "name"
parseJSON e = failParse e
type TransferRate = Double
type Price = Double
data Size = Size { szSlug :: SizeSlug
, szMemory :: Bytes Mega
, szVcpus :: Int
, szDisk :: Bytes Giga
, szTransfer :: TransferRate
, szPrice_Monthly :: Price
, szPrice_Hourly :: Price
, szRegions :: [ Region ]
, szAvailable :: Bool
} deriving (Show)
instance FromJSON Size where
parseJSON (Object o) = Size
<$> o .: "slug"
<*> o .: "memory"
<*> o .: "vcpus"
<*> o .: "disk"
<*> o .: "transfer"
<*> o .: "price_monthly"
<*> o .: "price_hourly"
<*> o .: "regions"
<*> o .: "available"
parseJSON e = failParse e
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 r) => FromJSON (ActionResult r) where
parseJSON (Object o) = ActionResult
<$> o .: "id"
<*> o .: "status"
<*> o .: "type"
<*> o .:? "started_at"
<*> o .:? "completed_at"
<*> o .: "resource_id"
<*> o .: "resource_type"
<*> o .: "region_slug"
parseJSON v = fail $ "cannot parse action " ++ show v
data ActionStatus = InProgress
| Completed
| Errored
deriving (Show)
instance FromJSON ActionStatus where
parseJSON (String s) = case s of
"in-progress" -> return InProgress
"completed" -> return Completed
"errored" -> return Errored
_ -> fail $ "unknown action status " ++ show s
parseJSON v = fail $ "cannot parse action status " ++ show v
data DropletActionType = PowerOff
| PowerOn
| MakeSnapshot
deriving (Show)
instance FromJSON DropletActionType where
parseJSON (String s) = case s of
"power_off" -> return PowerOff
"power_on" -> return PowerOn
"snapshot" -> return MakeSnapshot
_ -> fail $ "unknown action type " ++ show s
parseJSON v = fail $ "cannot parse action type " ++ show v
instance ToJSON DropletActionType where
toJSON PowerOff = String "power_off"
toJSON PowerOn = String "power_on"
toJSON MakeSnapshot = String "snapshot"
data Action = DoPowerOff
| DoPowerOn
| CreateSnapshot String
deriving Show
instance ToJSON Action where
toJSON DoPowerOff = object [ "type" .= PowerOff ]
toJSON DoPowerOn = object [ "type" .= PowerOn ]
toJSON (CreateSnapshot snapshotName) = object [ "type" .= MakeSnapshot
, "name" .= snapshotName
]
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
parseJSON (Object o) = Domain
<$> o .: "name"
<*> o .: "ttl"
<*> o .: "zone_file"
parseJSON e = failParse e
data DomainConfig = DomainConfig DomainName IP
instance ToJSON DomainConfig where
toJSON (DomainConfig name ip) = object [ "name" .= name
, "ip_address" .= ip
]
data DNSType = A | CNAME | TXT | PTR | SRV | NS | AAAA | MX
deriving (Show, Read, Generic)
instance FromJSON DNSType
instance ToJSON DNSType
data DomainRecord = DomainRecord { recordId :: Id
, recordType :: DNSType
, recordName :: String
, recordData :: String
, recordPriority :: Maybe Int
, recordPort :: Maybe Int
, recordWeight :: Maybe Int
} deriving (Show)
instance FromJSON DomainRecord where
parseJSON (Object o) = DomainRecord
<$> o .: "id"
<*> o .: "type"
<*> o .: "name"
<*> o .: "data"
<*> o .: "priority"
<*> o .: "port"
<*> 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
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
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
data Volume = Volume
{ volumeId :: Id
, volumeRegion :: Region
, volumeDropletIds :: [Id]
, volumeName :: String
, volumeDescription :: String
, volumeSizeGigaBytes :: Int
, volumeCreatedAt :: Date
} 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 TagName = String
data Tag = Tag
{ tagName :: TagName
, tagResources :: TagResources
} deriving (Show)
data TagResources = TagResources
{ tagDroplets :: TagDroplets
, tagVolumes :: TagVolumes
} deriving (Show)
data TagDroplets = TagDroplets
{ tagDropletsCount :: Int
, tagDropletsLastTagged :: Maybe Droplet
} deriving (Show)
data TagVolumes = TagVolumes
{ tagVolumesCount :: Int
, tagVolumesLastTagged :: Maybe Volume
} deriving (Show)
data TagPairs = TagPairs
{ tagPairsResources :: [TagPair]
} deriving (Show)
data TagPair = TagPair
{ tagPairResourceId :: Id
, tagPairResourceType :: ResourceType
} 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
]
failParse :: (Show a1, Monad m) => a1 -> m a
failParse e = fail $ "cannot parse " <> show e