{-# LANGUAGE OverloadedRecordDot #-}

module Cloudy.Cmd.Scaleway.Create where

import Cloudy.Cli.Scaleway (ScalewayCreateCliOpts (..))
import Cloudy.Cmd.Scaleway.Utils (createAuthReq, getZone, runScalewayClientM, getInstanceType, getImageId)
import Cloudy.InstanceSetup (findInstanceSetup)
import Cloudy.InstanceSetup.Types (InstanceSetup (..), InstanceSetupData (..))
import Cloudy.LocalConfFile (LocalConfFileOpts (..), LocalConfFileScalewayOpts (..))
import Cloudy.Db (newCloudyInstance, newScalewayInstance, withCloudyDb)
import Cloudy.Scaleway (ipsPostApi, Zone (..), IpsReq (..), IpsResp (..), ProjectId (..), serversPostApi, ServersReq (..), ServersResp (..), ImageId (ImageId), serversUserDataPatchApi, UserDataKey (UserDataKey), UserData (UserData), ServersActionReq (..), serversActionPostApi, ServersRespVolume (..), ServersReqVolume (..), VolumesReq (..), volumesPatchApi, ServerId, unServerId, serversGetApi, IpId, unIpId, zoneToText, serversUserDataGetApi)
import Control.Applicative (some)
import Control.Concurrent (threadDelay)
import Control.Exception (bracket, SomeException, try)
import Control.FromSum (fromEitherM)
import Control.Monad (when, void)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as ByteString
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import Data.Set (isSubsetOf)
import qualified Data.Set as Set
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8)
import Data.Time (getCurrentTime)
import Data.Word (Word64)
import Network.Socket (AddrInfo(..), SocketType (Stream), defaultHints, getAddrInfo, openSocket, gracefulClose, connect)
import Servant.Client (ClientM)
import Servant.API (NoContent(NoContent))
import System.Directory (getHomeDirectory, copyFile)
import System.Exit (ExitCode(..))
import System.FilePath ((</>), (<.>))
import System.Process (readProcessWithExitCode)
import Text.Parsec (ParseError, parse, Parsec, newline, space, eof, sepEndBy1, digit, char, anyChar, manyTill)
import Text.Read (readMaybe)

data ScalewayCreateSettings = ScalewayCreateSettings
  { ScalewayCreateSettings -> Text
secretKey :: Text
  , ScalewayCreateSettings -> ProjectId
projectId :: ProjectId
  , ScalewayCreateSettings -> Zone
zone :: Zone
  , ScalewayCreateSettings -> Text
instanceType :: Text
  , ScalewayCreateSettings -> Int
volumeSizeGb :: Int
  , ScalewayCreateSettings -> Text
imageId :: Text
  , ScalewayCreateSettings -> Maybe InstanceSetup
instanceSetup :: Maybe InstanceSetup
  }

mkSettings :: LocalConfFileOpts -> ScalewayCreateCliOpts -> IO ScalewayCreateSettings
mkSettings :: LocalConfFileOpts
-> ScalewayCreateCliOpts -> IO ScalewayCreateSettings
mkSettings LocalConfFileOpts
localConfFileOpts ScalewayCreateCliOpts
cliOpts = do
  let maybeSecretKey :: Maybe Text
