module Main where
import qualified Prelude
import RIO hiding (view)
import RIO.List.Partial
import qualified RIO.HashMap as HM
import qualified RIO.HashMap.Partial as HMP
import RIO.Process
import qualified RIO.Text as Text
import qualified RIO.Text.Partial as TextP
import Baserock.Schema.V9
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Lens as JSON
import qualified Data.Aeson.Types as JSON (typeMismatch)
import Data.Hashable (Hashable)
import Gitlab
import GHC.Generics (Generic)
import Lens.Micro.Platform
import qualified System.Etc as Etc
import Paths_baserock_schema (getDataFileName)
--------------------------------------------------------------------------------
-- We specify the support commands for our program
data Cmd
= PrintConfig
| Sanitize
| SetAllRefs
| BumpShas
deriving (Show, Eq, Generic)
instance Hashable Cmd
instance JSON.FromJSON Cmd where
parseJSON json =
case json of
JSON.String cmdName
| cmdName == "config" -> return PrintConfig
| cmdName == "sanitize" -> return Sanitize
| cmdName == "set-all-refs" -> return SetAllRefs
| cmdName == "bump-shas" -> return BumpShas
| otherwise -> JSON.typeMismatch ("Cmd (" <> Text.unpack cmdName <> ")") json
_ -> JSON.typeMismatch "Cmd" json
instance JSON.ToJSON Cmd where
toJSON cmd =
case cmd of
PrintConfig -> JSON.String "config"
Sanitize -> JSON.String "sanitize"
SetAllRefs -> JSON.String "set-all-refs"
BumpShas -> JSON.String "bump-shas"
---------------------------------------------------------------------------------
type Aliases = HashMap Text Text
chunkLatest :: MonadGitlab env m => Chunk -> m (Maybe GitlabCommitData)
chunkLatest c = forM (liftA2 (,) (Text.dropSuffix ".git" . toSignificantSuffix <$> _repo c) (_ref c)) $ uncurry getCommitData
expandAliases :: Aliases -> Chunk -> Chunk
expandAliases as = over (repo . _Just) (flip (HM.foldrWithKey TextP.replace) as)
bumpChunkSha :: (MonadGitlab env m, HasLogFunc env, MonadUnliftIO m) => Aliases -> Chunk -> m Chunk
bumpChunkSha as c = if isNothing $ _repo c then return c else do
logInfo $ "Grabbing latest sha for project " <> display (view (repo . _Just) c) <> " on branch " <> display (view (ref . _Just) c)
t <- catch (chunkLatest $ expandAliases as c) $ \(e :: SomeException) -> do
logInfo "No value found, moving on."
return Nothing
case t of
Just x -> do
logInfo $ "Got value: " <> display (_glCommitId x)
return $ (sha ?~ _glCommitId x) c
Nothing -> return c
toSignificantSuffix = (!! 1) . TextP.splitOn ":"
getAliases ybdconf = do
ybdconf <- decodeFileThrow ybdconf
let Right (Object as) = parseEither (.: "aliases") ybdconf
return $ (\(String y) -> y) <$> as
sanitizeStratum :: (MonadIO m, MonadThrow m) => FilePath -> m Stratum
sanitizeStratum = sanitizeFile
setStratumRef :: (MonadReader env m, HasLogFunc env, MonadIO m, MonadThrow m) => FilePath -> Text -> m Stratum
setStratumRef f a = do
logInfo $ "Setting ref of Stratum " <> displayShow f <> " to " <> displayShow a
inplace overFile f (chunks . traverse) (ref ?~ a)
setSystemRef :: (MonadReader env m, HasLogFunc env, MonadIO m, MonadThrow m) => FilePath -> Text -> m System
setSystemRef f a = do
logInfo $ "Setting ref of System " <> displayShow f <> " to " <> displayShow a
s <- decodeFileThrow f
forM_ (s ^.. (strata . traverse . stratumIncludeMorph)) $ flip setStratumRef a . Text.unpack
return s
bumpStratum as f = do
logInfo $ "Bumping all shas in stratum " <> displayShow f
inplace traverseOfFile f (chunks . traverse) (bumpChunkSha as)
bumpSystem as f = do
logInfo $ "Bumping all shas in system " <> displayShow f
s <- decodeFileThrow f
forM_ (s ^.. (strata. traverse . stratumIncludeMorph)) $ bumpStratum as . Text.unpack
return s
data BaserockApp =
BaserockApp {
appLogFunc :: !LogFunc
, appProcessContext :: !ProcessContext
, appGitlabConfig :: !GitlabConfig
}
instance HasLogFunc BaserockApp where
logFuncL = lens appLogFunc (\x y -> x { appLogFunc = y })
instance HasProcessContext BaserockApp where
processContextL = lens appProcessContext (\x y -> x { appProcessContext = y })
instance HasGitlabConfig BaserockApp where
gitlabConfigL = lens appGitlabConfig (\x y -> x { appGitlabConfig = y })
main :: IO ()
main = do
specPath <- getDataFileName "spec.yaml"
configSpec <- Etc.readConfigSpec (Text.pack specPath)
Etc.reportEnvMisspellingWarnings configSpec
(configFiles, _fileWarnings) <- Etc.resolveFiles configSpec
(cmd , configCli ) <- Etc.resolveCommandCli configSpec
configEnv <- Etc.resolveEnv configSpec
let configDefault = Etc.resolveDefault configSpec
config = configDefault `mappend` configFiles `mappend` configEnv `mappend` configCli
logOptions <- logOptionsHandle stdout True
let cValueS = flip Etc.getConfigValue config :: [Text] -> IO String
let cValueB = flip Etc.getConfigValue config :: [Text] -> IO Bool
appProcessContext <- mkDefaultProcessContext
withLogFunc logOptions $ \logFunc -> case cmd of
PrintConfig -> Etc.printPrettyConfig config
Sanitize -> do
f <- cValueS ["system"]
runRIO logFunc $ do
logInfo $ "Sanitizing system " <> displayShow f
s <- sanitizeFile f
forM_ (s ^.. (strata . traverse . stratumIncludeMorph)) $ \x -> do
logInfo $ "Sanitizing stratum " <> displayShow x
sanitizeStratum . Text.unpack $ x
SetAllRefs -> do
f <- cValueS ["morph"]
a <- cValueS ["ref"]
runRIO logFunc $ void $ do
(m :: Value) <- decodeFileThrow f
case m ^? JSON.key "kind" of
Just (String "stratum") -> void $ setStratumRef f (Text.pack a)
Just (String "system") -> void $ setSystemRef f (Text.pack a)
BumpShas -> do
f <- cValueS ["morph"]
gUrl <- cValueS ["gitlab", "url"]
gToken <- cValueS ["gitlab", "token"]
aliases <- liftIO $ getAliases "ybd.conf"
let gConfg = GitlabConfig (fromString gUrl) (fromString gToken)
runRIO (BaserockApp logFunc appProcessContext gConfg) $ do
(m :: Value) <- decodeFileThrow f
case m ^? JSON.key "kind" of
Just (String "stratum") -> void $ bumpStratum aliases f
Just (String "system") -> void $ bumpSystem aliases f