module Network.Linode
(
createLinode
, createCluster
, defaultLinodeCreationOptions
, waitForSSH
, deleteInstance
, deleteCluster
, getAccountInfo
, getDatacenters
, getDistributions
, getInstances
, getKernels
, getPlans
, getIpList
, createConfig
, createDiskFromDistribution
, createDisklessLinode
, createSwapDisk
, createDisk
, boot
, jobList
, waitUntilCompletion
, select
, publicAddress
, exampleCreateOneLinode
, exampleCreateTwoLinodes
, module Network.Linode.Types
) 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
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)
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)
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
}
waitForSSH :: Address -> IO ()
waitForSSH address = R.recoverAll retryPolicy command
where retryPolicy = R.constantDelay oneSecond <> R.limitRetries 100
oneSecond = 1000 * 1000
command = P.callCommand $ "ssh -q -o StrictHostKeyChecking=no root@" <> ip address <> " exit"
deleteInstance :: ApiKey -> LinodeId -> IO (Either LinodeError DeletedLinode)
deleteInstance apiKey (LinodeId i) = runExceptT $ getWith $
W.defaults & W.param "api_key" .~ [T.pack apiKey]
& W.param "api_action" .~ [T.pack "linode.delete"]
& W.param "LinodeID" .~ [T.pack $ show i]
& W.param "skipChecks" .~ ["true"]
deleteCluster :: ApiKey -> [LinodeId] -> IO ([LinodeError],[DeletedLinode])
deleteCluster apiKey linodes = partitionEithers <$> mapM (deleteInstance apiKey) linodes
getAccountInfo :: ApiKey -> ExceptT LinodeError IO AccountInfo
getAccountInfo = simpleGetter "account.info"
getDatacenters :: ApiKey -> ExceptT LinodeError IO [Datacenter]
getDatacenters = simpleGetter "avail.datacenters"
getDistributions :: ApiKey -> ExceptT LinodeError IO [Distribution]
getDistributions = simpleGetter "avail.distributions"
getInstances :: ApiKey -> ExceptT LinodeError IO [Instance]
getInstances = simpleGetter "linode.list"
getKernels :: ApiKey -> ExceptT LinodeError IO [Kernel]
getKernels = simpleGetter "avail.kernels"
getPlans :: ApiKey -> ExceptT LinodeError IO [Plan]
getPlans = simpleGetter "avail.linodeplans"
getIpList :: ApiKey -> LinodeId -> ExceptT LinodeError IO [Address]
getIpList apiKey (LinodeId i) = getWith $
W.defaults & W.param "api_key" .~ [T.pack apiKey]
& W.param "api_action" .~ [T.pack "linode.ip.list"]
& W.param "LinodeID" .~ [T.pack $ show i]
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 "api_key" .~ [T.pack apiKey]
& W.param "api_action" .~ [T.pack "linode.config.create"]
& 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
createDiskFromDistribution :: ApiKey -> LinodeId -> DistributionId -> String -> Int -> String -> Maybe String -> ExceptT LinodeError IO CreatedDisk
createDiskFromDistribution apiKey (LinodeId i) (DistributionId d) label size pass sshPublicKey = getWith $
W.defaults & W.param "api_key" .~ [T.pack apiKey]
& W.param "api_action" .~ [T.pack "linode.disk.createfromdistribution"]
& 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]
createDisklessLinode :: ApiKey -> DatacenterId -> PlanId -> PaymentTerm -> ExceptT LinodeError IO CreatedLinode
createDisklessLinode apiKey (DatacenterId d) (PlanId p) paymentTerm = getWith $
W.defaults & W.param "api_key" .~ [T.pack apiKey]
& W.param "api_action" .~ [T.pack "linode.create"]
& W.param "DatacenterID" .~ [T.pack $ show d]
& W.param "PlanID" .~ [T.pack $ show p]
& W.param "PaymentTerm" .~ [T.pack $ show (paymentTermToInt paymentTerm)]
createSwapDisk :: ApiKey -> LinodeId -> String -> Int -> ExceptT LinodeError IO CreatedDisk
createSwapDisk apiKey linId label = createDisk apiKey linId label Swap
createDisk :: ApiKey -> LinodeId -> String -> DiskType -> Int -> ExceptT LinodeError IO CreatedDisk
createDisk apiKey (LinodeId i) label diskType size = getWith $
W.defaults & W.param "api_key" .~ [T.pack apiKey]
& W.param "api_action" .~ [T.pack "linode.disk.create"]
& 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]
boot :: ApiKey-> LinodeId -> ConfigId -> ExceptT LinodeError IO BootedInstance
boot apiKey (LinodeId i) (ConfigId c) = getWith $
W.defaults & W.param "api_key" .~ [T.pack apiKey]
& W.param "api_action" .~ [T.pack "linode.boot"]
& W.param "LinodeID" .~ [T.pack $ show i]
& W.param "ConfigID" .~ [T.pack $ show c]
jobList :: ApiKey -> LinodeId -> ExceptT LinodeError IO [WaitingJob]
jobList apiKey (LinodeId i) = getWith $
W.defaults & W.param "api_key" .~ [T.pack apiKey]
& W.param "api_action" .~ [T.pack "linode.job.list"]
& W.param "LinodeID" .~ [T.pack $ show i]
& W.param "pendingOnly" .~ ["true"]
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 :: 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"
publicAddress :: Linode -> Maybe Address
publicAddress = headMay . linodeAddresses
exampleCreateOneLinode :: IO (Maybe Linode)
exampleCreateOneLinode = do
apiKey <- fmap (head . words) (readFile "apiKey")
sshPublicKey <- readFile "id_rsa.pub"
let options = defaultLinodeCreationOptions {
datacenterSelect = find ((=="atlanta") . datacenterName),
planSelect = find ((=="Linode 1024") . planName),
sshKey = Just sshPublicKey
}
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"
exampleCreateTwoLinodes :: IO (Maybe [Linode])
exampleCreateTwoLinodes = do
sshPublicKey <- readFile "id_rsa.pub"
apiKey <- fmap (head . words) (readFile "apiKey")
let options = defaultLinodeCreationOptions {
datacenterSelect = find ((=="atlanta") . datacenterName),
planSelect = find ((=="Linode 1024") . planName),
sshKey = Just sshPublicKey
}
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"