Haskell script to automate creating (and re-creating) vagrant base boxes with veewee.

buildBaseBox.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where


import           Data.Monoid
import qualified Data.Text.Lazy as LT
import           Prelude hiding (FilePath)
import           Shelly
import           System.Environment (getArgs)


publicHtml :: FilePath
publicHtml = "publicHtml"

vBoxGuestAdditions :: FilePath
vBoxGuestAdditions = "VBoxGuestAdditions_4.2.4"

usage :: IO ()
usage = putStrLn "usage: buildBaseBox NAME"

buildBaseBox :: LT.Text -> IO ()
buildBaseBox name = shelly $ verbosely $ do
    let name'  = fromText name
        box    = name' <.> "box"
        iso    = "iso" :: FilePath
        server = "blue.unix.virginia.edu"
    gitAnnexCopyFrom_ "time-machine" [ box
                                     , (iso </>) . fromText $ name `mappend` "*"
                                     , iso </> vBoxGuestAdditions
                                     ]

    whenM (test_f box)
          (gitRm_ box)

    -- For some reason the next command failed, although it reported that it
    -- finished successfully.
    veeweeVBoxBuild_ name
    vagrantBox_ "remove" [name]
    vagrantBasebox_ "export" name
    vagrantBox_ "add" [name, toTextIgnore box]

    upload server box
    verifyUpload server box

    gitAnnexAdd_ box
    gitCommit_ $ "Updated " `mappend` name
    gitAnnexSync_
    gitAnnexMoveTo_ "time-machine" [ box
                                   , (iso </>) . fromText $ name `mappend` "*"
                                   , iso </> vBoxGuestAdditions
                                   ]


gitAnnexCopyFrom_ :: LT.Text -> [FilePath] -> Sh ()
gitAnnexCopyFrom_ src files =
    run_ "git" $
        ["annex", "copy", "--from", src] ++ [ toTextIgnore fn | fn <- files ]

gitAnnexAdd_ :: FilePath -> Sh ()
gitAnnexAdd_ pathName =
    run_ "git" ["annex", "add", toTextIgnore pathName]

gitAnnexSync_ :: Sh ()
gitAnnexSync_ = run_ "git" ["annex", "sync"]

gitAnnexMoveTo_ :: LT.Text -> [FilePath] -> Sh ()
gitAnnexMoveTo_ dest files =
    run_ "git" $
        ["annex", "move", "--to", dest] ++ [ toTextIgnore fn | fn <- files ]

gitRm_ :: FilePath -> Sh ()
gitRm_ pathName = run_ "git" ["rm", toTextIgnore pathName]

gitCommit_ :: LT.Text -> Sh ()
gitCommit_ msg = run_ "git" ["commit", "-m", msg]

veeweeVBoxBuild_ :: LT.Text -> Sh ()
veeweeVBoxBuild_ name = run_ "veewee" ["vbox", "build", name]

vagrantBox_ :: LT.Text -> [LT.Text] -> Sh ()
vagrantBox_ commandStr args = run_ "vagrant" $ ["box", commandStr] ++ args

vagrantBasebox_ :: LT.Text -> LT.Text -> Sh ()
vagrantBasebox_ commandStr box = run_ "vagrant" ["basebox", commandStr, box]

upload :: LT.Text -> FilePath -> Sh ()
upload server box = do
    scp_ box $ server `mappend` ":public_html/"
    sshPairs_ server
              [("chmod", ["a+r", toTextIgnore $ publicHtml </> box])]

verifyUpload :: LT.Text -> FilePath -> Sh ()
verifyUpload server box = do
    sshPairs_ server
              [("ls", ["-l", toTextIgnore $ publicHtml </> box])]
    curl ["-I"] url -|- check200
    where url = "http://people.virginia.edu/~err8n/" `mappend` toTextIgnore box

curl :: [LT.Text] -> LT.Text -> Sh LT.Text
curl options url = run "curl" $ options ++ [url]

check200 :: Sh ()
check200 = run_ "grep" ["200 OK"]

scp_ :: FilePath -> LT.Text -> Sh ()
scp_ src dest = run_ "scp" [toTextIgnore src, dest]

main :: IO ()
main = do
    args <- getArgs
    case args of
        ["-h"]     -> usage
        ["--help"] -> usage
        ["help"]   -> usage
        [name]     -> buildBaseBox $ LT.pack name
        _          -> usage