├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── ec2-unikernel.cabal ├── package.sh ├── packaging ├── debian │ ├── changelog │ ├── compat │ ├── control │ ├── copyright │ ├── docs │ ├── install │ ├── rules │ └── source │ │ └── format ├── ec2-unikernel.dsc └── ec2-unikernel.spec ├── policies ├── role-policy.json └── trust-policy.json ├── src ├── CommandLine.hs ├── Main.hs └── Options.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .cabal-sandbox/ 3 | rpmbuild/ 4 | results/ 5 | cabal.sandbox.config 6 | *.raw 7 | *.swp 8 | ec2-unikernel-* 9 | ec2-unikernel_* 10 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | ghc: 4 | - "7.10" 5 | - "8.0" 6 | - "8.2" 7 | - "8.4" 8 | 9 | install: travis_wait 45 cabal install --only-dependencies --enable-tests 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Adam Wick 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Adam Wick nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ec2-unikernel 2 | 3 | This tool is designed to provide a single-step mechanism for uploading 4 | your unikernels to run on EC2. At its core, it takes an ELF binary that 5 | is the unikernel, along with any auxiliary modules, uploads them to S3, 6 | and them bundles the whole collection as an AMI that you can then launch 7 | at will. 8 | 9 | THIS SOFTWARE IS ALPHA QUALITY. BE WARNED. 10 | 11 | ## Where to Get Binaries 12 | 13 | ### Fedora Binaries 14 | 15 | The easiest way to get binary installations for Fedora 22, 23, and 24 16 | is through the HaLVM repositories. Using this method will also get you 17 | automatically updated when successive versions come out. To use the 18 | HaLVM repositories, run `dnf install` with one of the following links, 19 | depending on your version and architecture: 20 | 21 | * Fedora 22 (32-bit): 22 | (http://repos.halvm.org/fedora-22/i686/halvm-yum-repo-22-3.fc22.noarch.rpm) 23 | * Fedora 23 (32-bit): 24 | (http://repos.halvm.org/fedora-23/i686/halvm-yum-repo-23-3.fc23.noarch.rpm) 25 | * Fedora 24 (32-bit): 26 | (http://repos.halvm.org/fedora-24/i686/halvm-yum-repo-24-3.fc24.noarch.rpm) 27 | * Fedora 22 (64-bit): 28 | (http://repos.halvm.org/fedora-22/x86_64/halvm-yum-repo-22-3.fc22.noarch.rpm) 29 | * Fedora 23 (64-bit): 30 | (http://repos.halvm.org/fedora-23/x86_64/halvm-yum-repo-23-3.fc23.noarch.rpm) 31 | * Fedora 24 (64-bit): 32 | (http://repos.halvm.org/fedora-24/x86_64/halvm-yum-repo-24-3.fc24.noarch.rpm) 33 | 34 | Then run `dnf update` to get all the information you need on the 35 | packages in this repository, and `dnf install ec2-unikernel` to install 36 | the tool 37 | 38 | ### Ubuntu Binaries 39 | 40 | Ubuntu binaries are also available on `repos.halvm.org`, although not 41 | in a nice friendly repository structure. (As an aside, if someone wants 42 | to tell me how I could make such a thing, please send me an email.) So 43 | you'll just need to download these manually: 44 | 45 | * Ubuntu 16.04 (32-bit): 46 | (http://repos.halvm.org/ubuntu-16.04/i686/ec2-unikernel_0.9-1_i386.deb) 47 | * Ubuntu 16.04 (64-bit): 48 | (http://repos.halvm.org/ubuntu-16.04/x86_64/ec2-unikernel_0.9-1_amd64.deb) 49 | 50 | Both of these packages should be signed with the HaLVM Maintainer key (fetch 51 | [here](http://repos.halvm.org/RPM-GPG-KEY-HaLVM), fingerprint 6240d595) using 52 | the `dpkg-sig` tool, if you want to verify the release. 53 | 54 | ## Installation 55 | 56 | First, we always suggest using a binary from the previous section, as 57 | they will usually tell you about any software prerequisites you are 58 | missing. (See the section on "Prerequisites" for non-software requirements.) 59 | 60 | If you're prefer to build from source, you can either pull the latest 61 | version from Hackage by doing: 62 | 63 | ``` 64 | cabal install ec2-unikernel 65 | ``` 66 | 67 | Or you can get the bleeding edge by pulling this repository and running 68 | `cabal install` directly. If you do the latter, let me suggest that a 69 | sandbox (or the forthcoming new-configure/new-build/new-install chain) 70 | might be your friend, as `ec2-unikernel` has one hell of a dependency 71 | chain. 72 | 73 | ## Limitations 74 | 75 | At the moment, `ec2-unikernel` only works with paravirtualized, 64-bit 76 | binaries. Extending the latter to support 32-bit binaries would be a 77 | lovely introductory project for someone who wants to join the project. 78 | Support for HVM domains might be a bit more work. 79 | 80 | In addition, `ec2-unikernel` only works on Linux systems with the `guestfish` 81 | program installed. 82 | 83 | ## Prerequisites 84 | 85 | This program has three prerequisites: 86 | 87 | * You must have an AWS account, account key, and secret key, with all 88 | the relevant permissions to create S3 buckets and objects and register 89 | EC2 snapshots and APIs. 90 | 91 | * As part of this, you must create a `vmimport` role and use it. (Another 92 | feature for someone to add: allow people to use a different name for 93 | this role.) See [this page from 94 | Amazon](https://docs.aws.amazon.com/AWSEC2/latest/UserGuide/VMImportPrerequisites.html#vmimport-service-role). 95 | You can find the policy files they mention in the `policies/` subdirectory. 96 | 97 | * You must have installed the `guestfish` program. 98 | 99 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ec2-unikernel.cabal: -------------------------------------------------------------------------------- 1 | name: ec2-unikernel 2 | version: 0.9.8 3 | synopsis: A handy tool for uploading unikernels to Amazon's EC2. 4 | description: This tool uploads unikernels built with the HaLVM, Mirage, 5 | or other tools to Amazon's cloud. The unikernel will then 6 | appear as an AMI, which can be run and shared as needed. 7 | homepage: http://github.com/GaloisInc/ec2-unikernel 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Adam Wick 11 | maintainer: Adam Wick 12 | copyright: Copyright 2016 Galois, Inc. 13 | category: AWS, Unikernel 14 | build-type: Simple 15 | extra-doc-files: README.md 16 | cabal-version: >=1.18 17 | Tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3 18 | 19 | executable ec2-unikernel 20 | main-is: Main.hs 21 | other-modules: Options, CommandLine 22 | default-extensions: OverloadedStrings, TemplateHaskell 23 | ghc-options: -Wall 24 | build-depends: 25 | amazonka >= 1.5.0 && < 1.7.0, 26 | amazonka-core >= 1.5.0 && < 1.7.0, 27 | amazonka-ec2 >= 1.5.0 && < 1.7.0, 28 | amazonka-s3 >= 1.5.0 && < 1.7.0, 29 | base >= 4.7.0 && < 5.0.0, 30 | bytestring >= 0.10 && < 0.12, 31 | directory >= 1.2.2 && < 1.4, 32 | filepath >= 1.3.0 && < 1.5, 33 | lens >= 4.13 && < 5.0, 34 | process >= 1.2 && < 1.7, 35 | semigroups >= 0.18 && < 0.20, 36 | temporary >= 1.2.0 && < 1.4, 37 | text >= 1.2.2 && < 1.4, 38 | time >= 1.5 && < 1.10, 39 | unix >= 2.7.1 && < 2.9 40 | hs-source-dirs: src 41 | default-language: Haskell2010 42 | 43 | source-repository head 44 | type: git 45 | location: git://github.com/GaloisInc/ec2-unikernel.git 46 | -------------------------------------------------------------------------------- /package.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | rpm_package() { 4 | mkdir -p rpmbuild/{SOURCES,SPECS} 5 | mkdir -p packages 6 | cabal sdist 7 | cp dist/ec2-unikernel*.tar.gz rpmbuild/SOURCES/ 8 | cp packaging/ec2-unikernel.spec rpmbuild/SPECS/ 9 | rpmbuild -ba --define "_version ${MY_VERSION}" \ 10 | --define "_topdir ${TOPDIR}/rpmbuild" \ 11 | rpmbuild/SPECS/ec2-unikernel.spec 12 | cp rpmbuild/RPMS/*/ec2-unikernel-${MY_VERSION}-1.fc*.rpm packages/ 13 | cp rpmbuild/SRPMS/ec2-unikernel-${MY_VERSION}-1.*.src.rpm packages/ 14 | } 15 | 16 | deb_package() { 17 | # get the base tarball 18 | SRC_TARBALL=ec2-unikernel_${MY_VERSION}.orig.tar.gz 19 | cabal sdist 20 | cp dist/ec2-unikernel*.tar.gz ./${SRC_TARBALL} 21 | 22 | # get the weird debian configuration tarball 23 | CONF_TARBALL=ec2-unikernel_${MY_VERSION}-1.debian.tar.gz 24 | NOW=`date -R` 25 | rm -rf tmp 26 | mkdir tmp 27 | cp -r packaging/debian tmp/debian 28 | sed -i -e "s!VERSION!${MY_VERSION}!g" -e "s!NOW!${NOW}!g" tmp/debian/changelog 29 | tar cz -C tmp -f ${CONF_TARBALL} debian/ 30 | rm -rf tmp 31 | 32 | # build the desc file 33 | DESC_FILE=ec2-unikernel_${MY_VERSION}-1.dsc 34 | ORIG_SHA1=`openssl sha -sha1 ${SRC_TARBALL} | sed 's/.*= //g'` 35 | ORIG_SHA256=`openssl sha -sha256 ${SRC_TARBALL} | sed 's/.*= //g'` 36 | ORIG_SIZE=`stat -c "%s" ${SRC_TARBALL}` 37 | CONF_SHA1=`openssl sha -sha1 ${CONF_TARBALL} | sed 's/.*= //g'` 38 | CONF_SHA256=`openssl sha -sha256 ${CONF_TARBALL} | sed 's/.*= //g'` 39 | CONF_SIZE=`stat -c "%s" ${CONF_TARBALL}` 40 | sed -e "s!ORIG_SHA1!${ORIG_SHA1}!g" \ 41 | -e "s!CONF_SHA1!${CONF_SHA1}!g" \ 42 | -e "s!ORIG_SHA256!${ORIG_SHA256}!g" \ 43 | -e "s!CONF_SHA256!${CONF_SHA256}!g" \ 44 | -e "s!ORIG_SIZE!${ORIG_SIZE}!g" \ 45 | -e "s!CONF_SIZE!${CONF_SIZE}!g" \ 46 | -e "s!VERSION!${MY_VERSION}!g" \ 47 | packaging/ec2-unikernel.dsc > ${DESC_FILE} 48 | 49 | # now actually build the thing 50 | tar zxf ${SRC_TARBALL} 51 | tar zxf ${CONF_TARBALL} -C ec2-unikernel-${MY_VERSION} 52 | (cd ec2-unikernel-${MY_VERSION} && dpkg-buildpackage -rfakeroot -uc -us) 53 | 54 | # save the packages 55 | mkdir -p packages 56 | cp *.deb packages/ 57 | cp *.dsc packages/ 58 | cp *.changes packages/ 59 | } 60 | 61 | . /etc/os-release 62 | 63 | which ghc > /dev/null 64 | if [ $? != 0 ]; then 65 | echo "GHC is required for package generation!" 66 | exit 1 67 | fi 68 | 69 | which cabal > /dev/null 70 | if [ $? != 0 ]; then 71 | echo "Cabal-install is required for package generation!" 72 | exit 1 73 | fi 74 | 75 | case "${ID}" in 76 | "ubuntu") TYPE="deb" ;; 77 | "debian") TYPE="deb" ;; 78 | "fedora") TYPE="rpm" ;; 79 | "centos") TYPE="rpm" ;; 80 | *) TYPE="unknown" ;; 81 | esac 82 | 83 | MY_VERSION=`grep "^version: " ec2-unikernel.cabal | sed "s/version: *//g"` 84 | TOPDIR=`pwd` 85 | echo "Building a ${TYPE} package for version ${MY_VERSION}" 86 | 87 | case "${TYPE}" in 88 | "deb") deb_package ;; 89 | "rpm") rpm_package ;; 90 | *) echo "Unknown package type."; exit 2 ;; 91 | esac 92 | -------------------------------------------------------------------------------- /packaging/debian/changelog: -------------------------------------------------------------------------------- 1 | ec2-unikernel (VERSION-1) unstable; urgency=low 2 | 3 | * Debian packaging 4 | 5 | -- Adam Wick NOW 6 | 7 | -------------------------------------------------------------------------------- /packaging/debian/compat: -------------------------------------------------------------------------------- 1 | 9 2 | -------------------------------------------------------------------------------- /packaging/debian/control: -------------------------------------------------------------------------------- 1 | Source: ec2-unikernel 2 | Section: devel 3 | Priority: optional 4 | Maintainer: HaLVM Maintainers 5 | Build-Depends: debhelper (>= 8.0.0), ghc, cabal-install, zlib1g, libghc-lens-dev, libghc-profunctors-dev, libghc-unix-dev, libghc-tls-dev, libghc-temporary-dev 6 | Standards-Version: 3.9.4 7 | Homepage: http://github.com/GaloisInc/ec2-unikernel 8 | Vcs-Git: git://github.com/GaloisInc/ec2-unikernel 9 | Vcs-Browser: http://github.com/GaloisInc/ec2-unikernel 10 | 11 | Package: ec2-unikernel 12 | Architecture: amd64 i386 13 | Depends: libguestfs-tools, libgmp, zlib1g 14 | Description: A tool for uploading unikernels to EC2 15 | A tool for automatically uploading, importing, and registering 16 | unikernels into EC2. Includes support for initrds / initramfs / 17 | modules, as well, and should be configurable via normal ec2 18 | environment variables and falgs. 19 | -------------------------------------------------------------------------------- /packaging/debian/copyright: -------------------------------------------------------------------------------- 1 | Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ 2 | Upstream-Name: ec2-unikernel 3 | Source: http://github.com/GaloisInc/ec2-unikernel 4 | 5 | Files: * 6 | Copyright: 2016 Galois, Inc. 7 | License: BSD-3-Clause 8 | 9 | Files: debian/* 10 | Copyright: 2016 Galois Inc. 11 | License: BSD-3-Clause 12 | 13 | License: BSD-3-Clause 14 | Redistribution and use in source and binary forms, with or without 15 | modification, are permitted provided that the following conditions 16 | are met: 17 | 1. Redistributions of source code must retain the above copyright 18 | notice, this list of conditions and the following disclaimer. 19 | 2. Redistributions in binary form must reproduce the above copyright 20 | notice, this list of conditions and the following disclaimer in the 21 | documentation and/or other materials provided with the distribution. 22 | 3. Neither the name of the University nor the names of its contributors 23 | may be used to endorse or promote products derived from this software 24 | without specific prior written permission. 25 | . 26 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 27 | ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 28 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 29 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE HOLDERS OR 30 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 31 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 32 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 33 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 34 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 35 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 36 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 37 | -------------------------------------------------------------------------------- /packaging/debian/docs: -------------------------------------------------------------------------------- 1 | README.md 2 | -------------------------------------------------------------------------------- /packaging/debian/install: -------------------------------------------------------------------------------- 1 | .cabal-sandbox/bin/ec2-unikernel usr/bin/ 2 | -------------------------------------------------------------------------------- /packaging/debian/rules: -------------------------------------------------------------------------------- 1 | #!/usr/bin/make -f 2 | # -*- makefile -*- 3 | 4 | # Uncomment this to turn on verbose mode. 5 | #export DH_VERBOSE=1 6 | 7 | packagever=$(subst version: ,,$(shell ghc-pkg field $1 version)) 8 | constraint=--constraint "$1 ==$(call packagever,$1)" 9 | 10 | %: 11 | dh $@ 12 | 13 | override_dh_auto_clean: 14 | rm -rf dist .cabal-sandbox cabal.sandbox.config 15 | 16 | override_dh_auto_build: 17 | cabal sandbox init 18 | cabal update 19 | cabal install --only-dependencies \ 20 | $(call constraint,adjunctions) \ 21 | $(call constraint,base) \ 22 | $(call constraint,bifunctors) \ 23 | $(call constraint,bytestring) \ 24 | $(call constraint,contravariant) \ 25 | $(call constraint,data-default-class) \ 26 | $(call constraint,directory) \ 27 | $(call constraint,filepath) \ 28 | $(call constraint,free) \ 29 | $(call constraint,kan-extensions) \ 30 | $(call constraint,lens) \ 31 | $(call constraint,process) \ 32 | $(call constraint,profunctors) \ 33 | $(call constraint,semigroupoids) \ 34 | $(call constraint,semigroups) \ 35 | $(call constraint,temporary) \ 36 | $(call constraint,text) \ 37 | $(call constraint,time) \ 38 | $(call constraint,tls) \ 39 | $(call constraint,unix) \ 40 | $(call constraint,x509) \ 41 | $(call constraint,x509-store) \ 42 | $(call constraint,x509-validation) 43 | cabal install --disable-executable-dynamic 44 | -------------------------------------------------------------------------------- /packaging/debian/source/format: -------------------------------------------------------------------------------- 1 | 3.0 (quilt) 2 | -------------------------------------------------------------------------------- /packaging/ec2-unikernel.dsc: -------------------------------------------------------------------------------- 1 | Format: 3.0 (quilt) 2 | Source: ec2-unikernel 3 | Binary: ec2-unikernel 4 | Architecture: amd64 i386 5 | Version: VERSION-1 6 | Maintainer: HaLVM Maintainers 7 | Build-Depends: ghc, cabal-install, zlib1g, libghc-lens-dev, libghc-profunctors-dev, libghc-unix-dev, libghc-tls-dev, libghc-temporary-dev 8 | Depends: libguestfs-tools, libgmp10, zlib1g 9 | Checksums-Sha1: 10 | ORIG_SHA1 ORIG_SIZE ec2-unikernel_VERSION.orig.tar.gz 11 | CONF_SHA1 CONF_SIZE ec2-unikernel_VERSION-1.debian.tar.gz 12 | Checksums-Sha256: 13 | ORIG_SHA256 ORIG_SIZE ec2-unikernel_VERSION.orig.tar.gz 14 | ORIG_SHA256 CONF_SIZE ec2-unikernel_VERSION-1.debian.tar.gz 15 | Files: 16 | -------------------------------------------------------------------------------- /packaging/ec2-unikernel.spec: -------------------------------------------------------------------------------- 1 | Name: ec2-unikernel 2 | Version: %{_version} 3 | Release: 1%{?dist} 4 | Summary: A tool for uploading unikernels into EC2 5 | Group: System Environment/Base 6 | License: BSD3 7 | URL: http://github.com/GaloisInc/ec2-unikernel 8 | Source0: ec2-unikernel-%{_version}.tar.gz 9 | 10 | BuildRequires: cabal-install, ghc-compiler, coreutils 11 | Requires: libguestfs-tools-c, glibc, libffi, gmp, zlib 12 | 13 | %define debug_package %{nil} 14 | 15 | %description 16 | A tool for uploading and registering unikernels into the EC2 ecosystem, 17 | including upload, import, and AMI registration of the unikernel binary. 18 | Supports any paravirtualized unikernel that builds ELF binaries for 19 | Xen, and can include an arbitrary number of modules (initrds, etc.) as 20 | required. 21 | 22 | %prep 23 | %setup 24 | cabal sandbox init 25 | cabal update 26 | 27 | %build 28 | cabal install --disable-executable-dynamic 29 | 30 | %install 31 | rm -rf %{buildroot} 32 | mkdir -p %{buildroot}%{_bindir} 33 | install .cabal-sandbox/bin/ec2-unikernel %{buildroot}%{_bindir}/ec2-unikernel 34 | 35 | %files 36 | %{_bindir}/ec2-unikernel 37 | 38 | %changelog 39 | 40 | -------------------------------------------------------------------------------- /policies/role-policy.json: -------------------------------------------------------------------------------- 1 | { 2 | "Version":"2012-10-17", 3 | "Statement":[ 4 | { 5 | "Effect":"Allow", 6 | "Action":[ 7 | "s3:ListBucket", 8 | "s3:GetBucketLocation" 9 | ], 10 | "Resource":[ 11 | "arn:aws:s3:::unikernels" 12 | ] 13 | }, 14 | { 15 | "Effect":"Allow", 16 | "Action":[ 17 | "s3:GetObject" 18 | ], 19 | "Resource":[ 20 | "arn:aws:s3:::unikernels/*" 21 | ] 22 | }, 23 | { 24 | "Effect":"Allow", 25 | "Action":[ 26 | "ec2:ModifySnapshotAttribute", 27 | "ec2:CopySnapshot", 28 | "ec2:RegisterImage", 29 | "ec2:Describe*" 30 | ], 31 | "Resource":"*" 32 | } 33 | ] 34 | } 35 | -------------------------------------------------------------------------------- /policies/trust-policy.json: -------------------------------------------------------------------------------- 1 | { 2 | "Version":"2012-10-17", 3 | "Statement":[ 4 | { 5 | "Sid":"", 6 | "Effect":"Allow", 7 | "Principal":{ 8 | "Service":"vmie.amazonaws.com" 9 | }, 10 | "Action":"sts:AssumeRole", 11 | "Condition":{ 12 | "StringEquals":{ 13 | "sts:ExternalId":"vmimport" 14 | } 15 | } 16 | } 17 | ] 18 | } 19 | -------------------------------------------------------------------------------- /src/CommandLine.hs: -------------------------------------------------------------------------------- 1 | module CommandLine(getOptions) 2 | where 3 | 4 | import Control.Exception(SomeException,catch) 5 | import Control.Lens(ASetter, view, set, elemOf, folded) 6 | import Control.Monad(forM_, unless, when) 7 | import Data.Char(isAlphaNum, toLower) 8 | import Data.Either(isLeft) 9 | import Data.String(IsString, fromString) 10 | import Data.Time.Clock(UTCTime, getCurrentTime) 11 | import Data.Time.Format(formatTime, defaultTimeLocale) 12 | import Network.AWS(Region(..), Credentials(..), Env, 13 | runAWS, runResourceT, newEnv, send, envRegion) 14 | import Network.AWS.Data(toText) 15 | import Network.AWS.EC2.DescribeAvailabilityZones(describeAvailabilityZones, 16 | dazrsAvailabilityZones, 17 | dazZoneNames) 18 | import Network.AWS.EC2.Types(azZoneName) 19 | import Options 20 | import System.Console.GetOpt(ArgDescr(..), OptDescr(..), ArgOrder(..)) 21 | import System.Console.GetOpt(getOpt, usageInfo) 22 | import System.Directory(doesFileExist) 23 | import System.Environment(lookupEnv) 24 | import System.Exit(ExitCode(ExitFailure), exitWith) 25 | import System.FilePath(takeFileName) 26 | 27 | type OptOrErr = Either [String] Options 28 | 29 | addError :: OptOrErr -> String -> OptOrErr 30 | addError (Left errs) err = Left (errs ++ [err]) 31 | addError (Right _) err = Left [err] 32 | 33 | addOpt :: OptOrErr -> (Options -> Options) -> OptOrErr 34 | addOpt (Left errs) _ = Left errs 35 | addOpt (Right o) f = Right (f o) 36 | 37 | validateAccessKey :: String -> OptOrErr -> OptOrErr 38 | validateAccessKey ak opts 39 | | length ak /= 20 = addError opts "Access key doesn't look right." 40 | | any (not . isAlphaNum) ak = addError opts "Access key has weird characters." 41 | | otherwise = addOpt opts (set optAwsAccessKey (fromString ak)) 42 | 43 | validateSecretKey :: String -> OptOrErr -> OptOrErr 44 | validateSecretKey sk opts 45 | | length sk /= 40 = addError opts "Secret key doesn't look right." 46 | | any (not . isSecKeyCh) sk = addError opts "Secret key has weird characters." 47 | | otherwise = addOpt opts (set optAwsSecretKey (fromString sk)) 48 | where isSecKeyCh c = isAlphaNum c || (c == '/') || (c == '+') 49 | 50 | validateS3Bucket :: String -> OptOrErr -> OptOrErr 51 | validateS3Bucket b opts 52 | | any (not . isBuckCh) b = addError opts "S3 bucket has weird characters." 53 | | otherwise = addOpt opts (set optS3Bucket (fromString b)) 54 | where isBuckCh c = isAlphaNum c || (c == '-') 55 | 56 | validateZone :: String -> OptOrErr -> OptOrErr 57 | validateZone z opts 58 | | z `elem` availabilityZones = addOpt opts (set optS3Zone (fromString z)) 59 | | otherwise = addError opts "Unknown S3 zone." 60 | 61 | validateRegion :: String -> OptOrErr -> OptOrErr 62 | validateRegion r opts = 63 | case lookup (map toLower r) regions of 64 | Nothing -> addError opts "Unknown AWS region." 65 | Just v -> addOpt opts (set optAwsRegion v) 66 | 67 | regions :: [(String, Region)] 68 | regions = 69 | [ ("ireland", Ireland), ("eu-west-1", Ireland) 70 | , ("frankfurt", Frankfurt), ("eu-central-1", Frankfurt) 71 | , ("tokyo", Tokyo), ("ap-northeast-1", Tokyo) 72 | , ("singapore", Singapore), ("ap-southeast-1", Singapore) 73 | , ("sydney", Sydney), ("ap-southeast-2", Sydney) 74 | , ("beijing", Beijing), ("cn-north-1", Beijing) 75 | , ("northvirginia", NorthVirginia), ("us-east-1", NorthVirginia) 76 | , ("northcalifornia", NorthCalifornia), ("us-west-1", NorthCalifornia) 77 | , ("oregon", Oregon), ("us-west-2", Oregon) 78 | , ("govcloud", GovCloud), ("us-gov-west-1", GovCloud) 79 | , ("govcloudfips", GovCloudFIPS), ("fips-us-gov-west-1", GovCloudFIPS) 80 | , ("saopaulo", SaoPaulo), ("sa-east-1", SaoPaulo) 81 | , ("london", London), ("eu-west-2", London) 82 | ] 83 | 84 | availabilityZones :: [String] 85 | availabilityZones = 86 | [ "us-west-2a" 87 | , "us-west-2b" 88 | , "us-west-2c" 89 | , "eu-west-1a" 90 | , "eu-west-1b" 91 | , "eu-west-1c" 92 | , "eu-west-2a" 93 | , "eu-west-2b" 94 | , "eu-west-2c" 95 | , "eu-central-1a" 96 | , "eu-central-1b" 97 | , "eu-central-1c" 98 | ] 99 | 100 | options :: [OptDescr (OptOrErr -> OptOrErr)] 101 | options = 102 | [ Option ['o'] ["aws-access-key"] (ReqArg validateAccessKey "KEY") 103 | "AWS access key to use" 104 | , Option ['w'] ["aws-secret-key"] (ReqArg validateSecretKey "VALUE") 105 | "AWS secret key to use" 106 | , Option ['b'] ["s3-bucket"] (ReqArg validateS3Bucket "BUCKET") 107 | "S3 bucket to upload to, temporarily." 108 | , Option ['z'] ["zone"] (ReqArg validateZone "ZONE") 109 | "S3 zone in which that bucket livees." 110 | , Option ['r'] ["region"] (ReqArg validateRegion "REGION") 111 | "S3 region to upload to." 112 | , Option ['a'] ["kernel-args"] 113 | (ReqArg (\a opts -> addOpt opts (set optKernelArgs a)) "STRING") 114 | "Kernel arguments to pass to the unikernel." 115 | ] 116 | 117 | maybeSet :: IsString b => ASetter s s a b -> Maybe String -> s -> s 118 | maybeSet _ Nothing x = x 119 | maybeSet field (Just v) x = set field (fromString v) x 120 | 121 | getOptions :: [String] -> IO (Options, Env) 122 | getOptions argv = 123 | do maccess <- lookupEnv "AWS_ACCESS_KEY" 124 | msecret <- lookupEnv "AWS_SECRET_KEY" 125 | let defaultOptions' = maybeSet optAwsAccessKey maccess defaultOptions 126 | defaultOptions'' = maybeSet optAwsSecretKey msecret defaultOptions' 127 | (res, xs, errs) = getOpt RequireOrder options argv 128 | doneOpts = foldl (flip id) (Right defaultOptions'') res 129 | optErrors = either id (const []) doneOpts 130 | kernelErrs = if null xs then ["No unikernel specified!"] else [] 131 | Right baseOpts = doneOpts 132 | now <- getCurrentTime 133 | let opts = adjustImageName 134 | $ adjustTargetName now 135 | $ set optKernel (head xs) 136 | $ set optRamdisks (tail xs) baseOpts 137 | when (isLeft doneOpts || null xs || not (null errs)) $ 138 | fail' (optErrors ++ kernelErrs ++ errs) 139 | kernelOk <- doesFileExist (view optKernel opts) 140 | ramdisksOk <- mapM doesFileExist (view optRamdisks opts) 141 | unless kernelOk $ fail' ["Unikernel not found"] 142 | unless (and ramdisksOk) $ 143 | do let disks = zip (view optRamdisks opts) ramdisksOk 144 | disks' = filter (not . snd) disks 145 | disks'' = map fst disks' 146 | fail' (map (\s -> "Ramdisk "++s++" not found.") disks'') 147 | let akey = view optAwsAccessKey opts 148 | skey = view optAwsSecretKey opts 149 | creds = FromKeys akey skey 150 | e <- set envRegion (view optAwsRegion opts) `fmap` newEnv creds 151 | let region = toText (view optS3Zone opts) 152 | zoneRequest = set dazZoneNames [region] describeAvailabilityZones 153 | r <- catch ((runResourceT . runAWS e) (send zoneRequest)) 154 | (\ se -> 155 | do printInitialServiceError se 156 | exitWith (ExitFailure 1)) 157 | let z = Just (view optS3Zone opts) 158 | unless (elemOf (dazrsAvailabilityZones . folded . azZoneName) z r) $ 159 | fail' ["Invalid availability zone for region."] 160 | return (opts, e) 161 | 162 | printInitialServiceError :: SomeException -> IO () 163 | printInitialServiceError se = 164 | do putStrLn "ERROR: Failed to get list of zones from Amazon. This typically" 165 | putStrLn "is caused by one of two problems:" 166 | putStrLn "" 167 | putStrLn " #1: There's something wrong with your keys. Check your" 168 | putStrLn " arguments, or make sure AWS_ACCESS_KEY and AWS_SECRET_KEY" 169 | putStrLn " are what you want them to be." 170 | putStrLn " #2: There's something wrong with your computer's clock. Run" 171 | putStrLn " whatever software you have to synchronize your clock, and" 172 | putStrLn " try again." 173 | putStrLn "" 174 | putStrLn "Just in case it's useful, here's the raw error:" 175 | putStrLn (show se) 176 | 177 | adjustTargetName :: UTCTime -> Options -> Options 178 | adjustTargetName now opts 179 | | view optTargetKey opts == view optTargetKey defaultOptions = 180 | let baseName = takeFileName (view optKernel opts) 181 | formStr = baseName ++ "-%0C%0y%m%d-%H%M%S.raw" 182 | keyStr = formatTime defaultTimeLocale formStr now 183 | in set optTargetKey (fromString keyStr) opts 184 | | otherwise = opts 185 | 186 | adjustImageName :: Options -> Options 187 | adjustImageName opts 188 | | view optImageName opts == view optImageName defaultOptions = 189 | set optImageName (toText (view optTargetKey opts)) opts 190 | | otherwise = opts 191 | 192 | fail' :: [String] -> IO a 193 | fail' errs = 194 | do forM_ errs $ \ e -> putStrLn ("ERROR: " ++ e) 195 | putStrLn ("\n" ++ usageInfo hdr options) 196 | exitWith (ExitFailure 1) 197 | where hdr = "Usage: ec2-unikernel [OPTION...] KERNEL [RAMDISK ...]" 198 | 199 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | import CommandLine(getOptions) 2 | import Control.Concurrent(threadDelay) 3 | import Control.Lens(ASetter, set, view, elemOf, folded) 4 | import Control.Monad(unless, void, foldM) 5 | import qualified Data.ByteString.Lazy as L 6 | import Data.Int(Int64) 7 | import Data.List(sortBy) 8 | import Data.List.NonEmpty(NonEmpty(..)) 9 | import Data.Maybe(fromMaybe) 10 | import Data.Monoid((<>)) 11 | import Data.Text(Text, unpack, isPrefixOf) 12 | import Network.AWS(Env, AWSRequest, Rs, runResourceT, runAWS, send) 13 | import Network.AWS.Data.Body(RqBody(..), toHashed, contentLength) 14 | import Network.AWS.Data.Text(toText) 15 | import Network.AWS.EC2.DescribeImages(describeImages, deseOwners, deseFilters, 16 | diirsImages) 17 | import Network.AWS.EC2.DescribeImportSnapshotTasks(DescribeImportSnapshotTasksResponse, 18 | distImportTaskIds, 19 | describeImportSnapshotTasks, 20 | distrsResponseStatus, 21 | distrsImportSnapshotTasks) 22 | import Network.AWS.EC2.ImportSnapshot(importSnapshot, isDiskContainer, 23 | isrsSnapshotTaskDetail, 24 | isrsResponseStatus, 25 | isrsImportTaskId) 26 | import Network.AWS.EC2.RegisterImage(registerImage, 27 | riRootDeviceName, riBlockDeviceMappings, 28 | riKernelId, riArchitecture, 29 | rirsResponseStatus, rirsImageId) 30 | import Network.AWS.EC2.Types(istSnapshotTaskDetail, 31 | ebsBlockDevice, ebdDeleteOnTermination, 32 | ebdVolumeSize, ebdSnapshotId, 33 | bdmEBS, blockDeviceMapping, 34 | SnapshotTaskDetail, stdStatus, stdSnapshotId, 35 | stdProgress, stdStatusMessage, 36 | snapshotDiskContainer, sdcURL, sdcFormat, 37 | iName, iImageId, 38 | filter', fValues, 39 | ArchitectureValues(..)) 40 | import Network.AWS.S3.AbortMultipartUpload(abortMultipartUpload) 41 | import Network.AWS.S3.CompleteMultipartUpload(completeMultipartUpload, 42 | cMultipartUpload, 43 | crsResponseStatus) 44 | import Network.AWS.S3.CreateBucket(createBucket, cbCreateBucketConfiguration) 45 | import Network.AWS.S3.CreateMultipartUpload(createMultipartUpload, 46 | cmursUploadId, 47 | cmursResponseStatus) 48 | import Network.AWS.S3.ListBuckets(listBuckets, lbrsBuckets) 49 | import Network.AWS.S3.Types(completedMultipartUpload, 50 | cmuParts, completedPart, 51 | LocationConstraint(..), 52 | createBucketConfiguration, 53 | cbcLocationConstraint, 54 | bName) 55 | import Network.AWS.S3.UploadPart(uploadPart, uprsETag, 56 | uprsResponseStatus) 57 | import Options(Options, optS3Bucket, optTargetKey, optImageName, 58 | optS3Bucket, optTargetKey, optKernel, optKernelArgs, 59 | optRamdisks, optS3Bucket, optAwsRegion) 60 | import System.Directory(copyFile) 61 | import System.Environment(getArgs) 62 | import System.Exit(ExitCode(..), exitWith) 63 | import System.FilePath(takeFileName, ()) 64 | import System.IO.Temp(withSystemTempDirectory) 65 | import System.Posix.Files(fileSize, getFileStatus) 66 | import System.Process(callProcess) 67 | import System.Timeout(timeout) 68 | 69 | main :: IO () 70 | main = 71 | do args <- getArgs 72 | (opts, e) <- getOptions args 73 | kernelId <- findPVGrubAKI e 74 | makeBucket opts e 75 | image <- buildDisk opts 76 | uploadFile opts e image 77 | snapshot <- makeSnapshot opts e 78 | ami <- createAMI opts e kernelId snapshot 79 | putStrLn (unpack ami) 80 | 81 | -- ----------------------------------------------------------------------------- 82 | -- ----------------------------------------------------------------------------- 83 | -- ----------------------------------------------------------------------------- 84 | 85 | findPVGrubAKI :: Env -> IO Text 86 | findPVGrubAKI e = 87 | do res <- awsSend e findRequest 88 | let grubs = filter isPVGrub (view diirsImages res) 89 | case reverse (sortBy sortGrubs grubs) of 90 | [] -> 91 | abort "Couldn't find PV-GRUB kernel for your region." 92 | (kernel:_) -> 93 | do let kernelId = view iImageId kernel 94 | Just kernelName = view iName kernel 95 | logm "KERNEL" ("Using kernel " ++ unpack kernelId ++ " (" ++ 96 | unpack kernelName ++ ")") 97 | return kernelId 98 | where 99 | findRequest = set deseOwners ["amazon"] 100 | $ set deseFilters [ set fValues ["x86_64"] (filter' "architecture") 101 | , set fValues ["xen"] (filter' "hypervisor") 102 | , set fValues ["paravirtual"] (filter' "virtualization-type") 103 | ] 104 | $ describeImages 105 | -- 106 | isPVGrub x = 107 | case view iName x of 108 | Nothing -> False 109 | Just n -> "pv-grub-" `isPrefixOf` n 110 | -- 111 | sortGrubs x y = compare (view iName x) (view iName y) 112 | 113 | -- ----------------------------------------------------------------------------- 114 | -- ----------------------------------------------------------------------------- 115 | -- ----------------------------------------------------------------------------- 116 | 117 | buildDisk :: Options -> IO FilePath 118 | buildDisk opts = 119 | withSystemTempDirectory "ec2-unikernel" $ \ path -> 120 | do logm "DISK" ("Building disk.") 121 | sizeb0 <- fileSize `fmap` getFileStatus (view optKernel opts) 122 | sizeb <- foldM addSize sizeb0 (view optRamdisks opts) 123 | let sizem = ceiling (fromInteger (fromIntegral sizeb) / onemeg) + 1 124 | writeFile (path "menu.lst") (grubMenu opts) 125 | writeFile (path "guestfish.scr") 126 | (guestFishScript (path "disk.raw") sizem 127 | (path "menu.lst") opts) 128 | callProcess "guestfish" ["-f", path "guestfish.scr"] 129 | let targetFile = unpack (toText (view optTargetKey opts)) 130 | copyFile (path "disk.raw") targetFile 131 | logm "DISK" ("Built disk " ++ targetFile) 132 | return targetFile 133 | where 134 | addSize inSize fileName = 135 | do fsize <- fileSize `fmap` getFileStatus fileName 136 | return (fsize + inSize) 137 | 138 | grubMenu :: Options -> String 139 | grubMenu opts = unlines 140 | ([ "default 0" 141 | , "timeout 1" 142 | , "title unikernel_boot" 143 | , "\troot (hd0,0)" 144 | , "\tkernel /" ++ takeFileName (view optKernel opts) ++ kernelArgs 145 | ] ++ map (\ f -> "\tmodule /" ++ takeFileName f) (view optRamdisks opts)) 146 | where 147 | kargs = view optKernelArgs opts 148 | kernelArgs | null kargs = "" 149 | | otherwise = " " ++ kargs 150 | 151 | guestFishScript :: String -> Integer -> FilePath -> Options -> String 152 | guestFishScript diskName diskSize menu opts = unlines 153 | ([ "disk-create " ++ diskName ++ " raw " ++ show diskSize ++ "M" 154 | , "add " ++ diskName 155 | , "run" 156 | , "part-disk /dev/sda mbr" 157 | , "mkfs ext2 /dev/sda1" 158 | , "mount /dev/sda1 /" 159 | , "mkdir /grub" 160 | , "sync" 161 | , "copy-in " ++ menu ++ " /grub/" 162 | , "rename /grub/" ++ takeFileName menu ++ " /grub/menu.lst" 163 | , "copy-in " ++ view optKernel opts ++ " /" 164 | ] ++ map (\ f -> "copy-in " ++ f ++ " /") (view optRamdisks opts) ++ 165 | [ "sync" 166 | , "exit" 167 | ]) 168 | 169 | onemeg :: Double 170 | onemeg = 1048576.0 171 | 172 | -- ----------------------------------------------------------------------------- 173 | -- ----------------------------------------------------------------------------- 174 | -- ----------------------------------------------------------------------------- 175 | 176 | amazonMinimimPartSizeInMB :: Integer 177 | amazonMinimimPartSizeInMB = 5 178 | 179 | amazonMinimimPartSizeInBytes :: Int64 180 | amazonMinimimPartSizeInBytes = 181 | fromIntegral amazonMinimimPartSizeInMB * 1024 * 1024 182 | 183 | statusOk :: Int 184 | statusOk = 200 185 | 186 | makeBucket :: Options -> Env -> IO () 187 | makeBucket opts e = 188 | do bkts <- awsSend e listBuckets 189 | unless (elemOf (lbrsBuckets . folded . bName) bucketName bkts) $ 190 | do void (awsSend e createRequest) 191 | logm "S3" ("Created bucket " ++ unpack (toText bucketName)) 192 | where 193 | bucketName = view optS3Bucket opts 194 | location = Just (LocationConstraint (view optAwsRegion opts)) 195 | config = set cbcLocationConstraint location createBucketConfiguration 196 | createRequest = set cbCreateBucketConfiguration (Just config) $ 197 | createBucket bucketName 198 | 199 | uploadFile :: Options -> Env -> FilePath -> IO () 200 | uploadFile opts e filename = 201 | do logm "UPLOAD" "Creating upload." 202 | rsp <- awsSend e (createMultipartUpload bucket key) 203 | case (view cmursUploadId rsp, view cmursResponseStatus rsp) of 204 | (Nothing, code) -> 205 | putStrLn ("ERROR: Upload initialization failed with code: "++show code) 206 | (Just upId, _) -> 207 | do bytes <- L.readFile filename 208 | sizeb <- fileSize `fmap` getFileStatus filename 209 | logm "UPLOAD" "Starting upload." 210 | runUpload upId 0 (fromIntegral sizeb) bytes 1 [] 211 | where 212 | bucket = view optS3Bucket opts 213 | key = view optTargetKey opts 214 | -- 215 | abortUploadAndFail upId = 216 | do void (awsSend e (abortMultipartUpload bucket key upId)) 217 | fail "Execution aborted (bad upload)" 218 | -- 219 | runUpload upId sentSize totalSize bytes partNo completedTags 220 | | L.null bytes = 221 | case reverse completedTags of 222 | [] -> 223 | do putStrLn ("ERROR: Empty upload?") 224 | abortUploadAndFail upId 225 | (x:rest) -> 226 | do let parts = x :| rest 227 | baseReq = completeMultipartUpload bucket key upId 228 | parts' = set cmuParts (Just parts) completedMultipartUpload 229 | rsp <- awsSend e (set cMultipartUpload (Just parts') baseReq) 230 | if view crsResponseStatus rsp == statusOk 231 | then logm "UPLOAD" "100% complete" 232 | else do putStrLn "ERROR: Bad final upload code." 233 | abortUploadAndFail upId 234 | | otherwise = 235 | do let (chunkBS, rest) = L.splitAt amazonMinimimPartSizeInBytes bytes 236 | chunk = Hashed (toHashed chunkBS) 237 | sentSize' = sentSize + contentLength chunk 238 | req = uploadPart bucket key partNo upId chunk 239 | rsp <- awsSend e req 240 | case (view uprsETag rsp, view uprsResponseStatus rsp) of 241 | (Nothing, code) -> 242 | do putStrLn ("ERROR: Upload failed with code: " ++ show code) 243 | putStrLn (" Attempting abort.") 244 | abortUploadAndFail upId 245 | (Just etag, _) -> 246 | do let percentDble = fromIntegral sentSize / totalSize 247 | percentInt = ceiling ((100.0 :: Double) * percentDble) :: Int 248 | logm "UPLOAD" (show percentInt ++ "% complete") 249 | let partNo' = partNo + 1 250 | completedTags' = completedPart partNo etag : completedTags 251 | runUpload upId sentSize' totalSize rest partNo' completedTags' 252 | 253 | 254 | -- ----------------------------------------------------------------------------- 255 | -- ----------------------------------------------------------------------------- 256 | -- ----------------------------------------------------------------------------- 257 | 258 | makeSnapshot :: Options -> Env -> IO Text 259 | makeSnapshot opts e = 260 | do res <- awsSend e importRequest 261 | let taskId = view isrsImportTaskId res 262 | errCode = view isrsResponseStatus res 263 | details = view isrsSnapshotTaskDetail res 264 | checkResponse (fromMaybe "" taskId) errCode details 265 | where 266 | url = "s3://" <> toText (view optS3Bucket opts) <> "/" <> toText (view optTargetKey opts) 267 | importRequest = setm isDiskContainer container importSnapshot 268 | container = setm sdcFormat "RAW" 269 | $ setm sdcURL url 270 | $ snapshotDiskContainer 271 | 272 | loop :: Text -> IO Text 273 | loop taskId = 274 | do threadDelay 2500000 275 | res <- awsSend e (set distImportTaskIds [taskId] describeImportSnapshotTasks) 276 | checkResponse taskId (view distrsResponseStatus res) (getDetails res) 277 | 278 | getDetails :: DescribeImportSnapshotTasksResponse -> Maybe SnapshotTaskDetail 279 | getDetails rsp = 280 | case view distrsImportSnapshotTasks rsp of 281 | [] -> Nothing 282 | (x:_) -> view istSnapshotTaskDetail x 283 | 284 | checkResponse :: Text -> Int -> Maybe SnapshotTaskDetail -> IO Text 285 | checkResponse _ errCode Nothing = 286 | abort ("Could not import disk snapshot. Error code: " ++ show errCode) 287 | checkResponse taskId err (Just d) | err /= 200 = 288 | do warn ("Weird error code from import: " ++ show err) 289 | checkResponse taskId 200 (Just d) 290 | checkResponse taskId _ (Just d) = 291 | processTaskDetail taskId d 292 | 293 | processTaskDetail :: Text -> SnapshotTaskDetail -> IO Text 294 | processTaskDetail taskId detail 295 | | view stdStatus detail == Just "completed" = 296 | case view stdSnapshotId detail of 297 | Nothing -> abort "Snapshot imported, but no id found." 298 | Just x -> return x 299 | | otherwise = 300 | do logm "IMPORT" (show' (view stdProgress detail) ++ "% " ++ 301 | "(" ++ show' (view stdStatusMessage detail) ++ ")") 302 | loop taskId 303 | 304 | -- ----------------------------------------------------------------------------- 305 | -- ----------------------------------------------------------------------------- 306 | -- ----------------------------------------------------------------------------- 307 | 308 | createAMI :: Options -> Env -> Text -> Text -> IO Text 309 | createAMI opts e kernelId snapshot = 310 | do res <- awsSend e registerRequest 311 | case (view rirsResponseStatus res, view rirsImageId res) of 312 | (errCode, Nothing) -> 313 | abort ("Could not register AMI. Error code: " ++ show errCode) 314 | (200, Just ami) -> 315 | do logm "IMPORT" "100%" 316 | return ami 317 | (err, Just ami) -> 318 | do warn ("Weird error code from register AMI: " ++ show err) 319 | return ami 320 | where 321 | ebsVol = setm ebdDeleteOnTermination True 322 | $ setm ebdVolumeSize 1 -- FIXME: Compute this 323 | $ setm ebdSnapshotId snapshot 324 | $ ebsBlockDevice 325 | blockDevMap = setm bdmEBS ebsVol 326 | $ blockDeviceMapping "/dev/sda1" 327 | registerRequest = setm riRootDeviceName "/dev/sda1" 328 | $ set riBlockDeviceMappings [blockDevMap] 329 | $ setm riArchitecture X86_64 330 | $ setm riKernelId kernelId 331 | $ registerImage (view optImageName opts) 332 | 333 | -- ----------------------------------------------------------------------------- 334 | -- ----------------------------------------------------------------------------- 335 | -- ----------------------------------------------------------------------------- 336 | 337 | abort :: String -> IO a 338 | abort msg = 339 | do putStrLn ("ERROR: " ++ msg) 340 | exitWith (ExitFailure 1) 341 | 342 | warn :: String -> IO () 343 | warn msg = putStrLn ("WARNING: " ++ msg) 344 | 345 | setm :: ASetter s t a (Maybe b) -> b -> s -> t 346 | setm field value obj = set field (Just value) obj 347 | 348 | logm :: String -> String -> IO () 349 | logm category message = putStrLn (category ++ ": " ++ message) 350 | 351 | awsSend :: AWSRequest r => Env -> r -> IO (Rs r) 352 | awsSend env request = go 5 request 353 | where 354 | go :: AWSRequest r => Int -> r -> IO (Rs r) 355 | go 0 _ = fail "Amazon request failed." 356 | go x v = 357 | do mrsp <- timeout (15 * 1000000) (runResourceT (runAWS env (send v))) 358 | case mrsp of 359 | Nothing -> putStrLn "Retrying." >> go (x - 1) v 360 | Just rsp -> return rsp 361 | 362 | show' :: Maybe Text -> String 363 | show' Nothing = "" 364 | show' (Just x) = unpack x 365 | -------------------------------------------------------------------------------- /src/Options.hs: -------------------------------------------------------------------------------- 1 | module Options( 2 | Options 3 | , defaultOptions 4 | , optAwsAccessKey 5 | , optAwsSecretKey 6 | , optS3Bucket 7 | , optS3Zone 8 | , optAwsRegion 9 | , optTargetKey 10 | , optImageName 11 | , optKernel 12 | , optKernelArgs 13 | , optRamdisks 14 | ) 15 | where 16 | 17 | import Control.Lens(Lens', lens) 18 | import Data.String(fromString) 19 | import Data.Text(Text) 20 | import Network.AWS(AccessKey, SecretKey, Region(..)) 21 | import Network.AWS.S3.Types(BucketName, ObjectKey) 22 | 23 | data Options = Options 24 | { _optAwsAccessKey :: AccessKey 25 | , _optAwsSecretKey :: SecretKey 26 | , _optS3Bucket :: BucketName 27 | , _optS3Zone :: Text 28 | , _optTargetKey :: ObjectKey 29 | , _optAwsRegion :: Region 30 | , _optKernel :: FilePath 31 | , _optKernelArgs :: String 32 | , _optRamdisks :: [FilePath] 33 | , _optImageName :: Text 34 | } 35 | 36 | defaultOptions :: Options 37 | defaultOptions = Options 38 | { _optAwsAccessKey = fromString "" 39 | , _optAwsSecretKey = fromString "" 40 | , _optS3Bucket = fromString "unikernels" 41 | , _optS3Zone = fromString "us-west-2a" 42 | , _optTargetKey = fromString "badfile/,:" 43 | , _optAwsRegion = Oregon 44 | , _optKernel = "kernel" 45 | , _optKernelArgs = "" 46 | , _optRamdisks = [] 47 | , _optImageName = fromString "" 48 | } 49 | 50 | -- We're explicitly writing these instances because some combination of 51 | -- Amazonka, lens, and Template Haskell explode when we try to build this 52 | -- under GHC 7.8.4. 53 | 54 | optAwsAccessKey :: Lens' Options AccessKey 55 | optAwsAccessKey = lens _optAwsAccessKey (\ x v -> x{ _optAwsAccessKey = v }) 56 | 57 | optAwsSecretKey :: Lens' Options SecretKey 58 | optAwsSecretKey = lens _optAwsSecretKey (\ x v -> x{ _optAwsSecretKey = v }) 59 | 60 | optS3Bucket :: Lens' Options BucketName 61 | optS3Bucket = lens _optS3Bucket (\ x v -> x{ _optS3Bucket = v }) 62 | 63 | optS3Zone :: Lens' Options Text 64 | optS3Zone = lens _optS3Zone (\ x v -> x{ _optS3Zone = v }) 65 | 66 | optTargetKey :: Lens' Options ObjectKey 67 | optTargetKey = lens _optTargetKey (\ x v -> x{ _optTargetKey = v }) 68 | 69 | optAwsRegion :: Lens' Options Region 70 | optAwsRegion = lens _optAwsRegion (\ x v -> x{ _optAwsRegion = v }) 71 | 72 | optKernel :: Lens' Options FilePath 73 | optKernel = lens _optKernel (\ x v -> x{ _optKernel = v }) 74 | 75 | optKernelArgs :: Lens' Options String 76 | optKernelArgs = lens _optKernelArgs (\ x v -> x{ _optKernelArgs = v }) 77 | 78 | optRamdisks :: Lens' Options [FilePath] 79 | optRamdisks = lens _optRamdisks (\ x v -> x{ _optRamdisks = v }) 80 | 81 | optImageName :: Lens' Options Text 82 | optImageName = lens _optImageName (\ x v -> x{ _optImageName = v }) 83 | 84 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.10 2 | --------------------------------------------------------------------------------