maybeSecretKey = LocalConfFileOpts
localConfFileOpts.scaleway Maybe LocalConfFileScalewayOpts
-> (LocalConfFileScalewayOpts -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LocalConfFileScalewayOpts
scale -> LocalConfFileScalewayOpts
scale.secretKey :: Maybe Text
  Text
secretKey <- Maybe Text -> [Char] -> IO Text
forall a. Maybe a -> [Char] -> IO a
getVal Maybe Text
maybeSecretKey [Char]
"Could not find scaleway.secret_key in config file"
  let maybeProjectId :: Maybe ProjectId
maybeProjectId = LocalConfFileOpts
localConfFileOpts.scaleway Maybe LocalConfFileScalewayOpts
-> (LocalConfFileScalewayOpts -> Maybe ProjectId)
-> Maybe ProjectId
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LocalConfFileScalewayOpts
scale -> (Text -> ProjectId) -> Maybe Text -> Maybe ProjectId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ProjectId
ProjectId LocalConfFileScalewayOpts
scale.defaultProjectId
  ProjectId
projectId <- Maybe ProjectId -> [Char] -> IO ProjectId
forall a. Maybe a -> [Char] -> IO a
getVal Maybe ProjectId
maybeProjectId [Char]
"Could not find scaleway.default_project_id in config file"
  let maybeZoneFromConfFile :: Maybe Text
maybeZoneFromConfFile = LocalConfFileOpts
localConfFileOpts.scaleway Maybe LocalConfFileScalewayOpts
-> (LocalConfFileScalewayOpts -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LocalConfFileScalewayOpts
scale -> LocalConfFileScalewayOpts
scale.defaultZone
  Zone
zone <- Maybe Text -> Maybe Text -> IO Zone
getZone Maybe Text
maybeZoneFromConfFile ScalewayCreateCliOpts
cliOpts.zone
  let maybeInstanceTypeFromConfFile :: Maybe Text
maybeInstanceTypeFromConfFile = LocalConfFileOpts
localConfFileOpts.scaleway Maybe LocalConfFileScalewayOpts
-> (LocalConfFileScalewayOpts -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LocalConfFileScalewayOpts
scale -> LocalConfFileScalewayOpts
scale.defaultInstanceType
      instanceType :: Text
instanceType = Maybe Text -> Maybe Text -> Text
getInstanceType Maybe Text
maybeInstanceTypeFromConfFile ScalewayCreateCliOpts
cliOpts.instanceType
  let maybeImageIdFromConfFile :: Maybe Text
maybeImageIdFromConfFile = LocalConfFileOpts
localConfFileOpts.scaleway Maybe LocalConfFileScalewayOpts
-> (LocalConfFileScalewayOpts -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LocalConfFileScalewayOpts
scale -> LocalConfFileScalewayOpts
scale.defaultImageId
      imageId :: Text
imageId = Maybe Text -> Maybe Text -> Text
getImageId Maybe Text
maybeImageIdFromConfFile ScalewayCreateCliOpts
cliOpts.imageId
  Maybe InstanceSetup
instanceSetup <- Maybe Text -> IO (Maybe InstanceSetup)
getInstanceSetup ScalewayCreateCliOpts
cliOpts.instanceSetup
  ScalewayCreateSettings -> IO ScalewayCreateSettings
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ScalewayCreateSettings
      { Text
$sel:secretKey:ScalewayCreateSettings :: Text
secretKey :: Text
secretKey
      , ProjectId
$sel:projectId:ScalewayCreateSettings :: ProjectId
projectId :: ProjectId
projectId
      , Zone
$sel:zone:ScalewayCreateSettings :: Zone
zone :: Zone
zone
      , Text
$sel:instanceType:ScalewayCreateSettings :: Text
instanceType :: Text
instanceType
      , $sel:volumeSizeGb:ScalewayCreateSettings :: Int
volumeSizeGb = ScalewayCreateCliOpts
cliOpts.volumeSizeGb
      , Text
$sel:imageId:ScalewayCreateSettings :: Text
imageId :: Text
imageId
      , Maybe InstanceSetup
$sel:instanceSetup:ScalewayCreateSettings :: Maybe InstanceSetup
instanceSetup :: Maybe InstanceSetup
instanceSetup
      }
  where
    getVal :: Maybe a -> String -> IO a
    getVal :: forall a. Maybe a -> [Char] -> IO a
getVal Maybe a
mayVal [Char]
errMsg = IO a -> (a -> IO a) -> Maybe a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> IO a
forall a. HasCallStack => [Char] -> a
error [Char]
errMsg) a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
mayVal

    getInstanceSetup :: Maybe Text -> IO (Maybe InstanceSetup)
    getInstanceSetup :: Maybe Text -> IO (Maybe InstanceSetup)
getInstanceSetup = \case
      -- No instance setup specified as a CLI option.  Don't use one.
      Maybe Text
Nothing -> Maybe InstanceSetup -> IO (Maybe InstanceSetup)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe InstanceSetup
forall a. Maybe a
Nothing
      Just Text
instSetupName -> do
        Maybe InstanceSetup
maybeInstSetup <- Text -> IO (Maybe InstanceSetup)
findInstanceSetup Text
instSetupName
        case Maybe InstanceSetup
maybeInstSetup of
          -- Despite specifying an instance setup name as a CLI option, we
          -- couldn't find a corresponding instance setup. Alert the user to this
          -- problem.
          Maybe InstanceSetup
Nothing -> [Char] -> IO (Maybe InstanceSetup)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (Maybe InstanceSetup))
-> [Char] -> IO (Maybe InstanceSetup)
forall a b. (a -> b) -> a -> b
$ [Char]
"Couldn't find instance setup: \"" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
unpack Text
instSetupName [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\""
          Just InstanceSetup
instSetup -> Maybe InstanceSetup -> IO (Maybe InstanceSetup)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe InstanceSetup -> IO (Maybe InstanceSetup))
-> Maybe InstanceSetup -> IO (Maybe InstanceSetup)
forall a b. (a -> b) -> a -> b
$ InstanceSetup -> Maybe InstanceSetup
forall a. a -> Maybe a
Just InstanceSetup
instSetup

runCreate :: LocalConfFileOpts -> ScalewayCreateCliOpts -> IO ()
runCreate :: LocalConfFileOpts -> ScalewayCreateCliOpts -> IO ()
runCreate LocalConfFileOpts
localConfFileOpts ScalewayCreateCliOpts
scalewayOpts = do
  ScalewayCreateSettings
settings <- LocalConfFileOpts
-> ScalewayCreateCliOpts -> IO ScalewayCreateSettings
mkSettings LocalConfFileOpts
localConfFileOpts ScalewayCreateCliOpts
scalewayOpts
  (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withCloudyDb ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
    (CloudyInstanceId
cloudyInstanceId, Text
instanceName) <- Connection -> IO (CloudyInstanceId, Text)
newCloudyInstance Connection
conn
    UTCTime
currentTime <- IO UTCTime
getCurrentTime
    (ServerId
scalewayServerId, IpId
scalewayIpId, Text
scalewayIpAddr) <- (forall x. ClientError -> IO x)
-> ClientM (ServerId, IpId, Text) -> IO (ServerId, IpId, Text)
forall a. (forall x. ClientError -> IO x) -> ClientM a -> IO a
runScalewayClientM
      (\ClientError
err -> [Char] -> IO x
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO x) -> [Char] -> IO x
forall a b. (a -> b) -> a -> b
$ [Char]
"ERROR! Problem creating instance: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ClientError -> [Char]
forall a. Show a => a -> [Char]
show ClientError
err)
      (ScalewayCreateSettings -> Text -> ClientM (ServerId, IpId, Text)
createScalewayServer ScalewayCreateSettings
settings Text
instanceName)
    Connection
-> UTCTime
-> CloudyInstanceId
-> Maybe InstanceSetup
-> Text
-> Text
-> Text
-> Text
-> IO ()
newScalewayInstance
      Connection
conn
      UTCTime
currentTime
      CloudyInstanceId
cloudyInstanceId
      ScalewayCreateSettings
settings.instanceSetup
      (Zone -> Text
zoneToText ScalewayCreateSettings
settings.zone)
      (ServerId -> Text
unServerId ServerId
scalewayServerId)
      (IpId -> Text
unIpId IpId
scalewayIpId)
      Text
scalewayIpAddr
    [Char] -> IO ()
putStrLn [Char]
"Waiting for Scaleway instance to become available..."
    (forall x. ClientError -> IO x) -> ClientM () -> IO ()
forall a. (forall x. ClientError -> IO x) -> ClientM a -> IO a
runScalewayClientM
      (\ClientError
err -> [Char] -> IO x
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO x) -> [Char] -> IO x
forall a b. (a -> b) -> a -> b
$ [Char]
"ERROR! Problem waiting for instance to be ready: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ClientError -> [Char]
forall a. Show a => a -> [Char]
show ClientError
err)
      (ScalewayCreateSettings -> ServerId -> ClientM ()
waitForScalewayServer ScalewayCreateSettings
settings ServerId
scalewayServerId)
    [Char] -> IO ()
putStrLn [Char]
"Scaleway instance now available."
    [Char] -> IO ()
putStrLn [Char]
"Waiting for SSH to be ready on the instance..."
    Text -> IO ()
waitForSshPort Text
scalewayIpAddr
    [Char] -> IO ()
putStrLn [Char]
"SSH now available on the instance."
    [Char] -> IO ()
putStrLn [Char]
"Getting instance SSH key fingerprints from Scaleway metadata API..."
    Text
rawSshKeyFingerprintsFromScalewayApi <- (forall x. ClientError -> IO x) -> ClientM Text -> IO Text
forall a. (forall x. ClientError -> IO x) -> ClientM a -> IO a
runScalewayClientM
      (\ClientError
err -> [Char] -> IO x
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO x) -> [Char] -> IO x
forall a b. (a -> b) -> a -> b
$ [Char]
"ERROR! Problem getting instance SSH key fingerprints: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ClientError -> [Char]
forall a. Show a => a -> [Char]
show ClientError
err)
      (ScalewayCreateSettings -> ServerId -> ClientM Text
getSshKeyFingerprints ScalewayCreateSettings
settings ServerId
scalewayServerId)
    [Char] -> IO ()
