Main.hs

module Main where

import Options.Applicative             hiding (action)
import Options.Applicative.Help.Pretty hiding ((</>))

import Control.Exception
import Data.Function                   (on)
import Data.List                       (groupBy)
import Data.Maybe
import Data.Version
import Paths_b9
import Prelude                         hiding (catch)
import System.Directory
import System.IO.Error                 hiding (catch)

import B9

main :: IO ()
main = do
  b9Opts <- parseCommandLine
  result <- runB9 b9Opts
  exit result
  where
    exit success = when (not success) (exitWith (ExitFailure 128))

parseCommandLine :: IO B9Options
parseCommandLine =
    execParser
        (info
             (helper <*> (B9Options <$> globals <*> cmds <*> buildVars))
             (fullDesc <>
              progDesc
                  "Build and run VM-Images inside LXC containers.\
                            \ Custom arguments follow after '--' and are\
                            \ accessable in many strings in build files \
                            \ trough shell like variable references, i.e. \
                            \'${arg_N}' referes to positional argument $N.\n\
                            \\n\
                            \Repository names passed to the command line are\
                            \ looked up in the B9 configuration file, which is\
                            \ per default located in: '~/.b9/b9.conf'" <>
              headerDoc (Just helpHeader)))
  where
    helpHeader =
        linebreak <>
        text ("B9 - a benign VM-Image build tool v. " ++ b9Version)

data B9Options =
    B9Options GlobalOpts
              BuildAction
              BuildVariables

data GlobalOpts = GlobalOpts
    { configFile :: Maybe SystemPath
    , cliB9Config :: B9Config
    }

type BuildAction = Maybe SystemPath -> ConfigParser -> B9Config -> IO Bool

runB9 :: B9Options -> IO Bool
runB9 (B9Options globalOpts action vars) = do
    let cfgWithArgs =
            cfgCli
            { envVars = envVars cfgCli ++ vars
            }
        cfgCli = cliB9Config globalOpts
        cfgFile = configFile globalOpts
    cp <- configure cfgFile cfgCli
    action cfgFile cp cfgWithArgs

runShowVersion :: BuildAction
runShowVersion _cfgFile _cp _conf = do
    putStrLn b9Version
    return True

runBuildArtifacts :: [FilePath] ->  BuildAction
runBuildArtifacts buildFiles _cfgFile cp conf = do
    generators <- mapM consult buildFiles
    buildArtifacts (mconcat generators) cp conf

runFormatBuildFiles :: [FilePath] ->  BuildAction
runFormatBuildFiles buildFiles _cfgFile _cp _conf = do
    generators <- mapM consult buildFiles
    let generatorsFormatted = map ppShow (generators :: [ArtifactGenerator])
    putStrLn `mapM` (generatorsFormatted)
    (uncurry writeFile) `mapM` (buildFiles `zip` generatorsFormatted)
    return True

