Linode.hs

{-# 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 1GB of RAM:

> {-# LANGUAGE OverloadedStrings #-}
> import Network.Linode
> import Data.List (find)
> import qualified System.Process as P
> import Data.Foldable (traverse_)
> import Data.Monoid ((<>))
>
> main :: IO()
> main = 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 -> print err
>     Right linode -> do
>       traverse_ (\a -> waitForSSH a >> setup a) (publicAddress linode)
>       print linode
>
> setup address = P.callCommand $ "scp yourfile root@" <> ip address <> ":/root"

You should see something like this:

> Creating empty linode (Linode 1024 at atlanta)
> Creating disk (24448 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

  , 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



{-|
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) = 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"]

{-|
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 = simpleGetter "account.info"

{-|
Read all Linode datacenters: dallas, fremont, atlanta, newark, london, tokyo, singapore, frankfurt
-}
getDatacenters :: ApiKey -> ExceptT LinodeError IO [Datacenter]
getDatacenters = simpleGetter "avail.datacenters"

{-|
Read all available Linux distributions. For example, Debian 8.1 has id 140.
-}
getDistributions :: ApiKey -> ExceptT LinodeError IO [Distribution]
getDistributions = simpleGetter "avail.distributions"

{-|
Read detailed information about all your instances.
-}
getInstances :: ApiKey -> ExceptT LinodeError IO [Instance]
getInstances = simpleGetter "linode.list"

{-|
Read all available Linux kernels.
-}
getKernels :: ApiKey -> ExceptT LinodeError IO [Kernel]
getKernels = simpleGetter "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 = simpleGetter "avail.linodeplans"

{-|
Read all IP addresses of an instance.
-}
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]

{-|
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 "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

{-|
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 = 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]

{-|
Create a Linode instance with no disk and no configuration. You probably want createLinode instead.
-}
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)]

{-|
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 = 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 a Linode instance.
-}
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]

{-|
List of pending jobs for this Linode instance.
-}
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"]

{-|
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. It expects the apiKey and id_rsa.pub files in the current directory.
-}
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"

{-|
Example of Linodes creation. It expects the apiKey and id_rsa.pub files in the current directory.
-}
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"