putStrLn [Char]
"Got instance SSH key fingerprints."
    Text -> Text -> IO ()
updateSshHostKeys Text
rawSshKeyFingerprintsFromScalewayApi Text
scalewayIpAddr

createScalewayServer :: ScalewayCreateSettings -> Text -> ClientM (ServerId, IpId, Text)
createScalewayServer :: ScalewayCreateSettings -> Text -> ClientM (ServerId, IpId, Text)
createScalewayServer ScalewayCreateSettings
settings Text
instanceName = do
  let authReq :: AuthenticatedRequest (AuthProtect "auth-token")
authReq = Text -> AuthenticatedRequest (AuthProtect "auth-token")
createAuthReq ScalewayCreateSettings
settings.secretKey
  IpsResp
ipsResp <- AuthenticatedRequest (AuthProtect "auth-token")
-> Zone -> IpsReq -> ClientM IpsResp
ipsPostApi AuthenticatedRequest (AuthProtect "auth-token")
authReq ScalewayCreateSettings
settings.zone (Text -> ProjectId -> IpsReq
IpsReq Text
"routed_ipv4" ScalewayCreateSettings
settings.projectId)
  IO () -> ClientM ()
forall a. IO a -> ClientM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ClientM ()) -> IO () -> ClientM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ips resp: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> IpsResp -> [Char]
forall a. Show a => a -> [Char]
show IpsResp
ipsResp
  let serversReq :: ServersReq
serversReq =
        ServersReq
          { $sel:bootType:ServersReq :: Text
bootType = Text
"local"
          , $sel:commercialType:ServersReq :: Text
commercialType = ScalewayCreateSettings
settings.instanceType
          , $sel:image:ServersReq :: ImageId
image = Text -> ImageId
ImageId ScalewayCreateSettings
settings.imageId
          , $sel:name:ServersReq :: Text
name = Text
"cloudy-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
instanceName
          , $sel:publicIps:ServersReq :: [IpId]
publicIps = [IpsResp
ipsResp.id]
          , $sel:tags:ServersReq :: [Text]
tags = [Text
"cloudy"]
          , $sel:volumes:ServersReq :: Map Text ServersReqVolume
volumes =
              [(Text, ServersReqVolume)] -> Map Text ServersReqVolume
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ ( Text
"0"
                  , ServersReqVolume
                      { $sel:size:ServersReqVolume :: Int
size = ScalewayCreateSettings
settings.volumeSizeGb Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
oneGb
                      , $sel:volumeType:ServersReqVolume :: Text
volumeType = Text
"b_ssd"
                      }
                  )
                ]
          , $sel:project:ServersReq :: ProjectId
project = ScalewayCreateSettings
settings.projectId
          }
  ServersResp
serversResp <- AuthenticatedRequest (AuthProtect "auth-token")
-> Zone -> ServersReq -> ClientM ServersResp
serversPostApi AuthenticatedRequest (AuthProtect "auth-token")
authReq ScalewayCreateSettings
settings.zone ServersReq
serversReq
  IO () -> ClientM ()
forall a. IO a -> ClientM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ClientM ()) -> IO () -> ClientM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"servers resp: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ServersResp -> [Char]
forall a. Show a => a -> [Char]
show ServersResp
serversResp
  let maybeFirstVol :: Maybe ServersRespVolume
maybeFirstVol = Text -> Map Text ServersRespVolume -> Maybe ServersRespVolume
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"0" ServersResp
serversResp.volumes
  ServersRespVolume
