linode (empty) → 0.1.0.0
raw patch · 7 files changed
+1020/−0 lines, 7 filesdep +aesondep +asyncdep +basesetup-changed
Dependencies added: aeson, async, base, binary, bytestring, containers, errors, lens, linode, process, retry, safe, tasty, tasty-hunit, tasty-quickcheck, text, transformers, wreq
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- linode.cabal +58/−0
- src/Network/Linode.hs +406/−0
- src/Network/Linode/Internal.hs +79/−0
- src/Network/Linode/Types.hs +357/−0
- test/Spec.hs +88/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ linode.cabal view
@@ -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
+ src/Network/Linode.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-|+Module : Network.Linode+License : BSD3+Stability : experimental++This package contains some helpers to create and configure <https://www.linode.com/ Linode> 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+ })
+ src/Network/Linode/Internal.hs view
@@ -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
+ src/Network/Linode/Types.hs view
@@ -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)]
+ test/Spec.hs view
@@ -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