module BDCS.API.Recipes(openOrCreateRepo,
findOrCreateBranch,
getBranchOIdFromObject,
writeCommit,
readCommit,
readCommitSpec,
listBranchFiles,
listCommitFiles,
deleteFile,
deleteRecipe,
revertFile,
revertFileCommit,
revertRecipe,
listRecipeCommits,
listCommits,
findCommitTag,
getRevisionFromTag,
tagFileCommit,
tagRecipeCommit,
commitRecipeFile,
commitRecipe,
commitRecipeDirectory,
readRecipeCommit,
recipeDiff,
runGitRepoTests,
runWorkspaceTests,
CommitDetails(..),
RecipeDiffEntry(..),
RecipeDiffType(..),
GitError(..),
printOId)
where
import BDCS.API.Recipe
import BDCS.API.Utils(caseInsensitive, maybeThrow)
import BDCS.API.Workspace
import Control.Conditional(ifM, whenM)
import Control.Exception
import Control.Monad(filterM, unless, void)
import Control.Monad.IO.Class(MonadIO)
import Control.Monad.Loops(allM)
import Data.Aeson(FromJSON(..), ToJSON(..), (.=), (.:), object, withObject, Value(..))
import qualified Data.ByteString as BS
import Data.Either(rights)
import Data.Foldable(asum)
import Data.List(elemIndices, find, isSuffixOf, sortBy)
import Data.Maybe(fromJust, isJust)
import Data.Set(difference, fromList, intersection, Set, toList)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Text.Encoding(decodeUtf8, encodeUtf8)
import Data.Word(Word32)
import GI.Gio
import qualified GI.Ggit as Git
import qualified GI.GLib as GLib
import System.Directory(doesFileExist, doesPathExist, listDirectory)
import System.FilePath.Posix((</>))
import System.IO.Temp(withTempDirectory)
import Text.Printf(printf)
import Text.Read(readMaybe)
data GitError =
OpenRepoError
| CreateRepoError
| CreateBlobError
| CreateCommitError
| CreateBranchError
| BranchNameError
| WriteTreeError
| GetIndexError
| GetHeadError
| RefLookupError
| TreeBuilderError
| GetByNameError
| GetNameError
| GetTargetError
| GetTimeError
| GetTimeZoneError
| GetTreeError
| GetTreeIdError
| GetCommitterError
| GetMessageError
| GetParentsError
| LookupError
| LookupBlobError
| LookupBranchError
| LookupCommitError
| LookupTagError
| LookupTreeError
| LookupReferenceError
| RevparseError
| BuilderWriteError
| BuilderInsertError
| GetEntryIdError
| GetIdError
| GetRawBlobError
| GetTargetIdError
| NewOIdError
| NewOptionsError
| NewTimeValError
| NewTreeError
| NewSignatureError
| NewWalkerError
| OIdError
deriving (Eq, Show)
instance Exception GitError
headCommit :: Git.Repository -> T.Text -> IO Git.Commit
headCommit repo branch = do
branch_obj <- Git.repositoryLookupBranch repo branch Git.BranchTypeLocal >>= maybeThrow LookupBranchError
branch_id <- getBranchOIdFromObject repo branch_obj
Git.repositoryLookupCommit repo branch_id >>= maybeThrow LookupCommitError
prepareCommit :: Git.Repository -> T.Text -> Git.TreeBuilder -> IO (Git.Tree, Git.Signature, Maybe T.Text, Maybe T.Text)
prepareCommit repo branch builder = do
tree_id <- Git.treeBuilderWrite builder >>= maybeThrow BuilderWriteError
tree <- Git.repositoryLookupTree repo tree_id >>= maybeThrow LookupTreeError
sig <- Git.signatureNewNow "bdcs-api" "user-email" >>= maybeThrow NewSignatureError
let ref = Just $ T.pack $ printf "refs/heads/%s" branch
let encoding = Just "UTF-8"
return (tree, sig, ref, encoding)
openOrCreateRepo :: FilePath -> IO Git.Repository
openOrCreateRepo path = do
gfile <- fileNewForPath (path ++ "/git")
ifM (doesPathExist $ path ++ "/git/HEAD")
(openRepo gfile)
(createWithInitialCommit gfile)
where
openRepo gfile = Git.repositoryOpen gfile >>= maybeThrow OpenRepoError
createWithInitialCommit gfile = do
repo <- Git.repositoryInitRepository gfile True >>= maybeThrow CreateRepoError
sig <- Git.signatureNewNow "bdcs-api" "user-email" >>= maybeThrow NewSignatureError
index <- Git.repositoryGetIndex repo >>= maybeThrow GetIndexError
tree_id <- Git.indexWriteTree index >>= maybeThrow WriteTreeError
tree <- Git.repositoryLookupTree repo tree_id >>= maybeThrow LookupTreeError
let ref = Just "HEAD"
let encoding = Just "UTF-8"
void $ Git.repositoryCreateCommit repo ref sig sig encoding "Initial Recipe repository commit" tree [] >>= maybeThrow CreateCommitError
return repo
findOrCreateBranch :: Git.Repository -> T.Text -> IO Git.Branch
findOrCreateBranch repo branch = do
mbranch <- Git.repositoryLookupBranch repo branch Git.BranchTypeLocal
maybe createBranch return mbranch
where
createBranch = do
head_ref <- Git.repositoryGetHead repo >>= maybeThrow GetHeadError
parent_obj <- Git.refLookup head_ref >>= maybeThrow RefLookupError
Git.repositoryCreateBranch repo branch parent_obj [Git.CreateFlagsNone] >>= maybeThrow CreateBranchError
getBranchOIdFromObject :: Git.Repository -> Git.Branch -> IO Git.OId
getBranchOIdFromObject repo branch_obj = do
branch_name <- Git.branchGetName branch_obj >>= maybeThrow BranchNameError
let branch_ref = T.pack $ printf "refs/heads/%s" branch_name
ref <- Git.repositoryLookupReference repo branch_ref >>= maybeThrow LookupReferenceError
Git.refGetTarget ref >>= maybeThrow GetTargetError
writeCommit :: Git.Repository -> T.Text -> T.Text -> T.Text -> BS.ByteString -> IO Git.OId
writeCommit repo branch filename message content = do
parent_commit <- headCommit repo branch
blob_id <- Git.repositoryCreateBlobFromBuffer repo content >>= maybeThrow CreateBlobError
parent_tree <- Git.commitGetTree parent_commit >>= maybeThrow GetTreeError
builder <- Git.repositoryCreateTreeBuilderFromTree repo parent_tree >>= maybeThrow TreeBuilderError
void $ Git.treeBuilderInsert builder filename blob_id Git.FileModeBlob >>= maybeThrow BuilderInsertError
(tree, sig, ref, encoding) <- prepareCommit repo branch builder
Git.repositoryCreateCommit repo ref sig sig encoding message tree [parent_commit] >>= maybeThrow CreateCommitError
readCommit :: Git.Repository -> T.Text -> T.Text -> Maybe T.Text -> IO BS.ByteString
readCommit repo branch filename Nothing = do
let spec = T.pack $ printf "%s:%s" branch filename
readCommitSpec repo spec
readCommit repo _ filename commit = do
let spec = T.pack $ printf "%s:%s" (fromJust commit) filename
readCommitSpec repo spec
readCommitSpec :: Git.Repository -> T.Text -> IO BS.ByteString
readCommitSpec repo spec = do
obj <- Git.repositoryRevparse repo spec >>= maybeThrow RevparseError
oid <- Git.objectGetId obj >>= maybeThrow GetIdError
blob <- Git.repositoryLookupBlob repo oid >>= maybeThrow LookupBlobError
Git.blobGetRawContent blob >>= maybeThrow GetRawBlobError
getFilename :: Git.Tree -> Word32 -> IO (Maybe T.Text)
getFilename tree idx = do
entry <- Git.treeGet tree idx >>= maybeThrow GetTreeError
ifM (isFileBlob entry)
(Just <$> Git.treeEntryGetName entry >>= maybeThrow GetNameError)
(return Nothing)
where
isFileBlob entry = Git.treeEntryGetFileMode entry >>= \case
Git.FileModeBlob -> return True
Git.FileModeBlobExecutable -> return True
_ -> return False
getFilenames :: Git.Tree -> Word32 -> IO [T.Text]
getFilenames tree idx = getFilenames' tree [] idx
getFilenames' :: Git.Tree -> [T.Text] -> Word32 -> IO [T.Text]
getFilenames' _ filenames 0 = return filenames
getFilenames' tree filenames idx = getFilename tree (idx1) >>= \case
Just name -> getFilenames' tree (name:filenames) (idx1)
Nothing -> getFilenames' tree filenames (idx1)
listBranchFiles :: Git.Repository -> T.Text -> IO [T.Text]
listBranchFiles repo branch =
headCommit repo branch >>= listCommitFiles repo
listCommitFiles :: Git.Repository -> Git.Commit -> IO [T.Text]
listCommitFiles repo commit = do
parent_tree_id <- Git.commitGetTreeId commit >>= maybeThrow GetTreeIdError
tree <- Git.repositoryLookupTree repo parent_tree_id >>= maybeThrow LookupTreeError
sz <- Git.treeSize tree
getFilenames tree sz
deleteRecipe :: Git.Repository -> T.Text -> T.Text -> IO Git.OId
deleteRecipe repo branch recipe_name = deleteFile repo branch (recipeTomlFilename $ T.unpack recipe_name)
deleteFile :: Git.Repository -> T.Text -> T.Text -> IO Git.OId
deleteFile repo branch filename = do
parent_commit <- headCommit repo branch
parent_tree <- Git.commitGetTree parent_commit >>= maybeThrow GetTreeError
builder <- Git.repositoryCreateTreeBuilderFromTree repo parent_tree >>= maybeThrow TreeBuilderError
Git.treeBuilderRemove builder filename
(tree, sig, ref, encoding) <- prepareCommit repo branch builder
let message = T.pack $ printf "Recipe %s deleted" filename
Git.repositoryCreateCommit repo ref sig sig encoding message tree [parent_commit] >>= maybeThrow CreateCommitError
revertRecipe :: Git.Repository -> T.Text -> T.Text -> T.Text -> IO Git.OId
revertRecipe repo branch recipe_name commit = revertFile repo branch (recipeTomlFilename $ T.unpack recipe_name) commit
revertFile :: Git.Repository -> T.Text -> T.Text -> T.Text -> IO Git.OId
revertFile repo branch filename commit = do
commit_id <- Git.oIdNewFromString commit >>= maybeThrow NewOIdError
revertFileCommit repo branch filename commit_id
revertFileCommit :: Git.Repository -> T.Text -> T.Text -> Git.OId -> IO Git.OId
revertFileCommit repo branch filename commit_id = do
commit_obj <- Git.repositoryLookupCommit repo commit_id >>= maybeThrow LookupCommitError
revert_tree <- Git.commitGetTree commit_obj >>= maybeThrow GetTreeError
entry <- Git.treeGetByName revert_tree filename >>= maybeThrow GetByNameError
blob_id <- Git.treeEntryGetId entry >>= maybeThrow GetEntryIdError
parent_commit <- headCommit repo branch
parent_tree <- Git.commitGetTree parent_commit >>= maybeThrow GetTreeError
builder <- Git.repositoryCreateTreeBuilderFromTree repo parent_tree >>= maybeThrow TreeBuilderError
void $ Git.treeBuilderInsert builder filename blob_id Git.FileModeBlob
(tree, sig, ref, encoding) <- prepareCommit repo branch builder
commit <- Git.oIdToString commit_id >>= maybeThrow OIdError
let message = T.pack $ printf "Recipe %s reverted to commit %s" filename commit
Git.repositoryCreateCommit repo ref sig sig encoding message tree [parent_commit] >>= maybeThrow CreateCommitError
data CommitDetails =
CommitDetails { cdCommit :: T.Text
, cdTime :: T.Text
, cdMessage :: T.Text
, cdRevision :: Maybe Int
} deriving (Show, Eq)
instance ToJSON CommitDetails where
toJSON CommitDetails{..} = object [
"commit" .= cdCommit
, "time" .= cdTime
, "message" .= cdMessage
, "revision" .= cdRevision ]
instance FromJSON CommitDetails where
parseJSON = withObject "/recipes/info response" $ \o -> do
cdCommit <- o .: "commit"
cdTime <- o .: "time"
cdMessage <- o .: "message"
cdRevision <- o .: "revision"
return CommitDetails{..}
listRecipeCommits :: Git.Repository -> T.Text -> T.Text -> IO [CommitDetails]
listRecipeCommits repo branch recipe_name = listCommits repo branch (recipeTomlFilename $ T.unpack recipe_name)
listCommits :: Git.Repository -> T.Text -> T.Text -> IO [CommitDetails]
listCommits repo branch filename = do
revwalk <- Git.revisionWalkerNew repo >>= maybeThrow NewWalkerError
Git.revisionWalkerSetSortMode revwalk [Git.SortModeReverse]
let branch_ref = T.pack $ printf "refs/heads/%s" branch
Git.revisionWalkerPushRef revwalk branch_ref
mfirst_id <- Git.revisionWalkerNext revwalk
commitDetails repo revwalk branch filename [] mfirst_id
commitDetails :: Git.Repository -> Git.RevisionWalker -> T.Text -> T.Text -> [CommitDetails] -> Maybe Git.OId -> IO [CommitDetails]
commitDetails _ _ _ _ details Nothing = return details
commitDetails repo revwalk branch filename details next_id = do
let commit_id = fromJust next_id
commit_obj <- Git.repositoryLookupCommit repo commit_id >>= maybeThrow LookupCommitError
parents <- Git.commitGetParents commit_obj >>= maybeThrow GetParentsError
num_parents <- Git.commitParentsGetSize parents
tree <- Git.commitGetTree commit_obj >>= maybeThrow GetTreeError
is_diff <- if num_parents > 0
then do
commits <- mapM (getCommitParent parents) [0..num_parents1]
allM (parentDiff repo filename tree) commits
else
return False
mnext_id <- Git.revisionWalkerNext revwalk
mentry <- Git.treeGetByName tree filename
if isJust mentry && is_diff
then getCommitDetails commit_id commit_obj mnext_id
else commitDetails repo revwalk branch filename details mnext_id
where
getCommitParent :: Git.CommitParents -> Word32 -> IO Git.Commit
getCommitParent parents idx = Git.commitParentsGet parents idx >>= maybeThrow GetParentsError
getCommitDetails :: Git.OId -> Git.Commit -> Maybe Git.OId -> IO [CommitDetails]
getCommitDetails commit_id commit_obj mnext_id = do
mtag <- findCommitTag repo branch filename commit_id
let revision = getRevisionFromTag mtag
message <- Git.commitGetMessage commit_obj >>= maybeThrow GetMessageError
commit_str <- Git.oIdToString commit_id >>= maybeThrow OIdError
sig <- Git.commitGetCommitter commit_obj >>= maybeThrow GetCommitterError
time_str <- Git.signatureGetTime sig >>= maybeThrow GetTimeError >>= formatDateTime
let commit = CommitDetails {cdCommit=commit_str, cdTime=time_str, cdMessage=message, cdRevision=revision}
commitDetails repo revwalk branch filename (commit:details) mnext_id
formatDateTime :: MonadIO m => GLib.DateTime -> m T.Text
formatDateTime datetime = do
utctime <- GLib.dateTimeToUtc datetime
year <- GLib.dateTimeGetYear utctime
month <- GLib.dateTimeGetMonth utctime
day <- GLib.dateTimeGetDayOfMonth utctime
hour <- GLib.dateTimeGetHour utctime
minute <- GLib.dateTimeGetMinute utctime
second <- GLib.dateTimeGetSecond utctime
micro <- GLib.dateTimeGetMicrosecond utctime
let secondsStr = (if micro /= 0 then printf "%02d.%06d" second micro
else printf "%02d" second) :: String
return $ T.pack $ printf "%d-%02d-%02dT%02d:%02d:%sZ" year month day hour minute secondsStr
parentDiff :: Git.Repository -> T.Text -> Git.Tree -> Git.Commit -> IO Bool
parentDiff repo filename commit_tree parent_commit = do
diff_opts <- Git.diffOptionsNew >>= maybeThrow NewOptionsError
Git.diffOptionsSetPathspec diff_opts (Just [filename])
parent_tree <- Git.commitGetTree parent_commit >>= maybeThrow GetTreeError
diff <- Git.diffNewTreeToTree repo (Just commit_tree) (Just parent_tree) (Just diff_opts) >>= maybeThrow NewTreeError
num_deltas <- Git.diffGetNumDeltas diff
return $ num_deltas > 0
findCommitTag :: Git.Repository -> T.Text -> T.Text -> Git.OId -> IO (Maybe T.Text)
findCommitTag repo branch filename commit_id = do
let tag_pattern = T.pack $ printf "%s/%s/r*" branch filename
Git.repositoryListTagsMatch repo (Just tag_pattern) >>= \case
Just [] -> return Nothing
Just tags -> filterTags tags
Nothing -> return Nothing
where
filterTags tags =
maybeOneTag <$> filterM isCommitTag tags
maybeOneTag :: [T.Text] -> Maybe T.Text
maybeOneTag [] = Nothing
maybeOneTag [tag] = Just tag
maybeOneTag _ = Nothing
isCommitTag :: T.Text -> IO Bool
isCommitTag tag = do
let ref_tag = T.pack $ printf "refs/tags/%s" tag
ref <- Git.repositoryLookupReference repo ref_tag >>= maybeThrow LookupReferenceError
tag_oid <- Git.refGetTarget ref >>= maybeThrow GetTargetError
tag_obj <- Git.repositoryLookupTag repo tag_oid >>= maybeThrow LookupTagError
oid <- Git.tagGetTargetId tag_obj >>= maybeThrow GetTargetIdError
cmp <- Git.oIdCompare oid commit_id
return $ cmp == 0
getRevisionFromTag :: Maybe T.Text -> Maybe Int
getRevisionFromTag mtag = case mtag of
Nothing -> Nothing
Just tag -> getRevision $ T.unpack tag
where
getRevision :: String -> Maybe Int
getRevision tag = do
let rs = elemIndices 'r' tag
if null rs
then Nothing
else readMaybe $ drop (last rs + 1) tag
tagRecipeCommit :: Git.Repository -> T.Text -> T.Text -> IO Bool
tagRecipeCommit repo branch recipe_name = tagFileCommit repo branch (recipeTomlFilename $ T.unpack recipe_name)
tagFileCommit :: Git.Repository -> T.Text -> T.Text -> IO Bool
tagFileCommit repo branch filename = do
commits <- listCommits repo branch filename
let rev_commit = findLastRev commits
if null commits || isFirstCommit commits rev_commit
then return False
else tagNewestCommit (head commits) rev_commit
where
tagNewestCommit :: CommitDetails -> Maybe CommitDetails -> IO Bool
tagNewestCommit last_commit rev_commit = do
let rev = if isJust rev_commit && isJust (cdRevision (fromJust rev_commit))
then fromJust (cdRevision (fromJust rev_commit)) + 1
else 1
let name = T.pack $ printf "%s/%s/r%d" branch filename rev
sig <- Git.signatureNewNow "bdcs-api" "user-email" >>= maybeThrow NewSignatureError
commit_id <- Git.oIdNewFromString (cdCommit last_commit) >>= maybeThrow NewOIdError
commit_type <- gobjectType (undefined :: Git.Commit)
commit_obj <- Git.repositoryLookup repo commit_id commit_type >>= maybeThrow LookupError
mtag_id <- Git.repositoryCreateTag repo name commit_obj sig name [Git.CreateFlagsNone]
return $ isJust mtag_id
findLastRev :: [CommitDetails] -> Maybe CommitDetails
findLastRev []= Nothing
findLastRev (x:xs) = case cdRevision x of
Nothing -> findLastRev xs
Just _ -> Just x
isFirstCommit :: [CommitDetails] -> Maybe CommitDetails -> Bool
isFirstCommit _ Nothing = False
isFirstCommit [] _ = False
isFirstCommit (c:_) (Just commit) = commit == c
commitRecipeFile :: Git.Repository -> T.Text -> FilePath -> IO Git.OId
commitRecipeFile repo branch filename = do
toml_in <- TIO.readFile filename
let erecipe = parseRecipe toml_in
let recipe = head $ rights [erecipe]
commitRecipe repo branch recipe
commitRecipe :: Git.Repository -> T.Text -> Recipe -> IO Git.OId
commitRecipe repo branch recipe = do
old_version <- getOldVersion (T.pack $ rName recipe)
let erecipe = recipeBumpVersion recipe old_version
let recipe' = head $ rights [erecipe]
let version = fromJust (rVersion recipe')
let toml_out = encodeUtf8 $ recipeTOML recipe'
let filename = recipeTomlFilename (rName recipe')
let message = T.pack $ printf "Recipe %s, version %s saved" filename version
writeCommit repo branch filename message toml_out
where
getOldVersion :: T.Text -> IO (Maybe String)
getOldVersion recipe_name = do
eold_recipe <- readRecipeCommit repo branch recipe_name Nothing
case eold_recipe of
Left _ -> return Nothing
Right old_recipe -> return $ rVersion old_recipe
commitRecipeDirectory :: Git.Repository -> T.Text -> FilePath -> IO [Git.OId]
commitRecipeDirectory repo branch directory = do
branch_files <- listBranchFiles repo branch
files <- map (directory </>) . filter (skipFiles branch_files) <$> listDirectory directory
mapM (commitRecipeFile repo branch) files
where
skipFiles :: [T.Text] -> String -> Bool
skipFiles branch_files file = T.pack file `notElem` branch_files && ".toml" `isSuffixOf` file
readRecipeCommit :: Git.Repository -> T.Text -> T.Text -> Maybe T.Text -> IO (Either String Recipe)
readRecipeCommit repo branch recipe_name commit = do
branch_files <- listBranchFiles repo branch
let filename = recipeTomlFilename $ T.unpack recipe_name
if filename `notElem` branch_files
then return $ Left (printf "%s is not present on branch %s" filename branch)
else parseRecipe . decodeUtf8 <$> readCommit repo branch filename commit
printOId :: Git.OId -> IO ()
printOId oid =
Git.oIdToString oid >>= print
data RecipeDiffType =
Name {rdtName :: String}
| Description {rdtDescription :: String}
| Version {rdtVersion :: Maybe String}
| Module {rdtModule :: RecipeModule}
| Package {rdtPackage :: RecipeModule}
| None
deriving (Eq, Show)
instance ToJSON RecipeDiffType where
toJSON Name{..} = object ["Name" .= rdtName]
toJSON Description{..} = object ["Description" .= rdtDescription]
toJSON Version{..} = object ["Version" .= rdtVersion]
toJSON Module{..} = object ["Module" .= toJSON rdtModule]
toJSON Package{..} = object ["Package" .= toJSON rdtPackage]
toJSON None = toJSON Null
instance FromJSON RecipeDiffType where
parseJSON = withObject "Recipe diff type" $ \o -> asum [
Name <$> o .: "Name",
Description <$> o .: "Description",
Version <$> o .: "Version",
Module <$> parseJSON (Object o),
Package <$> parseJSON (Object o) ]
data RecipeDiffEntry =
RecipeDiffEntry {
rdeOld :: RecipeDiffType,
rdeNew :: RecipeDiffType
} deriving (Eq, Show)
instance ToJSON RecipeDiffEntry where
toJSON RecipeDiffEntry{..} = object [
"old" .= rdeOld
, "new" .= rdeNew ]
instance FromJSON RecipeDiffEntry where
parseJSON = withObject "Recipe diff entry" $ \o -> do
rdeOld <- o .: "old"
rdeNew <- o .: "new"
return RecipeDiffEntry{..}
recipeDiff :: Recipe -> Recipe -> [RecipeDiffEntry]
recipeDiff oldRecipe newRecipe = do
let removed_modules = removed_diff module_removed (rModules oldRecipe) (rModules newRecipe)
let removed_packages = removed_diff package_removed (rPackages oldRecipe) (rPackages newRecipe)
let added_modules = added_diff module_added (rModules oldRecipe) (rModules newRecipe)
let added_packages = added_diff package_added (rPackages oldRecipe) (rPackages newRecipe)
let same_modules = same_diff module_diff (rModules oldRecipe) (rModules newRecipe)
let same_packages = same_diff package_diff (rPackages oldRecipe) (rPackages newRecipe)
let diffs = [name_diff oldRecipe newRecipe,
description_diff oldRecipe newRecipe,
version_diff oldRecipe newRecipe
] ++ removed_modules ++ added_modules ++ same_modules
++ removed_packages ++ added_packages ++ same_packages
map fromJust (filter isJust diffs)
where
added_diff :: (RecipeModule -> Maybe RecipeDiffEntry) -> [RecipeModule] -> [RecipeModule] -> [Maybe RecipeDiffEntry]
added_diff diff_f o n = map (diff_f . new_m) added_m
where
added_m :: [String]
added_m = sortBy caseInsensitive $ toList $ module_names n `difference` module_names o
new_m :: String -> RecipeModule
new_m m = get_module m n
removed_diff :: (RecipeModule -> Maybe RecipeDiffEntry) -> [RecipeModule] -> [RecipeModule] -> [Maybe RecipeDiffEntry]
removed_diff diff_f o n = map (diff_f . old_m) removed_m
where
removed_m :: [String]
removed_m = sortBy caseInsensitive $ toList $ module_names o `difference` module_names n
old_m :: String -> RecipeModule
old_m m = get_module m o
same_diff :: (RecipeModule -> RecipeModule -> Maybe RecipeDiffEntry) -> [RecipeModule] -> [RecipeModule] -> [Maybe RecipeDiffEntry]
same_diff diff_f o n = map (\m -> diff_f (old_m m) (new_m m)) same_m
where
same_m :: [String]
same_m = sortBy caseInsensitive $ toList $ module_names o `intersection` module_names n
old_m :: String -> RecipeModule
old_m m = get_module m o
new_m :: String -> RecipeModule
new_m m = get_module m n
name_diff :: Recipe -> Recipe -> Maybe RecipeDiffEntry
name_diff o n =
if rName o == rName n then Nothing else
Just $ RecipeDiffEntry (Name (rName o)) (Name (rName n))
description_diff :: Recipe -> Recipe -> Maybe RecipeDiffEntry
description_diff o n =
if rDescription o == rDescription n then Nothing else
Just $ RecipeDiffEntry (Description (rDescription o)) (Description (rDescription n))
version_diff :: Recipe -> Recipe -> Maybe RecipeDiffEntry
version_diff o n =
if rVersion o == rVersion n then Nothing else
Just $ RecipeDiffEntry (Version $ rVersion o) (Version $ rVersion n)
module_diff :: RecipeModule -> RecipeModule -> Maybe RecipeDiffEntry
module_diff o n =
if rmVersion o == rmVersion n then Nothing else
Just $ RecipeDiffEntry (Module o) (Module n)
package_diff :: RecipeModule -> RecipeModule -> Maybe RecipeDiffEntry
package_diff o n =
if rmVersion o == rmVersion n then Nothing else
Just $ RecipeDiffEntry (Package o) (Package n)
module_removed :: RecipeModule -> Maybe RecipeDiffEntry
module_removed o = Just $ RecipeDiffEntry (Module o) None
package_removed :: RecipeModule -> Maybe RecipeDiffEntry
package_removed o = Just $ RecipeDiffEntry (Package o) None
module_added :: RecipeModule -> Maybe RecipeDiffEntry
module_added n = Just $ RecipeDiffEntry None (Module n)
package_added :: RecipeModule -> Maybe RecipeDiffEntry
package_added n = Just $ RecipeDiffEntry None (Package n)
module_names :: [RecipeModule] -> Set String
module_names modules = fromList $ map rmName modules
get_module :: String -> [RecipeModule] -> RecipeModule
get_module module_name module_list = fromJust $ find (\e -> rmName e == module_name) module_list
testRecipe :: Recipe
testRecipe =
Recipe {rName = "test-server",
rVersion = Just "0.1.2",
rDescription = "Testing git commit of a Recipe record",
rPackages = [RecipeModule {rmName = "tmux", rmVersion = "2.2"},
RecipeModule {rmName = "openssh-server", rmVersion = "6.6.*"},
RecipeModule {rmName = "rsync", rmVersion = "3.0.*"}],
rModules = [RecipeModule {rmName = "httpd", rmVersion = "2.4.*"},
RecipeModule {rmName = "mod_auth_kerb", rmVersion = "5.4"},
RecipeModule {rmName = "mod_ssl", rmVersion = "2.4.*"},
RecipeModule {rmName = "php", rmVersion = "5.4.*"},
RecipeModule {rmName = "php-mysql", rmVersion = "5.4.*"}]
}
testFiles :: [T.Text]
testFiles = ["glusterfs.toml","http-server.toml","kubernetes.toml","test-fake.toml","test-server.toml"]
testFiles2 :: [T.Text]
testFiles2 = ["glusterfs.toml","kubernetes.toml","test-fake.toml","test-server.toml"]
data TestError =
FileListError [T.Text]
| ListCommitsError
| HttpCommitError [CommitDetails]
| TagCommitError
| CommitRevisionError [CommitDetails]
| DeleteFailedError FilePath
| RecipeReadError
| RecipeMismatchError [Recipe]
| ChangesOrderError
deriving (Eq, Show)
instance Exception TestError
runGitRepoTests :: IO Bool
runGitRepoTests = withTempDirectory "/var/tmp/" "bdcsgit-test" testGitRepo
testGitRepo :: FilePath -> IO Bool
testGitRepo tmpdir = do
Git.init
repo <- openOrCreateRepo tmpdir
putStrLn " - Committing http-server.toml"
void $ commitRecipeFile repo "master" "./tests/recipes/http-server.toml"
putStrLn " - Committing a directory of recipes"
void $ commitRecipeDirectory repo "master" "./tests/recipes/"
putStrLn " - Committing a Recipe record"
void $ commitRecipe repo "master" testRecipe
putStrLn " - Checking Recipe Version"
erecipe <- readRecipeCommit repo "master" "test-server" Nothing
let recipe = head $ rights [erecipe]
unless (testRecipe == recipe) (throwIO $ RecipeMismatchError [testRecipe, recipe])
let new_recipe1 = testRecipe { rDescription = "Second commit with same version, should bump" }
putStrLn " - Committing a Recipe record with changed description"
void $ commitRecipe repo "master" new_recipe1
putStrLn " - Checking Modified Recipe's Version"
erecipe' <- readRecipeCommit repo "master" "test-server" Nothing
let recipe' = head $ rights [erecipe']
unless (new_recipe1 {rVersion = Just "0.1.3"} == recipe') (throwIO $ RecipeMismatchError [new_recipe1, recipe'])
let new_recipe2 = testRecipe {rDescription = "Third commit with new version, should just use it",
rVersion = Just "0.3.1"}
putStrLn " - Committing a Recipe record with changed description and different version"
void $ commitRecipe repo "master" new_recipe2
putStrLn " - Checking Modified Recipe's Version"
erecipe'' <- readRecipeCommit repo "master" "test-server" Nothing
let recipe'' = head $ rights [erecipe'']
unless (new_recipe2 == recipe'') (throwIO $ RecipeMismatchError [new_recipe2, recipe''])
putStrLn " - Listing the committed files"
files <- listBranchFiles repo "master"
unless (files == testFiles) (throwIO $ FileListError files)
putStrLn " - List commits to http-server.toml"
http_commits <- listCommits repo "master" "http-server.toml"
let expected_msg_1 = "Recipe http-server.toml, version 0.2.0 saved"
let msg_1 = cdMessage (head http_commits)
unless (msg_1 == expected_msg_1) (throwIO $ HttpCommitError http_commits)
putStrLn " - Delete the http-server.toml file"
void $ deleteRecipe repo "master" "http-server"
putStrLn " - Check that http-server.toml has been deleted"
files2 <- listBranchFiles repo "master"
unless (files2 == testFiles2) (throwIO $ FileListError files2)
commit_id <- Git.oIdNewFromString (cdCommit $ head http_commits) >>= maybeThrow NewOIdError
revert_id <- revertFileCommit repo "master" "http-server.toml" commit_id
putStrLn " - Check that http-server.toml has been restored"
files3 <- listBranchFiles repo "master"
unless (files3 == testFiles) (throwIO $ FileListError files3)
putStrLn " - Tag most recent commit of http-server.toml"
ok <- tagRecipeCommit repo "master" "http-server"
unless ok (throwIO TagCommitError)
putStrLn " - Check the Tag"
commits <- listCommits repo "master" "http-server.toml"
let revision = cdRevision (head commits)
unless (revision == Just 1) (throwIO $ CommitRevisionError commits)
let top_commit = cdCommit $ head commits
revert_hash <- fromJust <$> Git.oIdToString revert_id
unless (top_commit == revert_hash) (throwIO ChangesOrderError)
return True
runWorkspaceTests :: IO Bool
runWorkspaceTests = withTempDirectory "/var/tmp/" "bdcsws-test" testWorkspace
testWorkspace :: FilePath -> IO Bool
testWorkspace tmpdir = do
Git.init
repo <- openOrCreateRepo tmpdir
putStrLn " - Write testRecipe to Workspace for master branch"
workspaceWrite repo "master" testRecipe
putStrLn " - Read Recipe from Workspace for master branch"
recipe <- workspaceRead repo "master" "test-server" >>= maybeThrow RecipeReadError
unless (testRecipe == recipe) (throwIO $ RecipeMismatchError [testRecipe, recipe])
putStrLn " - Delete Recipe from Workspace for master branch"
workspaceDelete repo "master" "test-server"
dir <- workspaceDir repo "master"
let filename = dir </> T.unpack (recipeTomlFilename $ T.unpack "test-server")
whenM (doesFileExist filename) (throwIO $ DeleteFailedError filename)
return True