firstVol <- ClientM ServersRespVolume
-> (ServersRespVolume -> ClientM ServersRespVolume)
-> Maybe ServersRespVolume
-> ClientM ServersRespVolume
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> ClientM ServersRespVolume
forall a. HasCallStack => [Char] -> a
error [Char]
"couldn't find first volume, unexpected") ServersRespVolume -> ClientM ServersRespVolume
forall a. a -> ClientM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ServersRespVolume
maybeFirstVol
  -- The volume's name has to initially be created as empty (""), and only
  -- after that can we set the name separately.
  Value
serversVolumesResp <-
    AuthenticatedRequest (AuthProtect "auth-token")
-> Zone -> VolumeId -> VolumesReq -> ClientM Value
volumesPatchApi
      AuthenticatedRequest (AuthProtect "auth-token")
authReq
      ScalewayCreateSettings
settings.zone
      ServersRespVolume
firstVol.id
      (Text -> VolumesReq
VolumesReq (Text -> VolumesReq) -> Text -> VolumesReq
forall a b. (a -> b) -> a -> b
$ Text
"cloudy-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
instanceName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-boot-block-volume")
  IO () -> ClientM ()
forall a. IO a -> ClientM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ClientM ()) -> IO () -> ClientM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"servers volumes resp: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Value -> [Char]
forall a. Show a => a -> [Char]
show Value
serversVolumesResp
  case ScalewayCreateSettings
settings.instanceSetup of
    -- No instanceSetup user data, do nothing.
    Maybe InstanceSetup
Nothing -> () -> ClientM ()
forall a. a -> ClientM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just InstanceSetup
instanceSetup -> do
      NoContent
NoContent <-
        AuthenticatedRequest (AuthProtect "auth-token")
-> Zone -> ServerId -> UserDataKey -> UserData -> ClientM NoContent
serversUserDataPatchApi
          AuthenticatedRequest (AuthProtect "auth-token")
authReq
          ScalewayCreateSettings
settings.zone
          ServersResp
serversResp.id
          (Text -> UserDataKey
UserDataKey Text
"cloud-init")
          (Text -> UserData
UserData InstanceSetup
instanceSetup.instanceSetupData.cloudInitUserData)
      IO () -> ClientM ()
forall a. IO a -> ClientM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ClientM ()) -> IO () -> ClientM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"created user data"
  let act :: ServersActionReq
act = ServersActionReq { $sel:action:ServersActionReq :: Text
action = Text
"poweron" }
  TaskResp
task <- AuthenticatedRequest (AuthProtect "auth-token")
-> Zone -> ServerId -> ServersActionReq -> ClientM TaskResp
serversActionPostApi AuthenticatedRequest (AuthProtect "auth-token")
authReq ScalewayCreateSettings
settings.zone ServersResp
serversResp.id ServersActionReq
act
  IO () -> ClientM ()
forall a. IO a -> ClientM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ClientM ()) -> IO () -> ClientM ()
forall a b. (a -> b) -> a -> b
$ TaskResp -> IO ()
forall a. Show a => a -> IO ()
print TaskResp
task
  (ServerId, IpId, Text) -> ClientM (ServerId, IpId, Text)
forall a. a -> ClientM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServersResp
serversResp.id, IpsResp
ipsResp.id, IpsResp
ipsResp.address)

oneGb :: Int
oneGb :: Int
oneGb = Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000

waitForScalewayServer :: ScalewayCreateSettings -> ServerId -> ClientM ()
waitForScalewayServer :: ScalewayCreateSettings -> ServerId -> ClientM ()
waitForScalewayServer ScalewayCreateSettings
settings ServerId
serverId = do
  let authReq :: AuthenticatedRequest (AuthProtect "auth-token")
authReq = Text -> AuthenticatedRequest (AuthProtect "auth-token")
createAuthReq ScalewayCreateSettings
settings.secretKey
  ServersResp
serversResp <- AuthenticatedRequest (AuthProtect "auth-token")
-> Zone -> ServerId -> ClientM ServersResp
serversGetApi AuthenticatedRequest (AuthProtect "auth-token")
authReq ScalewayCreateSettings
settings.zone ServerId
serverId
  Bool -> ClientM () -> ClientM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ServersResp
serversResp.state Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"running") (ClientM () -> ClientM ()) -> ClientM () -> ClientM ()
forall a b. (a -> b) -> a -> b
$ ScalewayCreateSettings -> ServerId -> ClientM ()
waitForScalewayServer ScalewayCreateSettings
settings ServerId
serverId

-- | Wait for port 22 to be available on the remote machine.
waitForSshPort :: Text -> IO ()
waitForSshPort :: Text -> IO ()
waitForSshPort Text
ipaddrText = do
  let hints :: AddrInfo
hints = AddrInfo
defaultHints { addrSocketType = Stream }
  [AddrInfo]
addrInfos <- Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO (t AddrInfo)
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack Text
ipaddrText) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"22")
  case [AddrInfo]
addrInfos of
    [] -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Couldn't get addr info for instance"
    AddrInfo
addrInfo : [AddrInfo]
_ -> AddrInfo -> IO ()
tryConnect AddrInfo
addrInfo
  where
    tryConnect :: AddrInfo -> IO ()
    tryConnect :: AddrInfo -> IO ()
tryConnect AddrInfo
addrInfo = do
      Either SomeException ()
res <-
        IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (AddrInfo -> IO Socket
openSocket AddrInfo
addrInfo) (Socket -> Int -> IO ()
`gracefulClose` Int
1000) ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock ->
          Socket -> SockAddr -> IO ()
connect Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
addrAddress AddrInfo
addrInfo
      case Either SomeException ()
res of
        Left (SomeException
_ :: SomeException) -> do
          Int -> IO ()
threadDelay Int
1_000_000
          AddrInfo -> IO ()
tryConnect AddrInfo
addrInfo
        Right ()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

