baserock-schema 0.0.3.4 → 0.0.3.5
raw patch · 5 files changed
+266/−113 lines, 5 files
Files
- ChangeLog.md +6/−0
- README.md +40/−8
- app/Main.hs +203/−101
- baserock-schema.cabal +2/−2
- resources/spec.yaml +15/−2
ChangeLog.md view
@@ -1,5 +1,11 @@ # Changelog for baserock-schema +## 0.0.3.5++Upgrade to yaml-0.8.31.1+Add maybe-track-ref for potentially tracking ref and updating sha+Add steal-instructions for pulling chunk instructions from a separate branch+ ## 0.0.3.4 Use hackage version of gitlab-api
README.md view
@@ -1,27 +1,59 @@ # baserock-schema -Definitions schema for baserock system definitions.+Definitions schema for baserock system definitions. This repository provides a library+for interaction with definitions via lenses as well as several common tools for+assisting with annoying rebase work where your development branch and master have+diverged too much. +## Building++You will need [stack](https://docs.haskellstack.org/en/stable/README/)+ You can build with stack build -You can test with+## Testing +You can run the tests with+ stack test -You can test the in-place application by running+## Installing +You can install the application by running+ stack install which will install the baserock executable. You may then sit in a definitions repository and run - baserock sanitize <path/to/system.morph>+ baserock sanitize <path/to/morph> -You can set all the refs in a given stratum by runnings+## Usage - baserock set-all-refs <ref> <path/to/stratum.morph>+The main executable has several commands you can use to manipulate definitions in useful ways.+All commands which take a <morph> field can usually be given either a system or a stratum, and+in some but not all cases a chunk morph where it makes sense. -For gitlab-only strata you can bump the shas to the latest head of that ref by doing+You can sanitize a system or stratum with - baserock bump-shas <path/to/stratum.morph>+ baserock sanitize <path/to/morph>++You can set all the refs for every chunk in a given system or stratum by running++ baserock set-all-refs <ref> <path/to/morph>++You can use information from gitlab to modify your morphologies. To bump the sha of+every chunk to the HEAD of its currently listed ref, run++ baserock bump-shas <path/to/morph> -t GITLAB_API_TOKEN -u GITLAB_BASE_URL++You can also change the ref and track shas if and only if the supplied ref exists+on gitlab, by running++ baserock maybe-track-ref <ref> <path/to/morph> -t GITLAB_API_TOKEN -u GITLAB_BASE_URL++You can checkout the chunk instructions for every chunk in a system or stratum from a+different branch in the current definitoins repository, by running++ baserock steal-instructions <branch> <path/to/morph>
app/Main.hs view
@@ -2,127 +2,218 @@ import qualified Prelude -import RIO hiding (view)++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 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 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 GHC.Generics ( Generic ) import Lens.Micro.Platform-import qualified System.Etc as Etc+import qualified System.Etc as Etc -import Paths_baserock_schema (getDataFileName)+import Paths_baserock_schema ( getDataFileName ) ----------------------------------------------------------------------------------- We specify the support commands for our program data Cmd- = PrintConfig+ = BumpShas+ | MaybeTrackRef+ | PrintConfig | Sanitize | SetAllRefs- | BumpShas+ | StealInstructions 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+ parseJSON json = case json of+ JSON.String cmdName+ | cmdName == "bump-shas" -> return BumpShas+ | cmdName == "maybe-track-ref" -> return MaybeTrackRef+ | cmdName == "print-config" -> return PrintConfig+ | cmdName == "sanitize" -> return Sanitize+ | cmdName == "set-all-refs" -> return SetAllRefs+ | cmdName == "steal-instructions" -> return StealInstructions+ | 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"+ toJSON cmd = case cmd of+ BumpShas -> JSON.String "bump-shas"+ PrintConfig -> JSON.String "print-config"+ MaybeTrackRef -> JSON.String "maybe-track-ref"+ Sanitize -> JSON.String "sanitize"+ SetAllRefs -> JSON.String "set-all-refs"+ StealInstructions -> JSON.String "steal-instructions" --------------------------------------------------------------------------------- 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)+class HasAliases a where+ aliasesL :: Lens' a Aliases -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- +type MonadSimpleApp env m = (MonadReader env m, HasLogFunc env, MonadIO m, MonadUnliftIO m)++type MonadBaserock env m = (MonadSimpleApp env m, MonadGitlab env m, HasAliases env)++type Repo = Text+type Ref = Text++data BaserockApp =+ BaserockApp {+ appAliases :: !Aliases+ , appGitlabConfig :: !GitlabConfig+ , appLogFunc :: !LogFunc+ , appProcessContext :: !ProcessContext+ }++data YBDConf = YBDConf {+ aliases :: Aliases+, directories :: HashMap Text Text+} deriving (Generic, Show)++instance FromJSON YBDConf++instance HasAliases BaserockApp where+ aliasesL = lens appAliases (\x y -> x { appAliases =y })++instance HasGitlabConfig BaserockApp where+ gitlabConfigL = lens appGitlabConfig (\x y -> x { appGitlabConfig = y })++instance HasLogFunc BaserockApp where+ logFuncL = lens appLogFunc (\x y -> x { appLogFunc = y })++instance HasProcessContext BaserockApp where+ processContextL = lens appProcessContext (\x y -> x { appProcessContext = y })++---------------------------------------------------------------------------------++toSignificantSuffix :: Repo -> Text toSignificantSuffix = (!! 1) . TextP.splitOn ":" -getAliases ybdconf = do- ybdconf <- decodeFileThrow ybdconf- let Right (Object as) = parseEither (.: "aliases") ybdconf- return $ (\(String y) -> y) <$> as+repoRefLatest :: MonadGitlab env m => Aliases -> Repo -> Ref -> m GitlabCommitData+repoRefLatest as = getCommitData . Text.dropSuffix ".git" . toSignificantSuffix . expandAliases as+ +expandAliases :: Aliases -> Repo -> Repo+expandAliases = flip (HM.foldrWithKey TextP.replace) -sanitizeStratum :: (MonadIO m, MonadThrow m) => FilePath -> m Stratum-sanitizeStratum = sanitizeFile+bumpChunkSha :: MonadBaserock env m => Chunk -> m Chunk+bumpChunkSha c = case liftA2 (,) (view repo c) (view ref c) of+ Nothing -> logInfo ("No repo/ref for chunk" <> display (view chunkName c)) >> return c+ Just (x, y) -> do+ as <- asks (view aliasesL)+ logInfo $ "Getting latest commit data for repo " <> display x <> " at ref " <> display y+ t <- (Just <$> repoRefLatest as x y) `catch` \(e :: SomeException) -> return Nothing+ case t of+ Nothing -> logInfo "No value found, moving on." >> return c+ Just z -> logInfo ("Found sha:" <> display (view glCommitId z)) >> return ((sha ?~ view glCommitId z) c) -setStratumRef :: (MonadReader env m, HasLogFunc env, MonadIO m, MonadThrow m) => FilePath -> Text -> m Stratum+mapSystemStrata :: Monad m => System -> (FilePath -> m b) -> m [b]+mapSystemStrata s x = forM (s ^.. (strata . traverse . stratumIncludeMorph)) $ x . Text.unpack++sanitizeStratum :: MonadSimpleApp env m => FilePath -> m Stratum+sanitizeStratum x = do+ logInfo $ "Sanitizing stratum " <> displayShow x+ sanitizeFile x++sanitizeSystem :: MonadSimpleApp env m => FilePath -> m System+sanitizeSystem x = do+ logInfo $ "Sanitizing system " <> displayShow x+ s <- sanitizeFile x+ mapSystemStrata s sanitizeStratum+ return s++setStratumRef :: MonadSimpleApp env 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 :: MonadSimpleApp env 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+ mapSystemStrata s $ flip setStratumRef a return s -bumpStratum as f = do+bumpStratum :: MonadBaserock env m => FilePath -> m Stratum+bumpStratum f = do logInfo $ "Bumping all shas in stratum " <> displayShow f- inplace traverseOfFile f (chunks . traverse) (bumpChunkSha as)+ inplace traverseOfFile f (chunks . traverse) bumpChunkSha -bumpSystem as f = do+bumpSystem :: MonadBaserock env m => FilePath -> m System+bumpSystem f = do logInfo $ "Bumping all shas in system " <> displayShow f s <- decodeFileThrow f- forM_ (s ^.. (strata. traverse . stratumIncludeMorph)) $ bumpStratum as . Text.unpack+ mapSystemStrata s bumpStratum return s -data BaserockApp =- BaserockApp {- appLogFunc :: !LogFunc- , appProcessContext :: !ProcessContext- , appGitlabConfig :: !GitlabConfig- }+maybeTrackRemote :: MonadBaserock env m => Ref -> Chunk -> m Chunk+maybeTrackRemote r c = case view repo c of+ Nothing -> logInfo ("No repo/ref for chunk" <> display (view chunkName c)) >> return c+ Just x -> do+ as <- asks (view aliasesL)+ logInfo $ "Getting latest commit data for repo " <> display x <> " at ref " <> display r+ t <- (Just <$> repoRefLatest as x r) `catch` \(e :: SomeException) -> return Nothing+ case t of+ Nothing -> logInfo "No value found, moving on." >> return c+ Just z -> logInfo ("Found sha:" <> display (view glCommitId z)) >> return ((sha ?~ view glCommitId z) . (ref ?~ r) $ c) -instance HasLogFunc BaserockApp where- logFuncL = lens appLogFunc (\x y -> x { appLogFunc = y })+maybeTrackStratum r f = do+ logInfo $ "Looking up tracking info for stratum " <> displayShow f <> " for ref " <> displayShow r+ inplace traverseOfFile f (chunks . traverse) (maybeTrackRemote r) -instance HasProcessContext BaserockApp where- processContextL = lens appProcessContext (\x y -> x { appProcessContext = y })+maybeTrackSystem r f = do+ logInfo $ "Looking up tracking info for system " <> displayShow f <> " for ref " <> displayShow r+ s <- decodeFileThrow f+ mapSystemStrata s $ maybeTrackStratum r+ return s -instance HasGitlabConfig BaserockApp where- gitlabConfigL = lens appGitlabConfig (\x y -> x { appGitlabConfig = y })+stealInstructionsChunk :: (HasProcessContext env, MonadSimpleApp env m) => String -> FilePath -> m ()+stealInstructionsChunk r f = do+ void $ proc "git" ["checkout", r, "--", f] readProcess+ void $ proc "git" ["reset", f, "HEAD"] readProcess +stealInstructionsStratum r f = do+ logInfo $ "Checking out instructions for stratum " <> displayShow f <> " on branch " <> displayShow r+ s <- decodeFileThrow f+ forM_ (s ^.. chunks . traverse . chunkMorph) $ mapM (stealInstructionsChunk r . Text.unpack)++stealInstructionsSystem r f = do+ logInfo $ "Checking out instructions for system " <> displayShow f <> " on branch " <> displayShow r+ s <- decodeFileThrow f+ mapSystemStrata s $ stealInstructionsStratum r++---------------------------------------------------------------------------------++runBaserock+ :: (Etc.IConfig config, MonadThrow m, MonadIO m)+ => config+ -> LogFunc+ -> ProcessContext+ -> (FilePath -> RIO BaserockApp b)+ -> m b+runBaserock c l p m = do+ let cValueS = flip Etc.getConfigValue c+ f <- cValueS ["morph"]+ gUrl <- cValueS ["gitlab", "url"]+ gToken <- cValueS ["gitlab", "token"]+ ybdConf <- decodeFileThrow "ybd.conf"+ let gConfg = GitlabConfig (fromString gUrl) (fromString gToken)+ runRIO (BaserockApp (aliases ybdConf) gConfg l p) $ m f+ main :: IO () main = do specPath <- getDataFileName "spec.yaml"@@ -146,34 +237,45 @@ appProcessContext <- mkDefaultProcessContext withLogFunc logOptions $ \logFunc -> case cmd of- PrintConfig -> Etc.printPrettyConfig config+ 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+ Sanitize -> do+ f <- cValueS ["morph"]+ runRIO logFunc $ do+ (m :: Value) <- decodeFileThrow f+ case m ^? JSON.key "kind" of+ Just (String "stratum") -> void $ sanitizeStratum f+ Just (String "system") -> void $ sanitizeSystem f - 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)+ SetAllRefs -> do+ f <- cValueS ["morph"]+ a <- cValueS ["ref"]+ runRIO logFunc $ 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+ BumpShas -> runBaserock config logFunc appProcessContext $ \f -> do+ (m :: Value) <- decodeFileThrow f+ case m ^? JSON.key "kind" of+ Just (String "stratum") -> void $ bumpStratum f+ Just (String "system") -> void $ bumpSystem f++ MaybeTrackRef -> do+ a <- cValueS ["ref"]+ runBaserock config logFunc appProcessContext $ \f -> do+ (m :: Value) <- decodeFileThrow f+ case m ^? JSON.key "kind" of+ Just (String "stratum") -> void $ maybeTrackStratum (Text.pack a) f+ Just (String "system") -> void $ maybeTrackSystem (Text.pack a) f++ StealInstructions -> do+ f <- cValueS ["morph"]+ a <- cValueS ["ref"]+ runRIO (LoggedProcessContext appProcessContext logFunc) $ do+ (m :: Value) <- decodeFileThrow f+ case m ^? JSON.key "kind" of+ Just (String "stratum") -> void $ stealInstructionsStratum a f+ Just (String "system") -> void $ stealInstructionsSystem a f+ Just (String "chunk") -> void $ stealInstructionsChunk a f
baserock-schema.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: a5b52313d9210e678dfe4723abea61a8ef2dc52296cc1f6a7c0fb18ccef4e211+-- hash: 94014c8a20eec49bf39ba2251a2405b2cf793684ba87002b32e9846d29d863c1 name: baserock-schema-version: 0.0.3.4+version: 0.0.3.5 synopsis: Baserock Definitions Schema description: Baserock Definitions Schema - Parsers, Printers, Encoders, Decoders, ASTs, Graphs and Traversals category: Data
resources/spec.yaml view
@@ -7,7 +7,7 @@ desc: "baserock - Utility toolkit for manipulating definitions" header: "baserock - Utility toolkit for manipulating definitions" commands:- config:+ print-config: desc: "Prints configuration summary" header: "Prints configuration summary" sanitize:@@ -19,6 +19,12 @@ bump-shas: desc: "Bump all shas in a stratum" header: ""+ maybe-track-ref:+ desc: "Will track a ref and bump the sha if the branch exists on the remote"+ header: ""+ steal-instructions:+ desc: "Checkout all chunk instructions for a morphology from another branch in the repo"+ header: "" etc/entries: morph:@@ -29,17 +35,22 @@ input: "argument" metavar: "MORPHFILE" commands:+ - sanitize - set-all-refs - bump-shas+ - maybe-track-ref+ - steal-instructions ref: etc/spec: type: "string"- help: "Value to set"+ help: "A ref value" cli: input: "argument" metavar: "REF" commands: - set-all-refs+ - maybe-track-ref+ - steal-instructions gitlab: url: etc/spec:@@ -52,6 +63,7 @@ metavar: "GITLAB_BASE_URL" commands: - bump-shas+ - maybe-track-ref token: etc/spec: sensitive: true@@ -64,3 +76,4 @@ metavar: "GITLAB_API_TOKEN" commands: - bump-shas+ - maybe-track-ref