content: module CommandLine(getOptions)
   where
  
  import Control.Exception(SomeException,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, envRegion)
  import Network.AWS.Data(toText)
  import Network.AWS.EC2.DescribeAvailabilityZones(describeAvailabilityZones,
                                                   dazrsAvailabilityZones,
                                                   dazZoneNames)
  import Network.AWS.EC2.Types(azZoneName)
  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 == '/') || (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` availabilityZones = addOpt   opts (set optS3Zone (fromString z))
    | otherwise      = addError opts "Unknown S3 zone."
  
  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)
    , ("london", London), ("eu-west-2", London)
    ]
  
  availabilityZones :: [String]
  availabilityZones =
    [ "us-west-2a"
    , "us-west-2b"
    , "us-west-2c"
    , "eu-west-1a"
    , "eu-west-1b"
    , "eu-west-1c"
    , "eu-west-2a"
    , "eu-west-2b"
    , "eu-west-2c"
    , "eu-central-1a"
    , "eu-central-1b"
    , "eu-central-1c"
    ]
  
  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 <- set envRegion (view optAwsRegion opts) `fmap` newEnv creds
       let region = toText (view optS3Zone opts)
           zoneRequest = set dazZoneNames [region] describeAvailabilityZones
       r <- catch ((runResourceT . runAWS e) (send zoneRequest))
              (\ se ->
                 do printInitialServiceError 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)
  
  printInitialServiceError :: SomeException -> IO ()
  printInitialServiceError se =
    do putStrLn "ERROR: Failed to get list of zones from Amazon. This typically"
       putStrLn "is caused by one of two problems:"
       putStrLn ""
       putStrLn "  #1: There's something wrong with your keys. Check your"
       putStrLn "      arguments, or make sure AWS_ACCESS_KEY and AWS_SECRET_KEY"
       putStrLn "      are what you want them to be."
       putStrLn "  #2: There's something wrong with your computer's clock. Run"
       putStrLn "      whatever software you have to synchronize your clock, and"
       putStrLn "      try again."
       putStrLn ""
       putStrLn "Just in case it's useful, here's the raw error:"
       putStrLn (show se)
  
  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 ...]"
  
  