getSshKeyFingerprints :: ScalewayCreateSettings -> ServerId -> ClientM Text
getSshKeyFingerprints :: ScalewayCreateSettings -> ServerId -> ClientM Text
getSshKeyFingerprints ScalewayCreateSettings
settings ServerId
serverId = do
  let authReq :: AuthenticatedRequest (AuthProtect "auth-token")
authReq = Text -> AuthenticatedRequest (AuthProtect "auth-token")
createAuthReq ScalewayCreateSettings
settings.secretKey
  UserData Text
rawSshKeyFingerprints <- AuthenticatedRequest (AuthProtect "auth-token")
-> Zone -> ServerId -> UserDataKey -> ClientM UserData
serversUserDataGetApi AuthenticatedRequest (AuthProtect "auth-token")
authReq ScalewayCreateSettings
settings.zone ServerId
serverId (Text -> UserDataKey
UserDataKey Text
"ssh-host-fingerprints")
  Text -> ClientM Text
forall a. a -> ClientM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
rawSshKeyFingerprints

updateSshHostKeys ::
  Text ->
  -- | IP Address
  Text ->
  IO ()
updateSshHostKeys :: Text -> Text -> IO ()
updateSshHostKeys Text
rawFingerprintsFromScalewayApi Text
ipAddr = do
  NonEmpty Fingerprint
fingerprintsFromScalewayApi <-
    (ParseError -> IO (NonEmpty Fingerprint))
-> Either ParseError (NonEmpty Fingerprint)
-> IO (NonEmpty Fingerprint)
forall (m :: * -> *) e a.
Applicative m =>
(e -> m a) -> Either e a -> m a
fromEitherM
      (\ParseError
parseErr ->
          [Char] -> IO (NonEmpty Fingerprint)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (NonEmpty Fingerprint))
-> [Char] -> IO (NonEmpty Fingerprint)
forall a b. (a -> b) -> a -> b
$
            [Char]
"Error parsing SSH host fingerprints from Scaleway metadata API: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
            ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
parseErr
      )
      (Text -> Text -> Either ParseError (NonEmpty Fingerprint)
parseFingerprints Text
"scaleway-metadata-api" Text
rawFingerprintsFromScalewayApi)
  [Char] -> IO ()
putStrLn [Char]
"Getting SSH host keys from instance..."
  Text
rawHostKeys <- Text -> IO Text
getSshHostKeys Text
ipAddr
  [Char] -> IO ()
putStrLn [Char]
"Got SSH keys host keys from instance."
  Text
rawFingerprintsFromHost <- Text -> IO Text
fingerprintsFromHostKeys Text
rawHostKeys
  NonEmpty Fingerprint
fingerprintsFromHost <-
    (ParseError -> IO (NonEmpty Fingerprint))
-> Either ParseError (NonEmpty Fingerprint)
-> IO (NonEmpty Fingerprint)
forall (m :: * -> *) e a.
Applicative m =>
(e -> m a) -> Either e a -> m a
fromEitherM
      (\ParseError
parseErr ->
          [Char] -> IO (NonEmpty Fingerprint)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (NonEmpty Fingerprint))
-> [Char] -> IO (NonEmpty Fingerprint)
forall a b. (a -> b) -> a -> b
$
            [Char]
"Error parsing SSH host fingerprints directly from instance: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
            ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
parseErr
      )
      (Text -> Text -> Either ParseError (NonEmpty Fingerprint)
parseFingerprints Text
"host" Text
rawFingerprintsFromScalewayApi)
  case NonEmpty Fingerprint -> NonEmpty Fingerprint -> FingerprintsMatch
doFingerprintsMatch NonEmpty Fingerprint
fingerprintsFromScalewayApi NonEmpty Fingerprint
fingerprintsFromHost of
    FingerprintsMatch
FingerprintsMatch -> do
      [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char]
"Fingerprints match between Scaleway metadata API and actual " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
        [Char]
"instance, so removing old known hosts keys for the IP address, " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
        [Char]
"and adding new known host keys..."
      Text -> IO ()
removeOldHostKeysFromKnownHosts Text
ipAddr
      Text -> IO ()
addNewHostKeysToKnownHosts Text
rawHostKeys
      [Char] -> IO ()
putStrLn [Char]
"Added known host keys for new instance."
    FingerprintsMatch
FingerprintsNoMatch ->
      [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char]
"ERROR: Fingerprints from scaleway metadata api, and fingerprints " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
        [Char]
"directly from host don't match.\n\nFrom metadata api:\n\n" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
        Text -> [Char]
