ec2-unikernel (empty) → 0.9
raw patch · 7 files changed
+773/−0 lines, 7 filesdep +amazonkadep +amazonka-coredep +amazonka-ec2setup-changed
Dependencies added: amazonka, amazonka-core, amazonka-ec2, amazonka-s3, base, bytestring, directory, filepath, lens, process, semigroups, temporary, text, time, unix
Files
- LICENSE +30/−0
- README.md +98/−0
- Setup.hs +2/−0
- ec2-unikernel.cabal +44/−0
- src/CommandLine.hs +171/−0
- src/Main.hs +345/−0
- src/Options.hs +83/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ec2-unikernel.cabal view
@@ -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 <awick@galois.com>+maintainer: Adam Wick <awick@galois.com>+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
+ src/CommandLine.hs view
@@ -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 ...]"+
+ src/Main.hs view
@@ -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
+ src/Options.hs view
@@ -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 })+