baserock-schema-0.0.1.5: app/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}

import Baserock.Schema.V9
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Control.Exception
import Control.Lens hiding (argument)
import Control.Monad (when)
import Control.Monad.Except
import Data.Char (toUpper)
import Data.HashMap.Strict
import Data.List
import qualified Data.Text as Text
import Data.Yaml
import Gitlab
import System.Environment (getEnv, getArgs)
import System.Console.Docopt

patterns :: Docopt
patterns = [docopt|
Usage:
  baserock bump-shas <stratum>
  baserock sanitize <system>
|]

getArgOrExit = getArgOrExitWith patterns

chunkLatest :: MonadGitlab m => Chunk -> m GitlabCommitData
chunkLatest = liftM2 getShaOfRef (toSignificantSuffix . _repo) _ref

bumpChunkSha :: MonadGitlab m => Chunk -> m Chunk
bumpChunkSha c = fmap (flip (sha ?~) c . commitId) . chunkLatest $ c

getAliases ybdconf = do
  ybdconf <- decodeFile ybdconf :: IO (Maybe Object)
  let Just (Object as) = join $ parseMaybe (flip (.:) "aliases") <$> ybdconf :: Maybe Value
  return $ fmap (\(String y) -> y) $ as

toSignificantSuffix = (!! 1) . Text.splitOn ":"

main = do
  args <- parseArgsOrExit patterns =<< getArgs

  when (args `isPresent` command "sanitize") $ do
    f <- args `getArgOrExit` (argument "system")
    s <- decodeSystemAST f
    case s of
      Right r -> encodeSystemAST f r
      Left e -> throwIO e

  when (args `isPresent` command "bump-shas") $ do
    f <- args `getArgOrExit` (argument "stratum")
    envPrivateToken      <- getEnv "GITLAB_PRIVATE_TOKEN"
    envBaseUrl           <- getEnv "GITLAB_BASE_URL"

    aliases <- getAliases "ybd.conf"

    let gconf = GitlabConfig { glCredsUrl = BS8.pack envBaseUrl, glCredsToken = BS8.pack envPrivateToken }

    s <- either (error . show) id <$> decodeFileEither f
    let s2 = over (chunks . traverse . repo) (flip (foldrWithKey Text.replace) aliases) s
    r <- runGitlab gconf $ mapMOf (chunks . traverse) bumpChunkSha $ s2
    let s3 = over (chunks . traverse . repo) (flip (foldlWithKey' ((flip . (flip . ) . flip) Text.replace)) aliases) r
    BS.writeFile f (toPrettyYaml s3)