unpack Text
rawFingerprintsFromScalewayApi [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
        [Char]
"\n\nFrom host: \n\n" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
        Text -> [Char]
unpack Text
rawFingerprintsFromHost
    FingerprintsMatchErr Text
err ->
      [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char]
"ERROR: There was an unexpected error when comparing fingerprints from " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
        [Char]
"the scaleway metadata API, and fingerprints directly from the host: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
        Text -> [Char]
unpack Text
err

-- | This datatype represents a line from an SSH fingerprint file, normally as
-- output by @ssh-keygen -l@.
--
-- Here's an example line:
--
-- > 3072 SHA256:dRJ/XiNOlh9UGnnN5/a2N+EMSP+OkqyHy8WTzHlUt5U root@cloudy-complete-knife (RSA)
data Fingerprint = Fingerprint
  { Fingerprint -> Word64
size :: Word64
    -- ^ Size of the key.  Example: @3072@
  , Fingerprint -> Text
fingerprint :: Text
    -- ^ The fingerprint of the key.  Example: @"SHA256:n6fLRD4O2Me3bRXhzHyCca1vWdQ2utxuPZVsIDUm6o0"@
  , Fingerprint -> Text
server :: Text
    -- ^ User and hostname.  Example: @"root\@cloudy-complete-knife"@
  , Fingerprint -> Text
keyType :: Text
    -- ^ Type of key.  Example: @"RSA"@
  }
  deriving stock Int -> Fingerprint -> [Char] -> [Char]
[Fingerprint] -> [Char] -> [Char]
Fingerprint -> [Char]
(Int -> Fingerprint -> [Char] -> [Char])
-> (Fingerprint -> [Char])
-> ([Fingerprint] -> [Char] -> [Char])
-> Show Fingerprint
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Fingerprint -> [Char] -> [Char]
showsPrec :: Int -> Fingerprint -> [Char] -> [Char]
$cshow :: Fingerprint -> [Char]
show :: Fingerprint -> [Char]
$cshowList :: [Fingerprint] -> [Char] -> [Char]
showList :: [Fingerprint] -> [Char] -> [Char]
Show

-- | Note that we don't enforce 'server' to be same between two Fingerprints.
instance Eq Fingerprint where
  Fingerprint
fing1 == :: Fingerprint -> Fingerprint -> Bool
== Fingerprint
fing2 =
    Fingerprint
fing1.size Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
fing2.size Bool -> Bool -> Bool
&&
    Fingerprint
fing1.fingerprint Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
fing2.fingerprint Bool -> Bool -> Bool
&&
    Fingerprint
fing1.keyType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
fing2.keyType

instance Ord Fingerprint where
  compare :: Fingerprint -> Fingerprint -> Ordering
compare Fingerprint
fing1 Fingerprint
fing2 =
    case Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Fingerprint
fing1.size Fingerprint
fing2.size of
      Ordering
EQ ->
        case Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Fingerprint
fing1.fingerprint Fingerprint
fing2.fingerprint of
          Ordering
EQ -> Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Fingerprint
fing1.keyType Fingerprint
fing2.keyType
          Ordering
res -> Ordering
res
      Ordering
res -> Ordering
res

type Parser = Parsec Text ()

parseFingerprints ::
  -- | Where are these fingerprints coming from?
  --
  -- Just used in error output to help debugging.
  Text ->
  -- | The raw fingerprint file.  See 'Fingerprint' for what a single line of
  -- this file looks like.  The whole file is just multiple of these lines,
  -- separate by a new line.
  Text ->
  Either ParseError (NonEmpty Fingerprint)
parseFingerprints :: Text -> Text -> Either ParseError (NonEmpty Fingerprint)
parseFingerprints Text
fromWhere Text
rawFingerprintText = do
  Parsec Text () (NonEmpty Fingerprint)
-> [Char] -> Text -> Either ParseError (NonEmpty Fingerprint)
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse (Parsec Text () (NonEmpty Fingerprint)
fingerprintsParser Parsec Text () (NonEmpty Fingerprint)
-> ParsecT Text () Identity ()
-> Parsec Text () (NonEmpty Fingerprint)
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Text () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) (Text -> [Char]
unpack Text
fromWhere) Text
rawFingerprintText

fingerprintsParser :: Parser (NonEmpty Fingerprint)
fingerprintsParser :: Parsec Text () (NonEmpty Fingerprint)
fingerprintsParser = do
  [Fingerprint]
fingerprints <- ParsecT Text () Identity Fingerprint
-> ParsecT Text () Identity Char
-> ParsecT Text () Identity [Fingerprint]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepEndBy1 ParsecT Text () Identity Fingerprint
fingerprintParser ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline
  case [Fingerprint]
fingerprints of
    [] -> [Char] -> Parsec Text () (NonEmpty Fingerprint)
forall a. HasCallStack => [Char] -> a
error [Char]
"fingerprintsParser: sepEndBy1 is never expected to return empty list"
    (Fingerprint
h : [Fingerprint]
ts) -> NonEmpty Fingerprint -> Parsec Text () (NonEmpty Fingerprint)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty Fingerprint -> Parsec Text () (NonEmpty Fingerprint))
-> NonEmpty Fingerprint -> Parsec Text () (NonEmpty Fingerprint)
forall a b. (a -> b) -> a -> b
$ Fingerprint
h Fingerprint -> [Fingerprint] -> NonEmpty Fingerprint
forall a. a -> [a] -> NonEmpty a
:| [Fingerprint]
ts

-- | Parse a single 'Fingerprint'.
--
-- >>> let finger = "3072 SHA256:dRJ/XiNOlh9UGnnN5/a2N+EMSP+OkqyHy8WTzHlUt5U root@cloudy-complete-knife (RSA)"
-- >>> parseTest fingerprintParser finger
-- Fingerprint {size = 3072, fingerprint = "SHA256:dRJ/XiNOlh9UGnnN5/a2N+EMSP+OkqyHy8WTzHlUt5U", server = "root@cloudy-complete-knife", keyType = "RSA"}
fingerprintParser :: Parser Fingerprint
fingerprintParser :: ParsecT Text () Identity Fingerprint
fingerprintParser = do
  Word64
size <- Parser Word64
int
  ParsecT Text () Identity Char -> ParsecT Text () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
  Text
fingerprint <- [Char] -> Text
pack ([Char] -> Text)
-> ParsecT Text () Identity [Char] -> ParsecT Text () Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Char
-> ParsecT Text () Identity Char -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
manyTill ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
  Text
server <- [Char] -> Text
pack ([Char] -> Text)
-> ParsecT Text () Identity [Char] -> ParsecT Text () Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Char
-> ParsecT Text () Identity Char -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
manyTill ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
  ParsecT Text () Identity Char -> ParsecT Text () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Text () Identity Char -> ParsecT Text () Identity ())
-> ParsecT Text () Identity Char -> ParsecT Text () Identity ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'('
  Text