runPush :: SharedImageName -> BuildAction
runPush name _cfgFile cp conf = impl
  where
    conf' =
        conf
        { keepTempDirs = False
        }
    impl =
        run
            cp
            conf'
            (if not (isJust (repository conf'))
                 then do
                     errorL
                         "No repository specified! \
                            \ Use '-r' to specify a repo BEFORE 'push'."
                     return False
                 else do
                     pushSharedImageLatestVersion name
                     return True)

runPull :: Maybe SharedImageName -> BuildAction
runPull mName _cfgFile cp conf =
    run cp conf' (pullRemoteRepos >> maybePullImage)
  where
    conf' =
        conf
        { keepTempDirs = False
        }
    maybePullImage = maybe (return True) pullLatestImage mName

runRun :: SharedImageName -> [String] -> BuildAction
runRun (SharedImageName name) cmdAndArgs _cfgFile cp conf = impl
  where
    conf' =
        conf
        { keepTempDirs = False
        , interactive = True
        }
    impl = buildArtifacts runCmdAndArgs cp conf'
      where
        runCmdAndArgs =
            Artifact
                (IID ("run-" ++ name))
                (VmImages
                     [ ImageTarget
                           Transient
                           (From name KeepSize)
                           (MountPoint "/")]
                     (VmScript
                          X86_64
                          [SharedDirectory "." (MountPoint "/mnt/CWD")]
                          (Run (head cmdAndArgs') (tail cmdAndArgs'))))
        cmdAndArgs' =
            if null cmdAndArgs
                then ["/usr/bin/zsh"]
                else cmdAndArgs


runGcLocalRepoCache :: BuildAction
runGcLocalRepoCache _cfgFile cp conf = impl
  where
    conf' =
        conf
        { keepTempDirs = False
        }
    impl =
        run cp conf' $
        do toDelete <-
               (obsoleteSharedmages . map snd) <$>
               lookupSharedImages (== Cache) (const True)
           imgDir <- getSharedImagesCacheDir
           let filesToDelete = (imgDir </>) <$> (infoFiles ++ imgFiles)
               infoFiles = sharedImageFileName <$> toDelete
               imgFiles = (imageFileName . sharedImageImage) <$> toDelete
           if null filesToDelete
               then liftIO $
                    do putStrLn "\n\nNO IMAGES TO DELETE\n"
                       return True
               else liftIO $
                    do putStrLn "DELETING FILES:"
                       putStrLn (unlines filesToDelete)
                       mapM_ removeIfExists filesToDelete
                       return True
    obsoleteSharedmages :: [SharedImage] -> [SharedImage]
    obsoleteSharedmages =
        concatMap (tail . reverse) .
        filter ((> 1) . length) . groupBy ((==) `on` siName)
    removeIfExists :: FilePath -> IO ()
    removeIfExists fileName = removeFile fileName `catch` handleExists
      where
        handleExists e
          | isDoesNotExistError e = return ()
          | otherwise = throwIO e

runGcRemoteRepoCache :: BuildAction
runGcRemoteRepoCache _cfgFile cp conf = impl
  where
    conf' =
        conf
        { keepTempDirs = False
        }
    impl =
        run cp conf' $
        do repos <- getSelectedRepos
           cache <- getRepoCache
           mapM_ (cleanRemoteRepo cache) repos
           return True

runListSharedImages :: BuildAction
runListSharedImages _cfgFile cp conf = impl
  where
    conf' =
        conf
        { keepTempDirs = False
        }
    impl =
        run cp conf' $
        do remoteRepo <- getSelectedRemoteRepo
           let repoPred =
                   maybe (== Cache) ((==) . toRemoteRepository) remoteRepo
           allRepos <- getRemoteRepos
           if isNothing remoteRepo
               then liftIO $
                    do putStrLn "Showing local shared images only."
                       putStrLn $
                           "\nTo view the contents of a remote repo add \n\
                        \the '-r' switch with one of the remote \n\
                        \repository ids."
               else liftIO $
                    putStrLn
                        ("Showing shared images on: " ++
                         remoteRepoRepoId (fromJust remoteRepo))
           when (not (null allRepos)) $
               liftIO $
               do putStrLn "\nAvailable remote repositories:"
                  mapM_ (putStrLn . (" * " ++) . remoteRepoRepoId) allRepos
           imgs <- lookupSharedImages repoPred (const True)
           if null imgs
               then liftIO $ putStrLn "\n\nNO SHARED IMAGES\n"
               else liftIO $
                    do putStrLn ""
                       putStrLn $ prettyPrintSharedImages $ map snd imgs
           return True


runAddRepo :: RemoteRepo -> BuildAction
runAddRepo repo cfgFile cp _conf = do
    repo' <- remoteRepoCheckSshPrivKey repo
    case writeRemoteRepoConfig repo' cp of
        Left er ->
            error
                (printf
                     "Failed to add remote repo '%s'\
                     \ to b9 configuration. The \
                     \error was: \"%s\"."
                     (show repo)
                     (show er))
        Right cpWithRepo -> writeB9Config cfgFile cpWithRepo
    return True

globals :: Parser GlobalOpts
globals =
    toGlobalOpts <$>
    optional
        (strOption
             (help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" <>
              short 'c' <>
              long "configuration-file" <>
              metavar "FILENAME")) <*>
    switch
        (help "Log everything that happens to stdout" <> short 'v' <>
         long "verbose") <*>
    switch (help "Suppress non-error output" <> short 'q' <> long "quiet") <*>
    optional
        (strOption
             (help "Path to a logfile" <> short 'l' <> long "log-file" <>
              metavar "FILENAME")) <*>
    optional
        (strOption
             (help "Output file for a command/timing profile" <>
              long "profile-file" <>
              metavar "FILENAME")) <*>
    optional
        (strOption
             (help "Root directory for build directories" <> short 'b' <>
              long "build-root-dir" <>
              metavar "DIRECTORY")) <*>
    switch
        (help "Keep build directories after exit" <> short 'k' <>
         long "keep-build-dir") <*>
    switch
        (help "Predictable build directory names" <> short 'u' <>
         long "predictable-build-dir") <*>
    optional
        (strOption
             (help
                  "Cache directory for shared images, default: '~/.b9/repo-cache'" <>
              long "repo-cache" <>
              metavar "DIRECTORY")) <*>
    optional
        (strOption
             (help "Remote repository to share image to" <> short 'r' <>
              long "repo" <>
              metavar "REPOSITORY_ID"))
  where
    toGlobalOpts
        :: Maybe FilePath
        -> Bool
        -> Bool
        -> Maybe FilePath
        -> Maybe FilePath
        -> Maybe FilePath
        -> Bool
        -> Bool
        -> Maybe FilePath
        -> Maybe String
        -> GlobalOpts
    toGlobalOpts cfg verbose quiet logF profF buildRoot keep notUnique mRepoCache repo =
        let minLogLevel =
                if verbose
                    then Just LogTrace
                    else if quiet
                             then Just LogError
                             else Nothing
            b9cfg' =
                let b9cfg =
                        mempty
                        { verbosity = minLogLevel
                        , logFile = logF
                        , profileFile = profF
                        , buildDirRoot = buildRoot
                        , keepTempDirs = keep
                        , uniqueBuildDirs = not notUnique
                        , repository = repo
                        }
                in b9cfg
                   { repositoryCache = Path <$> mRepoCache
                   }
        in GlobalOpts
           { configFile = (Path <$> cfg) <|> pure defaultB9ConfigFile
           , cliB9Config = b9cfg'
           }

cmds :: Parser BuildAction
cmds =
    subparser
        (command
             "version"
             (info
                  (pure runShowVersion)
                  (progDesc "Show program version and exit.")) <>
         command
             "build"
             (info
                  (runBuildArtifacts <$> buildFileParser)
                  (progDesc
                       "Merge all build file and\
                                               \ generate all artifacts.")) <>
         command
             "run"
             (info
                  (runRun <$> sharedImageNameParser <*> many (strArgument idm))
                  (progDesc
                       "Run a command on the lastest version of the\
                                        \ specified shared image. All modifications\
                                        \ are lost on exit.")) <>
         command
             "push"
             (info
                  (runPush <$> sharedImageNameParser)
                  (progDesc
                       "Push the lastest shared image\
                                        \ from cache to the selected \
                                        \ remote repository.")) <>
         command
             "pull"
             (info
                  (runPull <$> optional sharedImageNameParser)
                  (progDesc
                       "Either pull shared image meta\
                                             \ data from all repositories,\
                                             \ or only from just a selected one.\
                                             \ If additionally the name of a\
                                             \ shared images was specified,\
                                             \ pull the newest version\
                                             \ from either the selected repo,\
                                             \ or from the repo with the most\
                                             \ recent version.")) <>
         command
             "clean-local"
             (info
                  (pure runGcLocalRepoCache)
                  (progDesc
                       "Remove old versions of shared images\
                                             \ from the local cache.")) <>
         command
             "clean-remote"
             (info
                  (pure runGcRemoteRepoCache)
                  (progDesc
                       "Remove cached meta-data of a remote repository. \
                       \If no '-r' is given, clean the meta data of ALL \
                       \remote repositories.")) <>
         command
             "list"
             (info (pure runListSharedImages) (progDesc "List shared images.")) <>
         command
             "add-repo"
             (info
                  (runAddRepo <$> remoteRepoParser)
                  (progDesc "Add a remote repo.")) <>
         command
             "reformat"
             (info
                  (runFormatBuildFiles <$> buildFileParser)
                  (progDesc "Re-Format all build files.")))

buildFileParser :: Parser [FilePath]
buildFileParser =
    helper <*>
    some
        (strOption
             (help
                  "Build file to load, specify multiple build\
                \ files (each witch '-f') to build them all in a single run." <>
              short 'f' <>
              long "project-file" <>
              metavar "FILENAME" <>
              noArgError (ErrorMsg "No build file specified!")))

buildVars :: Parser BuildVariables
buildVars =
    zip (("arg_" ++) . show <$> ([1 ..] :: [Int])) <$> many (strArgument idm)

remoteRepoParser :: Parser RemoteRepo
remoteRepoParser =
    helper <*>
    (RemoteRepo <$>
     strArgument (help "The name of the remmote repository." <> metavar "NAME") <*>
     strArgument
         (help "The (remote) repository root path." <>
          metavar "REMOTE_DIRECTORY") <*>
     (SshPrivKey <$>
      strArgument
          (help
               "Path to the SSH private\
                                         \ key file used for \
                                         \ authorization." <>
           metavar "SSH_PRIV_KEY_FILE")) <*>
     (SshRemoteHost <$>
      ((,) <$> strArgument (help "Repo hostname or IP" <> metavar "HOST") <*>
       argument
           auto
           (help "SSH-Port number" <> value 22 <> showDefault <> metavar "PORT"))) <*>
     (SshRemoteUser <$>
      strArgument (help "SSH-User to login" <> metavar "USER")))

sharedImageNameParser :: Parser SharedImageName
sharedImageNameParser =
    helper <*>
    (SharedImageName <$>
     strArgument (help "Shared image name" <> metavar "NAME"))

b9Version :: String
b9Version = showVersion version