diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Adam Wick + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Adam Wick nor the names of other + 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 +OWNER 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,98 @@ +# ec2-unikernel + +This tool is designed to provide a single-step mechanism for uploading +your unikernels to run on EC2. At its core, it takes an ELF binary that +is the unikernel, along with any auxiliary modules, uploads them to S3, +and them bundles the whole collection as an AMI that you can then launch +at will. + +THIS SOFTWARE IS ALPHA QUALITY. BE WARNED. + +## Where to Get Binaries + +### Fedora Binaries + +The easiest way to get binary installations for Fedora 22, 23, and 24 +is through the HaLVM repositories. Using this method will also get you +automatically updated when successive versions come out. To use the +HaLVM repositories, run `dnf install` with one of the following links, +depending on your version and architecture: + + * Fedora 22 (32-bit): + (http://repos.halvm.org/fedora-22/i686/halvm-yum-repo-22-3.fc22.noarch.rpm) + * Fedora 23 (32-bit): + (http://repos.halvm.org/fedora-23/i686/halvm-yum-repo-23-3.fc23.noarch.rpm) + * Fedora 24 (32-bit): + (http://repos.halvm.org/fedora-24/i686/halvm-yum-repo-24-3.fc24.noarch.rpm) + * Fedora 22 (64-bit): + (http://repos.halvm.org/fedora-22/x86_64/halvm-yum-repo-22-3.fc22.noarch.rpm) + * Fedora 23 (64-bit): + (http://repos.halvm.org/fedora-23/x86_64/halvm-yum-repo-23-3.fc23.noarch.rpm) + * Fedora 24 (64-bit): + (http://repos.halvm.org/fedora-24/x86_64/halvm-yum-repo-24-3.fc24.noarch.rpm) + +Then run `dnf update` to get all the information you need on the +packages in this repository, and `dnf install ec2-unikernel` to install +the tool + +### Ubuntu Binaries + +Ubuntu binaries are also available on `repos.halvm.org`, although not +in a nice friendly repository structure. (As an aside, if someone wants +to tell me how I could make such a thing, please send me an email.) So +you'll just need to download these manually: + + * Ubuntu 16.04 (32-bit): + (http://repos.halvm.org/ubuntu-16.04/i686/ec2-unikernel_0.9-1_i386.deb) + * Ubuntu 16.04 (64-bit): + (http://repos.halvm.org/ubuntu-16.04/x86_64/ec2-unikernel_0.9-1_amd64.deb) + +Both of these packages should be signed with the HaLVM Maintainer key (fetch +[here](http://repos.halvm.org/RPM-GPG-KEY-HaLVM), fingerprint 6240d595) using +the `dpkg-sig` tool, if you want to verify the release. + +## Installation + +First, we always suggest using a binary from the previous section, as +they will usually tell you about any software prerequisites you are +missing. (See the section on "Prerequisites" for non-software requirements.) + +If you're prefer to build from source, you can either pull the latest +version from Hackage by doing: + +``` +cabal install ec2-unikernel +``` + +Or you can get the bleeding edge by pulling this repository and running +`cabal install` directly. If you do the latter, let me suggest that a +sandbox (or the forthcoming new-configure/new-build/new-install chain) +might be your friend, as `ec2-unikernel` has one hell of a dependency +chain. + +## Limitations + +At the moment, `ec2-unikernel` only works with paravirtualized, 64-bit +binaries. Extending the latter to support 32-bit binaries would be a +lovely introductory project for someone who wants to join the project. +Support for HVM domains might be a bit more work. + +In addition, `ec2-unikernel` only works on Linux systems with the `guestfish` +program installed. + +## Prerequisites + +This program has three prerequisites: + + * You must have an AWS account, account key, and secret key, with all + the relevant permissions to create S3 buckets and objects and register + EC2 snapshots and APIs. + + * As part of this, you must create a `vmimport` role and use it. (Another + feature for someone to add: allow people to use a different name for + this role.) See [this page from +Amazon](https://docs.aws.amazon.com/AWSEC2/latest/UserGuide/VMImportPrerequisites.html#vmimport-service-role). +You can find the policy files they mention in the `policies/` subdirectory. + + * You must have installed the `guestfish` program. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ec2-unikernel.cabal b/ec2-unikernel.cabal new file mode 100644 --- /dev/null +++ b/ec2-unikernel.cabal @@ -0,0 +1,44 @@ +name: ec2-unikernel +version: 0.9 +synopsis: A handy tool for uploading unikernels to Amazon's EC2. +description: This tool uploads unikernels built with the HaLVM, Mirage, + or other tools to Amazon's cloud. The unikernel will then + appear as an AMI, which can be run and shared as needed. +homepage: http://github.com/GaloisInc/ec2-unikernel +license: BSD3 +license-file: LICENSE +author: Adam Wick +maintainer: Adam Wick +copyright: Copyright 2016 Galois, Inc. +category: AWS, Unikernel +build-type: Simple +extra-doc-files: README.md +cabal-version: >=1.10 + +executable ec2-unikernel + main-is: Main.hs + other-modules: Options, CommandLine + default-extensions: OverloadedStrings, TemplateHaskell + ghc-options: -Wall + build-depends: + amazonka >= 1.4.0 && < 1.6.0, + amazonka-core >= 1.4.0 && < 1.6.0, + amazonka-ec2 >= 1.4.0 && < 1.6.0, + amazonka-s3 >= 1.4.0 && < 1.6.0, + base >= 4.7.0 && < 5.0.0, + bytestring >= 0.10 && < 0.12, + directory >= 1.2.2 && < 1.4, + filepath >= 1.3.0 && < 1.5, + lens >= 4.13 && < 5.0, + process >= 1.2 && < 1.5, + semigroups >= 0.18 && < 0.20, + temporary >= 1.2.0 && < 1.4, + text >= 1.2.2 && < 1.4, + time >= 1.5 && < 1.8, + unix >= 2.7.1 && < 2.9 + hs-source-dirs: src + default-language: Haskell2010 + +source-repository head + type: git + location: git://github.com/GaloisInc/ec2-unikernel.git diff --git a/src/CommandLine.hs b/src/CommandLine.hs new file mode 100644 --- /dev/null +++ b/src/CommandLine.hs @@ -0,0 +1,171 @@ +module CommandLine(getOptions) + where + +import Control.Exception(catch) +import Control.Lens(ASetter, view, set, elemOf, folded) +import Control.Monad(forM_, unless, when) +import Data.Char(isAlphaNum, toLower) +import Data.Either(isLeft) +import Data.String(IsString, fromString) +import Data.Time.Clock(UTCTime, getCurrentTime) +import Data.Time.Format(formatTime, defaultTimeLocale) +import Network.AWS(Region(..), Credentials(..), Env, + runAWS, runResourceT, newEnv, send) +import Network.AWS.Data(toText) +import Network.AWS.EC2.DescribeAvailabilityZones(describeAvailabilityZones, + dazrsAvailabilityZones, + dazZoneNames) +import Network.AWS.EC2.Types(azZoneName) +import Network.AWS.Types(Error(..), serviceCode) +import Options +import System.Console.GetOpt(ArgDescr(..), OptDescr(..), ArgOrder(..)) +import System.Console.GetOpt(getOpt, usageInfo) +import System.Directory(doesFileExist) +import System.Environment(lookupEnv) +import System.Exit(ExitCode(ExitFailure), exitWith) +import System.FilePath(takeFileName) + +type OptOrErr = Either [String] Options + +addError :: OptOrErr -> String -> OptOrErr +addError (Left errs) err = Left (errs ++ [err]) +addError (Right _) err = Left [err] + +addOpt :: OptOrErr -> (Options -> Options) -> OptOrErr +addOpt (Left errs) _ = Left errs +addOpt (Right o) f = Right (f o) + +validateAccessKey :: String -> OptOrErr -> OptOrErr +validateAccessKey ak opts + | length ak /= 20 = addError opts "Access key doesn't look right." + | any (not . isAlphaNum) ak = addError opts "Access key has weird characters." + | otherwise = addOpt opts (set optAwsAccessKey (fromString ak)) + +validateSecretKey :: String -> OptOrErr -> OptOrErr +validateSecretKey sk opts + | length sk /= 40 = addError opts "Secret key doesn't look right." + | any (not . isSecKeyCh) sk = addError opts "Secret key has weird characters." + | otherwise = addOpt opts (set optAwsSecretKey (fromString sk)) + where isSecKeyCh c = isAlphaNum c || (c == '/') + +validateS3Bucket :: String -> OptOrErr -> OptOrErr +validateS3Bucket b opts + | any (not . isBuckCh) b = addError opts "S3 bucket has weird characters." + | otherwise = addOpt opts (set optS3Bucket (fromString b)) + where isBuckCh c = isAlphaNum c || (c == '-') + +validateZone :: String -> OptOrErr -> OptOrErr +validateZone z opts + | z `elem` zones = addOpt opts (set optS3Zone (fromString z)) + | otherwise = addError opts "Unknown S3 zone." + where zones = ["us-west-2a"] + +validateRegion :: String -> OptOrErr -> OptOrErr +validateRegion r opts = + case lookup (map toLower r) regions of + Nothing -> addError opts "Unknown AWS region." + Just v -> addOpt opts (set optAwsRegion v) + +regions :: [(String, Region)] +regions = + [ ("ireland", Ireland), ("eu-west-1", Ireland) + , ("frankfurt", Frankfurt), ("eu-central-1", Frankfurt) + , ("tokyo", Tokyo), ("ap-northeast-1", Tokyo) + , ("singapore", Singapore), ("ap-southeast-1", Singapore) + , ("sydney", Sydney), ("ap-southeast-2", Sydney) + , ("beijing", Beijing), ("cn-north-1", Beijing) + , ("northvirginia", NorthVirginia), ("us-east-1", NorthVirginia) + , ("northcalifornia", NorthCalifornia), ("us-west-1", NorthCalifornia) + , ("oregon", Oregon), ("us-west-2", Oregon) + , ("govcloud", GovCloud), ("us-gov-west-1", GovCloud) + , ("govcloudfips", GovCloudFIPS), ("fips-us-gov-west-1", GovCloudFIPS) + , ("saopaulo", SaoPaulo), ("sa-east-1", SaoPaulo) + ] + +options :: [OptDescr (OptOrErr -> OptOrErr)] +options = + [ Option ['o'] ["aws-access-key"] (ReqArg validateAccessKey "KEY") + "AWS access key to use" + , Option ['w'] ["aws-secret-key"] (ReqArg validateSecretKey "VALUE") + "AWS secret key to use" + , Option ['b'] ["s3-bucket"] (ReqArg validateS3Bucket "BUCKET") + "S3 bucket to upload to, temporarily." + , Option ['z'] ["zone"] (ReqArg validateZone "ZONE") + "S3 zone in which that bucket livees." + , Option ['r'] ["region"] (ReqArg validateRegion "REGION") + "S3 region to upload to." + , Option ['a'] ["kernel-args"] + (ReqArg (\a opts -> addOpt opts (set optKernelArgs a)) "STRING") + "Kernel arguments to pass to the unikernel." + ] + +maybeSet :: IsString b => ASetter s s a b -> Maybe String -> s -> s +maybeSet _ Nothing x = x +maybeSet field (Just v) x = set field (fromString v) x + +getOptions :: [String] -> IO (Options, Env) +getOptions argv = + do maccess <- lookupEnv "AWS_ACCESS_KEY" + msecret <- lookupEnv "AWS_SECRET_KEY" + let defaultOptions' = maybeSet optAwsAccessKey maccess defaultOptions + defaultOptions'' = maybeSet optAwsSecretKey msecret defaultOptions' + (res, xs, errs) = getOpt RequireOrder options argv + doneOpts = foldl (flip id) (Right defaultOptions'') res + optErrors = either id (const []) doneOpts + kernelErrs = if null xs then ["No unikernel specified!"] else [] + Right baseOpts = doneOpts + now <- getCurrentTime + let opts = adjustImageName + $ adjustTargetName now + $ set optKernel (head xs) + $ set optRamdisks (tail xs) baseOpts + when (isLeft doneOpts || null xs || not (null errs)) $ + fail' (optErrors ++ kernelErrs ++ errs) + kernelOk <- doesFileExist (view optKernel opts) + ramdisksOk <- mapM doesFileExist (view optRamdisks opts) + unless kernelOk $ fail' ["Unikernel not found"] + unless (and ramdisksOk) $ + do let disks = zip (view optRamdisks opts) ramdisksOk + disks' = filter (not . snd) disks + disks'' = map fst disks' + fail' (map (\s -> "Ramdisk "++s++" not found.") disks'') + let akey = view optAwsAccessKey opts + skey = view optAwsSecretKey opts + creds = FromKeys akey skey + e <- newEnv (view optAwsRegion opts) creds + let region = toText (view optS3Zone opts) + zoneRequest = set dazZoneNames [region] describeAvailabilityZones + r <- catch ((runResourceT . runAWS e) (send zoneRequest)) + (\ (ServiceError se) -> + do putStr "ERROR: Failed to connect with Amazon. " + putStrLn "This is typically a problem with your keys." + putStrLn (" ("++show(view serviceCode se)++")") + putStrLn (show se) + exitWith (ExitFailure 1)) + let z = Just (view optS3Zone opts) + unless (elemOf (dazrsAvailabilityZones . folded . azZoneName) z r) $ + fail' ["Invalid availability zone for region."] + return (opts, e) + +adjustTargetName :: UTCTime -> Options -> Options +adjustTargetName now opts + | view optTargetKey opts == view optTargetKey defaultOptions = + let baseName = takeFileName (view optKernel opts) + formStr = baseName ++ "-%0C%0y%m%d-%H%M%S.raw" + keyStr = formatTime defaultTimeLocale formStr now + in set optTargetKey (fromString keyStr) opts + | otherwise = opts + +adjustImageName :: Options -> Options +adjustImageName opts + | view optImageName opts == view optImageName defaultOptions = + set optImageName (toText (view optTargetKey opts)) opts + | otherwise = opts + +fail' :: [String] -> IO a +fail' errs = + do forM_ errs $ \ e -> putStrLn ("ERROR: " ++ e) + putStrLn ("\n" ++ usageInfo hdr options) + exitWith (ExitFailure 1) + where hdr = "Usage: ec2-unikernel [OPTION...] KERNEL [RAMDISK ...]" + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,345 @@ +import CommandLine(getOptions) +import Control.Concurrent(threadDelay) +import Control.Lens(ASetter, set, view, elemOf, folded) +import Control.Monad(unless, void) +import qualified Data.ByteString.Lazy as L +import Data.Int(Int64) +import Data.List(sortBy) +import Data.List.NonEmpty(NonEmpty(..)) +import Data.Maybe(fromMaybe) +import Data.Monoid((<>)) +import Data.Text(Text, unpack, isPrefixOf) +import Network.AWS(Env, AWSRequest, Rs, runResourceT, runAWS, send) +import Network.AWS.Data.Body(RqBody(..), toHashed, contentLength) +import Network.AWS.Data.Text(toText) +import Network.AWS.EC2.DescribeImages(describeImages, deseOwners, deseFilters, + desrsImages) +import Network.AWS.EC2.DescribeImportSnapshotTasks(DescribeImportSnapshotTasksResponse, + distImportTaskIds, + describeImportSnapshotTasks, + distrsResponseStatus, + distrsImportSnapshotTasks) +import Network.AWS.EC2.ImportSnapshot(importSnapshot, isDiskContainer, + isrsSnapshotTaskDetail, + isrsResponseStatus, + isrsImportTaskId) +import Network.AWS.EC2.RegisterImage(registerImage, + riRootDeviceName, riBlockDeviceMappings, + riKernelId, riArchitecture, + rirsResponseStatus, rirsImageId) +import Network.AWS.EC2.Types(istSnapshotTaskDetail, + ebsBlockDevice, ebdDeleteOnTermination, + ebdVolumeSize, ebdSnapshotId, + bdmEBS, blockDeviceMapping, + SnapshotTaskDetail, stdStatus, stdSnapshotId, + stdProgress, stdStatusMessage, + snapshotDiskContainer, sdcURL, sdcFormat, + iName, iImageId, + filter', fValues, + ArchitectureValues(..)) +import Network.AWS.S3.AbortMultipartUpload(abortMultipartUpload) +import Network.AWS.S3.CompleteMultipartUpload(completeMultipartUpload, + cMultipartUpload, + crsResponseStatus) +import Network.AWS.S3.CreateBucket(createBucket, cbCreateBucketConfiguration) +import Network.AWS.S3.CreateMultipartUpload(createMultipartUpload, + cmursUploadId, + cmursResponseStatus) +import Network.AWS.S3.ListBuckets(listBuckets, lbrsBuckets) +import Network.AWS.S3.Types(completedMultipartUpload, + cmuParts, completedPart, + LocationConstraint(..), + createBucketConfiguration, + cbcLocationConstraint, + bName) +import Network.AWS.S3.UploadPart(uploadPart, uprsETag, + uprsResponseStatus) +import Options(Options, optS3Bucket, optTargetKey, optImageName, + optS3Bucket, optTargetKey, optKernel, optKernelArgs, + optRamdisks, optS3Bucket, optAwsRegion) +import System.Directory(copyFile) +import System.Environment(getArgs) +import System.Exit(ExitCode(..), exitWith) +import System.FilePath(takeFileName, ()) +import System.IO.Temp(withSystemTempDirectory) +import System.Posix.Files(fileSize, getFileStatus) +import System.Process(callProcess) + +main :: IO () +main = + do args <- getArgs + (opts, e) <- getOptions args + kernelId <- findPVGrubAKI e + makeBucket opts e + image <- buildDisk opts + uploadFile opts e image + snapshot <- makeSnapshot opts e + ami <- createAMI opts e kernelId snapshot + putStrLn (unpack ami) + +-- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- + +findPVGrubAKI :: Env -> IO Text +findPVGrubAKI e = + do res <- awsSend e findRequest + let grubs = filter isPVGrub (view desrsImages res) + case reverse (sortBy sortGrubs grubs) of + [] -> + abort "Couldn't find PV-GRUB kernel for your region." + (kernel:_) -> + do let kernelId = view iImageId kernel + Just kernelName = view iName kernel + logm "KERNEL" ("Using kernel " ++ unpack kernelId ++ " (" ++ + unpack kernelName ++ ")") + return kernelId + where + findRequest = set deseOwners ["amazon"] + $ set deseFilters [ set fValues ["x86_64"] (filter' "architecture") + , set fValues ["xen"] (filter' "hypervisor") + , set fValues ["paravirtual"] (filter' "virtualization-type") + ] + $ describeImages + -- + isPVGrub x = + case view iName x of + Nothing -> False + Just n -> "pv-grub-" `isPrefixOf` n + -- + sortGrubs x y = compare (view iName x) (view iName y) + +-- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- + +buildDisk :: Options -> IO FilePath +buildDisk opts = + withSystemTempDirectory "ec2-unikernel" $ \ path -> + do sizeb <- fileSize `fmap` getFileStatus (view optKernel opts) + let sizem = ceiling (fromInteger (fromIntegral sizeb) / onemeg) + 1 + writeFile (path "menu.lst") (grubMenu opts) + writeFile (path "guestfish.scr") + (guestFishScript (path "disk.raw") sizem + (path "menu.lst") opts) + callProcess "guestfish" ["-f", path "guestfish.scr"] + let targetFile = unpack (toText (view optTargetKey opts)) + copyFile (path "disk.raw") targetFile + return targetFile + +grubMenu :: Options -> String +grubMenu opts = unlines + ([ "default 0" + , "timeout 1" + , "title unikernel_boot" + , "\troot (hd0,0)" + , "\tkernel /" ++ takeFileName (view optKernel opts) ++ kernelArgs + ] ++ map (\ f -> "\tmodule /" ++ takeFileName f) (view optRamdisks opts)) + where + kargs = view optKernelArgs opts + kernelArgs | null kargs = "" + | otherwise = " " ++ kargs + +guestFishScript :: String -> Integer -> FilePath -> Options -> String +guestFishScript diskName diskSize menu opts = unlines + ([ "disk-create " ++ diskName ++ " raw " ++ show diskSize ++ "M" + , "add " ++ diskName + , "run" + , "part-disk /dev/sda mbr" + , "mkfs ext2 /dev/sda1" + , "mount /dev/sda1 /" + , "mkdir /grub" + , "sync" + , "copy-in " ++ menu ++ " /grub/" + , "rename /grub/" ++ takeFileName menu ++ " /grub/menu.lst" + , "copy-in " ++ view optKernel opts ++ " /" + ] ++ map (\ f -> "copy-in " ++ f ++ " /") (view optRamdisks opts) ++ + [ "sync" + , "exit" + ]) + +onemeg :: Double +onemeg = 1048576.0 + +-- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- + +amazonMinimimPartSizeInMB :: Integer +amazonMinimimPartSizeInMB = 5 + +amazonMinimimPartSizeInBytes :: Int64 +amazonMinimimPartSizeInBytes = + fromIntegral amazonMinimimPartSizeInMB * 1024 * 1024 + +statusOk :: Int +statusOk = 200 + +makeBucket :: Options -> Env -> IO () +makeBucket opts e = + do bkts <- awsSend e listBuckets + unless (elemOf (lbrsBuckets . folded . bName) bucketName bkts) $ + do void (awsSend e createRequest) + logm "S3" ("Created bucket " ++ unpack (toText bucketName)) + where + bucketName = view optS3Bucket opts + location = Just (LocationConstraint (view optAwsRegion opts)) + config = set cbcLocationConstraint location createBucketConfiguration + createRequest = set cbCreateBucketConfiguration (Just config) $ + createBucket bucketName + +uploadFile :: Options -> Env -> FilePath -> IO () +uploadFile opts e filename = + do rsp <- awsSend e (createMultipartUpload bucket key) + case (view cmursUploadId rsp, view cmursResponseStatus rsp) of + (Nothing, code) -> + putStrLn ("ERROR: Upload initialization failed with code: "++show code) + (Just upId, _) -> + do bytes <- L.readFile filename + sizeb <- fileSize `fmap` getFileStatus filename + runUpload upId 0 (fromIntegral sizeb) bytes 1 [] + where + bucket = view optS3Bucket opts + key = view optTargetKey opts + -- + abortUploadAndFail upId = + do void (awsSend e (abortMultipartUpload bucket key upId)) + fail "Execution aborted (bad upload)" + -- + runUpload upId sentSize totalSize bytes partNo completedTags + | L.null bytes = + case reverse completedTags of + [] -> + do putStrLn ("ERROR: Empty upload?") + abortUploadAndFail upId + (x:rest) -> + do let parts = x :| rest + baseReq = completeMultipartUpload bucket key upId + parts' = set cmuParts (Just parts) completedMultipartUpload + rsp <- awsSend e (set cMultipartUpload (Just parts') baseReq) + if view crsResponseStatus rsp == statusOk + then logm "UPLOAD" "100% complete" + else do putStrLn "ERROR: Bad final upload code." + abortUploadAndFail upId + | otherwise = + do let (chunkBS, rest) = L.splitAt amazonMinimimPartSizeInBytes bytes + chunk = Hashed (toHashed chunkBS) + sentSize' = sentSize + contentLength chunk + rsp <- awsSend e (uploadPart bucket key partNo upId chunk) + case (view uprsETag rsp, view uprsResponseStatus rsp) of + (Nothing, code) -> + do putStrLn ("ERROR: Upload failed with code: " ++ show code) + putStrLn (" Attempting abort.") + abortUploadAndFail upId + (Just etag, _) -> + do let percentDble = fromIntegral sentSize / totalSize + percentInt = ceiling ((100.0 :: Double) * percentDble) :: Int + logm "UPLOAD" (show percentInt ++ "% complete") + let partNo' = partNo + 1 + completedTags' = completedPart partNo etag : completedTags + runUpload upId sentSize' totalSize rest partNo' completedTags' + + +-- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- + +makeSnapshot :: Options -> Env -> IO Text +makeSnapshot opts e = + do res <- awsSend e importRequest + let taskId = view isrsImportTaskId res + errCode = view isrsResponseStatus res + details = view isrsSnapshotTaskDetail res + checkResponse (fromMaybe "" taskId) errCode details + where + url = "s3://" <> toText (view optS3Bucket opts) <> "/" <> toText (view optTargetKey opts) + importRequest = setm isDiskContainer container importSnapshot + container = setm sdcFormat "RAW" + $ setm sdcURL url + $ snapshotDiskContainer + + loop :: Text -> IO Text + loop taskId = + do threadDelay 2500000 + res <- awsSend e (set distImportTaskIds [taskId] describeImportSnapshotTasks) + checkResponse taskId (view distrsResponseStatus res) (getDetails res) + + getDetails :: DescribeImportSnapshotTasksResponse -> Maybe SnapshotTaskDetail + getDetails rsp = + case view distrsImportSnapshotTasks rsp of + [] -> Nothing + (x:_) -> view istSnapshotTaskDetail x + + checkResponse :: Text -> Int -> Maybe SnapshotTaskDetail -> IO Text + checkResponse _ errCode Nothing = + abort ("Could not import disk snapshot. Error code: " ++ show errCode) + checkResponse taskId err (Just d) | err /= 200 = + do warn ("Weird error code from import: " ++ show err) + checkResponse taskId 200 (Just d) + checkResponse taskId _ (Just d) = + processTaskDetail taskId d + + processTaskDetail :: Text -> SnapshotTaskDetail -> IO Text + processTaskDetail taskId detail + | view stdStatus detail == Just "completed" = + case view stdSnapshotId detail of + Nothing -> abort "Snapshot imported, but no id found." + Just x -> return x + | otherwise = + do logm "IMPORT" (show' (view stdProgress detail) ++ "% " ++ + "(" ++ show' (view stdStatusMessage detail) ++ ")") + loop taskId + +-- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- + +createAMI :: Options -> Env -> Text -> Text -> IO Text +createAMI opts e kernelId snapshot = + do res <- awsSend e registerRequest + case (view rirsResponseStatus res, view rirsImageId res) of + (errCode, Nothing) -> + abort ("Could not register AMI. Error code: " ++ show errCode) + (200, Just ami) -> + do logm "IMPORT" "100%" + return ami + (err, Just ami) -> + do warn ("Weird error code from register AMI: " ++ show err) + return ami + where + ebsVol = setm ebdDeleteOnTermination True + $ setm ebdVolumeSize 1 -- FIXME: Compute this + $ setm ebdSnapshotId snapshot + $ ebsBlockDevice + blockDevMap = setm bdmEBS ebsVol + $ blockDeviceMapping "/dev/sda1" + registerRequest = setm riRootDeviceName "/dev/sda1" + $ set riBlockDeviceMappings [blockDevMap] + $ setm riArchitecture X86_64 + $ setm riKernelId kernelId + $ registerImage (view optImageName opts) + +-- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- + +abort :: String -> IO a +abort msg = + do putStrLn ("ERROR: " ++ msg) + exitWith (ExitFailure 1) + +warn :: String -> IO () +warn msg = putStrLn ("WARNING: " ++ msg) + +setm :: ASetter s t a (Maybe b) -> b -> s -> t +setm field value obj = set field (Just value) obj + +logm :: String -> String -> IO () +logm category message = putStrLn (category ++ ": " ++ message) + +awsSend :: AWSRequest r => Env -> r -> IO (Rs r) +awsSend e x = runResourceT (runAWS e (send x)) + +show' :: Maybe Text -> String +show' Nothing = "" +show' (Just x) = unpack x diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -0,0 +1,83 @@ +module Options( + Options + , defaultOptions + , optAwsAccessKey + , optAwsSecretKey + , optS3Bucket + , optS3Zone + , optAwsRegion + , optTargetKey + , optImageName + , optKernel + , optKernelArgs + , optRamdisks + ) + where + +import Control.Lens(Lens', lens) +import Data.String(fromString) +import Data.Text(Text) +import Network.AWS(AccessKey, SecretKey, Region(..)) +import Network.AWS.S3.Types(BucketName, ObjectKey) + +data Options = Options + { _optAwsAccessKey :: AccessKey + , _optAwsSecretKey :: SecretKey + , _optS3Bucket :: BucketName + , _optS3Zone :: Text + , _optTargetKey :: ObjectKey + , _optAwsRegion :: Region + , _optKernel :: FilePath + , _optKernelArgs :: String + , _optRamdisks :: [FilePath] + , _optImageName :: Text + } + +defaultOptions :: Options +defaultOptions = Options + { _optAwsAccessKey = fromString "" + , _optAwsSecretKey = fromString "" + , _optS3Bucket = fromString "unikernels" + , _optS3Zone = fromString "us-west-2a" + , _optTargetKey = fromString "badfile/,:" + , _optAwsRegion = Oregon + , _optKernel = "kernel" + , _optKernelArgs = "" + , _optRamdisks = [] + , _optImageName = fromString "" + } + +-- We're explicitly writing these instances because some combination of +-- Amazonka, lens, and Template Haskell explode when we try to build this +-- under GHC 7.8.4. + +optAwsAccessKey :: Lens' Options AccessKey +optAwsAccessKey = lens _optAwsAccessKey (\ x v -> x{ _optAwsAccessKey = v }) + +optAwsSecretKey :: Lens' Options SecretKey +optAwsSecretKey = lens _optAwsSecretKey (\ x v -> x{ _optAwsSecretKey = v }) + +optS3Bucket :: Lens' Options BucketName +optS3Bucket = lens _optS3Bucket (\ x v -> x{ _optS3Bucket = v }) + +optS3Zone :: Lens' Options Text +optS3Zone = lens _optS3Zone (\ x v -> x{ _optS3Zone = v }) + +optTargetKey :: Lens' Options ObjectKey +optTargetKey = lens _optTargetKey (\ x v -> x{ _optTargetKey = v }) + +optAwsRegion :: Lens' Options Region +optAwsRegion = lens _optAwsRegion (\ x v -> x{ _optAwsRegion = v }) + +optKernel :: Lens' Options FilePath +optKernel = lens _optKernel (\ x v -> x{ _optKernel = v }) + +optKernelArgs :: Lens' Options String +optKernelArgs = lens _optKernelArgs (\ x v -> x{ _optKernelArgs = v }) + +optRamdisks :: Lens' Options [FilePath] +optRamdisks = lens _optRamdisks (\ x v -> x{ _optRamdisks = v }) + +optImageName :: Lens' Options Text +optImageName = lens _optImageName (\ x v -> x{ _optImageName = v }) +