keyType <- [Char] -> Text
pack ([Char] -> Text)
-> ParsecT Text () Identity [Char] -> ParsecT Text () Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Char
-> ParsecT Text () Identity Char -> ParsecT Text () Identity [Char]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
manyTill ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')')
  Fingerprint -> ParsecT Text () Identity Fingerprint
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fingerprint -> ParsecT Text () Identity Fingerprint)
-> Fingerprint -> ParsecT Text () Identity Fingerprint
forall a b. (a -> b) -> a -> b
$ Fingerprint { Word64
$sel:size:Fingerprint :: Word64
size :: Word64
size, Text
$sel:fingerprint:Fingerprint :: Text
fingerprint :: Text
fingerprint, Text
$sel:server:Fingerprint :: Text
server :: Text
server, Text
$sel:keyType:Fingerprint :: Text
keyType :: Text
keyType }
  where
    int :: Parser Word64
    int :: Parser Word64
int = do
      [Char]
digits <- ParsecT Text () Identity Char -> ParsecT Text () Identity [Char]
forall a.
ParsecT Text () Identity a -> ParsecT Text () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
      case [Char] -> Maybe Word64
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
digits of
        Maybe Word64
Nothing -> [Char] -> Parser Word64
forall a. [Char] -> ParsecT Text () Identity a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser Word64) -> [Char] -> Parser Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"Couldn't read digits as Word64: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
digits
        Just Word64
i -> Word64 -> Parser Word64
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
i

-- | Returns the SSH host keys for the given host.
--
-- This effectively just runs @ssh-keyscan@ on the given host.
--
-- This returns an output that looks like the following:
--
-- > 123.100.200.3 ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABgQCiRtLMhK1Dh72tpJIXF+NjLAPPyXbq/tYC0ztDTMBFfQEj2jixURcugtGM7WjcqDCHHgnPDcSHrlkl9dMOV0MvjA2WxNupDU1bPQ31h10rIiiSjL+IB+c9e1wEgJylt72pDPzxDjdNfuAS3gspOjYNuy2vRBlV8rQ9GDlSoSvqMGbQ7W9bdCLnANsUkI+FCXFZCzIL3MU26ddqrBdCgiTvFUVxHjfFJMxwsKwLa18P6dc586mYXocmQGwjyXfJCiOw5kajvH4a9BzRr21nQT23GI2e4RlJ2Rkum9lazBNaVaQBYIUgLVVFMSfxbEt2GGBv82UKbQTbk6KHrrKE8ABYmkE81lgE+8zlnh6lxlaEQ9if6/KvtwP97g0md3hxc9b2MvGnQLEX9jjHJ/B9bHW7jJzqWRQAnCQZzenbyTht5lNK480Q9qGTu0h8FNteapzos/JnQ3B8taGQI5fpxosRLyhX3wzdQrmaAiBnILgYV2sPWZT3th0M6gsLDi4ao40=
-- > 123.100.200.3 ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIBJKYO35BsIkFjiAXACgkWzTC+tA2sH5RSqoYoGq8Lv+
-- > 123.100.200.3 ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBKR0UH9ZSmUyYUJfE/4mUT4SLZ9wskvsCXkVL8QNIprmFt7Zz7eRerQVyqoOm4/Zhu2OWlleqfIWOmuyPDGkImo=
getSshHostKeys ::
  -- | IP Address or hostname.  Example: @\"123.100.200.3\"@
  Text ->
  IO Text
getSshHostKeys :: Text -> IO Text
getSshHostKeys Text
ipAddr = do
  (ExitCode
exitCode, [Char]
stdout, [Char]
stderr) <- [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode [Char]
"ssh-keyscan" [Text -> [Char]
unpack Text
ipAddr] [Char]
""
  case ExitCode
exitCode of
    ExitFailure Int
_ -> do
      [Char] -> IO Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO Text) -> [Char] -> IO Text
forall a b. (a -> b) -> a -> b
$
        [Char]
