cloudy (empty) → 0.1.0.0
raw patch · 41 files changed
+4583/−0 lines, 41 filesdep +QuickCheckdep +aesondep +basebuild-type:Customsetup-changed
Dependencies added: QuickCheck, aeson, base, bytestring, cloudy, containers, deepseq, directory, doctest, file-embed, filepath, from-sum, http-api-data, http-client-tls, http-media, network, network-bsd, optparse-applicative, parsec, pretty-simple, process, random, servant, servant-client, servant-client-core, sqlite-simple, tasty, tasty-hunit, template-haskell, text, time, unix, uuid, yaml
Files
- CHANGELOG.md +4/−0
- LICENSE +28/−0
- README.md +273/−0
- Setup.hs +6/−0
- app/Main.hs +7/−0
- cloudy.cabal +156/−0
- default.nix +3/−0
- instance-setups/hello-world-cloud-config.yaml +12/−0
- instance-setups/hello-world.yaml +7/−0
- nix/default.nix +23/−0
- nix/overlay.nix +142/−0
- shell.nix +3/−0
- src/Cloudy.hs +11/−0
- src/Cloudy/Cli.hs +326/−0
- src/Cloudy/Cli/Aws.hs +42/−0
- src/Cloudy/Cli/Scaleway.hs +214/−0
- src/Cloudy/Cli/Utils.hs +32/−0
- src/Cloudy/Cmd.hs +20/−0
- src/Cloudy/Cmd/Aws.hs +17/−0
- src/Cloudy/Cmd/CopyFile.hs +65/−0
- src/Cloudy/Cmd/Destroy.hs +78/−0
- src/Cloudy/Cmd/List.hs +68/−0
- src/Cloudy/Cmd/Scaleway.hs +14/−0
- src/Cloudy/Cmd/Scaleway/Create.hs +437/−0
- src/Cloudy/Cmd/Scaleway/ListImages.hs +113/−0
- src/Cloudy/Cmd/Scaleway/ListInstanceTypes.hs +127/−0
- src/Cloudy/Cmd/Scaleway/Utils.hs +110/−0
- src/Cloudy/Cmd/Ssh.hs +33/−0
- src/Cloudy/Cmd/Utils.hs +47/−0
- src/Cloudy/Db.hs +419/−0
- src/Cloudy/InstanceSetup.hs +80/−0
- src/Cloudy/InstanceSetup/Types.hs +51/−0
- src/Cloudy/LocalConfFile.hs +77/−0
- src/Cloudy/NameGen.hs +769/−0
- src/Cloudy/Path.hs +30/−0
- src/Cloudy/Scaleway.hs +590/−0
- src/Cloudy/Table.hs +97/−0
- test/DocTest.hs +12/−0
- test/Test.hs +8/−0
- test/Test/Cloudy.hs +12/−0
- test/Test/Cloudy/InstanceSetup.hs +20/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@++## 0.1.0.0++* Initial release.
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2024, Dennis Gosnell++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+ 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 HOLDER 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.
+ README.md view
@@ -0,0 +1,273 @@+# Cloudy++Cloudy is a CLI tool to easily spin up and control compute instances in+various cloud environments. You can think of it as an alternative to+cloud-specific CLI tools, like `aws` for AWS, or `scw` for Scaleway.++Cloudy focuses on easily controlling compute instances (as opposed to the full+functionality provided by cloud vendors). Cloudy's goal is to make it easy to+run one-off cloud-based compute instances from the command line. It is+somewhat similar to `docker` or `vagrant`, but for running instances in the+Cloud instead of locally.++Cloudy is a good fit for things like the following:++- Spinning up a webserver in the cloud in order to show a friend or coworker a tech demo.+- Creating a temporary VPN in order to work around location restrictions.+- Creating a cloud-based environment to test a tool that you don't want to install locally.++Cloudy makes both spinning up and destroying an instance just a single command,+as well as providing nice Bash completion. It is quite lightweight and quick+to use.++For instance, creating a new instance on Scaleway with a 150 gb disk is as+simple as:++```console+$ cloudy scaleway create --volume-size 150+```++You can then SSH to the instance with the command:++```console+$ cloudy ssh+```++When you're finished, you can destroy the instance (and all related resources)+with the command:++```console+$ cloudy destroy+```++## Supported Cloud Providers++Cloudy currently supports the following cloud providers:++- [AWS](https://aws.amazon.com/) ([support planned](https://github.com/cdepillabout/cloudy/issues/2))+- [Scaleway](https://www.scaleway.com/)++PRs providing support for additional cloud providers are always welcome!++## Installation++Cloudy provides a single CLI tool, `cloudy`.++This section lists installation instructions for various distros.++### Generic Linux++There is a statically-linked x86_64 Linux ELF binary for `cloudy` available on each of+the [GitHub Releases](https://github.com/cdepillabout/cloudy/releases).++### Nix / NixOS++Cloudy can be built with Nix by using the `.nix` files in this repo:++```console+$ nix-build+```++You can find the `cloudy` binary in `./result/bin/cloudy`.++You can also install Cloudy from Nixpkgs by using the `haskellPackages.cloudy`+derivation:++```console+$ nix-build '<nixpkgs>' -A haskellPackages.cloudy+```++### Other Distros++PRs are welcome adding instructions for installing Cloudy on other Linux+distributions!++## Setup++Cloudy requires some setup before first use. The required setup is different+depending on which cloud providers you want to use.++You must create a config file in `~/.config/cloudy/cloudy.yaml`. The following+sections explain what options need to be set in the config file for each cloud+provider.++### Setup for Scaleway++You need to add things like your Scaleway access key and secret key to the+`~/.config/cloudy/cloudy.yaml` config file.++You can find these values by generating a new API key on the Scaleway website+at <https://console.scaleway.com/iam/api-keys>:++```yaml+scaleway:+ # (required) Scaleway key, secret, and default org and project. You can get these+ # values from the Scaleway website by generating a new API key.+ access_key: "SCWXIH85IR279KUH0X2I"+ secret_key: "4985bead-91a4-4e96-9e8e-5d88280cf26b"+ default_organization_id: "074712d9-c5e9-454c-b909-7a6be0c92cf0"+ default_project_id: "074712d9-c5e9-454c-b909-7a6be0c92cf0"++ # (optional) The default zone to use. You can find all zones listed in+ # https://registry.terraform.io/providers/scaleway/scaleway/latest/docs/guides/regions_and_zones+ #+ # If you don't specify this, then you'll need to pass it on the command line+ # to all commands that require it.+ default_zone: "nl-ams-1"++ # (optional) The default instance type to use when creating instances.+ # You can find all instance types in the output of the+ # `cloudy scaleway list-instance-types` command.+ #+ # If you don't specify this, then you'll need to pass it on the command line+ # to all commands that require it.+ default_instance_type: "PLAY2-PICO"++ # (optional) The default image to use. You can find other image IDs in the+ # output of the `cloudy scaleway list-images` command.+ #+ # If you don't specify this, then you'll need to pass it on the command line+ # to all commands that require it.+ default_image_id: "ubuntu_noble"+```++### Setup for AWS++(AWS support has [not yet been added](https://github.com/cdepillabout/cloudy/issues/2).)++## Usage++This section explains how to use Cloudy, assuming you've gone through the setup above.++### Create a Cloud Instance++The commands for creating a cloud instance differ between cloud providers.+The commands for each cloud provider are explained below.++Note that if you experience an error when running a command to create a cloud+instance, you must go to the cloud provider management UI and manually delete+all resources that Cloudy has created.++### Create a Scaleway Instance++A Scaleway instance can be created with a command like the following:++```console+$ cloudy scaleway create \+ --zone nl-ams-1 \+ --instance-type PLAY2-NANO \+ --volume-size 75 \+ --image-id "1ec31ce3-bec3-4866-81fc-08d4b6966f9f"+```++This creates a `PLAY2-NANO` Scaleway instance in zone `nl-ams-1` with a 75 GB+root disk, using an Ubuntu 24.04 disk image.++Here's the meaning of each of these arguments:++- `--zone`: A Scaleway zone. You can find all available values in+ <https://registry.terraform.io/providers/scaleway/scaleway/latest/docs/guides/regions_and_zones>.++- `--instance-type`: The Scaleway instance type. You can find all+ available instance types with the command+ `cloudy scaleway list-instance-types`.++- `--volume-size`: The size in GB of the root disk. Some instance+ types have minimum / maximum root disk sizes that they support.+ You can find this information in the output of the+ `cloudy scaleway list-instance-types` command.++ Cloudy provides no way to add additional disks to an instance.++- `--image-id`: The ID of the image. You can find all available+ image IDs with the command `cloudy scaleway list-images`. There+ are images available for many popular Linux distros.++See `cloudy scaleway create --help` for more information.++### Create an AWS EC2 Instance++(AWS support has [not yet been added](https://github.com/cdepillabout/cloudy/issues/2).)++### List all Cloud Instances++You can see all your active Cloud Instances with the `cloudy list` command:++```console+$ cloudy list+|---------------------------------------------------------------------------------------------------------|+| instance id | instance name | created date | cloud | zone | ip | instance setup |+|=============|================|==================|==========|==========|================|================|+| 7 | belief-example | 2024-09-22 18:23 | scaleway | nl-ams-1 | 61.252.131.123 | nginx |+| 10 | land-secretary | 2024-09-22 18:24 | scaleway | fr-par-3 | 73.128.200.201 | (none) |+|---------------------------------------------------------------------------------------------------------|+```++### SSH to Cloud Instance++You can SSH to an instance with the `cloudy ssh` command:++```console+$ cloudy ssh --name belief-example+```++You can pick which instance to SSH to with either the `--name` or `--id`+argument. If you have only a single instance available, then you don't need to+specify either the `--name` or `--id` argument.++### Copy Files to/from Cloud Instance++You can copy files to an instance with a command like the following:++```console+$ cloudy copy-file --to-instance ./my-local-file my-remote-file+```++This copies the local file `my-local-file` to the cloud instance with the name+`my-remote-file`.++See `cloudy copy-file --help` for more examples of copying files.++### Destroy Cloud Instance++You can destroy a cloud instance with a command like the following:++```console+$ cloudy destroy --name belief-example+```++You can pick which instance to SSH to with either the `--name` or `--id`+argument. If you have only a single instance available, then you don't need to+specify either the `--name` or `--id` argument.++After destroying the instance, you likely want to double check the cloud+provider's management UI to confirm that all the related resources have been+deleted.++## Instance Setup Scripts++TODO++## Moving Past Cloudy++Cloudy is meant to be simple and easy to use from the command line. If you+want to change many additional settings when creating an instance, or you want+to create multiple instances at once, you likely want a more flexible solution+than Cloudy.++I recommend you look into either directly calling the CLI tool for a given+cloud provider, or using a tool like Terraform to create cloud resources.++## WARNING++Cloudy is still beta software. It is possible that cloud resources are not+correctly created or deleted. You should make sure to manually check your+cloud provider's management UI to confirm that all expected resources have been+deleted after running commands like `cloudy destroy`.++You should also make sure to check the cloud provider's management UI if any+Cloudy commands fail, like `cloudy PROVIDER create`.++Cloudy is provided as-is, without any warranty of any kind. You are solely+responsible for all charges incurred due to Cloudy usage, even in the face of+Cloudy-related bugs or mistakes.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main where++import Distribution.Extra.Doctest (defaultMainWithDoctests)++main :: IO ()+main = defaultMainWithDoctests "doctests"
+ app/Main.hs view
@@ -0,0 +1,7 @@++module Main where++import Cloudy (defaultMain)++main :: IO ()+main = defaultMain
+ cloudy.cabal view
@@ -0,0 +1,156 @@+cabal-version: 3.4++name: cloudy+version: 0.1.0.0+synopsis: CLI tool to easily spin up and control compute instances in various cloud environments+-- description: CLI tool+homepage: https://github.com/cdepillabout/cloudy+license: BSD-3-Clause+license-file: LICENSE+author: Dennis Gosnell+maintainer: cdep.illabout@gmail.com+copyright: 2024-2024 Dennis Gosnell+category: Productivity+build-type: Custom+extra-source-files: README.md+ , CHANGELOG.md+ , default.nix+ , instance-setups/*.yaml+ , nix/default.nix+ , nix/overlay.nix+ , shell.nix++custom-setup+ -- Hackage apparently gives an error if you don't specify an+ -- upper bound on your setup-depends. But I don't want to+ -- have to remember to bump the upper bound of each of these+ -- setup depends every time I want to make a release of cloudy,+ -- especially since I already have upper bounds on important things+ -- like base below. I'm never going to want my bounds on setup-depends+ -- to differ from the bounds on my actual depends.+ setup-depends: base <999+ , cabal-doctest >=1.0.2 && <1.1+ , Cabal >= 3.8 && < 9999++library+ hs-source-dirs: src+ exposed-modules: Cloudy+ Cloudy.Cli+ Cloudy.Cli.Aws+ Cloudy.Cli.Scaleway+ Cloudy.Cli.Utils+ Cloudy.Cmd+ Cloudy.Cmd.Aws+ Cloudy.Cmd.CopyFile+ Cloudy.Cmd.Destroy+ Cloudy.Cmd.List+ Cloudy.Cmd.Scaleway+ Cloudy.Cmd.Scaleway.Create+ Cloudy.Cmd.Scaleway.ListImages+ Cloudy.Cmd.Scaleway.ListInstanceTypes+ Cloudy.Cmd.Scaleway.Utils+ Cloudy.Cmd.Ssh+ Cloudy.Cmd.Utils+ Cloudy.Db+ Cloudy.InstanceSetup+ Cloudy.InstanceSetup.Types+ Cloudy.LocalConfFile+ Cloudy.NameGen+ Cloudy.Path+ Cloudy.Scaleway+ Cloudy.Table+ other-modules: Paths_cloudy+ autogen-modules: Paths_cloudy+ build-depends: base >= 4.17 && < 9999+ , aeson+ , bytestring+ , containers+ , deepseq+ , directory+ , file-embed+ , filepath+ , from-sum+ , http-api-data+ , http-client-tls+ , http-media+ , network+ , network-bsd+ , optparse-applicative+ , parsec+ , pretty-simple+ , process+ , random+ , servant+ , servant-client+ , servant-client-core+ , sqlite-simple+ , text+ , time+ , unix+ , uuid+ , yaml+ ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates+ default-extensions: DataKinds+ DeriveDataTypeable+ DeriveFunctor+ DeriveGeneric+ DerivingStrategies+ DuplicateRecordFields+ GeneralizedNewtypeDeriving+ InstanceSigs+ LambdaCase+ MultiParamTypeClasses+ NamedFieldPuns+ NumericUnderscores+ OverloadedLabels+ OverloadedStrings+ PolyKinds+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneKindSignatures+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ other-extensions: DeriveAnyClass+ OverloadedRecordDot+ QuasiQuotes+ TemplateHaskell+ UndecidableInstances++executable cloudy+ main-is: Main.hs+ hs-source-dirs: app+ build-depends: base+ , cloudy+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N++test-suite doctests+ type: exitcode-stdio-1.0+ main-is: DocTest.hs+ hs-source-dirs: test+ build-depends: base+ , doctest+ , QuickCheck+ , template-haskell+ , cloudy+ default-language: Haskell2010+ ghc-options: -Wall++test-suite cloudy-tests+ type: exitcode-stdio-1.0+ main-is: Test.hs+ hs-source-dirs: test+ other-modules: Test.Cloudy+ , Test.Cloudy.InstanceSetup+ build-depends: base+ , cloudy+ , tasty+ , tasty-hunit+ default-language: Haskell2010+ ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-N++source-repository head+ type: git+ location: git@github.com:cdepillabout/cloudy.git
+ default.nix view
@@ -0,0 +1,3 @@+{...}:++(import ./nix {}).cloudy-just-exe
+ instance-setups/hello-world-cloud-config.yaml view
@@ -0,0 +1,12 @@++short-description: A basic hello-world instance-setup that shows how to run a cloud-config script.++cloud-init-user-data: |+ #cloud-config++ packages:+ - cowsay++ runcmd:+ - |+ cowsay "hello world from Cloudy!" > /tmp/hello-from-cloudy
+ instance-setups/hello-world.yaml view
@@ -0,0 +1,7 @@++short-description: A basic hello-world instance-setup that shows how to run a bash script.++cloud-init-user-data: |+ #!/usr/bin/env bash++ echo "hello world from Cloudy!" > /tmp/hello-from-cloudy
+ nix/default.nix view
@@ -0,0 +1,23 @@++{...}:++let+ nixpkgs-src = builtins.fetchTarball {+ # nixpkgs-unstable as of 2024-08-04+ url = "https://github.com/NixOS/nixpkgs/archive/81610abc161d4021b29199aa464d6a1a521e0cc9.tar.gz";+ sha256 = "19j550srrsmsfzz0arfva1n13kjdz5yiz3x2ss3mgpaxacny7iad";++ # # nixos-24.05 as of 2024-07-08+ # url = "https://github.com/NixOS/nixpkgs/archive/49ee0e94463abada1de470c9c07bfc12b36dcf40.tar.gz";+ # sha256 = "142yikglqm22yzn4m6ccwkf55rqyrn94fr6qmf9dsmfcag8dbc2s";++ # nixos-23.11 as of 2024-07-08+ # url = "https://github.com/NixOS/nixpkgs/archive/7144d6241f02d171d25fba3edeaf15e0f2592105.tar.gz";+ # sha256 = "1lm7rkcbr7gg5zp62bga8iqyhg5hsvcly95hq0p3mcv7zq8n3wc2";+ };++ my-overlay = import ./overlay.nix;++in++import nixpkgs-src { overlays = [ my-overlay ]; }
+ nix/overlay.nix view
@@ -0,0 +1,142 @@+final: prev:++let+ mkCloudy = final: hfinal:+ let+ filesToIgnore = [+ ".git"+ ".github"+ ".stack-work"+ ".travis.yml"+ "cabal.project"+ "default.nix"+ "flake.lock"+ "flake.nix"+ "nix"+ "result"+ "shell.nix"+ "stack-nightly.yaml"+ "stack.yaml"+ ];++ src =+ builtins.path {+ name = "cloudy-src";+ path = ./..;+ filter = path: type:+ with final.lib;+ ! elem (baseNameOf path) filesToIgnore &&+ ! any (flip hasPrefix (baseNameOf path)) [ "dist" ".ghc" ];+ };++ extraCabal2nixOptions = "";+ in+ hfinal.callCabal2nixWithOptions "cloudy" src extraCabal2nixOptions {};+in+{+ ###############################+ ## Haskell package overrides ##+ ###############################++ cloudy-haskell =+ let+ myHaskellOverride = oldAttrs: {+ overrides =+ final.lib.composeExtensions+ (oldAttrs.overrides or (_: _: {}))+ (hfinal: hprev: {+ cloudy = mkCloudy final hfinal;+ });+ };+ in+ prev.haskell // {+ packages = prev.haskell.packages // {+ ${final.cloudy-ghc-version} =+ prev.haskell.packages.${final.cloudy-ghc-version}.override+ myHaskellOverride;++ native-bignum = prev.haskell.packages.native-bignum // {+ ${final.cloudy-static-ghc-version} =+ prev.haskell.packages.native-bignum.${final.cloudy-static-ghc-version}.override+ myHaskellOverride;+ };+ };+ };++ cloudy-ghc-version-short = "966";++ cloudy-ghc-version = "ghc" + final.cloudy-ghc-version-short;++ cloudy-haskell-pkg-set = final.cloudy-haskell.packages.${final.cloudy-ghc-version};++ cloudy = final.cloudy-haskell-pkg-set.cloudy;++ cloudy-just-exe =+ final.lib.pipe+ final.cloudy+ [+ ( final.haskell.lib.compose.overrideCabal (oldAttrs: {+ postInstall = ''+ export HOME=$TMPDIR+ '' + (oldAttrs.postInstall or "");+ })+ )+ (final.cloudy-haskell-pkg-set.generateOptparseApplicativeCompletions ["cloudy"])+ final.haskell.lib.justStaticExecutables+ ];++ cloudy-shell = final.cloudy-haskell-pkg-set.shellFor {+ packages = hpkgs: [ hpkgs.cloudy ];+ };++ my-haskell-language-server =+ final.haskell-language-server.override {+ supportedGhcVersions = [ final.cloudy-ghc-version-short ];+ };++ dev-shell = final.mkShell {+ nativeBuildInputs = [+ final.cabal-install+ final.my-haskell-language-server+ final.sqlite-interactive+ ];+ inputsFrom = [+ final.cloudy-shell+ ];+ # These environment variables are important. Without these,+ # doctest doesn't pick up nix's version of ghc, and will fail+ # claiming it can't find your dependencies+ shellHook = ''+ export NIX_GHC="${final.cloudy-shell.NIX_GHC}"+ export NIX_GHC_LIBDIR="${final.cloudy-shell.NIX_GHC_LIBDIR}"+ '';+ };++ ##############################+ ## Statically-linked builds ##+ ##############################++ # Static builds only work on ghc94, not ghc96+ :-(+ cloudy-static-ghc-version-short = "948";++ cloudy-static-ghc-version = "ghc" + final.cloudy-static-ghc-version-short;++ cloudy-static-haskell-pkg-set = final.pkgsStatic.cloudy-haskell.packages.native-bignum.${final.cloudy-static-ghc-version};++ cloudy-static = final.cloudy-static-haskell-pkg-set.cloudy;++ cloudy-static-just-exe =+ final.lib.pipe+ final.cloudy-static+ [+ ( final.haskell.lib.compose.overrideCabal (oldAttrs: {+ postInstall = ''+ export HOME=$TMPDIR+ '' + (oldAttrs.postInstall or "");+ })+ )+ (final.cloudy-static-haskell-pkg-set.generateOptparseApplicativeCompletions ["cloudy"])+ final.haskell.lib.justStaticExecutables+ ];+}+
+ shell.nix view
@@ -0,0 +1,3 @@+{...}:++(import ./nix {}).dev-shell
+ src/Cloudy.hs view
@@ -0,0 +1,11 @@+module Cloudy where++import Cloudy.Cli (parseCliOpts)+import Cloudy.Cmd (runCmd)+import Cloudy.LocalConfFile (readLocalConfFile)++defaultMain :: IO ()+defaultMain = do+ cmd <- parseCliOpts+ localConfFileOpts <- readLocalConfFile+ runCmd localConfFileOpts cmd
+ src/Cloudy/Cli.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Cloudy.Cli+ ( parseCliOpts+ , CliCmd(..)+ , ScalewayCliOpts(..)+ , AwsCliOpts(..)+ , ListCliOpts(..)+ , SshCliOpts(..)+ , CopyFileCliOpts(..)+ , DestroyCliOpts(..)+ , CopyFileDirection(..)+ , Recursive(..)+ )+ where++import Cloudy.Cli.Aws (AwsCliOpts(..), awsCliOptsParser)+import Cloudy.Cli.Scaleway (ScalewayCliOpts(..), scalewayCliOptsParser)+import Cloudy.Db (CloudyInstanceId (..), CloudyInstance (..), withCloudyDb, findAllCloudyInstances)+import Cloudy.InstanceSetup (getUserInstanceSetups)+import Cloudy.InstanceSetup.Types (InstanceSetup)+import Control.Applicative (Alternative(many), optional)+import Data.Int (Int64)+import Data.Text (Text, unpack)+import Data.Version (showVersion)+import Options.Applicative+ ( Alternative((<|>)), Parser, (<**>), command, fullDesc, header, info+ , progDesc, execParser, helper, footer, hsubparser, ParserInfo, strOption, long, short, metavar, help, option, auto, noIntersperse, forwardOptions, strArgument, footerDoc, flag', flag, completeWith, simpleVersioner )+import Options.Applicative.Help (vsep)+import Paths_cloudy (version)++data CliCmd+ = Aws AwsCliOpts+ | List ListCliOpts+ | Scaleway ScalewayCliOpts+ | Ssh SshCliOpts+ | CopyFile CopyFileCliOpts+ | Destroy DestroyCliOpts+ deriving stock Show++data ListCliOpts = ListCliOpts+ deriving stock Show++data SshCliOpts = SshCliOpts+ { id :: Maybe CloudyInstanceId+ , name :: Maybe Text+ , passthru :: [Text]+ }+ deriving stock Show++data CopyFileCliOpts = CopyFileCliOpts+ { id :: Maybe CloudyInstanceId+ , name :: Maybe Text+ , direction :: CopyFileDirection+ , recursive :: Recursive+ , filesToCopyArgs :: [Text]+ }+ deriving stock Show++data DestroyCliOpts = DestroyCliOpts+ { id :: Maybe CloudyInstanceId+ , name :: Maybe Text+ }+ deriving stock Show++-- | Which direction to copy files in the @copy-file@ command+data CopyFileDirection = FromInstanceToLocal | ToInstanceFromLocal+ deriving stock Show++-- | Whether or not to recursively copy files from directories in the+-- @copy-file@ command.+data Recursive = Recursive | NoRecursive+ deriving stock Show++parseCliOpts :: IO CliCmd+parseCliOpts = do+ userInstanceSetups <- getUserInstanceSetups+ activeCloudyInstances <- withCloudyDb findAllCloudyInstances+ execParser (cliCmdParserInfo activeCloudyInstances userInstanceSetups)++cliCmdParserInfo :: [CloudyInstance] -> [InstanceSetup] -> ParserInfo CliCmd+cliCmdParserInfo activeCloudyInstances userInstanceSetups =+ info+ ( cliCmdParser activeCloudyInstances userInstanceSetups <**>+ helper <**>+ simpleVersioner (showVersion version)+ )+ ( fullDesc <>+ -- progDesc "cloudy" <>+ header "cloudy - create, setup, and manage compute instances in various cloud environments"+ )++cliCmdParser :: [CloudyInstance] -> [InstanceSetup] -> Parser CliCmd+cliCmdParser activeCloudyInstances userInstanceSetups = hsubparser subParsers <|> list+ where+ subParsers =+ awsCommand <>+ scalewayCommand <>+ listCommand <>+ sshCommand <>+ copyFileCommand <>+ destroyCommand++ awsCommand =+ command+ "aws"+ ( info+ (fmap Aws awsCliOptsParser)+ (progDesc "Run AWS-specific commands")+ )++ scalewayCommand =+ command+ "scaleway"+ ( info+ (Scaleway <$> scalewayCliOptsParser userInstanceSetups)+ (progDesc "Run Scaleway-specific commands")+ )++ listCommand =+ command+ "list"+ ( info+ list+ (progDesc "List currently running compute instances")+ )++ sshCommand =+ command+ "ssh"+ ( info+ (Ssh <$> sshCliOptsParser activeCloudyInstances)+ ( progDesc "SSH to currently running compute instances" <>+ noIntersperse <>+ (footerDoc . Just $+ -- TODO: do this better+ vsep+ [ "This command internally executes SSH like the following:"+ , ""+ , " $ ssh root@12.34.9.9"+ , ""+ , "Any additional arguments specified to this function will be passed to SSH as-is. \+ \For instance, if you run the following command:"+ , ""+ , " $ cloudy ssh ls /"+ , ""+ , "then internally it will execute SSH like the following:"+ , ""+ , " $ ssh root@12.34.9.9 ls /"+ , ""+ , "Note that if you want to pass an option to SSH that matches \+ \an option understood by Cloudy, use \"--\" to separate arguments. \+ \For instance, if you run the following command:"+ , ""+ , " $ cloudy ssh -i pumpkin-dog -- -i ~/.ssh/my_id_rsa"+ , ""+ , "Cloudy will internally execute the following SSH command against the \+ \instance named \"pumpkin-dog\":"+ , ""+ , " $ ssh root@12.34.9.9 -i ~/.ssh/my_id_rsa"+ , ""+ , "SSH also understands the \"--\" argument, so you may need to \+ \combine these depending on what you're trying to do:"+ , ""+ , " $ cloudy ssh -i pumpkin-dog -- -i ~/.ssh/my_id_rsa -- ls -i /"+ ]+ )+ )+ )++ copyFileCommand =+ command+ "copy-file"+ ( info+ (CopyFile <$> copyFileCliOptsParser activeCloudyInstances)+ ( progDesc "Copy files to/from currently running compute instances" <>+ forwardOptions <>+ (footerDoc . Just $+ -- TODO: do this better+ vsep+ [ "Here's an example of using this command to copy files from \+ \the cloud instance to your local machine:"+ , ""+ , " $ cloudy copy-file -i pumpkin-dog --from-instance my-file-remote1 my-file-remote2 ./my-dir-local/"+ , ""+ , "This internally uses SCP to copy files, running a command \+ \like the following:"+ , ""+ , " $ scp root@12.34.9.9:my-file-remote1 root@12.34.9.9:my-file-remote2 ./my-dir-local/"+ , ""+ , "Cloudy will prepend the correct username and IP address to \+ \all the remote files. Note that this uses SCP's normal \+ \rules for paths, so relative paths will be relative to \+ \the user's HOME directory. For instance, in the above \+ \command, \"my-file-remote1\" and \"my-file-remote2\" are \+ \expected to live in the root user's HOME directory (/root)."+ , ""+ , "Here's an example of using this command to copy files from \+ \your local machine to the cloud instance:"+ , ""+ , " $ cloudy copy-file -i pumpkin-dog --to-instance --recursive my-file-local my-dir-local/ my-dir-remote/"+ , ""+ , "This internally runs a command like the following:"+ , ""+ , " $ scp -r my-file-local my-dir-local/ root@12.34.9.9:my-dir-remote/"+ ]+ )+ )+ )++ destroyCommand =+ command+ "destroy"+ ( info+ (Destroy <$> destroyCliOptsParser activeCloudyInstances)+ ( progDesc "Destroy currently running compute instance" <>+ footer+ "If neither a CLOUDY_INSTANCE_ID nor a CLOUDY_INSTANCE_NAME is \+ \specified, AND there is only a single active Cloudy Instance, \+ \it will be used. Otherwise, you must specify either \+ \CLOUDY_INSTANCE_ID or CLOUDY_INSTANCE_NAME, but not both. \+ \Use `cloudy list` to get a list of all active instances ids \+ \and names."+ )+ )++ list = fmap List listCliOptsParser++listCliOptsParser :: Parser ListCliOpts+listCliOptsParser = pure ListCliOpts++sshCliOptsParser :: [CloudyInstance] -> Parser SshCliOpts+sshCliOptsParser activeCloudyInstances =+ SshCliOpts+ <$> cloudyInstanceIdParser activeCloudyInstances+ <*> cloudyInstanceNameParser activeCloudyInstances+ <*> passthruArgs++copyFileCliOptsParser :: [CloudyInstance] -> Parser CopyFileCliOpts+copyFileCliOptsParser activeCloudyInstances =+ CopyFileCliOpts+ <$> cloudyInstanceIdParser activeCloudyInstances+ <*> cloudyInstanceNameParser activeCloudyInstances+ <*> directionParser+ <*> recursiveParser+ <*> copyFilesParser++destroyCliOptsParser :: [CloudyInstance] -> Parser DestroyCliOpts+destroyCliOptsParser activeCloudyInstances =+ DestroyCliOpts+ <$> cloudyInstanceIdParser activeCloudyInstances+ <*> cloudyInstanceNameParser activeCloudyInstances++cloudyInstanceIdParser :: [CloudyInstance] -> Parser (Maybe CloudyInstanceId)+cloudyInstanceIdParser activeCloudyInstances = fmap CloudyInstanceId <$> innerParser+ where+ innerParser :: Parser (Maybe Int64)+ innerParser =+ optional $+ option+ auto+ ( long "id" <>+ short 'i' <>+ metavar "CLOUDY_INSTANCE_ID" <>+ help "Cloudy instance ID to operate on." <>+ completeWith (fmap (\inst -> show $ unCloudyInstanceId inst.id) activeCloudyInstances)+ )++cloudyInstanceNameParser :: [CloudyInstance] -> Parser (Maybe Text)+cloudyInstanceNameParser activeCloudyInstances =+ optional $+ strOption+ ( long "name" <>+ short 'n' <>+ metavar "CLOUDY_INSTANCE_NAME" <>+ help "Cloudy instance name to operate on." <>+ completeWith (fmap (\inst -> unpack inst.name) activeCloudyInstances)+ )++-- | Parser for arguments that are not really parsed, just passed through.+--+-- Used to pass through arguments to SSH.+passthruArgs :: Parser [Text]+passthruArgs =+ many $+ strArgument+ ( metavar "SSH_ARG..." <>+ help "Arguments to passthru to SSH"+ )++-- | Parser for file names for the copy-files command.+copyFilesParser :: Parser [Text]+copyFilesParser =+ many $+ strArgument+ ( metavar "FILE..." <>+ help "File names to copy to/from"+ )++directionParser :: Parser CopyFileDirection+directionParser =+ let fromInstanceFlag =+ flag'+ FromInstanceToLocal+ ( long "from-instance" <>+ short 'f' <>+ help "Copy files FROM CLOUD INSTANCE to your local machine"+ )+ toInstanceFlag =+ flag'+ ToInstanceFromLocal+ ( long "to-instance" <>+ short 't' <>+ help "Copy files from your local machine TO CLOUD INSTANCE"+ )+ in fromInstanceFlag <|> toInstanceFlag++recursiveParser :: Parser Recursive+recursiveParser =+ flag+ NoRecursive+ Recursive+ ( long "recursive" <>+ short 'r' <>+ help "Recursively copy entire directories"+ )
+ src/Cloudy/Cli/Aws.hs view
@@ -0,0 +1,42 @@++module Cloudy.Cli.Aws where++import Options.Applicative (Parser, command, info, progDesc, hsubparser)++data AwsCliOpts+ = AwsCreate AwsCreateCliOpts+ | AwsListInstanceTypes AwsListInstanceTypesCliOpts+ deriving stock Show++data AwsCreateCliOpts = AwsCreateCliOpts+ deriving stock Show++data AwsListInstanceTypesCliOpts = AwsListInstanceTypesCliOpts+ deriving stock Show++awsCliOptsParser :: Parser AwsCliOpts+awsCliOptsParser = hsubparser subParsers+ where+ subParsers = createCommand <> listInstanceTypesCommand++ createCommand =+ command+ "create"+ ( info+ (fmap AwsCreate awsCreateCliOptsParser)+ (progDesc "Create a new compute instance in AWS")+ )++ listInstanceTypesCommand =+ command+ "list-instance-types"+ ( info+ (fmap AwsListInstanceTypes awsListInstanceTypesCliOptsParser)+ (progDesc "List all instance types in AWS")+ )++awsCreateCliOptsParser :: Parser AwsCreateCliOpts+awsCreateCliOptsParser = pure AwsCreateCliOpts++awsListInstanceTypesCliOptsParser :: Parser AwsListInstanceTypesCliOpts+awsListInstanceTypesCliOptsParser = pure AwsListInstanceTypesCliOpts
+ src/Cloudy/Cli/Scaleway.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Cloudy.Cli.Scaleway where++import Cloudy.Cli.Utils (maybeOpt)+import Cloudy.InstanceSetup (builtInInstanceSetups)+import Cloudy.InstanceSetup.Types (InstanceSetup (..), InstanceSetupData (..))+import Control.Applicative (optional)+import Data.Text (Text, unpack)+import Options.Applicative (Parser, command, info, progDesc, hsubparser, strOption, long, short, metavar, option, help, value, showDefault, maybeReader, switch, auto, footerDoc, completeWith)+import Options.Applicative.Help (vsep, Doc)+import Data.String (IsString(fromString))+import Cloudy.Scaleway (allScalewayZones, zoneToText)++data ScalewayCliOpts+ = ScalewayCreate ScalewayCreateCliOpts+ | ScalewayListInstanceTypes ScalewayListInstanceTypesCliOpts+ | ScalewayListImages ScalewayListImagesCliOpts+ deriving stock Show++data ScalewayCreateCliOpts = ScalewayCreateCliOpts+ { zone :: Maybe Text+ , instanceType :: Maybe Text+ , volumeSizeGb :: Int+ , imageId :: Maybe Text+ , instanceSetup :: Maybe Text+ }+ deriving stock Show++data ScalewayListInstanceTypesCliOpts = ScalewayListInstanceTypesCliOpts+ { zone :: Maybe Text+ }+ deriving stock Show++data ScalewayListImagesCliOpts = ScalewayListImagesCliOpts+ { zone :: Maybe Text+ , arch :: Text+ , nameFilter :: Maybe Text+ , allVersions :: Bool+ }+ deriving stock Show++scalewayCliOptsParser :: [InstanceSetup] -> Parser ScalewayCliOpts+scalewayCliOptsParser userInstanceSetups = hsubparser subParsers+ where+ subParsers = createCommand <> listInstanceTypesCommand <> listImagesCommand++ createCommand =+ command+ "create"+ ( info+ (ScalewayCreate <$> scalewayCreateCliOptsParser userInstanceSetups)+ ( progDesc "Create a new compute instance in Scaleway" <>+ (footerDoc . Just $+ -- TODO: do this better+ vsep+ ( [ "You can use the --instance-setup option to configure which \+ \instance setup script is used to setup the instance after \+ \boot. The instance setup scripts generally have a \+ \`cloud-init` section, which specifies the actual cloud-init \+ \setup to use."+ , ""+ , "Default instance-setup scripts builtin to Cloudy:"+ , ""+ ] <>+ fmap instanceSetupToDoc builtInInstanceSetups <>+ [ ""+ , "User-defined instance-setup scripts in ~/.config/cloudy/instance-setups/:"+ , ""+ ] <>+ case userInstanceSetups of+ [] -> ["(none exist)"]+ _ -> fmap instanceSetupToDoc userInstanceSetups+ )+ )+ )+ )++ listInstanceTypesCommand =+ command+ "list-instance-types"+ ( info+ (fmap ScalewayListInstanceTypes scalewayListInstanceTypesCliOptsParser)+ (progDesc "List all instance types in Scaleway")+ )++ listImagesCommand =+ command+ "list-images"+ ( info+ (fmap ScalewayListImages scalewayListImagesCliOptsParser)+ (progDesc "List available images in Scaleway")+ )++instanceSetupToDoc :: InstanceSetup -> Doc+instanceSetupToDoc instanceSetup =+ " - " <> fromString (unpack instanceSetup.name) <>+ " -- " <> fromString (unpack instanceSetup.instanceSetupData.shortDescription)++scalewayCreateCliOptsParser :: [InstanceSetup] -> Parser ScalewayCreateCliOpts+scalewayCreateCliOptsParser userInstanceSetups =+ ScalewayCreateCliOpts+ <$> zoneParser+ <*> instanceTypeParser+ <*> volumeSizeGbParser+ <*> imageIdParser+ <*> instanceSetupParser userInstanceSetups++scalewayListInstanceTypesCliOptsParser :: Parser ScalewayListInstanceTypesCliOpts+scalewayListInstanceTypesCliOptsParser = ScalewayListInstanceTypesCliOpts <$> zoneParser++scalewayListImagesCliOptsParser :: Parser ScalewayListImagesCliOpts+scalewayListImagesCliOptsParser =+ ScalewayListImagesCliOpts+ <$> zoneParser+ <*> archParser+ <*> nameFilterParser+ <*> allVersionsParser++zoneParser :: Parser (Maybe Text)+zoneParser =+ maybeOpt+ "Scaleway zone in which to create the new instance"+ "nl-ams-1"+ strOption+ ( long "zone" <>+ short 'z' <>+ metavar "ZONE" <>+ completeWith (unpack . zoneToText <$> allScalewayZones)+ )++instanceTypeParser :: Parser (Maybe Text)+instanceTypeParser =+ maybeOpt+ "Scaleway instance type (use `cloudy scaleway list-instance-types` command to get list of all instance types)"+ "PLAY2-NANO"+ strOption+ ( long "instance-type" <>+ short 'c' <>+ metavar "INSTANCE_TYPE"+ )++archParser :: Parser Text+archParser =+ option+ (maybeReader archReader)+ ( long "arch" <>+ short 'a' <>+ metavar "ARCH" <>+ help "Architecture of image. Possiblities: \"x86_64\", \"arm\", or \"arm64\"" <>+ value "x86_64" <>+ showDefault <>+ completeWith ["x86_64", "arm", "arm64"]+ )+ where+ archReader :: String -> Maybe Text+ archReader = \case+ "x86_64" -> Just "x86_64"+ "arm" -> Just "arm"+ "arm64" -> Just "arm64"+ _ -> Nothing++nameFilterParser :: Parser (Maybe Text)+nameFilterParser =+ optional $+ strOption+ ( long "name-filter" <>+ short 'n' <>+ metavar "NAME_FILTER" <>+ help "Only show images whose name contains this value, case-insensitive (default: no filter)"+ )++allVersionsParser :: Parser Bool+allVersionsParser =+ switch+ ( long "all-versions" <>+ short 'a' <>+ help "List all versions of each image. By default, only show the latest version for each image name."+ )++volumeSizeGbParser :: Parser Int+volumeSizeGbParser =+ option+ auto+ ( long "volume-size" <>+ short 's' <>+ metavar "VOLUME_SIZE" <>+ help "Size of the root volume in GBs" <>+ value 50 <>+ showDefault+ )++imageIdParser :: Parser (Maybe Text)+imageIdParser =+ maybeOpt+ "Scaleway image ID (use `cloudy scaleway list-images` command to get list of possible image IDs). Also can be image label, like \"ubuntu_noble\" (TODO: implement market api to return list of possible labels)"+ "ubuntu_noble"+ strOption+ ( long "image-id" <>+ short 'i' <>+ metavar "IMAGE_ID"+ )++instanceSetupParser :: [InstanceSetup] -> Parser (Maybe Text)+instanceSetupParser userInstanceSetups =+ optional $+ strOption+ ( long "instance-setup" <>+ short 't' <>+ metavar "INSTANCE_SETUP" <>+ help "Name of the instance-setup to use when booting the image. (default: do no instance setup)" <>+ completeWith+ (fmap (\instSetup -> unpack instSetup.name) (userInstanceSetups <> builtInInstanceSetups))+ )
+ src/Cloudy/Cli/Utils.hs view
@@ -0,0 +1,32 @@++module Cloudy.Cli.Utils where++import Control.Applicative (optional)+import Options.Applicative (Parser, help, Mod)++-- | This lifts a option 'Parser' to a 'Parser' of 'Maybe', allowing you to+-- specify a default value.+--+-- Given a call like:+--+-- @+-- 'maybeOpt' \"Which foobar to use\" \"bazqux\" 'strOption' ('short' \'f\' <> 'metavar' \"FOOBAR\") :: 'Parser' (Maybe 'Text')+-- @+--+-- this returns 'Nothing' if the user doesn't specify the @-f@ option, and+-- 'Just' if the user does. It also shows that the default values is @\"bazqux\"@.+--+-- Using 'maybeOpt' is different than just using the 'value' 'Mod' in order to+-- set a default value, since 'maybeOpt' returns 'Nothing' if the option was+-- not given on the command line (but it still shows the default value in the+-- @--help@ output.+maybeOpt ::+ Show a =>+ String ->+ a ->+ (Mod f a -> Parser a) ->+ Mod f a ->+ Parser (Maybe a)+maybeOpt helpStr defaultVal p mods = optional (p $ mods <> help helpWithDefaultStr)+ where+ helpWithDefaultStr = helpStr <> " (default: " <> show defaultVal <> ")"
+ src/Cloudy/Cmd.hs view
@@ -0,0 +1,20 @@++module Cloudy.Cmd where++import Cloudy.Cli (CliCmd (..))+import Cloudy.Cmd.Aws (runAws)+import Cloudy.Cmd.CopyFile (runCopyFile)+import Cloudy.Cmd.List (runList)+import Cloudy.Cmd.Scaleway (runScaleway)+import Cloudy.Cmd.Ssh (runSsh)+import Cloudy.Cmd.Destroy (runDestroy)+import Cloudy.LocalConfFile (LocalConfFileOpts)++runCmd :: LocalConfFileOpts -> CliCmd -> IO ()+runCmd localConfFileOpts = \case+ Aws awsCliOpts -> runAws localConfFileOpts awsCliOpts+ List listCliOpts -> runList localConfFileOpts listCliOpts+ Scaleway scalewayCliOpts -> runScaleway localConfFileOpts scalewayCliOpts+ Ssh sshCliOpts -> runSsh localConfFileOpts sshCliOpts+ CopyFile copyFileCliOpts -> runCopyFile localConfFileOpts copyFileCliOpts+ Destroy destroyCliOpts -> runDestroy localConfFileOpts destroyCliOpts
+ src/Cloudy/Cmd/Aws.hs view
@@ -0,0 +1,17 @@++module Cloudy.Cmd.Aws where++import Cloudy.LocalConfFile (LocalConfFileOpts)+import Cloudy.Cli (AwsCliOpts (..))+import Cloudy.Cli.Aws (AwsCreateCliOpts (..), AwsListInstanceTypesCliOpts (..))++runAws :: LocalConfFileOpts -> AwsCliOpts -> IO ()+runAws localConfFileOpts = \case+ AwsCreate awsCreateCliOpts -> runAwsCreate localConfFileOpts awsCreateCliOpts+ AwsListInstanceTypes awsListInstanceTypesCliOpts -> runAwsListInstanceTypes localConfFileOpts awsListInstanceTypesCliOpts++runAwsCreate :: LocalConfFileOpts -> AwsCreateCliOpts -> IO ()+runAwsCreate _localConfFileOpts _createCliOpts = undefined++runAwsListInstanceTypes :: LocalConfFileOpts -> AwsListInstanceTypesCliOpts -> IO ()+runAwsListInstanceTypes _localConfFileOpts _listInstanceTypesCliOpts = undefined
+ src/Cloudy/Cmd/CopyFile.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Cloudy.Cmd.CopyFile where++import Cloudy.Cli (CopyFileCliOpts (..), CopyFileDirection (..), Recursive (..))+import Cloudy.Cmd.Utils (SelectInstBy, findInstanceInfoForSelectInstBy, mkSelectInstBy)+import Cloudy.LocalConfFile (LocalConfFileOpts (..))+import Cloudy.Db (withCloudyDb, InstanceInfo (..), ScalewayInstance (..))+import Data.Text (unpack, Text)+import Data.Void (absurd)+import System.Posix.Process (executeFile)+import Control.Monad (when)+import Control.FromSum (fromMaybeM)++data CopyFileSettings = CopyFileSettings+ { selectInstBy :: SelectInstBy+ , direction :: CopyFileDirection+ , recursive :: Recursive+ , filesToCopyArgs :: [Text]+ }+ deriving stock Show++mkSettings :: LocalConfFileOpts -> CopyFileCliOpts -> IO CopyFileSettings+mkSettings _localConfFileOpts cliOpts = do+ selectInstBy <- mkSelectInstBy cliOpts.id cliOpts.name+ pure+ CopyFileSettings+ { selectInstBy+ , direction = cliOpts.direction+ , recursive = cliOpts.recursive+ , filesToCopyArgs = cliOpts.filesToCopyArgs+ }++runCopyFile :: LocalConfFileOpts -> CopyFileCliOpts -> IO ()+runCopyFile localConfFileOpts cliOpts = do+ settings <- mkSettings localConfFileOpts cliOpts+ ipAddr <- withCloudyDb $ \conn -> do+ instanceInfo <- findInstanceInfoForSelectInstBy conn settings.selectInstBy+ case instanceInfo of+ CloudyAwsInstance _cloudyInstance void -> absurd void+ CloudyScalewayInstance _cloudyInstance scalewayInstance -> pure scalewayInstance.scalewayIpAddress+ when (length settings.filesToCopyArgs <= 1) $+ error "ERROR: must pass at least 2 files"+ (firstFiles, lastFile) <-+ fromMaybeM+ (error "ERROR: unsnoc should have succeeded since we check there are at least 2 files")+ (unsnoc settings.filesToCopyArgs)+ let recursiveArg =+ case settings.recursive of+ Recursive -> ["-r"]+ NoRecursive -> []+ scpFilesArgs =+ case settings.direction of+ FromInstanceToLocal ->+ fmap (\file -> "root@" <> ipAddr <> ":" <> file) firstFiles <>+ [lastFile]+ ToInstanceFromLocal -> firstFiles <> ["root@" <> ipAddr <> ":" <> lastFile]+ scpArgs =+ fmap unpack $ recursiveArg <> scpFilesArgs+ putStrLn $ "About to run scp command: " <> show ("scp" : scpArgs)+ executeFile "scp" True scpArgs Nothing++-- TODO: Available from Data.List in GHC-9.8+unsnoc :: [a] -> Maybe ([a], a)+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
+ src/Cloudy/Cmd/Destroy.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Cloudy.Cmd.Destroy where++import Cloudy.Cli (DestroyCliOpts (..))+import Cloudy.Cmd.Utils (SelectInstBy, findInstanceInfoForSelectInstBy, mkSelectInstBy)+import Cloudy.LocalConfFile (LocalConfFileOpts (..), LocalConfFileScalewayOpts (..))+import Cloudy.Db (CloudyInstance (..), withCloudyDb, InstanceInfo (..), ScalewayInstance (..), setCloudyInstanceDeleted, cloudyInstanceFromInstanceInfo)+import Data.Text (Text, unpack)+import Data.Void (absurd)+import Servant.Client (ClientM)+import Servant.API (NoContent(..))+import Cloudy.Cmd.Scaleway.Utils (runScalewayClientM, createAuthReq)+import Cloudy.Scaleway (ipsDeleteApi, zoneFromText, ServersActionReq (..), serversActionPostApi)+import qualified Cloudy.Scaleway as Scaleway+import Control.FromSum (fromMaybeM)+import Control.Monad.IO.Class (liftIO)++data DestroySettings = DestroySettings+ { selectInstBy :: SelectInstBy+ }+ deriving stock Show++data ScalewayDestroySettings = ScalewayDestroySettings+ { secretKey :: Text+ }+ deriving stock Show++mkSettings :: LocalConfFileOpts -> DestroyCliOpts -> IO DestroySettings+mkSettings _localConfFileOpts cliOpts = do+ selectInstBy <- mkSelectInstBy cliOpts.id cliOpts.name+ pure DestroySettings { selectInstBy }++mkScalewaySettings :: LocalConfFileOpts -> IO ScalewayDestroySettings+mkScalewaySettings localConfFileOpts = do+ let maybeSecretKey = localConfFileOpts.scaleway >>= \scale -> scale.secretKey :: Maybe Text+ secretKey <- getVal maybeSecretKey "Could not find scaleway.secret_key in config file"+ pure ScalewayDestroySettings { secretKey }+ where+ getVal :: Maybe a -> String -> IO a+ getVal mayVal errMsg = maybe (error errMsg) pure mayVal++runDestroy :: LocalConfFileOpts -> DestroyCliOpts -> IO ()+runDestroy localConfFileOpts scalewayOpts = do+ settings <- mkSettings localConfFileOpts scalewayOpts+ withCloudyDb $ \conn -> do+ instanceInfo <- findInstanceInfoForSelectInstBy conn settings.selectInstBy+ case instanceInfo of+ CloudyAwsInstance _cloudyInstance void -> absurd void+ CloudyScalewayInstance _cloudyInstance scalewayInstance -> do+ scalewaySettings <- mkScalewaySettings localConfFileOpts+ runScalewayClientM+ (\err -> error $ "ERROR! Problem deleting instance: " <> show err)+ (destroyScalewayServer settings scalewaySettings scalewayInstance)+ let cloudyInstanceId = (cloudyInstanceFromInstanceInfo instanceInfo).id+ setCloudyInstanceDeleted conn cloudyInstanceId++destroyScalewayServer ::+ DestroySettings ->+ ScalewayDestroySettings ->+ ScalewayInstance ->+ ClientM ()+destroyScalewayServer _settings scalewaySettings scalewayInstance = do+ let authReq = createAuthReq scalewaySettings.secretKey+ ipId = Scaleway.IpId scalewayInstance.scalewayIpId+ zoneErrMsg =+ "destroyScalewayServer: Could not figure out Scaleway zone from string: " <>+ scalewayInstance.scalewayZone+ zone <-+ fromMaybeM+ (error $ unpack zoneErrMsg)+ (zoneFromText scalewayInstance.scalewayZone)+ NoContent <- ipsDeleteApi authReq zone ipId+ liftIO . putStrLn . unpack $ "Successfully deleted Scaleway IP: " <> scalewayInstance.scalewayIpAddress+ let act = ServersActionReq { action = "terminate" }+ scalewayInstId = Scaleway.ServerId scalewayInstance.scalewayInstanceId+ _task <- serversActionPostApi authReq zone scalewayInstId act+ liftIO . putStrLn . unpack $ "Successfully deleted Scaleway server: " <> scalewayInstance.scalewayInstanceId
+ src/Cloudy/Cmd/List.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Cloudy.Cmd.List where++import Cloudy.Cli (ListCliOpts (..))+import Cloudy.Db (CloudyInstance (..), InstanceInfo (..), ScalewayInstance (..), cloudyInstanceFromInstanceInfo, findAllInstanceInfos, withCloudyDb, unCloudyInstanceId)+import Cloudy.InstanceSetup.Types (InstanceSetup (..))+import Cloudy.LocalConfFile (LocalConfFileOpts)+import Cloudy.Table (Table (..), printTable, Align (..))+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text, pack)+import Data.Time (defaultTimeLocale, formatTime, UTCTime, utcToZonedTime, TimeZone, getCurrentTimeZone)+import Data.Void (absurd)++runList :: LocalConfFileOpts -> ListCliOpts -> IO ()+runList _localConfFileOpts _opts = do+ instInfos <- withCloudyDb $ \conn -> findAllInstanceInfos conn+ displayInstanceInfos instInfos++displayInstanceInfos :: [InstanceInfo] -> IO ()+displayInstanceInfos instInfos = do+ tz <- getCurrentTimeZone+ let sortByCloudyInstId = sortOn (\instInfo -> (cloudyInstanceFromInstanceInfo instInfo).id) instInfos+ case sortByCloudyInstId of+ [] -> putStrLn "No instances currently running."+ (hInst : tInsts) -> do+ let instTable = mkTable tz (hInst :| tInsts)+ printTable instTable++mkTable :: TimeZone -> NonEmpty InstanceInfo -> Table+mkTable tz instanceTypes =+ Table+ { tableHeaders =+ (RightJustified, "instance id") :|+ [ (LeftJustified, "instance name")+ , (LeftJustified, "created date")+ , (LeftJustified, "cloud")+ , (LeftJustified, "zone")+ , (LeftJustified, "ip")+ , (LeftJustified, "instance setup")+ ]+ , tableBodyRows = fmap (mkRow tz) instanceTypes+ }++mkRow :: TimeZone -> InstanceInfo -> NonEmpty Text+mkRow tz = \case+ CloudyAwsInstance _ void -> absurd void+ CloudyScalewayInstance cloudyInstance scalewayInstance ->+ pack (show (unCloudyInstanceId cloudyInstance.id)) :|+ [ cloudyInstance.name+ , formatDateTime cloudyInstance.createdAt+ , "scaleway"+ , scalewayInstance.scalewayZone+ , scalewayInstance.scalewayIpAddress+ , prettyInstanceSetup cloudyInstance.instanceSetup+ ]+ where+ formatDateTime :: Maybe UTCTime -> Text+ formatDateTime = \case+ Nothing -> "ERROR: expecting cloudy instance to have created_at value"+ Just createdAt ->+ pack $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M" $ utcToZonedTime tz createdAt++ prettyInstanceSetup :: Maybe InstanceSetup -> Text+ prettyInstanceSetup = \case+ Nothing -> "(none)"+ Just instSetup -> instSetup.name
+ src/Cloudy/Cmd/Scaleway.hs view
@@ -0,0 +1,14 @@++module Cloudy.Cmd.Scaleway where++import Cloudy.Cli (ScalewayCliOpts (..))+import Cloudy.Cmd.Scaleway.Create (runCreate)+import Cloudy.Cmd.Scaleway.ListImages (runListImages)+import Cloudy.Cmd.Scaleway.ListInstanceTypes (runListInstanceTypes)+import Cloudy.LocalConfFile (LocalConfFileOpts)++runScaleway :: LocalConfFileOpts -> ScalewayCliOpts -> IO ()+runScaleway localConfFileOpts = \case+ ScalewayCreate scalewayCreateCliOpts -> runCreate localConfFileOpts scalewayCreateCliOpts+ ScalewayListImages scalewayListImagesCliOpts -> runListImages localConfFileOpts scalewayListImagesCliOpts+ ScalewayListInstanceTypes scalewayListInstanceTypesCliOpts -> runListInstanceTypes localConfFileOpts scalewayListInstanceTypesCliOpts
+ src/Cloudy/Cmd/Scaleway/Create.hs view
@@ -0,0 +1,437 @@+{-# 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+ { secretKey :: Text+ , projectId :: ProjectId+ , zone :: Zone+ , instanceType :: Text+ , volumeSizeGb :: Int+ , imageId :: Text+ , instanceSetup :: Maybe InstanceSetup+ }++mkSettings :: LocalConfFileOpts -> ScalewayCreateCliOpts -> IO ScalewayCreateSettings+mkSettings localConfFileOpts cliOpts = do+ let maybeSecretKey = localConfFileOpts.scaleway >>= \scale -> scale.secretKey :: Maybe Text+ secretKey <- getVal maybeSecretKey "Could not find scaleway.secret_key in config file"+ let maybeProjectId = localConfFileOpts.scaleway >>= \scale -> fmap ProjectId scale.defaultProjectId+ projectId <- getVal maybeProjectId "Could not find scaleway.default_project_id in config file"+ let maybeZoneFromConfFile = localConfFileOpts.scaleway >>= \scale -> scale.defaultZone+ zone <- getZone maybeZoneFromConfFile cliOpts.zone+ let maybeInstanceTypeFromConfFile = localConfFileOpts.scaleway >>= \scale -> scale.defaultInstanceType+ instanceType = getInstanceType maybeInstanceTypeFromConfFile cliOpts.instanceType+ let maybeImageIdFromConfFile = localConfFileOpts.scaleway >>= \scale -> scale.defaultImageId+ imageId = getImageId maybeImageIdFromConfFile cliOpts.imageId+ instanceSetup <- getInstanceSetup cliOpts.instanceSetup+ pure+ ScalewayCreateSettings+ { secretKey+ , projectId+ , zone+ , instanceType+ , volumeSizeGb = cliOpts.volumeSizeGb+ , imageId+ , instanceSetup+ }+ where+ getVal :: Maybe a -> String -> IO a+ getVal mayVal errMsg = maybe (error errMsg) pure mayVal++ getInstanceSetup :: Maybe Text -> IO (Maybe InstanceSetup)+ getInstanceSetup = \case+ -- No instance setup specified as a CLI option. Don't use one.+ Nothing -> pure Nothing+ Just instSetupName -> do+ maybeInstSetup <- findInstanceSetup instSetupName+ case 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.+ Nothing -> error $ "Couldn't find instance setup: \"" <> unpack instSetupName <> "\""+ Just instSetup -> pure $ Just instSetup++runCreate :: LocalConfFileOpts -> ScalewayCreateCliOpts -> IO ()+runCreate localConfFileOpts scalewayOpts = do+ settings <- mkSettings localConfFileOpts scalewayOpts+ withCloudyDb $ \conn -> do+ (cloudyInstanceId, instanceName) <- newCloudyInstance conn+ currentTime <- getCurrentTime+ (scalewayServerId, scalewayIpId, scalewayIpAddr) <- runScalewayClientM+ (\err -> error $ "ERROR! Problem creating instance: " <> show err)+ (createScalewayServer settings instanceName)+ newScalewayInstance+ conn+ currentTime+ cloudyInstanceId+ settings.instanceSetup+ (zoneToText settings.zone)+ (unServerId scalewayServerId)+ (unIpId scalewayIpId)+ scalewayIpAddr+ putStrLn "Waiting for Scaleway instance to become available..."+ runScalewayClientM+ (\err -> error $ "ERROR! Problem waiting for instance to be ready: " <> show err)+ (waitForScalewayServer settings scalewayServerId)+ putStrLn "Scaleway instance now available."+ putStrLn "Waiting for SSH to be ready on the instance..."+ waitForSshPort scalewayIpAddr+ putStrLn "SSH now available on the instance."+ putStrLn "Getting instance SSH key fingerprints from Scaleway metadata API..."+ rawSshKeyFingerprintsFromScalewayApi <- runScalewayClientM+ (\err -> error $ "ERROR! Problem getting instance SSH key fingerprints: " <> show err)+ (getSshKeyFingerprints settings scalewayServerId)+ putStrLn "Got instance SSH key fingerprints."+ updateSshHostKeys rawSshKeyFingerprintsFromScalewayApi scalewayIpAddr++createScalewayServer :: ScalewayCreateSettings -> Text -> ClientM (ServerId, IpId, Text)+createScalewayServer settings instanceName = do+ let authReq = createAuthReq settings.secretKey+ ipsResp <- ipsPostApi authReq settings.zone (IpsReq "routed_ipv4" settings.projectId)+ liftIO $ putStrLn $ "ips resp: " <> show ipsResp+ let serversReq =+ ServersReq+ { bootType = "local"+ , commercialType = settings.instanceType+ , image = ImageId settings.imageId+ , name = "cloudy-" <> instanceName+ , publicIps = [ipsResp.id]+ , tags = ["cloudy"]+ , volumes =+ Map.fromList+ [ ( "0"+ , ServersReqVolume+ { size = settings.volumeSizeGb * oneGb+ , volumeType = "b_ssd"+ }+ )+ ]+ , project = settings.projectId+ }+ serversResp <- serversPostApi authReq settings.zone serversReq+ liftIO $ putStrLn $ "servers resp: " <> show serversResp+ let maybeFirstVol = Map.lookup "0" serversResp.volumes+ firstVol <- maybe (error "couldn't find first volume, unexpected") pure maybeFirstVol+ -- The volume's name has to initially be created as empty (""), and only+ -- after that can we set the name separately.+ serversVolumesResp <-+ volumesPatchApi+ authReq+ settings.zone+ firstVol.id+ (VolumesReq $ "cloudy-" <> instanceName <> "-boot-block-volume")+ liftIO $ putStrLn $ "servers volumes resp: " <> show serversVolumesResp+ case settings.instanceSetup of+ -- No instanceSetup user data, do nothing.+ Nothing -> pure ()+ Just instanceSetup -> do+ NoContent <-+ serversUserDataPatchApi+ authReq+ settings.zone+ serversResp.id+ (UserDataKey "cloud-init")+ (UserData instanceSetup.instanceSetupData.cloudInitUserData)+ liftIO $ putStrLn "created user data"+ let act = ServersActionReq { action = "poweron" }+ task <- serversActionPostApi authReq settings.zone serversResp.id act+ liftIO $ print task+ pure (serversResp.id, ipsResp.id, ipsResp.address)++oneGb :: Int+oneGb = 1000 * 1000 * 1000++waitForScalewayServer :: ScalewayCreateSettings -> ServerId -> ClientM ()+waitForScalewayServer settings serverId = do+ let authReq = createAuthReq settings.secretKey+ serversResp <- serversGetApi authReq settings.zone serverId+ when (serversResp.state /= "running") $ waitForScalewayServer settings serverId++-- | Wait for port 22 to be available on the remote machine.+waitForSshPort :: Text -> IO ()+waitForSshPort ipaddrText = do+ let hints = defaultHints { addrSocketType = Stream }+ addrInfos <- getAddrInfo (Just hints) (Just $ unpack ipaddrText) (Just "22")+ case addrInfos of+ [] -> error "Couldn't get addr info for instance"+ addrInfo : _ -> tryConnect addrInfo+ where+ tryConnect :: AddrInfo -> IO ()+ tryConnect addrInfo = do+ res <-+ try $ bracket (openSocket addrInfo) (`gracefulClose` 1000) $ \sock ->+ connect sock $ addrAddress addrInfo+ case res of+ Left (_ :: SomeException) -> do+ threadDelay 1_000_000+ tryConnect addrInfo+ Right _ -> pure ()++getSshKeyFingerprints :: ScalewayCreateSettings -> ServerId -> ClientM Text+getSshKeyFingerprints settings serverId = do+ let authReq = createAuthReq settings.secretKey+ UserData rawSshKeyFingerprints <- serversUserDataGetApi authReq settings.zone serverId (UserDataKey "ssh-host-fingerprints")+ pure rawSshKeyFingerprints++updateSshHostKeys ::+ Text ->+ -- | IP Address+ Text ->+ IO ()+updateSshHostKeys rawFingerprintsFromScalewayApi ipAddr = do+ fingerprintsFromScalewayApi <-+ fromEitherM+ (\parseErr ->+ error $+ "Error parsing SSH host fingerprints from Scaleway metadata API: " <>+ show parseErr+ )+ (parseFingerprints "scaleway-metadata-api" rawFingerprintsFromScalewayApi)+ putStrLn "Getting SSH host keys from instance..."+ rawHostKeys <- getSshHostKeys ipAddr+ putStrLn "Got SSH keys host keys from instance."+ rawFingerprintsFromHost <- fingerprintsFromHostKeys rawHostKeys+ fingerprintsFromHost <-+ fromEitherM+ (\parseErr ->+ error $+ "Error parsing SSH host fingerprints directly from instance: " <>+ show parseErr+ )+ (parseFingerprints "host" rawFingerprintsFromScalewayApi)+ case doFingerprintsMatch fingerprintsFromScalewayApi fingerprintsFromHost of+ FingerprintsMatch -> do+ putStrLn $+ "Fingerprints match between Scaleway metadata API and actual " <>+ "instance, so removing old known hosts keys for the IP address, " <>+ "and adding new known host keys..."+ removeOldHostKeysFromKnownHosts ipAddr+ addNewHostKeysToKnownHosts rawHostKeys+ putStrLn "Added known host keys for new instance."+ FingerprintsNoMatch ->+ error $+ "ERROR: Fingerprints from scaleway metadata api, and fingerprints " <>+ "directly from host don't match.\n\nFrom metadata api:\n\n" <>+ unpack rawFingerprintsFromScalewayApi <>+ "\n\nFrom host: \n\n" <>+ unpack rawFingerprintsFromHost+ FingerprintsMatchErr err ->+ error $+ "ERROR: There was an unexpected error when comparing fingerprints from " <>+ "the scaleway metadata API, and fingerprints directly from the host: " <>+ unpack 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+ { size :: Word64+ -- ^ Size of the key. Example: @3072@+ , fingerprint :: Text+ -- ^ The fingerprint of the key. Example: @"SHA256:n6fLRD4O2Me3bRXhzHyCca1vWdQ2utxuPZVsIDUm6o0"@+ , server :: Text+ -- ^ User and hostname. Example: @"root\@cloudy-complete-knife"@+ , keyType :: Text+ -- ^ Type of key. Example: @"RSA"@+ }+ deriving stock Show++-- | Note that we don't enforce 'server' to be same between two Fingerprints.+instance Eq Fingerprint where+ fing1 == fing2 =+ fing1.size == fing2.size &&+ fing1.fingerprint == fing2.fingerprint &&+ fing1.keyType == fing2.keyType++instance Ord Fingerprint where+ compare fing1 fing2 =+ case compare fing1.size fing2.size of+ EQ ->+ case compare fing1.fingerprint fing2.fingerprint of+ EQ -> compare fing1.keyType fing2.keyType+ res -> res+ res -> 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 fromWhere rawFingerprintText = do+ parse (fingerprintsParser <* eof) (unpack fromWhere) rawFingerprintText++fingerprintsParser :: Parser (NonEmpty Fingerprint)+fingerprintsParser = do+ fingerprints <- sepEndBy1 fingerprintParser newline+ case fingerprints of+ [] -> error "fingerprintsParser: sepEndBy1 is never expected to return empty list"+ (h : ts) -> pure $ h :| 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 = do+ size <- int+ void space+ fingerprint <- pack <$> manyTill anyChar space+ server <- pack <$> manyTill anyChar space+ void $ char '('+ keyType <- pack <$> manyTill anyChar (char ')')+ pure $ Fingerprint { size, fingerprint, server, keyType }+ where+ int :: Parser Word64+ int = do+ digits <- some digit+ case readMaybe digits of+ Nothing -> fail $ "Couldn't read digits as Word64: " <> digits+ Just i -> pure 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 ipAddr = do+ (exitCode, stdout, stderr) <- readProcessWithExitCode "ssh-keyscan" [unpack ipAddr] ""+ case exitCode of+ ExitFailure _ -> do+ error $+ "getSshHostKeys: error running ssh-keyscan on ip " <> unpack ipAddr <> ": " <>+ stderr+ ExitSuccess -> pure $ pack 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 rawHostKeys = do+ (exitCode, stdout, stderr) <-+ readProcessWithExitCode "ssh-keygen" ["-l", "-f", "-"] (unpack rawHostKeys)+ case exitCode of+ ExitFailure _ -> do+ error $+ "fingerprintsFromHostKeys: error running ssh-keygen on raw host keys: " <>+ stderr+ ExitSuccess -> pure $ pack 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 Show++doFingerprintsMatch :: NonEmpty Fingerprint -> NonEmpty Fingerprint -> FingerprintsMatch+doFingerprintsMatch fings1 fings2 =+ let fingsLen1 = length fings1+ fingsLen2 = length fings2+ fingsSet1 = Set.fromList $ NonEmpty.toList fings1+ fingsSet2 = Set.fromList $ NonEmpty.toList fings2+ fingsSetLen1 = length fingsSet1+ fingsSetLen2 = length fingsSet2+ in+ if fingsLen1 /= fingsSetLen1 then FingerprintsMatchErr "first set of fingerprints is not unique" else+ if fingsLen2 /= fingsSetLen2 then FingerprintsMatchErr "second set of fingerprints is not unique" else+ if fingsSetLen1 /= fingsSetLen2 then FingerprintsMatchErr "two sets of fingerprints have different numbers of fingerprints" else+ if isSubsetOf fingsSet1 fingsSet2 && isSubsetOf fingsSet2 fingsSet1+ then FingerprintsMatch+ else 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 ipAddr = do+ (exitCode, _, stderr) <- readProcessWithExitCode "ssh-keygen" ["-R", unpack ipAddr] ""+ case exitCode of+ ExitFailure _ -> do+ error $+ "remove: removeOldHostKeysFromKnownHosts error running ssh-keygen -R on IP " <> unpack ipAddr <> ": " <>+ stderr+ ExitSuccess -> 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 newSshHostKeys = do+ homeDir <- getHomeDirectory+ let knownHosts = homeDir </> ".ssh" </> "known_hosts"+ knownHostsOld = knownHosts <.> "old"+ newSshHostKeysRaw = encodeUtf8 newSshHostKeys+ -- make copy of known hosts+ copyFile knownHosts knownHostsOld+ ByteString.appendFile knownHosts ("\n" <> newSshHostKeysRaw)++-- $setup+--+-- >>> import Text.Parsec (parseTest)
+ src/Cloudy/Cmd/Scaleway/ListImages.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Cloudy.Cmd.Scaleway.ListImages where++import Cloudy.Cli.Scaleway (ScalewayListImagesCliOpts (..))+import Cloudy.Cmd.Scaleway.Utils (createAuthReq, getZone, runScalewayClientM, fetchPagedApi)+import Cloudy.LocalConfFile (LocalConfFileOpts (..), LocalConfFileScalewayOpts (..))+import Cloudy.Scaleway (Zone (..), PerPage (PerPage), imagesGetApi, ImagesResp (ImagesResp), Image (..))+import Cloudy.Table (printTable, Table (..), Align (..))+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty ((:|)), groupAllWith)+import Data.Text (Text, isInfixOf, pack, toLower)+import Servant.Client (ClientM)+import Data.Time (formatTime, defaultTimeLocale)+import qualified Data.List.NonEmpty as NE++data ScalewayListImagesSettings = ScalewayListImagesSettings+ { secretKey :: Text+ , zone :: Zone+ , arch :: Text+ , nameFilter :: Maybe Text+ , showAllVersions :: Bool+ }++mkSettings :: LocalConfFileOpts -> ScalewayListImagesCliOpts -> IO ScalewayListImagesSettings+mkSettings localConfFileOpts cliOpts = do+ let maybeSecretKey = localConfFileOpts.scaleway >>= \scale -> scale.secretKey :: Maybe Text+ secretKey <- getVal maybeSecretKey "Could not find scaleway.secret_key in config file"+ let maybeZoneFromConfFile = localConfFileOpts.scaleway >>= \scale -> scale.defaultZone+ zone <- getZone maybeZoneFromConfFile cliOpts.zone+ pure+ ScalewayListImagesSettings+ { secretKey+ , zone+ , arch = cliOpts.arch+ , nameFilter = cliOpts.nameFilter+ , showAllVersions = cliOpts.allVersions+ }+ where+ getVal :: Maybe a -> String -> IO a+ getVal mayVal errMsg = maybe (error errMsg) pure mayVal++runListImages :: LocalConfFileOpts -> ScalewayListImagesCliOpts -> IO ()+runListImages localConfFileOpts scalewayOpts = do+ settings <- mkSettings localConfFileOpts scalewayOpts+ imgs <-+ runScalewayClientM+ (\err -> error $ "Problem fetching instance types: " <> show err)+ (fetchImages settings)+ displayImages settings imgs++fetchImages :: ScalewayListImagesSettings -> ClientM [Image]+fetchImages settings = do+ let authReq = createAuthReq settings.secretKey+ numPerPage = 100+ ImagesResp imgs <-+ fetchPagedApi+ (imagesGetApi authReq settings.zone (Just settings.arch) (Just $ PerPage numPerPage))+ (\(ImagesResp images1) (ImagesResp images2) -> ImagesResp $ images1 <> images2)+ (\(ImagesResp imgs) -> length imgs)+ pure imgs++displayImages :: ScalewayListImagesSettings -> [Image] -> IO ()+displayImages settings imgs = do+ let nameFilteredImages =+ case settings.nameFilter of+ Nothing -> imgs+ Just name -> filter (\img -> isInfixOf (toLower name) (toLower img.name)) imgs+ volFilteredImages = filter (\img -> img.rootVolType == "unified") nameFilteredImages+ latestImages =+ if settings.showAllVersions+ then volFilteredImages+ else+ nubByNameArch volFilteredImages+ sortByModDateImages = sortOn (\img -> img.modificationDate) latestImages+ case sortByModDateImages of+ [] -> putStrLn "Found no images."+ (hImg : tImg) -> do+ let imgTable = mkTable (hImg :| tImg)+ printTable imgTable++nubByNameArch :: [Image] -> [Image]+nubByNameArch imgs =+ fmap getMostRecent $ groupAllWith (\img -> (img.name, img.arch)) imgs+ where+ getMostRecent :: NonEmpty Image -> Image+ getMostRecent = NE.head . NE.sortWith (\img -> img.modificationDate)++mkTable :: NonEmpty Image -> Table+mkTable images =+ Table+ { tableHeaders =+ (LeftJustified, "image id") :|+ [ (LeftJustified, "name")+ , (LeftJustified, "arch")+ , (LeftJustified, "modify date")+ -- , (LeftJustified, "create date")+ , (LeftJustified, "state")+ ]+ , tableBodyRows = fmap mkRow images+ }++mkRow :: Image -> NonEmpty Text+mkRow img =+ img.id :|+ [ img.name+ , img.arch+ , formatDate img.modificationDate+ -- , formatDate img.creationDate+ , img.state+ ]+ where+ formatDate = pack . formatTime defaultTimeLocale "%Y-%m-%d"
+ src/Cloudy/Cmd/Scaleway/ListInstanceTypes.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Cloudy.Cmd.Scaleway.ListInstanceTypes where++import Cloudy.Cli.Scaleway (ScalewayListInstanceTypesCliOpts (..))+import Cloudy.Cmd.Scaleway.Utils (createAuthReq, getZone, runScalewayClientM)+import Cloudy.LocalConfFile (LocalConfFileOpts (..), LocalConfFileScalewayOpts (..))+import Cloudy.Scaleway (Zone (..), productsServersGetApi, ProductServersResp (..), ProductServer (..), ProductServersAvailabilityResp (..), productsServersAvailabilityGetApi, PerPage (PerPage), VolumeConstraint (..))+import Cloudy.Table (printTable, Table (..), Align (..))+import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Map.Merge.Strict (merge, mapMissing, dropMissing, zipWithMatched)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text, pack)+import Servant.Client (ClientM)+import Text.Printf (printf)+import qualified Data.Text as Text++data ScalewayListInstanceTypesSettings = ScalewayListInstanceTypesSettings+ { secretKey :: Text+ , zone :: Zone+ }++mkSettings :: LocalConfFileOpts -> ScalewayListInstanceTypesCliOpts -> IO ScalewayListInstanceTypesSettings+mkSettings localConfFileOpts cliOpts = do+ let maybeSecretKey = localConfFileOpts.scaleway >>= \scale -> scale.secretKey :: Maybe Text+ secretKey <- getVal maybeSecretKey "Could not find scaleway.secret_key in config file"+ let maybeZoneFromConfFile = localConfFileOpts.scaleway >>= \scale -> scale.defaultZone+ zone <- getZone maybeZoneFromConfFile cliOpts.zone+ pure ScalewayListInstanceTypesSettings { secretKey, zone }+ where+ getVal :: Maybe a -> String -> IO a+ getVal mayVal errMsg = maybe (error errMsg) pure mayVal++runListInstanceTypes :: LocalConfFileOpts -> ScalewayListInstanceTypesCliOpts -> IO ()+runListInstanceTypes localConfFileOpts scalewayOpts = do+ settings <- mkSettings localConfFileOpts scalewayOpts+ instanceTypes <-+ runScalewayClientM+ (\err -> error $ "ERROR! Problem fetching instance types: " <> show err)+ (fetchInstanceTypes settings)+ displayInstanceTypes instanceTypes++fetchInstanceTypes :: ScalewayListInstanceTypesSettings -> ClientM (Map Text (ProductServer, Text))+fetchInstanceTypes settings = do+ let authReq = createAuthReq settings.secretKey+ numPerPage = 100+ ProductServersResp productServers <- productsServersGetApi authReq settings.zone (Just $ PerPage numPerPage)+ let numProductServers = length $ Map.elems productServers+ when (numProductServers == numPerPage) $+ liftIO $ putStrLn "WARNING: The number of instance types returned is equal to the max per page. PROPER PAGING NEEDS TO BE IMPLEMENTED! We are likely missing instance types...."+ ProductServersAvailabilityResp avail <- productsServersAvailabilityGetApi authReq settings.zone (Just $ PerPage numPerPage)+ let numAvail = length $ Map.elems avail+ when (numAvail == numPerPage) $+ liftIO $ putStrLn "WARNING: The number of availabilities returned is equal to the max per page. PROPER PAGING NEEDS TO BE IMPLEMENTED! We are likely missing instance types...."+ pure $+ merge+ (mapMissing (\_ prod -> (prod, "UNKNOWN")))+ dropMissing+ (zipWithMatched (\_ -> (,)))+ productServers+ avail++displayInstanceTypes :: Map Text (ProductServer, Text) -> IO ()+displayInstanceTypes instanceTypes = do+ let instList = Map.toList instanceTypes+ sortByPriceInstList = sortOn (\(_, (prod, _)) -> prod.monthlyPrice) instList+ case sortByPriceInstList of+ [] -> putStrLn "Found no instance types."+ (hInst : tInsts) -> do+ let instTable = mkTable (hInst :| tInsts)+ printTable instTable++mkTable :: NonEmpty (Text, (ProductServer, Text)) -> Table+mkTable instanceTypes =+ Table+ { tableHeaders =+ (LeftJustified, "instance type id") :|+ [ (RightJustified, "monthly cost")+ , (LeftJustified, "arch")+ , (RightJustified, "cpus")+ , (RightJustified, "memory")+ , (RightJustified, "bandwidth")+ , (LeftJustified, "vol constraint")+ , (LeftJustified, "availability")+ , (LeftJustified, "alt names")+ ]+ , tableBodyRows = fmap mkRow instanceTypes+ }++mkRow :: (Text, (ProductServer, Text)) -> NonEmpty Text+mkRow (instType, (prod, availability)) =+ instType :|+ [ "€" <> pack (printf "%8.2f" prod.monthlyPrice)+ , prod.arch+ , pack $ show prod.ncpus+ , pack $ printf "%8.01f gib" (fromIntegral prod.ram / oneGib :: Double)+ , pack $ printf "%8.03f gbps" (fromIntegral prod.sumInternetBandwidth / oneGb :: Double)+ , formatVolumesConstraint prod.volumesConstraint+ , availability+ , case prod.altNames of+ [] -> "(none)"+ names -> Text.intercalate ", " names+ ]++formatVolumesConstraint :: VolumeConstraint -> Text+formatVolumesConstraint volConstr =+ if volConstr.minSize == 0 && volConstr.maxSize == 0+ then "(none)"+ else+ pack $+ printf+ "%3d min / %4d max (gb)"+ (bytesToGigabytes volConstr.minSize)+ (bytesToGigabytes volConstr.maxSize)+ where+ bytesToGigabytes :: Int -> Int+ bytesToGigabytes bs = round $ fromIntegral bs / (oneGb :: Double)++oneGib :: Num a => a+oneGib = 1024 * 1024 * 1024++oneGb :: Num a => a+oneGb = 1000 * 1000 * 1000
+ src/Cloudy/Cmd/Scaleway/Utils.hs view
@@ -0,0 +1,110 @@+module Cloudy.Cmd.Scaleway.Utils where++import Cloudy.Scaleway (Zone (..), zoneFromText, PageNum (PageNum))+import Data.Foldable (asum, foldl')+import Data.Maybe (fromMaybe)+import Data.Text (Text, unpack)+import Network.HTTP.Client.TLS (newTlsManager)+import Servant.API (AuthProtect, Headers (Headers), Header, HList (..), ResponseHeader (Header))+import Servant.Client (BaseUrl (BaseUrl), Scheme (Https), ClientM, ClientError, mkClientEnv, runClientM)+import Servant.Client.Core (mkAuthenticatedRequest, AuthenticatedRequest, AuthClientData, Request, addHeader)++createAuthReq :: Text -> AuthenticatedRequest (AuthProtect "auth-token")+createAuthReq secretKey = mkAuthenticatedRequest secretKey createAuthTokenHeader++createAuthTokenHeader :: Text -> Request -> Request+createAuthTokenHeader authData = addHeader "X-Auth-Token" authData++type instance AuthClientData (AuthProtect "auth-token") = Text++scalewayBaseUrl :: BaseUrl+scalewayBaseUrl = BaseUrl Https "api.scaleway.com" 443 ""++runScalewayClientM :: (forall x. ClientError -> IO x) -> ClientM a -> IO a+runScalewayClientM errHandler action = do+ manager <- newTlsManager+ let clientEnv = mkClientEnv manager scalewayBaseUrl+ res <- runClientM action clientEnv+ case res of+ Left err -> errHandler err+ Right a -> pure a++defaultZone :: Zone+defaultZone = NL1++getZone :: Maybe Text -> Maybe Text -> IO Zone+getZone maybeZoneFromConfFile maybeZoneFromCliOpts =+ case (maybeZoneFromConfFile, maybeZoneFromCliOpts) of+ (_, Just zoneFromCliOpts) ->+ case zoneFromText zoneFromCliOpts of+ Nothing ->+ error . unpack $+ "Could not parse zone specified in --zone option on cli: " <> zoneFromCliOpts+ Just zone -> pure zone+ (Just zoneFromConfFile, _) ->+ case zoneFromText zoneFromConfFile of+ Nothing ->+ error . unpack $+ "Could not parse zone specified in scaleway.defaultZone in config file: " <> zoneFromConfFile+ Just zone -> pure zone+ (Nothing, Nothing) -> pure defaultZone++getMaybeOrDefault :: Foldable t => a -> t (Maybe a) -> a+getMaybeOrDefault defVal maybes = fromMaybe defVal (asum maybes)++defaultInstanceType :: Text+defaultInstanceType = "PLAY2-NANO"++getInstanceType :: Maybe Text -> Maybe Text -> Text+getInstanceType maybeInstanceTypeFromConfFile maybeInstanceTypeFromCliOpts =+ getMaybeOrDefault+ defaultInstanceType+ [maybeInstanceTypeFromCliOpts, maybeInstanceTypeFromConfFile]++defaultImageId :: Text+defaultImageId = "ubuntu_noble"++getImageId :: Maybe Text -> Maybe Text -> Text+getImageId maybeImageIdFromConfFile maybeImageIdFromCliOpts =+ getMaybeOrDefault+ defaultImageId+ [maybeImageIdFromCliOpts, maybeImageIdFromConfFile]++fetchPagedApi ::+ Monad m =>+ (Maybe PageNum -> m (Headers '[Header "x-total-count" Int] a)) ->+ (a -> a -> a) ->+ (a -> Int) ->+ m a+fetchPagedApi fetchPage combineResults countResultsOnPage = do+ Headers page1Res headers <- fetchPage (Just $ PageNum 1)+ let page1Count = countResultsOnPage page1Res+ totalCount <-+ case headers of+ HCons h HNil ->+ case h of+ Header totalCount -> pure totalCount+ _ -> error "fetchPagedApi: could not find or decode header x-total-count for some reason"+ if page1Count >= totalCount+ then pure page1Res+ else do+ allRes <-+ unfoldM+ (\(currTotal, pageNumToFetch) ->+ if currTotal >= totalCount+ then pure Nothing+ else do+ Headers pageRes _ <- fetchPage (Just $ PageNum pageNumToFetch)+ let newTotal = currTotal + countResultsOnPage pageRes+ nextPageNum = pageNumToFetch + 1+ pure $ Just (pageRes, (newTotal, nextPageNum))+ )+ (page1Count, 2)+ pure $ foldl' combineResults page1Res allRes++unfoldM :: Monad m => (s -> m (Maybe (a, s))) -> s -> m [a]+unfoldM f s = do+ mres <- f s+ case mres of+ Nothing -> return []+ Just (a, s') -> fmap (a :) (unfoldM f s')
+ src/Cloudy/Cmd/Ssh.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Cloudy.Cmd.Ssh where++import Cloudy.Cli (SshCliOpts (..))+import Cloudy.Cmd.Utils (SelectInstBy, findInstanceInfoForSelectInstBy, mkSelectInstBy)+import Cloudy.LocalConfFile (LocalConfFileOpts (..))+import Cloudy.Db (withCloudyDb, InstanceInfo (..), ScalewayInstance (..))+import Data.Text (unpack, Text)+import Data.Void (absurd)+import System.Posix.Process (executeFile)++data SshSettings = SshSettings+ { selectInstBy :: SelectInstBy+ , sshPassthruArgs :: [Text]+ }+ deriving stock Show++mkSettings :: LocalConfFileOpts -> SshCliOpts -> IO SshSettings+mkSettings _localConfFileOpts cliOpts = do+ selectInstBy <- mkSelectInstBy cliOpts.id cliOpts.name+ pure SshSettings { selectInstBy, sshPassthruArgs = cliOpts.passthru }++runSsh :: LocalConfFileOpts -> SshCliOpts -> IO ()+runSsh localConfFileOpts cliOpts = do+ settings <- mkSettings localConfFileOpts cliOpts+ ipAddr <- withCloudyDb $ \conn -> do+ instanceInfo <- findInstanceInfoForSelectInstBy conn settings.selectInstBy+ case instanceInfo of+ CloudyAwsInstance _cloudyInstance void -> absurd void+ CloudyScalewayInstance _cloudyInstance scalewayInstance -> pure scalewayInstance.scalewayIpAddress+ let sshArgs = fmap unpack $ "root@" <> ipAddr : settings.sshPassthruArgs+ executeFile "ssh" True sshArgs Nothing
+ src/Cloudy/Cmd/Utils.hs view
@@ -0,0 +1,47 @@++module Cloudy.Cmd.Utils where++import Cloudy.Db (CloudyInstanceId, OnlyOne (..), InstanceInfo, findCloudyInstanceIdByName, findOnlyOneInstanceId, instanceInfoForId)+import Data.Text (Text, unpack)+import Database.SQLite.Simple (Connection)++data SelectInstBy = SelectInstByName Text | SelectInstById CloudyInstanceId | SelectInstOnlyOne+ deriving stock Show++mkSelectInstBy :: Maybe CloudyInstanceId -> Maybe Text -> IO SelectInstBy+mkSelectInstBy maybeCloudyInstId maybeCloudyInstName =+ case (maybeCloudyInstId, maybeCloudyInstName) of+ (Just cloudyInstanceId, Nothing) -> pure $ SelectInstById cloudyInstanceId+ (Nothing, Just cloudyInstanceName) -> pure $ SelectInstByName cloudyInstanceName+ (Nothing, Nothing) -> pure SelectInstOnlyOne+ (_, _) -> error "Both cloudy instance id and cloudy instance name were specified. You can only specify at most one of these."++findCloudyInstanceIdForSelectInstBy :: Connection -> SelectInstBy -> IO CloudyInstanceId+findCloudyInstanceIdForSelectInstBy conn = \case+ SelectInstByName instName -> do+ maybeCloudyInstId <- findCloudyInstanceIdByName conn instName+ case maybeCloudyInstId of+ Nothing ->+ error . unpack $+ "No cloudy instances found with name \"" <> instName <> "\""+ Just cloudyInstId -> pure cloudyInstId+ SelectInstById cloudyInstanceId -> pure cloudyInstanceId+ SelectInstOnlyOne -> do+ onlyOneInstId <- findOnlyOneInstanceId conn+ case onlyOneInstId of+ OnlyOne instId -> pure instId+ MultipleExist ->+ error+ "Multiple cloudy instances exist in the database, so you must pass \+ \--id or --name to operate on a specific instance."+ NoneExist ->+ error "No cloudy instances exist in the database"++findInstanceInfoForSelectInstBy :: Connection -> SelectInstBy -> IO InstanceInfo+findInstanceInfoForSelectInstBy conn selectInstBy = do+ cloudyInstanceId <- findCloudyInstanceIdForSelectInstBy conn selectInstBy+ maybeInstInfo <- instanceInfoForId conn cloudyInstanceId+ case maybeInstInfo of+ Nothing -> error $ "Couldn't find instance info for selection: " <> show selectInstBy+ Just instInfo -> pure instInfo+
+ src/Cloudy/Db.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedRecordDot #-}++module Cloudy.Db where++import Cloudy.InstanceSetup.Types (InstanceSetup (..))+import Cloudy.NameGen (instanceNameGen)+import Cloudy.Path (getCloudyDbPath)+import Control.Exception (Exception, throwIO)+import Data.Aeson (eitherDecodeStrict, encode)+import qualified Data.ByteString as ByteString+import Data.Foldable (fold)+import Data.Int (Int64)+import Data.List (find)+import Data.Maybe (listToMaybe, catMaybes)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import Data.Time ( UTCTime, getCurrentTime )+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)+import Data.Traversable (for)+import Data.Void (Void)+import Database.SQLite.Simple (withConnection, Connection, execute_, Query, query_, FromRow (..), ToRow (..), execute, withTransaction, lastInsertRowId, query, Only (..), field)+import Database.SQLite.Simple.FromField (FromField (..))+import Database.SQLite.Simple.ToField (ToField (..))++createLocalDatabase :: Connection -> IO ()+createLocalDatabase conn = do+ execute_+ conn+ "CREATE TABLE IF NOT EXISTS cloudy_instance \+ \ ( id INTEGER PRIMARY KEY AUTOINCREMENT \+ \ , name TEXT NOT NULL UNIQUE \+ \ , created_at INTEGER \+ \ , deleted_at INTEGER \+ \ , instance_setup TEXT \+ \ ) \+ \STRICT"+ execute_+ conn+ "CREATE TABLE IF NOT EXISTS scaleway_instance \+ \ ( cloudy_instance_id INTEGER NOT NULL UNIQUE \+ \ , scaleway_zone TEXT NOT NULL \+ \ , scaleway_instance_id TEXT NOT NULL UNIQUE \+ \ , scaleway_ip_id TEXT NOT NULL \+ \ , scaleway_ip_address TEXT NOT NULL \+ \ , FOREIGN KEY (cloudy_instance_id) REFERENCES cloudy_instance(id) \+ \ ) \+ \STRICT"++withCloudyDb :: (Connection -> IO a) -> IO a+withCloudyDb action = do+ dcutDbPath <- getCloudyDbPath+ withSqliteConn dcutDbPath $ \conn -> do+ createLocalDatabase conn+ -- TODO: Maybe create some sort of production build that doesn't check+ -- the invariants.+ assertDbInvariants conn+ res <- action conn+ assertDbInvariants conn+ pure res++withSqliteConn :: FilePath -> (Connection -> IO a) -> IO a+withSqliteConn dbPath action =+ withConnection+ dbPath+ (\conn -> do+ execute_+ conn+ -- Also consider using the following settings:+ --+ -- - `PRAGMA synchronous = NORMAL;`:+ -- Change the synchronization model. NORMAL is faster than the+ -- default, and still safe with journal_mode=WAL.+ --+ -- - `PRAGMA cache_size = 1000000000;`:+ -- Change the maximum number of database disk pages that SQLite+ -- will hold in memory at once. Each page uses about 1.5K of+ -- memory. The default cache size is 2000.+ --+ -- More suggestions in https://kerkour.com/sqlite-for-servers+ "PRAGMA journal_mode = WAL; -- better concurrency \+ \PRAGMA foreign_keys = true; -- enforce foreign key constraints \+ \PRAGMA busy_timeout = 5000; -- helps prevent SQLITE_BUSY errors"+ action conn+ )++data QuerySingleErr = QuerySingleErr Query String+ deriving stock (Eq, Show)+ deriving anyclass (Exception)++querySingleErr_ :: FromRow r => Connection -> Query -> IO r+querySingleErr_ conn q = do+ onlyOneRes <- querySingle_ conn q+ case onlyOneRes of+ OnlyOne r -> pure r+ NoneExist -> throwIO $ QuerySingleErr q "query returned NO results, expecting exactly one"+ MultipleExist -> throwIO $ QuerySingleErr q "query returned multiple results, expecting exactly one"++data OnlyOne r = OnlyOne r | MultipleExist | NoneExist+ deriving stock (Functor, Show)++querySingle_ :: FromRow r => Connection -> Query -> IO (OnlyOne r)+querySingle_ conn q = do+ res <- query_ conn q+ case res of+ [] -> pure NoneExist+ [r] -> pure $ OnlyOne r+ _:_ -> pure MultipleExist+++-- | Query on a column with a UNIQUE constraint. Throws an exception if+-- multiple values are returned.+queryUnique :: (ToRow a, FromRow r) => Connection -> Query -> a -> IO (Maybe r)+queryUnique conn q a = do+ res <- query conn q a+ case res of+ [] -> pure Nothing+ [r] -> pure $ Just r+ _:_ -> error "queryUnique: expecting only a single result at most, but got multiple results. Is there really a UNIQUE constraint here?"++newtype CloudyInstanceId = CloudyInstanceId { unCloudyInstanceId :: Int64 }+ deriving stock (Eq, Ord, Show)+ deriving newtype (FromField, ToField)++data CloudyInstance = CloudyInstance+ { id :: CloudyInstanceId+ , name :: Text+ , createdAt :: Maybe UTCTime+ , deletedAt :: Maybe UTCTime+ , instanceSetup :: Maybe InstanceSetup+ }+ deriving stock (Eq, Show)++instance FromRow CloudyInstance where+ fromRow = do+ id' <- field+ name <- field+ createdAt <- fmap utcTimeFromSqliteInt <$> field+ deletedAt <- fmap utcTimeFromSqliteInt <$> field+ instanceSetup <- fmap unDbInstanceSetup <$> field+ pure $ CloudyInstance { id = id', name, createdAt, deletedAt, instanceSetup }++-- | newtype to hold the 'FromField' instance for 'InstanceSetup', for use in+-- the 'FromRow' instance for 'CloudyInstance'.+--+-- The @instance_setup@ column in the @cloudy_instance@ table holds a+-- JSON-encoded 'InstanceSetup' value.+newtype DbInstanceSetup = DbInstanceSetup { unDbInstanceSetup :: InstanceSetup }++instance FromField DbInstanceSetup where+ fromField fld = do+ rawInstanceSetup :: Text <- fromField fld+ let eitherInstanceSetup = eitherDecodeStrict $ encodeUtf8 rawInstanceSetup+ case eitherInstanceSetup of+ Left err -> fail $ "Failed to json decode instance_setup column as InstanceSetup: " <> err+ Right instanceSetup -> pure $ DbInstanceSetup instanceSetup++instance ToField DbInstanceSetup where+ toField (DbInstanceSetup instSetup) =+ toField $ decodeUtf8 $ ByteString.toStrict $ encode instSetup++data ScalewayInstance = ScalewayInstance+ { cloudyInstanceId :: CloudyInstanceId+ , scalewayZone :: Text+ , scalewayInstanceId :: Text+ , scalewayIpId :: Text+ , scalewayIpAddress :: Text+ }+ deriving stock (Eq, Show)++instance FromRow ScalewayInstance where+ fromRow = do+ cloudyInstanceId <- field+ scalewayZone <- field+ scalewayInstanceId <- field+ scalewayIpId <- field+ scalewayIpAddress <- field+ pure $ ScalewayInstance { cloudyInstanceId, scalewayZone, scalewayInstanceId, scalewayIpId, scalewayIpAddress }++instance ToRow ScalewayInstance where+ toRow ScalewayInstance {cloudyInstanceId, scalewayZone, scalewayInstanceId, scalewayIpId, scalewayIpAddress} =+ toRow (cloudyInstanceId, scalewayZone, scalewayInstanceId, scalewayIpId, scalewayIpAddress)++data InstanceInfo+ = CloudyScalewayInstance CloudyInstance ScalewayInstance+ | CloudyAwsInstance CloudyInstance Void {- TODO: actually implement AWS stuff -}+ deriving stock Show++cloudyInstanceFromInstanceInfo :: InstanceInfo -> CloudyInstance+cloudyInstanceFromInstanceInfo = \case+ CloudyScalewayInstance cloudyInstance _ -> cloudyInstance+ CloudyAwsInstance cloudyInstance _ -> cloudyInstance++newCloudyInstance :: Connection -> IO (CloudyInstanceId, Text)+newCloudyInstance conn = withTransaction conn go+ where+ go :: IO (CloudyInstanceId, Text)+ go = do+ possibleName <- instanceNameGen+ maybeInstance <- findCloudyInstanceByNameWithDeleted conn possibleName+ case maybeInstance of+ -- No instance exists with this name yet. Insert a new blank instance.+ Nothing -> do+ execute+ conn+ "INSERT INTO cloudy_instance \+ \(name) \+ \VALUES (?)"+ (Only possibleName)+ cloudyInstanceId <- lastInsertRowId conn+ pure (CloudyInstanceId cloudyInstanceId, possibleName)+ -- An instance already exists with this name, try again.+ Just _ -> go++-- | Return a cloudy instance matching the given name.+-- This will return an instance even if it has already been deleted.+findCloudyInstanceByNameWithDeleted :: Connection -> Text -> IO (Maybe CloudyInstance)+findCloudyInstanceByNameWithDeleted conn cloudyInstanceName = do+ listToMaybe <$>+ query+ conn+ "SELECT id, name, created_at, deleted_at, instance_setup \+ \FROM cloudy_instance \+ \WHERE name == ? \+ \ORDER BY id"+ (Only cloudyInstanceName)++findCloudyInstanceIdByName :: Connection -> Text -> IO (Maybe CloudyInstanceId)+findCloudyInstanceIdByName conn cloudyInstanceName = do+ fmap fromOnly . listToMaybe <$>+ query+ conn+ "SELECT id \+ \FROM cloudy_instance \+ \WHERE name == ? AND deleted_at IS NULL"+ (Only cloudyInstanceName)++findCloudyInstanceById :: Connection -> CloudyInstanceId -> IO (Maybe CloudyInstance)+findCloudyInstanceById conn cloudyInstanceId = do+ listToMaybe <$>+ query+ conn+ "SELECT id, name, created_at, deleted_at, instance_setup \+ \FROM cloudy_instance \+ \WHERE id == ? AND deleted_at IS NULL AND created_at IS NOT NULL"+ (Only cloudyInstanceId)++findAllCloudyInstances :: Connection -> IO [CloudyInstance]+findAllCloudyInstances conn =+ query_+ conn+ "SELECT id, name, created_at, deleted_at, instance_setup \+ \FROM cloudy_instance \+ \WHERE deleted_at IS NULL AND created_at IS NOT NULL \+ \ORDER BY id"++setCloudyInstanceDeleted :: Connection -> CloudyInstanceId -> IO ()+setCloudyInstanceDeleted conn cloudyInstanceId = do+ currTime <- getCurrentTime+ execute+ conn+ "UPDATE cloudy_instance \+ \SET deleted_at = ? \+ \WHERE id = ?"+ (utcTimeToSqliteInt currTime, cloudyInstanceId)++newScalewayInstance ::+ Connection ->+ UTCTime ->+ CloudyInstanceId ->+ Maybe InstanceSetup ->+ -- | Scaleway Zone+ Text ->+ -- | Scaleway Instance Id+ Text ->+ -- | Scaleway IP Id+ Text ->+ -- | Scaleway IP Address+ Text ->+ IO ()+newScalewayInstance conn creationTime cloudyInstanceId instSetup scalewayZone scalewayInstanceId scalewayIpId scalewayIpAddress =+ withTransaction conn $ do+ execute+ conn+ "UPDATE cloudy_instance \+ \SET created_at = ?, instance_setup = ? \+ \WHERE id = ?"+ (utcTimeToSqliteInt creationTime, fmap DbInstanceSetup instSetup, cloudyInstanceId)+ execute+ conn+ "INSERT INTO scaleway_instance \+ \(cloudy_instance_id, scaleway_zone, scaleway_instance_id, scaleway_ip_id, scaleway_ip_address) \+ \VALUES (?, ?, ?, ?, ?)"+ ScalewayInstance { cloudyInstanceId, scalewayZone, scalewayInstanceId, scalewayIpId, scalewayIpAddress }++findScalewayInstanceByCloudyInstanceId :: Connection -> CloudyInstanceId -> IO (Maybe ScalewayInstance)+findScalewayInstanceByCloudyInstanceId conn cloudyInstanceId =+ listToMaybe <$>+ query+ conn+ "SELECT cloudy_instance_id, scaleway_zone, scaleway_instance_id, scaleway_ip_id, scaleway_ip_address \+ \FROM scaleway_instance \+ \WHERE cloudy_instance_id == ?"+ (Only cloudyInstanceId)++findAllScalewayInstances :: Connection -> IO [ScalewayInstance]+findAllScalewayInstances conn =+ query_+ conn+ "SELECT \+ \ scaleway_instance.cloudy_instance_id, \+ \ scaleway_instance.scaleway_zone, \+ \ scaleway_instance.scaleway_instance_id, \+ \ scaleway_instance.scaleway_ip_id, \+ \ scaleway_instance.scaleway_ip_address \+ \FROM scaleway_instance \+ \INNER JOIN cloudy_instance ON scaleway_instance.cloudy_instance_id == cloudy_instance.id \+ \WHERE cloudy_instance.deleted_at IS NULL AND cloudy_instance.created_at IS NOT NULL"+++-- | Return a single CloudyInstanceId if there is exactly one in the database that+-- is not already deleted.+findOnlyOneInstanceId :: Connection -> IO (OnlyOne CloudyInstanceId)+findOnlyOneInstanceId conn = do+ onlyOneInstId <-+ querySingle_+ conn+ "SELECT id \+ \FROM cloudy_instance \+ \WHERE deleted_at IS NULL"+ pure $ fmap fromOnly onlyOneInstId++utcTimeToSqliteInt :: UTCTime -> Int64+utcTimeToSqliteInt = round . utcTimeToPOSIXSeconds++utcTimeFromSqliteInt :: Int64 -> UTCTime+utcTimeFromSqliteInt = posixSecondsToUTCTime . fromIntegral++instanceInfoForId :: Connection -> CloudyInstanceId -> IO (Maybe InstanceInfo)+instanceInfoForId conn cloudyInstanceId = withTransaction conn $ do+ maybeCloudyInstance <- findCloudyInstanceById conn cloudyInstanceId+ case maybeCloudyInstance of+ Nothing -> pure Nothing+ Just cloudyInstance -> do+ maybeCloudyInstanceId <- findScalewayInstanceByCloudyInstanceId conn cloudyInstance.id+ pure $ fmap (CloudyScalewayInstance cloudyInstance) maybeCloudyInstanceId++findAllInstanceInfos :: Connection -> IO [InstanceInfo]+findAllInstanceInfos conn = withTransaction conn $ do+ cloudyInstances <- findAllCloudyInstances conn+ scalewayInstances <- findAllScalewayInstances conn+ for cloudyInstances $ \cloudyInstance -> do+ let maybeScalewayInstance =+ find+ (\scalewayInst -> scalewayInst.cloudyInstanceId == cloudyInstance.id)+ scalewayInstances+ case maybeScalewayInstance of+ Nothing ->+ error $ "Could not find scaleway instance for cloudyInstance: " <> show cloudyInstance+ Just scalewayInstance ->+ pure $ CloudyScalewayInstance cloudyInstance scalewayInstance+++data DbInvariantErr+ = CloudyInstanceHasNoProviderInstance CloudyInstanceId+ | CloudyInstanceHasMultipleProviderInstances CloudyInstanceId+ | CloudyInstanceHasNullCreatedAt CloudyInstanceId+ deriving stock Show++assertDbInvariants :: Connection -> IO ()+assertDbInvariants conn = withTransaction conn $ do+ invariantErrors :: [DbInvariantErr] <-+ fold+ [ invariantEveryCloudyInstHasExactlyOneProviderInst conn+ , invariantCloudyInstCorectDates conn+ -- TODO: add invariant that says two non-deleted scaleway servers should+ -- never have the same IP addresses+ ]+ case invariantErrors of+ [] -> pure ()+ _ ->+ error $+ "assertDbInvariants: DB invariants have been violated: " <> show invariantErrors++-- | There needs to be EXACTLY ONE corresponding cloud provider instance for each+-- cloudy instance.+invariantEveryCloudyInstHasExactlyOneProviderInst :: Connection -> IO [DbInvariantErr]+invariantEveryCloudyInstHasExactlyOneProviderInst conn = do+ allCloudyInstIds <- fmap fromOnly <$> query_ conn "SELECT id FROM cloudy_instance"+ maybeErrs <- for allCloudyInstIds checkCloudyInstProviders+ pure $ catMaybes maybeErrs+ where+ checkCloudyInstProviders :: CloudyInstanceId -> IO (Maybe DbInvariantErr)+ checkCloudyInstProviders cloudyInstId = do+ maybeScalewayInstId :: Maybe Text <-+ fmap fromOnly <$>+ queryUnique+ conn+ "SELECT scaleway_instance_id \+ \FROM scaleway_instance \+ \WHERE cloudy_instance_id == ?"+ (Only cloudyInstId)+ case maybeScalewayInstId of+ Just _scalewayInstId -> pure Nothing+ Nothing -> pure $ Just $ CloudyInstanceHasNoProviderInstance cloudyInstId++-- | Cloudy instances should always have a @created_at@ value that is non-null.+--+-- The only time a Cloudy instance can have a @created_at@ value that is null+-- is within the Create CLI command. Although this invariant should hold both+-- before and after the Create CLI command.+invariantCloudyInstCorectDates :: Connection -> IO [DbInvariantErr]+invariantCloudyInstCorectDates conn = do+ instIds <-+ fmap fromOnly <$>+ query_+ conn+ "SELECT id FROM cloudy_instance WHERE created_at is NULL"+ pure $ fmap CloudyInstanceHasNullCreatedAt instIds
+ src/Cloudy/InstanceSetup.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TemplateHaskell #-}++module Cloudy.InstanceSetup where++import Cloudy.InstanceSetup.Types ( InstanceSetup(..) )+import Cloudy.Path (getCloudyInstanceSetupsDir)+import Control.DeepSeq (force)+import Control.FromSum (fromEither)+import Data.Bifunctor (Bifunctor(first))+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import Data.FileEmbed (embedDir)+import Data.Functor ((<&>))+import Data.List (sort, find)+import Data.Text (pack, Text)+import Data.Text.Encoding (decodeUtf8')+import Data.Yaml (decodeEither', ParseException (OtherParseException))+import System.Directory (listDirectory)+import System.FilePath (takeBaseName, takeExtension, (</>))+import Control.Exception (SomeException(SomeException))++rawBuiltInInstanceSetups :: [(FilePath, ByteString)]+rawBuiltInInstanceSetups = $(embedDir "instance-setups/")++builtInInstanceSetups :: [InstanceSetup]+builtInInstanceSetups =+ -- force is used here because we want to make sure any YAML decoding errors+ -- are surfaced the very first time builtInInstanceSetups is used. We should+ -- almost never see any errors, since we control the raw instance-setup files+ -- that are used here.+ --+ -- We also have tests that should catch problems with decoding these+ -- instance-setup files.+ force $+ sort rawBuiltInInstanceSetups <&> \(fp, rawData) ->+ fromEither+ (\err ->+ error $+ "Failed to decode instance-setup data in " <> fp <>+ " as InstanceSetupData: " <> show err+ )+ (parseInstanceSetup fp rawData)++parseInstanceSetup :: FilePath -> ByteString -> Either ParseException InstanceSetup+parseInstanceSetup fp rawData = do+ let name = pack $ takeBaseName fp+ rawDataText <- first (OtherParseException . SomeException) $ decodeUtf8' rawData+ instanceSetupData <- decodeEither' rawData+ pure $ InstanceSetup { name, instanceSetupData, rawInstanceSetupData = rawDataText }+++getUserInstanceSetups :: IO [InstanceSetup]+getUserInstanceSetups = do+ instanceSetupsDir <- getCloudyInstanceSetupsDir+ files <- fmap (instanceSetupsDir </>) <$> listDirectory instanceSetupsDir+ let yamlFiles = filter isYamlExt files+ traverse yamlFileToInstanceSetup yamlFiles+ where+ isYamlExt :: FilePath -> Bool+ isYamlExt fp = takeExtension fp == ".yaml" || takeExtension fp == ".yml"++yamlFileToInstanceSetup :: FilePath -> IO InstanceSetup+yamlFileToInstanceSetup rawInstanceSetupFp = do+ rawInstanceSetupData <- ByteString.readFile rawInstanceSetupFp+ case parseInstanceSetup rawInstanceSetupFp rawInstanceSetupData of+ Left err -> error $ "Failed to decode " <> rawInstanceSetupFp <> " as instance-setup: " <> show err+ Right instanceSetup -> pure instanceSetup++-- | Find an 'InstanceSetup' from within the built-in and user-defined instance+-- setups.+findInstanceSetup ::+ -- | Name of the 'InstanceSetup' to look for.+ Text ->+ IO (Maybe InstanceSetup)+findInstanceSetup nameToFind = do+ userInstanceSetups <- getUserInstanceSetups+ let allInstanceSetups = userInstanceSetups <> builtInInstanceSetups+ maybeInstanceSetup :: Maybe InstanceSetup = find (\instSetup -> instSetup.name == nameToFind) allInstanceSetups+ pure maybeInstanceSetup
+ src/Cloudy/InstanceSetup/Types.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveAnyClass #-}++module Cloudy.InstanceSetup.Types where++import Control.DeepSeq (NFData)+import Data.Aeson (FromJSON(..), ToJSON (..), object, (.=), FromJSON, withObject, (.:))+import Data.Text (Text)+import GHC.Generics (Generic)++data InstanceSetup = InstanceSetup+ { name :: Text+ , instanceSetupData :: InstanceSetupData+ , rawInstanceSetupData :: Text+ }+ deriving stock (Eq, Generic, Show)+ deriving anyclass (NFData)++instance ToJSON InstanceSetup where+ toJSON InstanceSetup{name, instanceSetupData, rawInstanceSetupData} =+ object+ [ "name" .= name+ , "data" .= instanceSetupData+ , "raw" .= rawInstanceSetupData+ ]++instance FromJSON InstanceSetup where+ parseJSON = withObject "InstanceSetup" $ \o -> do+ name <- o .: "name"+ instanceSetupData <- o .: "data"+ rawInstanceSetupData <- o .: "raw"+ pure InstanceSetup { name, instanceSetupData, rawInstanceSetupData }++data InstanceSetupData = InstanceSetupData+ { shortDescription :: Text+ , cloudInitUserData :: Text+ }+ deriving stock (Eq, Generic, Show)+ deriving anyclass (NFData)++instance ToJSON InstanceSetupData where+ toJSON InstanceSetupData{shortDescription, cloudInitUserData} =+ object+ [ "short-description" .= shortDescription+ , "cloud-init-user-data" .= cloudInitUserData+ ]++instance FromJSON InstanceSetupData where+ parseJSON = withObject "InstanceSetupData" $ \o -> do+ shortDescription <- o .: "short-description"+ cloudInitUserData <- o .: "cloud-init-user-data"+ pure InstanceSetupData { shortDescription, cloudInitUserData }
+ src/Cloudy/LocalConfFile.hs view
@@ -0,0 +1,77 @@++module Cloudy.LocalConfFile where++import Cloudy.Path (getCloudyConfFilePath)+import Control.Exception (throwIO)+import Data.Aeson (FromJSON (parseJSON), withObject, (.:?), Value (Null), Object)+import Data.Aeson.Types (Parser)+import qualified Data.ByteString as BS+import Data.Text (Text)+import Data.Yaml (decodeEither')+import System.IO.Error (tryIOError, isDoesNotExistError)++data LocalConfFileScalewayOpts = LocalConfFileScalewayOpts+ { accessKey :: Maybe Text+ , secretKey :: Maybe Text+ , defaultOrganizationId :: Maybe Text+ , defaultProjectId :: Maybe Text+ , defaultZone :: Maybe Text+ , defaultInstanceType :: Maybe Text+ , defaultImageId :: Maybe Text+ } deriving Show++instance FromJSON LocalConfFileScalewayOpts where+ parseJSON :: Value -> Parser LocalConfFileScalewayOpts+ parseJSON = withObject "LocalConfFileScalewayOpts" $ \o -> do+ accessKey <- o .:? "access_key"+ secretKey <- o .:? "secret_key"+ defaultOrganizationId <- o .:? "default_organization_id"+ defaultProjectId <- o .:? "default_project_id"+ defaultZone <- o .:? "default_zone"+ defaultInstanceType <- o .:? "default_instance_type"+ defaultImageId <- o .:? "default_image_id"+ pure+ LocalConfFileScalewayOpts+ { accessKey+ , secretKey+ , defaultOrganizationId+ , defaultProjectId+ , defaultZone+ , defaultInstanceType+ , defaultImageId+ }++data LocalConfFileOpts = LocalConfFileOpts+ { scaleway :: Maybe LocalConfFileScalewayOpts+ } deriving Show++instance FromJSON LocalConfFileOpts where+ parseJSON Null = pure defaultLocalConfFileOpts+ parseJSON v = withObject "LocalConfFileOpts" parseObj v+ where+ parseObj :: Object -> Parser LocalConfFileOpts+ parseObj o = do+ LocalConfFileOpts <$> o .:? "scaleway"++defaultLocalConfFileOpts :: LocalConfFileOpts+defaultLocalConfFileOpts = LocalConfFileOpts { scaleway = Nothing }++readLocalConfFile :: IO LocalConfFileOpts+readLocalConfFile = do+ confFilePath <- getCloudyConfFilePath+ eitherConfFileRaw <- tryIOError (BS.readFile confFilePath)+ case eitherConfFileRaw of+ Left ioEx+ | isDoesNotExistError ioEx ->+ -- conf file does not exist yet on disk, just return the default options+ pure defaultLocalConfFileOpts+ | otherwise ->+ -- We got an IOException that we weren't expecting. Rethrow it.+ throwIO ioEx+ Right confFileRaw -> do+ let eitherConfFileOpts = decodeEither' confFileRaw+ case eitherConfFileOpts of+ Left parseErr ->+ -- We got an error when trying to parse the config file. This is unexpected. Throw it.+ throwIO parseErr+ Right confFile -> pure confFile
+ src/Cloudy/NameGen.hs view
@@ -0,0 +1,769 @@++module Cloudy.NameGen where++import Data.Text (Text)+import System.Random (randomRIO)++nameWords :: [Text]+nameWords =+ [ "able"+ , "account"+ , "acid"+ , "act"+ , "addition"+ , "adjustment"+ , "advertisement"+ , "agreement"+ , "air"+ , "amount"+ , "amusement"+ , "angle"+ , "angry"+ , "animal"+ , "answer"+ , "ant"+ , "apparatus"+ , "apple"+ , "approval"+ , "arch"+ , "argument"+ , "arm"+ , "army"+ , "art"+ , "attack"+ , "attempt"+ , "attention"+ , "attraction"+ , "authority"+ , "automatic"+ , "awake"+ , "baby"+ , "back"+ , "bad"+ , "bag"+ , "balance"+ , "ball"+ , "band"+ , "base"+ , "basin"+ , "basket"+ , "bath"+ , "beautiful"+ , "bed"+ , "bee"+ , "behaviour"+ , "belief"+ , "bell"+ , "bent"+ , "berry"+ , "bird"+ , "birth"+ , "bit"+ , "bite"+ , "bitter"+ , "black"+ , "blade"+ , "blood"+ , "blow"+ , "blue"+ , "board"+ , "boat"+ , "body"+ , "boiling"+ , "bone"+ , "book"+ , "boot"+ , "bottle"+ , "box"+ , "boy"+ , "brain"+ , "brake"+ , "branch"+ , "brass"+ , "bread"+ , "breath"+ , "brick"+ , "bridge"+ , "bright"+ , "broken"+ , "brother"+ , "brown"+ , "brush"+ , "bucket"+ , "building"+ , "bulb"+ , "burn"+ , "burst"+ , "business"+ , "butter"+ , "button"+ , "cake"+ , "camera"+ , "canvas"+ , "card"+ , "care"+ , "carriage"+ , "cart"+ , "cat"+ , "cause"+ , "certain"+ , "chain"+ , "chalk"+ , "chance"+ , "change"+ , "cheap"+ , "cheese"+ , "chemical"+ , "chest"+ , "chief"+ , "chin"+ , "church"+ , "circle"+ , "clean"+ , "clear"+ , "clock"+ , "cloth"+ , "cloud"+ , "coal"+ , "coat"+ , "cold"+ , "collar"+ , "colour"+ , "comb"+ , "comfort"+ , "committee"+ , "common"+ , "company"+ , "comparison"+ , "competition"+ , "complete"+ , "complex"+ , "condition"+ , "connection"+ , "conscious"+ , "control"+ , "cook"+ , "copper"+ , "copy"+ , "cord"+ , "cork"+ , "cotton"+ , "cough"+ , "country"+ , "cover"+ , "cow"+ , "crack"+ , "credit"+ , "crime"+ , "cruel"+ , "crush"+ , "cry"+ , "cup"+ , "current"+ , "curtain"+ , "curve"+ , "cushion"+ , "cut"+ , "damage"+ , "danger"+ , "dark"+ , "daughter"+ , "day"+ , "dead"+ , "dear"+ , "death"+ , "debt"+ , "decision"+ , "deep"+ , "degree"+ , "delicate"+ , "dependent"+ , "design"+ , "desire"+ , "destruction"+ , "detail"+ , "development"+ , "different"+ , "digestion"+ , "direction"+ , "dirty"+ , "discovery"+ , "discussion"+ , "disease"+ , "disgust"+ , "distance"+ , "distribution"+ , "division"+ , "dog"+ , "door"+ , "doubt"+ , "drain"+ , "drawer"+ , "dress"+ , "drink"+ , "driving"+ , "drop"+ , "dry"+ , "dust"+ , "ear"+ , "early"+ , "earth"+ , "edge"+ , "education"+ , "effect"+ , "egg"+ , "elastic"+ , "electric"+ , "end"+ , "engine"+ , "equal"+ , "error"+ , "event"+ , "example"+ , "exchange"+ , "existence"+ , "expansion"+ , "experience"+ , "expert"+ , "eye"+ , "face"+ , "fact"+ , "fall"+ , "false"+ , "family"+ , "farm"+ , "fat"+ , "father"+ , "fear"+ , "feather"+ , "feeble"+ , "feeling"+ , "female"+ , "fertile"+ , "fiction"+ , "field"+ , "fight"+ , "finger"+ , "fire"+ , "first"+ , "fish"+ , "fixed"+ , "flag"+ , "flame"+ , "flat"+ , "flight"+ , "floor"+ , "flower"+ , "fly"+ , "fold"+ , "food"+ , "foolish"+ , "foot"+ , "force"+ , "fork"+ , "form"+ , "fowl"+ , "frame"+ , "free"+ , "frequent"+ , "friend"+ , "front"+ , "fruit"+ , "full"+ , "future"+ , "garden"+ , "general"+ , "girl"+ , "glass"+ , "glove"+ , "goat"+ , "gold"+ , "good"+ , "government"+ , "grain"+ , "grass"+ , "great"+ , "green"+ , "grey"+ , "grip"+ , "group"+ , "growth"+ , "guide"+ , "gun"+ , "hair"+ , "hammer"+ , "hand"+ , "hanging"+ , "happy"+ , "harbour"+ , "hard"+ , "harmony"+ , "hat"+ , "hate"+ , "head"+ , "healthy"+ , "hearing"+ , "heart"+ , "heat"+ , "help"+ , "high"+ , "history"+ , "hole"+ , "hollow"+ , "hook"+ , "hope"+ , "horn"+ , "horse"+ , "hospital"+ , "hour"+ , "house"+ , "humour"+ , "ice"+ , "idea"+ , "ill"+ , "important"+ , "impulse"+ , "increase"+ , "industry"+ , "ink"+ , "insect"+ , "instrument"+ , "insurance"+ , "interest"+ , "invention"+ , "iron"+ , "island"+ , "jelly"+ , "jewel"+ , "join"+ , "journey"+ , "judge"+ , "jump"+ , "kettle"+ , "key"+ , "kick"+ , "kind"+ , "kiss"+ , "knee"+ , "knife"+ , "knot"+ , "knowledge"+ , "land"+ , "language"+ , "last"+ , "late"+ , "laugh"+ , "law"+ , "lead"+ , "leaf"+ , "learning"+ , "leather"+ , "left"+ , "leg"+ , "letter"+ , "level"+ , "library"+ , "lift"+ , "light"+ , "like"+ , "limit"+ , "line"+ , "linen"+ , "lip"+ , "liquid"+ , "list"+ , "living"+ , "lock"+ , "long"+ , "look"+ , "loose"+ , "loss"+ , "loud"+ , "love"+ , "low"+ , "machine"+ , "male"+ , "man"+ , "manager"+ , "map"+ , "mark"+ , "market"+ , "married"+ , "mass"+ , "match"+ , "material"+ , "meal"+ , "measure"+ , "meat"+ , "medical"+ , "meeting"+ , "memory"+ , "metal"+ , "middle"+ , "military"+ , "milk"+ , "mind"+ , "mine"+ , "minute"+ , "mist"+ , "mixed"+ , "money"+ , "monkey"+ , "month"+ , "moon"+ , "morning"+ , "mother"+ , "motion"+ , "mountain"+ , "mouth"+ , "move"+ , "muscle"+ , "music"+ , "nail"+ , "name"+ , "narrow"+ , "nation"+ , "natural"+ , "necessary"+ , "neck"+ , "need"+ , "needle"+ , "nerve"+ , "net"+ , "new"+ , "news"+ , "night"+ , "noise"+ , "normal"+ , "nose"+ , "note"+ , "number"+ , "nut"+ , "observation"+ , "offer"+ , "office"+ , "oil"+ , "old"+ , "open"+ , "operation"+ , "opinion"+ , "opposite"+ , "orange"+ , "order"+ , "organization"+ , "ornament"+ , "oven"+ , "owner"+ , "page"+ , "pain"+ , "paint"+ , "paper"+ , "parallel"+ , "parcel"+ , "part"+ , "past"+ , "paste"+ , "payment"+ , "peace"+ , "pen"+ , "pencil"+ , "person"+ , "physical"+ , "picture"+ , "pig"+ , "pin"+ , "pipe"+ , "place"+ , "plane"+ , "plant"+ , "plate"+ , "play"+ , "pleasure"+ , "plough"+ , "pocket"+ , "point"+ , "poison"+ , "polish"+ , "political"+ , "poor"+ , "porter"+ , "position"+ , "possible"+ , "pot"+ , "potato"+ , "powder"+ , "power"+ , "present"+ , "price"+ , "print"+ , "prison"+ , "private"+ , "probable"+ , "process"+ , "produce"+ , "profit"+ , "property"+ , "prose"+ , "protest"+ , "public"+ , "pull"+ , "pump"+ , "punishment"+ , "purpose"+ , "push"+ , "quality"+ , "question"+ , "quick"+ , "quiet"+ , "rail"+ , "rain"+ , "range"+ , "rat"+ , "rate"+ , "ray"+ , "reaction"+ , "reading"+ , "ready"+ , "reason"+ , "receipt"+ , "record"+ , "red"+ , "regret"+ , "regular"+ , "relation"+ , "religion"+ , "representative"+ , "request"+ , "respect"+ , "responsible"+ , "rest"+ , "reward"+ , "rhythm"+ , "rice"+ , "right"+ , "ring"+ , "river"+ , "road"+ , "rod"+ , "roll"+ , "roof"+ , "room"+ , "root"+ , "rough"+ , "round"+ , "rub"+ , "rule"+ , "run"+ , "sad"+ , "safe"+ , "sail"+ , "salt"+ , "same"+ , "sand"+ , "scale"+ , "school"+ , "science"+ , "scissors"+ , "screw"+ , "sea"+ , "seat"+ , "second"+ , "secret"+ , "secretary"+ , "seed"+ , "selection"+ , "self"+ , "sense"+ , "separate"+ , "serious"+ , "servant"+ , "shade"+ , "shake"+ , "shame"+ , "sharp"+ , "sheep"+ , "shelf"+ , "ship"+ , "shirt"+ , "shock"+ , "shoe"+ , "short"+ , "shut"+ , "side"+ , "sign"+ , "silk"+ , "silver"+ , "simple"+ , "sister"+ , "size"+ , "skin"+ , "skirt"+ , "sky"+ , "sleep"+ , "slip"+ , "slope"+ , "slow"+ , "small"+ , "smash"+ , "smell"+ , "smile"+ , "smoke"+ , "smooth"+ , "snake"+ , "sneeze"+ , "snow"+ , "soap"+ , "society"+ , "sock"+ , "soft"+ , "solid"+ , "son"+ , "song"+ , "sort"+ , "sound"+ , "soup"+ , "space"+ , "spade"+ , "special"+ , "sponge"+ , "spoon"+ , "spring"+ , "square"+ , "stage"+ , "stamp"+ , "star"+ , "start"+ , "statement"+ , "station"+ , "steam"+ , "steel"+ , "stem"+ , "step"+ , "stick"+ , "sticky"+ , "stiff"+ , "stitch"+ , "stocking"+ , "stomach"+ , "stone"+ , "stop"+ , "store"+ , "story"+ , "straight"+ , "strange"+ , "street"+ , "stretch"+ , "strong"+ , "structure"+ , "substance"+ , "sudden"+ , "sugar"+ , "suggestion"+ , "summer"+ , "sun"+ , "support"+ , "surprise"+ , "sweet"+ , "swim"+ , "system"+ , "table"+ , "tail"+ , "talk"+ , "tall"+ , "taste"+ , "tax"+ , "teaching"+ , "tendency"+ , "test"+ , "theory"+ , "thick"+ , "thin"+ , "thing"+ , "thought"+ , "thread"+ , "throat"+ , "thumb"+ , "thunder"+ , "ticket"+ , "tight"+ , "time"+ , "tin"+ , "tired"+ , "toe"+ , "tongue"+ , "tooth"+ , "top"+ , "touch"+ , "town"+ , "trade"+ , "train"+ , "transport"+ , "tray"+ , "tree"+ , "trick"+ , "trouble"+ , "trousers"+ , "true"+ , "turn"+ , "twist"+ , "umbrella"+ , "unit"+ , "use"+ , "value"+ , "verse"+ , "vessel"+ , "view"+ , "violent"+ , "voice"+ , "waiting"+ , "walk"+ , "wall"+ , "war"+ , "warm"+ , "wash"+ , "waste"+ , "watch"+ , "water"+ , "wave"+ , "wax"+ , "way"+ , "weather"+ , "week"+ , "weight"+ , "wet"+ , "wheel"+ , "whip"+ , "whistle"+ , "white"+ , "wide"+ , "wind"+ , "window"+ , "wine"+ , "wing"+ , "winter"+ , "wire"+ , "wise"+ , "woman"+ , "wood"+ , "wool"+ , "word"+ , "work"+ , "worm"+ , "wound"+ , "writing"+ , "wrong"+ , "year"+ , "yellow"+ , "young"+ ]++randomName :: IO Text+randomName = do+ nameIdx <- randomRIO (0, length nameWords - 1)+ pure $ nameWords !! nameIdx++instanceNameGen :: IO Text+instanceNameGen = do+ name1 <- randomName+ name2 <- randomName+ pure $ name1 <> "-" <> name2
+ src/Cloudy/Path.hs view
@@ -0,0 +1,30 @@++module Cloudy.Path where++import System.Directory (getXdgDirectory, XdgDirectory (XdgConfig, XdgData), createDirectoryIfMissing)+import System.FilePath ( (</>) )++getCloudyConfDir :: IO FilePath+getCloudyConfDir = do+ cloudyConfDirLocal <- getXdgDirectory XdgConfig "cloudy"+ createDirectoryIfMissing True cloudyConfDirLocal+ pure cloudyConfDirLocal++getCloudyConfFilePath :: IO FilePath+getCloudyConfFilePath = do+ cloudyConfDirLocal <- getCloudyConfDir+ pure $ cloudyConfDirLocal </> "cloudy.yaml"++getCloudyInstanceSetupsDir :: IO FilePath+getCloudyInstanceSetupsDir = do+ cloudyConfDirLocal <- getCloudyConfDir+ let instanceSetupsDir = cloudyConfDirLocal </> "instance-setups"+ createDirectoryIfMissing False instanceSetupsDir+ pure instanceSetupsDir++getCloudyDbPath :: IO FilePath+getCloudyDbPath = do+ cloudyStateDirLocal <- getXdgDirectory XdgData "cloudy"+ createDirectoryIfMissing True cloudyStateDirLocal+ pure $ cloudyStateDirLocal </> "db.sqlite3"+
+ src/Cloudy/Scaleway.hs view
@@ -0,0 +1,590 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE EmptyDataDecls #-}++module Cloudy.Scaleway where++import Data.Aeson (ToJSON(..), object, (.=), FromJSON (..), withObject, Value, (.:), withText)+import Data.Map.Strict (Map)+import Data.Proxy (Proxy (Proxy))+import Data.Text (Text)+import Servant.API ((:>), Capture, ReqBody, JSON, AuthProtect, (:<|>) ((:<|>)), PostCreated, Get, QueryParam, Headers, Header, PlainText, NoContent, MimeRender (mimeRender), PatchNoContent, Accept (contentType), PostAccepted, Patch, DeleteNoContent, MimeUnrender (..))+import Servant.Client (client, ClientM)+import Servant.Client.Core (AuthenticatedRequest)+import Web.HttpApiData (ToHttpApiData (..), FromHttpApiData)+import Data.Aeson.Types (Parser)+import Data.Kind (Type)+import Data.Time (UTCTime)+import Network.HTTP.Media ((//))++data PlainTextNoUTF8++instance Accept PlainTextNoUTF8 where+ contentType _ = "text" // "plain"++instance MimeRender PlainTextNoUTF8 Text where+ mimeRender _ = mimeRender (Proxy @PlainText)++instance MimeUnrender PlainTextNoUTF8 Text where+ mimeUnrender _ = mimeUnrender (Proxy @PlainText)++newtype PerPage = PerPage { unPerPage :: Int }+ deriving stock Show+ deriving newtype (FromHttpApiData, FromJSON, ToHttpApiData, ToJSON)++newtype PageNum = PageNum { unPageNum :: Int }+ deriving stock Show+ deriving newtype (FromHttpApiData, FromJSON, ToHttpApiData, ToJSON)++type Paged :: forall k l. (k -> l -> Type) -> k -> l -> Type+type family Paged verb ct resp where+ Paged verb ct resp =+ QueryParam "per_page" PerPage :>+ QueryParam "page" PageNum :>+ verb ct (Headers '[Header "x-total-count" Int] resp)++data Zone = NL1 | NL2 | NL3+ deriving (Bounded, Enum, Eq, Show)+++instance ToJSON Zone where toJSON = toJSON . zoneToText+instance FromJSON Zone where+ parseJSON = withText "Zone" $ maybe (fail "Failed to parse Zone") pure . zoneFromText++allScalewayZones :: [Zone]+allScalewayZones = enumFromTo minBound maxBound++zoneToText :: Zone -> Text+zoneToText = \case+ NL1 -> "nl-ams-1"+ NL2 -> "nl-ams-2"+ NL3 -> "nl-ams-3"++zoneFromText :: Text -> Maybe Zone+zoneFromText = \case+ "nl-ams-1" -> Just NL1+ "nl-ams-2" -> Just NL2+ "nl-ams-3" -> Just NL3+ _ -> Nothing++instance ToHttpApiData Zone where+ toUrlPiece :: Zone -> Text+ toUrlPiece = zoneToText++newtype ImageId = ImageId { unImageId :: Text }+ deriving stock (Eq, Show)+ deriving newtype (FromHttpApiData, FromJSON, ToHttpApiData, ToJSON)++newtype IpId = IpId { unIpId :: Text }+ deriving stock (Eq, Show)+ deriving newtype (FromHttpApiData, FromJSON, ToHttpApiData, ToJSON)++newtype OrganizationId = OrganizationId { unOrganizationId :: Text }+ deriving stock (Eq, Show)+ deriving newtype (FromHttpApiData, FromJSON, ToHttpApiData, ToJSON)++newtype ProjectId = ProjectId { unProjectId :: Text }+ deriving stock (Eq, Show)+ deriving newtype (FromHttpApiData, FromJSON, ToHttpApiData, ToJSON)++newtype ServerId = ServerId { unServerId :: Text }+ deriving stock (Eq, Show)+ deriving newtype (FromHttpApiData, FromJSON, ToHttpApiData, ToJSON)++newtype VolumeId = VolumeId { unVolumeId :: Text }+ deriving stock (Eq, Show)+ deriving newtype (FromHttpApiData, FromJSON, ToHttpApiData, ToJSON)++newtype UserDataKey = UserDataKey { unUserDataKey :: Text }+ deriving stock (Eq, Show)+ deriving newtype (FromHttpApiData, FromJSON, ToHttpApiData, ToJSON)++newtype UserData = UserData { unUserData :: Text }+ deriving stock (Eq, Show)+ deriving newtype (MimeRender PlainTextNoUTF8, MimeUnrender PlainTextNoUTF8)++data ServersReqVolume = ServersReqVolume+ { {- name :: Text+ , -} size :: Int+ , volumeType :: Text+ }+ deriving stock Show++instance ToJSON ServersReqVolume where+ toJSON volume =+ object+ [ {- "name" .= volume.name+ , -} "size" .= volume.size+ , "volume_type" .= volume.volumeType+ ]++data ServersRespVolume = ServersRespVolume+ { id :: VolumeId+ , name :: Text+ , size :: Int+ , volumeType :: Text+ }+ deriving stock Show++instance FromJSON ServersRespVolume where+ parseJSON :: Value -> Parser ServersRespVolume+ parseJSON = withObject "ServersRespVolume" $ \o -> do+ id_ <- o .: "id"+ name <- o .: "name"+ size <- o .: "size"+ volumeType <- o .: "volume_type"+ pure ServersRespVolume { id = id_, name, size, volumeType }++data IpsReq = IpsReq+ { type_ :: Text+ , project :: ProjectId+ }+ deriving stock Show++instance ToJSON IpsReq where+ toJSON ipsReq =+ object+ [ "type" .= ipsReq.type_+ , "project" .= ipsReq.project+ ]++data IpsResp = IpsResp+ { id :: IpId+ , address :: Text+ , organization :: OrganizationId+ , project :: ProjectId+ , zone :: Zone+ }+ deriving stock Show++instance FromJSON IpsResp where+ parseJSON :: Value -> Parser IpsResp+ parseJSON = withObject "IpsResp outer wrapper" $ \o -> do+ innerObj <- o .: "ip"+ id_ <- innerObj .: "id"+ address <- innerObj .: "address"+ organization <- innerObj .: "organization"+ project <- innerObj .: "project"+ zone <- innerObj .: "zone"+ pure IpsResp { id = id_, address, organization, project, zone }++data ServersReq = ServersReq+ { bootType :: Text+ , commercialType :: Text+ , image :: ImageId+ , name :: Text+ , publicIps :: [IpId]+ , tags :: [Text]+ , volumes :: Map Text ServersReqVolume+ , project :: ProjectId+ }+ deriving stock Show++instance ToJSON ServersReq where+ toJSON serversReq =+ object+ [ "boot_type" .= serversReq.bootType+ , "commercial_type" .= serversReq.commercialType+ , "image" .= serversReq.image+ , "name" .= serversReq.name+ , "public_ips" .= serversReq.publicIps+ , "tags" .= serversReq.tags+ , "volumes" .= serversReq.volumes+ , "project" .= serversReq.project+ ]++data ServersResp = ServersResp+ { id :: ServerId+ , name :: Text+ , volumes :: Map Text ServersRespVolume+ , state :: Text+ }+ deriving stock Show++instance FromJSON ServersResp where+ parseJSON :: Value -> Parser ServersResp+ parseJSON = withObject "ServersResp outer wrapper" $ \o -> do+ innerObj <- o .: "server"+ id_ <- innerObj .: "id"+ name <- innerObj .: "name"+ volumes <- innerObj .: "volumes"+ state <- innerObj .: "state"+ pure ServersResp { id = id_, name, volumes, state }++data ServersActionReq = ServersActionReq+ { action :: Text+ }+ deriving stock Show++instance ToJSON ServersActionReq where+ toJSON serversActionReq =+ object+ [ "action" .= serversActionReq.action+ ]++data VolumesReq = VolumesReq+ { name :: Text+ }+ deriving stock Show++instance ToJSON VolumesReq where+ toJSON volumesReq =+ object+ [ "name" .= volumesReq.name+ ]++data TaskResp = TaskResp+ { id :: Text+ , description :: Text+ , status :: Text+ }+ deriving stock Show++instance FromJSON TaskResp where+ parseJSON :: Value -> Parser TaskResp+ parseJSON = withObject "TaskResp outer wrapper" $ \o -> do+ innerObj <- o .: "task"+ id_ <- innerObj .: "id"+ description <- innerObj .: "description"+ status <- innerObj .: "status"+ pure TaskResp { id = id_, description, status }++data VolumeConstraint = VolumeConstraint+ { minSize :: Int+ , maxSize :: Int+ }+ deriving stock Show++instance FromJSON VolumeConstraint where+ parseJSON :: Value -> Parser VolumeConstraint+ parseJSON = withObject "VolumeConstraint" $ \o -> do+ minSize <- o .: "min_size"+ maxSize <- o .: "max_size"+ pure VolumeConstraint { minSize, maxSize }++newtype ProductServersResp = ProductServersResp+ { unProductServersResp :: Map Text ProductServer }+ deriving stock Show++instance FromJSON ProductServersResp where+ parseJSON :: Value -> Parser ProductServersResp+ parseJSON = withObject "ProductServersResp outer wrapper" $ \o -> do+ productServers <- o .: "servers"+ pure $ ProductServersResp productServers++data ProductServer = ProductServer+ { monthlyPrice :: Float+ , ncpus :: Int+ , ram :: Int+ , arch :: Text+ , sumInternetBandwidth :: Int+ , altNames :: [Text]+ , volumesConstraint :: VolumeConstraint+ }+ deriving stock Show++instance FromJSON ProductServer where+ parseJSON :: Value -> Parser ProductServer+ parseJSON = withObject "ProductServer" $ \o -> do+ altNames <- o .: "alt_names"+ monthlyPrice <- o .: "monthly_price"+ ncpus <- o .: "ncpus"+ ram <- o .: "ram"+ arch <- o .: "arch"+ volumesConstraint <- o .: "volumes_constraint"+ networkObj <- o .: "network"+ sumInternetBandwidth <- networkObj .: "sum_internal_bandwidth"+ pure ProductServer+ { monthlyPrice+ , ncpus+ , ram+ , sumInternetBandwidth+ , arch+ , altNames+ , volumesConstraint+ }++newtype ProductServersAvailabilityResp = ProductServersAvailabilityResp { unProductServersAvailabilityResp :: Map Text Text }+ deriving stock Show++instance FromJSON ProductServersAvailabilityResp where+ parseJSON :: Value -> Parser ProductServersAvailabilityResp+ parseJSON = withObject "ProductServersAvailabilityResp outer wrapper" $ \o -> do+ serversObj :: Map Text Value <- o .: "servers"+ availabilityMap <- traverse parseAvail serversObj+ pure $ ProductServersAvailabilityResp availabilityMap+ where+ parseAvail :: Value -> Parser Text+ parseAvail = withObject "ProductServersAvailability availability obj" $ \a -> a .: "availability"++newtype ImagesResp = ImagesResp { unImagesResp :: [Image] }+ deriving stock Show++instance FromJSON ImagesResp where+ parseJSON :: Value -> Parser ImagesResp+ parseJSON = withObject "ImagesResp outer wrapper" $ \o -> do+ images <- o .: "images"+ pure $ ImagesResp images++data Image = Image+ { id :: Text+ , name :: Text+ , arch :: Text+ , creationDate :: UTCTime+ , modificationDate :: UTCTime+ , state :: Text+ , rootVolId :: Text+ , rootVolName :: Text+ , rootVolType :: Text+ , rootVolSize :: Int+ }+ deriving stock Show++instance FromJSON Image where+ parseJSON :: Value -> Parser Image+ parseJSON = withObject "Image" $ \o -> do+ id' <- o .: "id"+ name <- o .: "name"+ arch <- o .: "arch"+ creationDate <- o .: "creation_date"+ modificationDate <- o .: "modification_date"+ state <- o .: "state"+ rootVol <- o .: "root_volume"+ rootVolId <- rootVol .: "id"+ rootVolName <- rootVol .: "name"+ rootVolType <- rootVol .: "volume_type"+ rootVolSize <- rootVol .: "size"+ pure+ Image+ { id = id'+ , name+ , arch+ , creationDate+ , modificationDate+ , state+ , rootVolId+ , rootVolName+ , rootVolType+ , rootVolSize+ }++type InstanceIpsPostApi =+ AuthProtect "auth-token" :>+ "instance" :>+ "v1" :>+ "zones" :>+ Capture "zone" Zone :>+ "ips" :>+ ReqBody '[JSON] IpsReq :>+ PostCreated '[JSON] IpsResp++type InstanceIpsDeleteApi =+ AuthProtect "auth-token" :>+ "instance" :>+ "v1" :>+ "zones" :>+ Capture "zone" Zone :>+ "ips" :>+ Capture "ip_id" IpId :>+ DeleteNoContent++type InstanceServersPostApi =+ AuthProtect "auth-token" :>+ "instance" :>+ "v1" :>+ "zones" :>+ Capture "zone" Zone :>+ "servers" :>+ ReqBody '[JSON] ServersReq :>+ PostCreated '[JSON] ServersResp++type InstanceServersGetApi =+ AuthProtect "auth-token" :>+ "instance" :>+ "v1" :>+ "zones" :>+ Capture "zone" Zone :>+ "servers" :>+ Capture "server_id" ServerId :>+ Get '[JSON] ServersResp++type InstanceServersActionPostApi =+ AuthProtect "auth-token" :>+ "instance" :>+ "v1" :>+ "zones" :>+ Capture "zone" Zone :>+ "servers" :>+ Capture "server_id" ServerId :>+ "action" :>+ ReqBody '[JSON] ServersActionReq :>+ PostAccepted '[JSON] TaskResp++type InstanceServersUserDataGetApi =+ AuthProtect "auth-token" :>+ "instance" :>+ "v1" :>+ "zones" :>+ Capture "zone" Zone :>+ "servers" :>+ Capture "server_id" ServerId :>+ "user_data" :>+ Capture "key" UserDataKey :>+ Get '[PlainTextNoUTF8] UserData++type InstanceServersUserDataPatchApi =+ AuthProtect "auth-token" :>+ "instance" :>+ "v1" :>+ "zones" :>+ Capture "zone" Zone :>+ "servers" :>+ Capture "server_id" ServerId :>+ "user_data" :>+ Capture "key" UserDataKey :>+ ReqBody '[PlainTextNoUTF8] UserData :>+ PatchNoContent++type InstanceVolumesPatchApi =+ AuthProtect "auth-token" :>+ "instance" :>+ "v1" :>+ "zones" :>+ Capture "zone" Zone :>+ "volumes" :>+ Capture "volume_id" VolumeId :>+ ReqBody '[JSON] VolumesReq :>+ Patch '[JSON] Value++type InstanceProductsServersGetApi =+ AuthProtect "auth-token" :>+ "instance" :>+ "v1" :>+ "zones" :>+ Capture "zone" Zone :>+ "products" :>+ "servers" :>+ QueryParam "per_page" PerPage :>+ Get '[JSON] ProductServersResp++type InstanceProductsServersAvailabilityGetApi =+ AuthProtect "auth-token" :>+ "instance" :>+ "v1" :>+ "zones" :>+ Capture "zone" Zone :>+ "products" :>+ "servers" :>+ "availability" :>+ QueryParam "per_page" PerPage :>+ Get '[JSON] ProductServersAvailabilityResp++type InstanceImagesGetApi =+ AuthProtect "auth-token" :>+ "instance" :>+ "v1" :>+ "zones" :>+ Capture "zone" Zone :>+ "images" :>+ QueryParam "arch" Text :>+ Paged Get '[JSON] ImagesResp++type ScalewayApi =+ InstanceIpsPostApi :<|>+ InstanceIpsDeleteApi :<|>+ InstanceServersPostApi :<|>+ InstanceServersGetApi :<|>+ InstanceServersActionPostApi :<|>+ InstanceServersUserDataGetApi :<|>+ InstanceServersUserDataPatchApi :<|>+ InstanceVolumesPatchApi :<|>+ InstanceProductsServersGetApi :<|>+ InstanceProductsServersAvailabilityGetApi :<|>+ InstanceImagesGetApi++scalewayApi :: Proxy ScalewayApi+scalewayApi = Proxy++ipsPostApi ::+ AuthenticatedRequest (AuthProtect "auth-token") ->+ Zone ->+ IpsReq ->+ ClientM IpsResp++ipsDeleteApi ::+ AuthenticatedRequest (AuthProtect "auth-token") ->+ Zone ->+ IpId ->+ ClientM NoContent++serversPostApi ::+ AuthenticatedRequest (AuthProtect "auth-token") ->+ Zone ->+ ServersReq ->+ ClientM ServersResp++serversGetApi ::+ AuthenticatedRequest (AuthProtect "auth-token") ->+ Zone ->+ ServerId ->+ ClientM ServersResp++serversActionPostApi ::+ AuthenticatedRequest (AuthProtect "auth-token") ->+ Zone ->+ ServerId ->+ ServersActionReq ->+ ClientM TaskResp++serversUserDataGetApi ::+ AuthenticatedRequest (AuthProtect "auth-token") ->+ Zone ->+ ServerId ->+ UserDataKey ->+ ClientM UserData++serversUserDataPatchApi ::+ AuthenticatedRequest (AuthProtect "auth-token") ->+ Zone ->+ ServerId ->+ UserDataKey ->+ UserData ->+ ClientM NoContent++volumesPatchApi ::+ AuthenticatedRequest (AuthProtect "auth-token") ->+ Zone ->+ VolumeId ->+ VolumesReq ->+ ClientM Value++productsServersGetApi ::+ AuthenticatedRequest (AuthProtect "auth-token") ->+ Zone ->+ Maybe PerPage ->+ ClientM ProductServersResp++productsServersAvailabilityGetApi ::+ AuthenticatedRequest (AuthProtect "auth-token") ->+ Zone ->+ Maybe PerPage ->+ ClientM ProductServersAvailabilityResp++imagesGetApi ::+ AuthenticatedRequest (AuthProtect "auth-token") ->+ Zone ->+ Maybe Text ->+ Maybe PerPage ->+ Maybe PageNum ->+ ClientM (Headers '[Header "x-total-count" Int] ImagesResp)++ipsPostApi+ :<|> ipsDeleteApi+ :<|> serversPostApi+ :<|> serversGetApi+ :<|> serversActionPostApi+ :<|> serversUserDataGetApi+ :<|> serversUserDataPatchApi+ :<|> volumesPatchApi+ :<|> productsServersGetApi+ :<|> productsServersAvailabilityGetApi+ :<|> imagesGetApi = client scalewayApi
+ src/Cloudy/Table.hs view
@@ -0,0 +1,97 @@++module Cloudy.Table where++import Control.Monad (when)+import Data.List.NonEmpty (NonEmpty ((:|)), cons, transpose)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Control.Exception (assert)++data Align = LeftJustified | Centered | RightJustified++data Table = Table+ { tableHeaders :: NonEmpty (Align, Text)+ , tableBodyRows :: NonEmpty (NonEmpty Text)+ }++printTable :: Table -> IO ()+printTable Table{tableHeaders, tableBodyRows} = do+ assertRowsSameLengths tableHeaders tableBodyRows+ let rawTable = renderTable tableHeaders tableBodyRows+ Text.putStrLn rawTable++assertRowsSameLengths :: NonEmpty a -> NonEmpty (NonEmpty b) -> IO ()+assertRowsSameLengths headers bodyRows =+ when (any (\row -> length headers /= length row) bodyRows) $+ error "Body row does not contain same number of elements as header row"++renderTable :: NonEmpty (Align, Text) -> NonEmpty (NonEmpty Text) -> Text+renderTable headers body =+ let headerTexts = fmap snd headers+ maxWidths = getMaxWidths $ cons headerTexts body+ maxAlignWidths = NonEmpty.zip (fmap fst headers) maxWidths+ rawHeaders = renderHeaders maxWidths headerTexts+ rawBody = renderBody maxAlignWidths body+ fatDiv = renderDiv True maxWidths "="+ skinnyDiv = renderDiv False maxWidths "-"+ in+ Text.intercalate+ "\n"+ [ skinnyDiv+ , rawHeaders+ , fatDiv+ , rawBody+ , skinnyDiv+ ]++renderDiv :: Bool -> NonEmpty Int -> Text -> Text+renderDiv shouldUseHorizontalDivs maxWidths c =+ let divider = if shouldUseHorizontalDivs then c <> "|" <> c else c <> c <> c+ rowMiddle = Text.intercalate divider . NonEmpty.toList $ fmap (\width -> Text.replicate width c) maxWidths+ in "|" <> c <> rowMiddle <> c <> "|"++renderHeaders :: NonEmpty Int -> NonEmpty Text -> Text+renderHeaders maxWidths headers =+ renderRow (zipThreeNE (Centered :| repeat Centered) maxWidths headers)++zipThreeNE :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty (a, b, c)+zipThreeNE (a :| as) (b :| bs) (c :| cs) = (a,b,c) :| zipThree as bs cs++zipThree :: [a] -> [b] -> [c] -> [(a,b,c)]+zipThree = \cases+ [] _ _ -> []+ _ [] _ -> []+ _ _ [] -> []+ (a : as) (b : bs) (c : cs) -> (a,b,c) : zipThree as bs cs++renderBody :: NonEmpty (Align, Int) -> NonEmpty (NonEmpty Text) -> Text+renderBody maxAlignWidths body =+ Text.intercalate "\n" $ NonEmpty.toList $ fmap (renderRow . zipOneMore maxAlignWidths) body++zipOneMore :: NonEmpty (a, b) -> NonEmpty c -> NonEmpty (a, b, c)+zipOneMore = NonEmpty.zipWith (\(a, b) c -> (a, b, c))++renderRow :: NonEmpty (Align, Int, Text) -> Text+renderRow columnInfo =+ let rowMiddle = Text.intercalate " | " . NonEmpty.toList $ fmap renderColumn columnInfo+ in "| " <> rowMiddle <> " |"++renderColumn :: (Align, Int, Text) -> Text+renderColumn (align, maxWidth, t) =+ let textWidth = Text.length t+ remainingLength = maxWidth - textWidth+ paddedText =+ case align of+ LeftJustified -> t <> Text.replicate remainingLength " "+ Centered ->+ let (surroundingLength, extra) = quotRem remainingLength 2+ leftSpace = Text.replicate surroundingLength " "+ rightSpace = Text.replicate (surroundingLength + extra) " "+ in leftSpace <> t <> rightSpace+ RightJustified -> Text.replicate remainingLength " " <> t+ in assert (remainingLength >= 0) paddedText++getMaxWidths :: NonEmpty (NonEmpty Text) -> NonEmpty Int+getMaxWidths = fmap (maximum . fmap Text.length) . transpose
+ test/DocTest.hs view
@@ -0,0 +1,12 @@++module Main where++import Build_doctests (flags, pkgs, module_sources)+import Test.DocTest (doctest)++main :: IO ()+main = do+ doctest args+ where+ args :: [String]+ args = flags ++ pkgs ++ module_sources
+ test/Test.hs view
@@ -0,0 +1,8 @@++module Main where++import Test.Cloudy (cloudyTests)+import Test.Tasty (defaultMain)++main :: IO ()+main = defaultMain cloudyTests
+ test/Test/Cloudy.hs view
@@ -0,0 +1,12 @@++module Test.Cloudy where++import Test.Cloudy.InstanceSetup (instanceSetupTests)+import Test.Tasty (TestTree, testGroup)++cloudyTests :: TestTree+cloudyTests =+ testGroup+ "Cloudy"+ [ instanceSetupTests+ ]
+ test/Test/Cloudy/InstanceSetup.hs view
@@ -0,0 +1,20 @@++module Test.Cloudy.InstanceSetup where++import Cloudy.InstanceSetup (builtInInstanceSetups)+import Control.Exception (evaluate)+import Control.Monad (void)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++instanceSetupTests :: TestTree+instanceSetupTests =+ testGroup+ "InstanceSetup"+ [ builtInInstanceSetupsNoException+ ]++builtInInstanceSetupsNoException :: TestTree+builtInInstanceSetupsNoException =+ testCase "builtInInstanceSetups should never throw an exception" $+ void $ evaluate builtInInstanceSetups