diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Sebastian de Bellefon (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Sebastian de Bellefon nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/linode.cabal b/linode.cabal new file mode 100644 --- /dev/null +++ b/linode.cabal @@ -0,0 +1,58 @@ +name: linode +version: 0.1.0.0 +synopsis: Bindings to the Linode API +description: Haskell bindings to the Linode API. Rent servers hourly or monthly. + . + This package contains some helpers to create and configure Linode instances. The API key can be created on the Linode website. + . +homepage: http://github.com/Helkafen/haskell-linode#readme +license: BSD3 +license-file: LICENSE +author: Sebastian de Bellefon +maintainer: arnaudpourseb@gmail.com +copyright: BSD3 +category: Network, Cloud, Distributed Computing +build-type: Simple +cabal-version: >=1.10 +Tested-with: GHC == 7.10.2 + +library + hs-source-dirs: src + exposed-modules: Network.Linode + ,Network.Linode.Internal + ,Network.Linode.Types + build-depends: base >= 4.7 && < 5 + ,aeson + ,async + ,binary + ,bytestring + ,containers + ,errors + ,lens + ,process + ,retry + ,safe + ,text + ,transformers + ,wreq >= 0.3 + default-language: Haskell2010 + ghc-options: -Wall + +test-suite linode-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , linode + , aeson + , containers + , tasty >= 0.10.1 + , tasty-hunit >= 0.8 + , tasty-quickcheck >= 0.8.2 + + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/Helkafen/haskell-linode diff --git a/src/Network/Linode.hs b/src/Network/Linode.hs new file mode 100644 --- /dev/null +++ b/src/Network/Linode.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| +Module : Network.Linode +License : BSD3 +Stability : experimental + +This package contains some helpers to create and configure instances. They all require an API key, which can be created on the Linode website. + +Usage example. We want to create one Linode instance in Atlanta with 2GB of RAM: + +> import Network.Linode +> import Data.List (find) +> import qualified System.Process as P +> +> main :: IO() +> main = do +> apiKey <- fmap (head . words) (readFile "apiKey") +> sshPublicKey <- readFile "id_rsa.pub" +> let log = True +> let options = defaultLinodeCreationOptions { +> datacenterSelect = find ((=="atlanta") . datacenterName), +> planSelect = find ((=="Linode 2048") . planName), +> sshKey = Just sshPublicKey +> } +> linode <- createLinode apiKey log options +> print linode +> traverse_ (\a -> waitForSSH a >> setup a) (publicAddress linode) -- Setup the instance when the ssh connexion is ready +> +> setup address = P.callCommand $ "scp yourfile root@" <> ip address <> ":/root" + +You should see something like this: + +> Creating empty linode (Linode 2048 at atlanta) +> Creating disk (49024 MB) +> ................................... +> Creating swap (128 MB) +> ............................... +> Creating config +> ....... +> Booting +> .................................... +> Booted linode 1481198 + +And get something like that: + +> Linode { +> linodeId = LinodeId {unLinodeId = 1481198}, +> linodeConfigId = ConfigId {unConfigId = 2251152}, +> linodeDatacenterName = "atlanta", +> linodePassword = "We4kP4ssw0rd", +> linodeAddresses = [Address {ip = "45.79.194.121", rdnsName = "li1293-121.members.linode.com"}]} + +-} + +module Network.Linode +( + -- * Most common operations + createLinode + , createCluster + , defaultLinodeCreationOptions + , waitForSSH + , deleteInstance + , deleteCluster + + -- * Lower level API calls + , getAccountInfo + , getDatacenters + , getDistributions + , getInstances + , getKernels + , getPlans + , getIpList + , createConfig + , createDiskFromDistribution + , createDisklessLinode + , createSwapDisk + , createDisk + , boot + , jobList + + -- * Helpers + , waitUntilCompletion + , select + , publicAddress + + -- * Examples + , exampleCreateOneLinode + , exampleCreateTwoLinodes + , testOptions +) where + +import Control.Concurrent (threadDelay) +import qualified Control.Concurrent.Async as A +import Control.Error hiding (err) +import Control.Lens +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import qualified Control.Retry as R +import Data.Foldable (traverse_) +import Data.List (find) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import qualified Network.Wreq as W +import Prelude hiding (log) +import qualified System.Process as P + +import Network.Linode.Internal +import Network.Linode.Types + + + +{-| +Create a Linode instance and boot it. +-} +createLinode :: ApiKey -> Bool -> LinodeCreationOptions -> IO (Either LinodeError Linode) +createLinode apiKey log options = do + i <- runExceptT create + case i of + Left e -> return $ Left e + Right (linId, selected) -> do + r <- runExceptT $ configure linId selected + case r of + Left e -> deleteInstance apiKey linId >> return (Left e) + Right l -> return $ Right l + where create :: ExceptT LinodeError IO (LinodeId, (Datacenter, Distribution, Plan, Kernel)) = do + (datacenter, distribution, plan, kernel) <- select apiKey options + printLog $ "Creating empty linode (" <> T.unpack (planName plan) <> " at " <> T.unpack (datacenterName datacenter) <> ")" + CreatedLinode linId <- createDisklessLinode apiKey (datacenterId datacenter) (planId plan) (paymentChoice options) + return (linId, (datacenter, distribution, plan, kernel)) + configure linId (datacenter, distribution, plan, kernel) = do + let swapSize = swapAmount options + let rootDiskSize = (1024 * disk plan) - swapSize + let wait = liftIO (waitUntilCompletion apiKey linId) + printLog $ "Creating disk (" ++ show rootDiskSize ++ " MB)" + (CreatedDisk diskId _) <- wait >> createDiskFromDistribution apiKey linId (distributionId distribution) (diskLabel options) rootDiskSize (password options) (sshKey options) + printLog $ "Creating swap (" ++ show swapSize ++ " MB)" + (CreatedDisk swapId _) <- wait >> createSwapDisk apiKey linId "swap" swapSize + printLog "Creating config" + (CreatedConfig configId) <- wait >> maybeOr (CreatedConfig <$> config options) (createConfig apiKey linId (kernelId kernel) "profile" [diskId, swapId]) + printLog "Booting" + (BootedInstance _) <- wait >> boot apiKey linId configId + printLog "Still booting" + addresses <- wait >> getIpList apiKey linId + printLog $ "Booted linode " ++ show (unLinodeId linId) + return $ Linode linId configId (datacenterName datacenter) (password options) addresses + printLog l = when log (liftIO $ putStrLn l) + + +{-| +Create a Linode cluster. +-} +createCluster :: ApiKey -> LinodeCreationOptions -> Int -> Bool -> IO (Either [LinodeError] [Linode]) +createCluster apiKey options number log = do + let optionsList = take number $ map (\(o,i) -> o {diskLabel = diskLabel o <> "-" <> show i}) (zip (repeat options) ([0..] :: [Int])) + r <- partitionEithers <$> A.mapConcurrently (createLinode apiKey log) optionsList + case r of + ([], linodes) -> return (Right linodes) + (errors, linodes) -> do + _ <- deleteCluster apiKey (map linodeId linodes) + return (Left errors) + +{-| +Default options to create an instance. Please customize the security options. +-} +defaultLinodeCreationOptions :: LinodeCreationOptions +defaultLinodeCreationOptions = LinodeCreationOptions { + datacenterSelect = find ((=="london") . datacenterName), + planSelect = find ((=="Linode 1024") . planName), + kernelSelect = find (("Latest 64 bit" `T.isPrefixOf`) . kernelName), + distributionSelect = find ((=="Debian 8.1") . distributionName), + paymentChoice = OneMonth, + swapAmount = 128, + password = "We4kP4ssw0rd", + sshKey = Nothing, + diskLabel = "mainDisk", + config = Nothing +} + +-- TODO: only works in linux and macos +{-| +Wait until an ssh connexion is possible, then add the Linode's ip in known_hosts. + +A newly created Linode is unreachable during a few seconds. +-} +waitForSSH :: Address -> IO () +waitForSSH address = R.recoverAll retryPolicy $ P.callCommand $ "ssh -q -o StrictHostKeyChecking=no root@" <> ip address <> " exit" + where retryPolicy = R.constantDelay oneSecond <> R.limitRetries 100 + oneSecond = 1000 * 1000 + + +{-| +Delete a Linode instance. +-} +deleteInstance :: ApiKey -> LinodeId -> IO (Either LinodeError DeletedLinode) +deleteInstance apiKey (LinodeId i) = do + let opts = W.defaults & W.param "LinodeID" .~ [T.pack $ show i] + & W.param "skipChecks" .~ ["true"] + runExceptT $ getWith opts (query "linode.delete" apiKey) + +{-| +Delete a list of Linode instances. +-} +deleteCluster :: ApiKey -> [LinodeId] -> IO ([LinodeError],[DeletedLinode]) +deleteCluster apiKey linodes = partitionEithers <$> mapM (deleteInstance apiKey) linodes + + +{-| +Read your global account information: network usage, billing state and billing method. +-} +getAccountInfo :: ApiKey -> ExceptT LinodeError IO AccountInfo +getAccountInfo = noParamQuery "account.info" + +{-| +Read all Linode datacenters: dallas, fremont, atlanta, newark, london, tokyo, singapore, frankfurt +-} +getDatacenters :: ApiKey -> ExceptT LinodeError IO [Datacenter] +getDatacenters = noParamQuery "avail.datacenters" + +{-| +Read all available Linux distributions. For example, Debian 8.1 has id 140. +-} +getDistributions :: ApiKey -> ExceptT LinodeError IO [Distribution] +getDistributions = noParamQuery "avail.distributions" + +{-| +Read detailed information about all your instances. +-} +getInstances :: ApiKey -> ExceptT LinodeError IO [Instance] +getInstances = noParamQuery "linode.list" + +{-| +Read all available Linux kernels. +-} +getKernels :: ApiKey -> ExceptT LinodeError IO [Kernel] +getKernels = noParamQuery "avail.kernels" + +{-| +Read all plans offered by Linode. A plan specifies the available CPU, RAM, network usage and pricing of an instance. +The smallest plan is Linode 1024. +-} +getPlans :: ApiKey -> ExceptT LinodeError IO [Plan] +getPlans = noParamQuery "avail.linodeplans" + +{-| +Read all IP addresses of an instance. +-} +getIpList :: ApiKey -> LinodeId -> ExceptT LinodeError IO [Address] +getIpList apiKey (LinodeId i) = do + let opts = W.defaults & W.param "LinodeID" .~ [T.pack $ show i] + getWith opts (query "linode.ip.list" apiKey) + +{-| +Create a Linode Config (a bag of instance options). +-} +createConfig :: ApiKey -> LinodeId -> KernelId -> String -> [DiskId] -> ExceptT LinodeError IO CreatedConfig +createConfig apiKey (LinodeId i) (KernelId k) label disksIds = do + let disksList = T.intercalate "," $ take 9 $ map (T.pack . show . unDisk) disksIds ++ repeat "" + let opts = W.defaults & W.param "LinodeID" .~ [T.pack $ show i] + & W.param "KernelID" .~ [T.pack $ show k] + & W.param "Label" .~ [T.pack label] + & W.param "DiskList" .~ [disksList] + & W.param "helper_distro" .~ ["true"] + & W.param "helper_network" .~ ["true"] + getWith opts (query "linode.config.create" apiKey) + +{-| +Create a disk from a supported Linux distribution. Size in MB. +-} +createDiskFromDistribution :: ApiKey -> LinodeId -> DistributionId -> String -> Int -> String -> Maybe String -> ExceptT LinodeError IO CreatedDisk +createDiskFromDistribution apiKey (LinodeId i) (DistributionId d) label size pass sshPublicKey = do + let opts = W.defaults & W.param "LinodeID" .~ [T.pack $ show i] + & W.param "DistributionID" .~ [T.pack $ show d] + & W.param "Label" .~ [T.pack label] + & W.param "Size" .~ [T.pack $ show size] + & W.param "rootPass" .~ [T.pack pass] + & case T.pack <$> sshPublicKey of + Nothing -> id + Just k -> W.param "rootSSHKey" .~ [k] + getWith opts (query "linode.disk.createfromdistribution" apiKey) + +{-| +Create a Linode instance with no disk and no configuration. You probably want createLinode. +-} +createDisklessLinode :: ApiKey -> DatacenterId -> PlanId -> PaymentTerm -> ExceptT LinodeError IO CreatedLinode +createDisklessLinode apiKey (DatacenterId d) (PlanId p) paymentTerm = do + let opts = W.defaults & W.param "DatacenterID" .~ [T.pack $ show d] + & W.param "PlanID" .~ [T.pack $ show p] + & W.param "PaymentTerm" .~ [T.pack $ show (paymentTermToInt paymentTerm)] + getWith opts (query "linode.create" apiKey) + + +{-| +Create a swap partition. +-} +createSwapDisk :: ApiKey -> LinodeId -> String -> Int -> ExceptT LinodeError IO CreatedDisk +createSwapDisk apiKey linId label = createDisk apiKey linId label Swap + +{-| +Create a partition. +-} +createDisk :: ApiKey -> LinodeId -> String -> DiskType -> Int -> ExceptT LinodeError IO CreatedDisk +createDisk apiKey (LinodeId i) label diskType size = do + let opts = W.defaults & W.param "LinodeID" .~ [T.pack $ show i] + & W.param "Label" .~ [T.pack label] + & W.param "Type" .~ [T.pack (diskTypeToString diskType)] + & W.param "size" .~ [T.pack $ show size] + getWith opts (query "linode.disk.create" apiKey) + + +{-| +Boot a Linode instance. +-} +boot :: ApiKey-> LinodeId -> ConfigId -> ExceptT LinodeError IO BootedInstance +boot apiKey (LinodeId i) (ConfigId c) = do + let opts = W.defaults & W.param "LinodeID" .~ [T.pack $ show i] + & W.param "ConfigID" .~ [T.pack $ show c] + getWith opts (query "linode.boot" apiKey) + + +{-| +List of pending jobs for this Linode instance. +-} +jobList :: ApiKey -> LinodeId -> ExceptT LinodeError IO [WaitingJob] +jobList apiKey (LinodeId i) = do + let opts = W.defaults & W.param "LinodeID" .~ [T.pack $ show i] + & W.param "pendingOnly" .~ ["true"] + getWith opts (query "linode.job.list" apiKey) + +{-| +Wait until all operations on one instance are done. +-} +waitUntilCompletion :: ApiKey -> LinodeId -> IO() +waitUntilCompletion apiKey linId = do + waitingJobs <- runExceptT $ jobList apiKey linId + case all waitingJobSuccess <$> waitingJobs of + Left e -> putStrLn $ "Error during wait:" ++ show e + Right True -> putStrLn "" + Right False -> do + putStr "." + threadDelay (100*1000) + waitUntilCompletion apiKey linId + + +{-| +Select a Datacenter, a Plan, a Linux distribution and kernel from all Linode offering. +-} +select :: ApiKey -> LinodeCreationOptions -> ExceptT LinodeError IO (Datacenter, Distribution, Plan, Kernel) +select apiKey options = (,,,) <$> + fetchAndSelect (runExceptT $ getDatacenters apiKey) (datacenterSelect options) "datacenter" <*> + fetchAndSelect (runExceptT $ getDistributions apiKey) (distributionSelect options) "distribution" <*> + fetchAndSelect (runExceptT $ getPlans apiKey) (planSelect options) "plan" <*> + fetchAndSelect (runExceptT $ getKernels apiKey) (kernelSelect options) "kernel" + + +{-| +Pick one public address of the Linode Instance +-} +publicAddress :: Linode -> Maybe Address +publicAddress = headMay . linodeAddresses + +{-| +Example of Linode creation. +-} +exampleCreateOneLinode :: IO (Maybe Linode) +exampleCreateOneLinode = do + (apiKey, options) <- testOptions + c <- createLinode apiKey True options + case c of + Left err -> do + print err + return Nothing + Right linode -> do + traverse_ (\a -> waitForSSH a >> setup a) (publicAddress linode) + return (Just linode) + where setup address = P.callCommand $ "scp TODO root@" <> ip address <> ":/root" + +{-| +Example of Linodes creation. +-} +exampleCreateTwoLinodes :: IO (Maybe [Linode]) +exampleCreateTwoLinodes = do + (apiKey, options) <- testOptions + c <- createCluster apiKey options 2 True + case c of + Left errors -> do + print ("error(s) in cluster creation" ++ show errors) + return Nothing + Right linodes -> do + mapM_ (traverse_ (\a -> waitForSSH a >> setup a) . publicAddress) linodes + return (Just linodes) + where setup address = P.callCommand $ "scp TODO root@" <> ip address <> ":/root" + +{-| +A set of options for the examples. It expects the apiKey and id_rsa.pub files in the current directory. +-} +testOptions :: IO (ApiKey, LinodeCreationOptions) +testOptions = do + apiKey <- fmap (head . words) (readFile "apiKey") + sshPublicKey <- readFile "id_rsa.pub" + return (apiKey, defaultLinodeCreationOptions { + datacenterSelect = find ((=="atlanta") . datacenterName), + planSelect = find ((=="Linode 1024") . planName), + sshKey = Just sshPublicKey + }) diff --git a/src/Network/Linode/Internal.hs b/src/Network/Linode/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Linode/Internal.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Linode.Internal where + +import Control.Error +import Control.Exception (IOException, handle) +import Control.Lens ((^?)) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (FromJSON, decode) +import qualified Data.ByteString.Lazy as B +import Data.Monoid ((<>)) +import qualified Data.Text.Encoding as E +import qualified Data.Text.IO as TIO +import qualified Network.Wreq as W + +import Network.Linode.Types + + +parseResponse :: FromJSON a => B.ByteString -> Either LinodeError a +parseResponse body = case decode body of + Nothing -> Left e + Just (Response [] (Just c)) -> Right c + Just (Response (x:_) _) -> Left x + _ -> Left e + where e = DeserializationError (E.decodeUtf8 $ B.toStrict body) + + +diskTypeToString :: DiskType -> String +diskTypeToString Ext3 = "ext3" +diskTypeToString Ext4 = "ext4" +diskTypeToString Swap = "swap" +diskTypeToString RawDisk = "raw" + +paymentTermToInt :: PaymentTerm -> Int +paymentTermToInt OneMonth = 1 +paymentTermToInt OneYear = 12 +paymentTermToInt TwoYears = 24 + +query :: String -> String -> String +query action apiKey = "https://api.linode.com/?api_key=" <> apiKey <> "&api_action=" <> action + + +get :: FromJSON a => String -> ExceptT LinodeError IO a +get url = ExceptT g + where g = handle (\(e :: IOException) -> return (Left $ NetworkError e)) $ do + response <- W.get url + return $ parseResponse (fromMaybe B.empty (response ^? W.responseBody)) + +getWith :: FromJSON a => W.Options -> String -> ExceptT LinodeError IO a +getWith opts url = ExceptT g + where g = handle (\(e :: IOException) -> return (Left $ NetworkError e)) $ do + response <- W.getWith opts url + return $ parseResponse (fromMaybe B.empty (response ^? W.responseBody)) + +noParamQuery :: FromJSON a => String -> String -> ExceptT LinodeError IO a +noParamQuery action apiKey = getWith W.defaults (query action apiKey) + +maybeOr :: Monad m => Maybe a -> ExceptT e m a -> ExceptT e m a +maybeOr v p = maybe p return v + +printCreationOptions :: Datacenter -> Plan -> PaymentTerm -> Distribution -> Int -> Int -> IO () +printCreationOptions datacenter plan paymentTerm distribution rootDiskSize swapSize = do + TIO.putStrLn $ "Datacenter: " <> datacenterName datacenter + TIO.putStrLn $ "Plan: " <> planName plan + putStrLn $ "PaymentTerm: " <> show paymentTerm + TIO.putStrLn $ "Distribution:" <> distributionName distribution + putStrLn $ "Disk size" ++ show rootDiskSize + putStrLn $ "Swap size" ++ show swapSize + + +fetchAndSelect :: IO (Either LinodeError [a]) -> ([a] -> Maybe a) -> String -> ExceptT LinodeError IO a +fetchAndSelect fetch select name = do + r <- liftIO fetch + case r of + Left e -> throwE $ SelectionError ("Error which fetching a " <> name <> " . " ++ show e) + Right xs -> case select xs of + Nothing -> throwE $ SelectionError ("Error: Selection of " <> name <> " returned no value") + Just x -> return x diff --git a/src/Network/Linode/Types.hs b/src/Network/Linode/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Linode/Types.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Linode.Types where + +import Control.Applicative (optional) +import Control.Exception (IOException) +import Control.Monad (guard, mzero) +import Data.Aeson +import Data.Binary +import qualified Data.Map as M +import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe) +import Data.Text +import GHC.Generics (Generic) +import Safe (readMay) + +type ApiKey = String + +data LinodeCreationOptions = LinodeCreationOptions { + datacenterSelect :: [Datacenter] -> Maybe Datacenter, + planSelect :: [Plan] -> Maybe Plan, + kernelSelect :: [Kernel] -> Maybe Kernel, + distributionSelect :: [Distribution] -> Maybe Distribution, + paymentChoice :: PaymentTerm, + swapAmount :: Int, -- MB + password :: String, + sshKey :: Maybe String, + diskLabel :: String, + config :: Maybe ConfigId +} + + +newtype ConfigId = ConfigId {unConfigId :: Int} + deriving (Eq, Show, Generic) + +newtype DatacenterId = DatacenterId Int + deriving (Eq, Ord, Show) + +newtype DistributionId = DistributionId Int + deriving (Eq, Ord, Show) + +newtype DiskId = DiskId {unDisk :: Int} + deriving (Eq, Show) + +newtype LinodeId = LinodeId {unLinodeId :: Int} + deriving (Eq, Ord, Show, Generic) + +newtype JobId = JobId Int + deriving (Eq, Show) + +newtype KernelId = KernelId Int + deriving (Eq, Ord, Show) + +newtype PlanId = PlanId Int + deriving (Eq, Ord, Show) + + + +data DiskType = Ext3 | Ext4 | Swap | RawDisk + deriving (Eq, Show) + +data InstanceStatus = BeingCreated | NewInstance | Running | PoweredOff -- -1: Being Created, 0: Brand New, 1: Running, and 2: Powered Off. + deriving (Eq, Show) + +data PaymentTerm = OneMonth | OneYear | TwoYears + deriving (Eq, Show) + + + +-- TODO: "ACTIVE_SINCE":"2011-09-23 15:08:13.0", +data AccountInfo = AccountInfo { + accountTransferPool :: Int, + accountTransferUsed :: Int, + accountTransferBillable :: Int, + accountManaged :: Bool, + accountBalance :: Int, + accountBillingMethod :: Text +} deriving (Eq, Show) + +data Address = Address { + ip :: String, + rdnsName :: String +} deriving (Eq, Show, Generic) + +data Datacenter = Datacenter { + datacenterId :: DatacenterId, + datacenterLocation :: Text, + datacenterName :: Text +} deriving (Eq, Show) + +data Distribution = Distribution { + distributionId :: DistributionId, + distributionName :: Text, + is64Bit :: Bool, + minImageSize :: Int, + requiresPvopsKernel :: Bool -- TODO explain +} deriving (Eq, Show) + +{- +TODO missing fields +"WATCHDOG":1, +"LPM_DISPLAYGROUP":"", +"ALERT_BWQUOTA_ENABLED":1, +"ALERT_DISKIO_THRESHOLD":1000, +"BACKUPWINDOW":1, +"ALERT_BWOUT_ENABLED":1, +"ALERT_BWOUT_THRESHOLD":5, +"ALERT_CPU_ENABLED":1, +"ALERT_BWQUOTA_THRESHOLD":80, +"ALERT_BWIN_THRESHOLD":5, +"BACKUPWEEKLYDAY":0, +"ALERT_CPU_THRESHOLD":90, +"ALERT_DISKIO_ENABLED":1, +"ALERT_BWIN_ENABLED":1, +"CREATE_DT":"2015-09-22 11:33:06.0", +"DISTRIBUTIONVENDOR": "Debian", +"ISXEN":0, +"ISKVM":1 +-} + +{-| +Detailed info about a Linode instance. Memory and transfer are given in MB. +-} +data Instance = Instance { + instanceId :: LinodeId, -- "LINODEID":8098, + instanceName :: Text, -- LABEL + instanceDatacenterId :: DatacenterId, -- "DATACENTERID" + instancePlanId :: PlanId, -- "PLANID":1, + instanceRAM :: Int, -- "TOTALRAM":1024, + instanceHD :: Int, -- "TOTALHD":40960, + instanceTransfer :: Int, -- "TOTALXFER":2000, + instanceBackupEnabled :: Bool, -- "BACKUPSENABLED":1, + instanceStatus :: InstanceStatus -- "STATUS" -- :2, +} deriving (Eq, Show) + +data Kernel = Kernel { + kernelId :: KernelId, + kernelName :: Text, + isXen :: Bool, + isKVM :: Bool, + isPVOPS :: Bool +} deriving (Eq, Show) + +data Plan = Plan { + planId :: PlanId, + planName :: Text, + ram :: Int, + disk :: Int, + xfer :: Int, + hourly :: Double, + availabilities :: M.Map DatacenterId Int +} deriving (Eq, Show) + + + + +data BootedInstance = BootedInstance { + bootJobId :: JobId +} deriving (Eq, Show) + +data CreatedConfig = CreatedConfig { + createdConfigId :: ConfigId +} deriving (Eq, Show) + +data CreatedLinode = CreatedLinode { + createdLinodeId :: LinodeId +} deriving (Eq, Show) + +data CreatedDisk = CreatedDisk { + diskCreationDiskId :: DiskId, + diskCreationJobId :: JobId +} deriving (Eq, Show) + +type DeletedLinode = CreatedLinode + +data WaitingJob = WaitingJob { + waitingJobId :: JobId, + waitingJobLinodeId :: LinodeId, + waitingJobSuccess :: Bool +} deriving (Eq, Show) + +{-| +Basic info about a linode instance. +-} +data Linode = Linode { + linodeId :: LinodeId, + linodeConfigId :: ConfigId, + linodeDatacenterName :: Text, + linodePassword :: String, + linodeAddresses :: [Address] +} deriving (Eq, Show, Generic) + +instance Binary ConfigId + +instance Binary LinodeId + +instance Binary Address + +instance Binary Linode + +type Cluster = [Linode] + + +data Response a = Response { + responseErrors :: [LinodeError], + responseContent :: Maybe a +} deriving (Eq, Show) + + +data LinodeError = BadRequest + | NoActionWasRequested + | TheRequestedClassDoesNotExist + | AuthenticationFailed + | ObjectNotFound + | ARequiredPropertyIsMissingForThisAction + | PropertyIsInvalid + | ADataValidationErrorHasOccurred + | MethodNotImplemented + | TooManyBatchedRequests + | RequestArrayIsntValidJSONOrWDDX + | BatchApproachingTimeout + | PermissionDenied + | APIRateLimitExceeded + | ChargingTheCreditCardFailed + | CreditCardIsExpired + | LimitOfLinodesAddedPerHourReached + | LinodeMustHaveNoDisksBeforeDelete + | DeserializationError Text + | NetworkError IOException + | UnknownError Int + | SelectionError String + deriving (Eq, Show) + + +----------------------------------------------- +-- Json instances + +instance FromJSON AccountInfo where + parseJSON (Object v) = AccountInfo <$> v .: "TRANSFER_POOL" <*> v .: "TRANSFER_USED" <*> v .: "TRANSFER_BILLABLE" <*> v .: "MANAGED" <*> v .: "BALANCE" <*> v .: "BILLING_METHOD" + parseJSON _ = mzero + +instance FromJSON BootedInstance where + parseJSON (Object v) = BootedInstance <$> (JobId <$> v .: "JobID") + parseJSON _ = mzero + +instance FromJSON CreatedLinode where + parseJSON (Object v) = CreatedLinode <$> (LinodeId <$> v .: "LinodeID") + parseJSON _ = mzero + +instance FromJSON CreatedConfig where + parseJSON (Object v) = CreatedConfig <$> (ConfigId <$> v .: "ConfigID") + parseJSON _ = mzero + +instance FromJSON CreatedDisk where + parseJSON (Object v) = CreatedDisk <$> (DiskId <$> v .: "DiskID") <*> (JobId <$> v .: "JobID") + parseJSON _ = mzero + +instance FromJSON Datacenter where + parseJSON (Object v) = Datacenter <$> (DatacenterId <$> v .: "DATACENTERID") <*> v .: "LOCATION" <*> v .: "ABBR" + parseJSON _ = mzero + +-- TODO: missing: "CREATE_DT":"2007-04-18 00:00:00.0", +instance FromJSON Distribution where + parseJSON = withObject "distribution" $ \o -> do + is64 <- o .: "IS64BIT" + requires <- o .: "REQUIRESPVOPSKERNEL" + guard (Prelude.all (`elem` [0,1]) [is64,requires]) + Distribution <$> fmap DistributionId (o .: "DISTRIBUTIONID") <*> o .: "LABEL" <*> pure (isTrue is64) <*> o .: "MINIMAGESIZE" <*> pure (isTrue requires) + where isTrue = (== (1::Int)) + +instance FromJSON Instance where + parseJSON = withObject "instance" $ \o -> do + s <- o .: "STATUS" + let status = instanceStatusFromInt s + guard (isJust status) + backup <- o .: "BACKUPSENABLED" + guard (Prelude.all (`elem` [0,1]) [backup]) + Instance <$> fmap LinodeId (o .: "LINODEID") + <*> o .: "LABEL" + <*> fmap DatacenterId (o .: "DATACENTERID") + <*> fmap PlanId (o .: "PLANID") + <*> o .: "TOTALRAM" + <*> o .: "TOTALHD" + <*> o .: "TOTALXFER" + <*> pure (isTrue backup) + <*> pure (fromJust status) + where isTrue = (== (1::Int)) + + +instance FromJSON Address where + parseJSON (Object v) = Address <$> v .: "IPADDRESS" <*> v .: "RDNS_NAME" + parseJSON _ = mzero + + +instance FromJSON Kernel where + parseJSON = withObject "kernel" $ \o -> do + xen <- o .: "ISXEN" + kvm <- o .: "ISKVM" + pvops <- o .: "ISPVOPS" + guard (Prelude.all (`elem` [0,1]) [xen,kvm,pvops]) + Kernel <$> fmap KernelId (o .: "KERNELID") <*> o .: "LABEL" <*> pure (isTrue xen) <*> pure (isTrue kvm) <*> pure (isTrue pvops) + where isTrue = (== (1::Int)) + +instance FromJSON LinodeError where + parseJSON = withObject "error response" $ \o -> do + errorCode <- o .: "ERRORCODE" + return $ linodeErrorFromCode errorCode + +instance FromJSON Plan where + parseJSON = withObject "plan" $ \o -> do + d <- o .: "AVAIL" + let toAvail = M.fromList . mapMaybe (\(k,v) -> may (DatacenterId <$> readMay k,v)) . M.toList + Plan <$> (PlanId <$> o .: "PLANID") <*> o .: "LABEL" <*> o .: "RAM" <*> o .: "DISK" <*> o .: "XFER" <*> o .: "HOURLY" <*> pure (toAvail d) + where may (Nothing, _) = Nothing + may (Just a, b) = Just (a,b) + +instance FromJSON WaitingJob where + parseJSON = withObject "person" $ \o -> do + j <- JobId <$> o .: "JOBID" + i <- LinodeId <$> o .: "LINODEID" + success :: Maybe Int <- optional (o .: "HOST_SUCCESS") -- 1 if ok, "" if not + return $ WaitingJob j i (fromMaybe 0 success == 1) + + +instance FromJSON a => FromJSON (Response a) where + parseJSON = withObject "list response" $ \o -> do + errs <- o .: "ERRORARRAY" + contentList <- optional (o.: "DATA") -- when ERRORARRAY is not empty, this field is malformed ('{}') and we default it to [] + return $ Response errs contentList + + + +linodeErrorFromCode :: Int -> LinodeError +linodeErrorFromCode 1 = BadRequest +linodeErrorFromCode 2 = NoActionWasRequested +linodeErrorFromCode 3 = TheRequestedClassDoesNotExist +linodeErrorFromCode 4 = AuthenticationFailed +linodeErrorFromCode 5 = ObjectNotFound +linodeErrorFromCode 6 = ARequiredPropertyIsMissingForThisAction +linodeErrorFromCode 7 = PropertyIsInvalid +linodeErrorFromCode 8 = ADataValidationErrorHasOccurred +linodeErrorFromCode 9 = MethodNotImplemented +linodeErrorFromCode 10 = TooManyBatchedRequests +linodeErrorFromCode 11 = RequestArrayIsntValidJSONOrWDDX +linodeErrorFromCode 12 = BatchApproachingTimeout +linodeErrorFromCode 13 = PermissionDenied +linodeErrorFromCode 14 = APIRateLimitExceeded +linodeErrorFromCode 30 = ChargingTheCreditCardFailed +linodeErrorFromCode 31 = CreditCardIsExpired +linodeErrorFromCode 40 = LimitOfLinodesAddedPerHourReached +linodeErrorFromCode 41 = LinodeMustHaveNoDisksBeforeDelete +linodeErrorFromCode x = UnknownError x + +instanceStatusFromInt :: Int -> Maybe InstanceStatus +instanceStatusFromInt n = lookup n m + where m = [(-1, BeingCreated),(0, NewInstance),(1, Running),(2, PoweredOff)] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Data.Aeson (decode) +import qualified Data.Map as M +import Network.Linode.Internal +import Network.Linode.Types +import Test.Tasty +import Test.Tasty.HUnit +import qualified Test.Tasty.QuickCheck as QC + +someFunc :: IO () +someFunc = do + let p = decode "{\"ERRORARRAY\":[{\"ERRORCODE\":4,\"ERRORMESSAGE\":\"Authentication failed\"}],\"DATA\":[],\"ACTION\":\"avail.datacenters\"}" :: Maybe (Response Datacenter) + print p + let q = decode "{\"ERRORARRAY\":[{\"ERRORCODE\":4,\"ERRORMESSAGE\":\"Authentication failed\"}],\"DATA\":{},\"ACTION\":\"avail.datacenters\"}" :: Maybe (Response Datacenter) + print q + let p = decode "{\"LOCATION\":\"Dallas, TX, USA\",\"DATACENTERID\":2,\"ABBR\":\"dallas\"}" :: Maybe Datacenter + print p + let p2 = decode "{\"ERRORARRAY\":[],\"DATA\":[{\"LOCATION\":\"Dallas, TX, USA\",\"DATACENTERID\":2,\"ABBR\":\"dallas\"},{\"LOCATION\":\"Fremont, CA, USA\",\"DATACENTERID\":3,\"ABBR\":\"fremont\"},{\"LOCATION\":\"Atlanta, GA, USA\",\"DATACENTERID\":4,\"ABBR\":\"atlanta\"},{\"LOCATION\":\"Newark, NJ, USA\",\"DATACENTERID\":6,\"ABBR\":\"newark\"},{\"LOCATION\":\"London, England, UK\",\"DATACENTERID\":7,\"ABBR\":\"london\"},{\"LOCATION\":\"Tokyo, JP\",\"DATACENTERID\":8,\"ABBR\":\"tokyo\"},{\"LOCATION\":\"Singapore, SG\",\"DATACENTERID\":9,\"ABBR\":\"singapore\"},{\"LOCATION\":\"Frankfurt, DE\",\"DATACENTERID\":10,\"ABBR\":\"frankfurt\"}],\"ACTION\":\"avail.datacenters\"}" :: Maybe (Response Datacenter) + print p2 + let p3 = decode "{\"REQUIRESPVOPSKERNEL\":0,\"DISTRIBUTIONID\":142,\"IS64BIT\":1,\"LABEL\":\"Arch Linux 2015.08\",\"MINIMAGESIZE\":800,\"CREATE_DT\":\"2015-08-24 11:17:18.0\"}" :: Maybe Distribution + print p3 + let p4 = decode "{\"ISKVM\":1,\"LABEL\":\"Latest 32 bit (4.1.5-x86-linode80)\",\"ISXEN\":1,\"ISPVOPS\":1,\"KERNELID\":137}" :: Maybe Kernel + print p4 + let p5 = decode "{\"CORES\":1,\"PRICE\":10.00,\"RAM\":1024,\"XFER\":2000,\"PLANID\":1,\"LABEL\":\"Linode 1024\",\"AVAIL\":{\"3\":500,\"2\":500,\"10\":500,\"7\":500,\"6\":500,\"4\":500,\"9\":500,\"8\":500},\"DISK\":24,\"HOURLY\":0.0150}" :: Maybe Plan + print p5 + let p6 = decode "{\"TRANSFER_USED\":1,\"BALANCE\":0.0000,\"TRANSFER_BILLABLE\":0,\"BILLING_METHOD\":\"prepay\",\"TRANSFER_POOL\":2000,\"ACTIVE_SINCE\":\"2011-03-10 19:18:43.0\",\"MANAGED\":false}" :: Maybe AccountInfo + print p6 + let p7 = decode "{\"LINODEID\":8098, \"LABEL\": \"api-node3\", \"DATACENTERID\": 5, \"PLANID\":1, \"TOTALRAM\":1024, \"TOTALHD\":40960, \"TOTALXFER\":2000, \"BACKUPSENABLED\":1, \"STATUS\":2}" :: Maybe Instance + print p7 + +testAuthenticationError :: Assertion +testAuthenticationError = assertEqual "Parsing an Authentication failure" (Left AuthenticationFailed) x + where x = parseResponse "{\"ERRORARRAY\":[{\"ERRORCODE\":4,\"ERRORMESSAGE\":\"Authentication failed\"}],\"DATA\":{},\"ACTION\":\"avail.datacenters\"}" :: Either LinodeError [Datacenter] + +testDatacenterList :: Assertion +testDatacenterList = assertEqual "Parsing an datacenter list" (Right [Datacenter (DatacenterId 2) "Dallas, TX, USA" "dallas"]) x + where x = parseResponse "{\"ERRORARRAY\":[],\"DATA\":[{\"LOCATION\":\"Dallas, TX, USA\",\"DATACENTERID\":2,\"ABBR\":\"dallas\"}],\"ACTION\":\"avail.datacenters\"}" + +testDistributionList :: Assertion +testDistributionList = assertEqual "Parsing a distribution list" (Right [Distribution (DistributionId 142) "Arch Linux 2015.08" True 800 False]) x + where x = parseResponse "{\"ERRORARRAY\":[],\"DATA\":[{\"REQUIRESPVOPSKERNEL\":0,\"DISTRIBUTIONID\":142,\"IS64BIT\":1,\"LABEL\":\"Arch Linux 2015.08\",\"MINIMAGESIZE\":800,\"CREATE_DT\":\"2015-08-24 11:17:18.0\"}],\"ACTION\":\"avail.distributions\"}" :: Either LinodeError [Distribution] + +testKernelList :: Assertion +testKernelList = assertEqual "Parsing a kernel list" (Right [Kernel (KernelId 137) "Latest 32 bit (4.1.5-x86-linode80)" True True True]) x + where x = parseResponse "{\"ERRORARRAY\":[],\"DATA\":[{\"ISKVM\":1,\"LABEL\":\"Latest 32 bit (4.1.5-x86-linode80)\",\"ISXEN\":1,\"ISPVOPS\":1,\"KERNELID\":137}],\"ACTION\":\"avail.kernels\"}" :: Either LinodeError [Kernel] + +testPlanList :: Assertion +testPlanList = assertEqual "Parsing a plan list" (Right [Plan (PlanId 1) "Linode 1024" 1024 24 2000 0.0150 (M.fromList [(DatacenterId 3,500),(DatacenterId 2,400)])]) x + where x = parseResponse "{\"ERRORARRAY\":[],\"DATA\":[{\"CORES\":1,\"PRICE\":10.00,\"RAM\":1024,\"XFER\":2000,\"PLANID\":1,\"LABEL\":\"Linode 1024\",\"AVAIL\":{\"3\":500,\"2\":400},\"DISK\":24,\"HOURLY\":0.0150}],\"ACTION\":\"avail.linodeplans\"}" :: Either LinodeError [Plan] + +testAccountInfo :: Assertion +testAccountInfo = assertEqual "Parsing some account info" (Right $ AccountInfo 2000 1 0 False 0 "prepay") x + where x = parseResponse "{\"ERRORARRAY\":[],\"DATA\":{\"TRANSFER_USED\":1,\"BALANCE\":0.0000,\"TRANSFER_BILLABLE\":0,\"BILLING_METHOD\":\"prepay\",\"TRANSFER_POOL\":2000,\"ACTIVE_SINCE\":\"2011-03-10 19:18:43.0\",\"MANAGED\":false},\"ACTION\":\"account.info\"}" :: Either LinodeError AccountInfo + +testInstanceList :: Assertion +testInstanceList = assertEqual "Parsing some account info" (Right [Instance {instanceId = LinodeId 8098, instanceName = "api-node3", instanceDatacenterId = DatacenterId 5, instancePlanId = PlanId 1, instanceRAM = 1024, instanceHD = 40960, instanceTransfer = 2000, instanceBackupEnabled = True, instanceStatus = PoweredOff}]) x + where x = parseResponse "{\"ERRORARRAY\":[],\"DATA\":[{\"LINODEID\":8098, \"LABEL\": \"api-node3\", \"DATACENTERID\": 5, \"PLANID\":1, \"TOTALRAM\":1024, \"TOTALHD\":40960, \"TOTALXFER\":2000, \"BACKUPSENABLED\":1, \"STATUS\":2}],\"ACTION\":\"linode.list\"}" :: Either LinodeError [Instance] + +testInstanceCreation :: Assertion +testInstanceCreation = assertEqual "Parsing the instanceId after a call to linode.create" (Right $ CreatedLinode (LinodeId 1449138)) x + where x = parseResponse "{\"ERRORARRAY\":[],\"DATA\":{\"LinodeID\":1449138},\"ACTION\":\"linode.create\"}" + +testDiskCreation :: Assertion +testDiskCreation = assertEqual "Parsing the diskId and jobId after creating a disk" (Right $ CreatedDisk (DiskId 55647) (JobId 1298)) x + where x = parseResponse "{\"ERRORARRAY\":[],\"ACTION\":\"linode.disk.createFromDistribution\",\"DATA\":{\"JobID\":1298,\"DiskID\":55647}}" + +testJobWait :: Assertion +testJobWait = assertEqual "Parsing a waiting job list" (Right [WaitingJob (JobId 29046473) (LinodeId 1450724) True, WaitingJob (JobId 29046472) (LinodeId 1450724) False]) x + where x = parseResponse "{\"ERRORARRAY\":[],\"DATA\":[{\"HOST_START_DT\":\"\",\"HOST_MESSAGE\":\"\",\"ENTERED_DT\":\"2015-11-08 10:38:15.0\",\"HOST_FINISH_DT\":\"\",\"LABEL\":\"Disk Create From Distribution - Debian 8.1\",\"JOBID\":29046473,\"HOST_SUCCESS\":1,\"ACTION\":\"fs.create.from.distro\",\"LINODEID\":1450724,\"DURATION\":\"\"},{\"HOST_START_DT\":\"\",\"HOST_MESSAGE\":\"\",\"ENTERED_DT\":\"2015-11-08 10:38:14.0\",\"HOST_FINISH_DT\":\"\",\"LABEL\":\"Linode Initial Configuration\",\"JOBID\":29046472,\"HOST_SUCCESS\":\"\",\"ACTION\":\"linode.create\",\"LINODEID\":1450724,\"DURATION\":\"\"}],\"ACTION\":\"linode.job.list\"}" + +tests :: TestTree +tests = testGroup "Parsing tests" [ + testCase "Parsing an Authentication failure" testAuthenticationError, + testCase "Parsing a datacenter list" testDatacenterList, + testCase "Parsing a distribution list" testDistributionList, + testCase "Parsing a kernel list" testKernelList, + testCase "Parsing a plan list" testPlanList, + testCase "Parsing some account info" testAccountInfo, + testCase "Parsing an instance list" testInstanceList, + testCase "Parsing the instanceId after a call to linode.create" testInstanceCreation, + testCase "Parsing the diskId and jobId after creating a disk" testDiskCreation, + testCase "Parsing a waiting job list" testJobWait + ] + + +main :: IO () +main = defaultMain tests