"getSshHostKeys: error running ssh-keyscan on ip " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
unpack Text
ipAddr [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
        [Char]
stderr
    ExitCode
ExitSuccess -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack [Char]
stdout

-- | Return the fingerprints for a set of raw host keys.
--
-- This effectively just runs @ssh-keygen -l@ on a set of raw host keys.
--
-- See the docs for 'Fingerprint' for an example of what this function outputs.
fingerprintsFromHostKeys ::
  -- | A newline-separated file of SSH host keys.  See the output of
  -- 'getSshHostKeys' for what this should look like.
  Text ->
  IO Text
fingerprintsFromHostKeys :: Text -> IO Text
fingerprintsFromHostKeys Text
rawHostKeys = do
  (ExitCode
exitCode, [Char]
stdout, [Char]
stderr) <-
    [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode [Char]
"ssh-keygen" [[Char]
"-l", [Char]
"-f", [Char]
"-"] (Text -> [Char]
unpack Text
rawHostKeys)
  case ExitCode
exitCode of
    ExitFailure Int
_ -> do
      [Char] -> IO Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO Text) -> [Char] -> IO Text
forall a b. (a -> b) -> a -> b
$
        [Char]
"fingerprintsFromHostKeys: error running ssh-keygen on raw host keys: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
        [Char]
stderr
    ExitCode
ExitSuccess -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack [Char]
stdout

-- | Results of comparing whether two sets of fingerprints match.
data FingerprintsMatch
  = FingerprintsMatch
  | FingerprintsNoMatch
  -- | There was some error when comparing the two sets of fingerprints.
  | FingerprintsMatchErr Text
  deriving stock Int -> FingerprintsMatch -> [Char] -> [Char]
[FingerprintsMatch] -> [Char] -> [Char]
FingerprintsMatch -> [Char]
(Int -> FingerprintsMatch -> [Char] -> [Char])
-> (FingerprintsMatch -> [Char])
-> ([FingerprintsMatch] -> [Char] -> [Char])
-> Show FingerprintsMatch
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> FingerprintsMatch -> [Char] -> [Char]
showsPrec :: Int -> FingerprintsMatch -> [Char] -> [Char]
$cshow :: FingerprintsMatch -> [Char]
show :: FingerprintsMatch -> [Char]
$cshowList :: [FingerprintsMatch] -> [Char] -> [Char]
showList :: [FingerprintsMatch] -> [Char] -> [Char]
Show

doFingerprintsMatch :: NonEmpty Fingerprint -> NonEmpty Fingerprint -> FingerprintsMatch
doFingerprintsMatch :: NonEmpty Fingerprint -> NonEmpty Fingerprint -> FingerprintsMatch
doFingerprintsMatch NonEmpty Fingerprint
fings1 NonEmpty Fingerprint
fings2 =
  let fingsLen1 :: Int
fingsLen1 = NonEmpty Fingerprint -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty Fingerprint
fings1
      fingsLen2 :: Int
fingsLen2 = NonEmpty Fingerprint -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty Fingerprint
fings2
      fingsSet1 :: Set Fingerprint
fingsSet1 = [Fingerprint] -> Set Fingerprint
forall a. Ord a => [a] -> Set a
Set.fromList ([Fingerprint] -> Set Fingerprint)
-> [Fingerprint] -> Set Fingerprint
forall a b. (a -> b) -> a -> b
$ NonEmpty Fingerprint -> [Fingerprint]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Fingerprint
fings1
      fingsSet2 :: Set Fingerprint
fingsSet2 = [Fingerprint] -> Set Fingerprint
forall a. Ord a => [a] -> Set a
Set.fromList ([Fingerprint] -> Set Fingerprint)
-> [Fingerprint] -> Set Fingerprint
forall a b. (a -> b) -> a -> b
$ NonEmpty Fingerprint -> [Fingerprint]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Fingerprint
fings2
      fingsSetLen1 :: Int
fingsSetLen1 = Set Fingerprint -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set Fingerprint
fingsSet1
      fingsSetLen2 :: Int
fingsSetLen2 = Set Fingerprint -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set Fingerprint
fingsSet2
  in
  if Int
fingsLen1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
fingsSetLen1 then Text -> FingerprintsMatch
FingerprintsMatchErr Text
"first set of fingerprints is not unique" else
  if Int
fingsLen2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
fingsSetLen2 then Text -> FingerprintsMatch
FingerprintsMatchErr Text
"second set of fingerprints is not unique" else
  if Int
fingsSetLen1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
fingsSetLen2 then Text -> FingerprintsMatch
FingerprintsMatchErr Text
"two sets of fingerprints have different numbers of fingerprints" else
  if Set Fingerprint -> Set Fingerprint -> Bool
forall a. Ord a => Set a -> Set a -> Bool
isSubsetOf Set Fingerprint
fingsSet1 Set Fingerprint
fingsSet2 Bool -> Bool -> Bool
&& Set Fingerprint -> Set Fingerprint -> Bool
forall a. Ord a => Set a -> Set a -> Bool
isSubsetOf Set Fingerprint
fingsSet2 Set Fingerprint
fingsSet1
    then FingerprintsMatch
FingerprintsMatch
    else FingerprintsMatch
FingerprintsNoMatch

-- | Remove old, out-of-date host keys from the user's @~/.ssh/known_hosts@ file.
--
-- This effectively just runs @ssh-keygen -R@ on the passed-in IP address.
removeOldHostKeysFromKnownHosts ::
  -- | IP Address or hostname.  Example: @\"123.100.200.3\"@.
  Text ->
  IO ()
removeOldHostKeysFromKnownHosts :: Text -> IO ()
removeOldHostKeysFromKnownHosts Text
ipAddr = do
  (ExitCode
exitCode, [Char]
_, [Char]
stderr) <- [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode [Char]
"ssh-keygen" [[Char]
"-R", Text -> [Char]
unpack Text
ipAddr] [Char]
""
  case ExitCode
exitCode of
    ExitFailure Int
_ -> do
      [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char]
"remove: removeOldHostKeysFromKnownHosts error running ssh-keygen -R on IP " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
unpack Text
ipAddr [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
        [Char]
stderr
    ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Add a set of new SSH host keys to the @~/.ssh/known_hosts@ file.
--
-- This effectively just appends the passed-in host keys to the file.
addNewHostKeysToKnownHosts ::
  -- | A set of SSH host keys.  See the output of 'getSshHostKeys' for
  -- what this should look like.
  Text ->
  IO ()
addNewHostKeysToKnownHosts :: Text -> IO ()
addNewHostKeysToKnownHosts Text
newSshHostKeys = do
  [Char]
homeDir <- IO [Char]
getHomeDirectory
  let knownHosts :: [Char]
knownHosts = [Char]
homeDir [Char] -> [Char] -> [Char]
</> [Char]
".ssh" [Char] -> [Char] -> [Char]
</> [Char]
"known_hosts"
      knownHostsOld :: [Char]
knownHostsOld = [Char]
knownHosts [Char] -> [Char] -> [Char]
<.> [Char]
"old"
      newSshHostKeysRaw :: ByteString
newSshHostKeysRaw = Text -> ByteString
encodeUtf8 Text
newSshHostKeys
  -- make copy of known hosts
  [Char] -> [Char] -> IO ()
copyFile [Char]
knownHosts [Char]
knownHostsOld
  [Char] -> ByteString -> IO ()
ByteString.appendFile [Char]
knownHosts (ByteString
"\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
newSshHostKeysRaw)

-- $setup
--
-- >>> import Text.Parsec (parseTest)