baserock-schema-0.0.2.0: app/Main.hs

{-# LANGUAGE QuasiQuotes #-}

import           Baserock.Schema.V9
import           Control.Monad.State
import           Gitlab
import           Lens.Micro.Platform
import           RIO
import           RIO.List.Partial
import qualified RIO.ByteString                as BS
import qualified RIO.HashMap                   as HM
import qualified RIO.HashMap.Partial           as HMP
import qualified RIO.Text                      as Text
import qualified RIO.Text.Partial              as TextP
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) = parseMaybe (.: "aliases") =<< ybdconf :: Maybe Value
  return $ (\(String y) -> y) <$> as

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

sanitize x = do
  s  <- loadSystem x
  xs <- use defStrata
  logInfo $ "Saving all strata in system " <> displayShow x
  forM_ (s ^.. (strata . traverse . stratumIncludeMorph)) $
    liftM2 encodeFilePrettyLogged (Text.unpack) (xs HMP.!)
  encodeFilePrettyLogged x s

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

  logOptions <- logOptionsHandle stdout True

  when (args `isPresent` command "sanitize") $ do
    f <- args `getArgOrExit` argument "system"
    withLogFunc logOptions $ flip runRIO $
      void $ flip execStateT mempty $ sanitize f

  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   = fromString envBaseUrl
          , glCredsToken = fromString envPrivateToken
          }

    withLogFunc logOptions $ flip runRIO $ do
      s <- decodeFileThrowLogged f
      let s2 = expandAliases aliases s
      r <- runGitlab gconf $ traverseOf (chunks . traverse) bumpChunkSha s2
      let s3 = contractAliases aliases r
      encodeFilePrettyLogged f s3