-- Copyright (C) 2017 Red Hat, Inc.
--
-- This file is part of bdcs-api.
--
-- bdcs-api is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- bdcs-api is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with bdcs-api. If not, see .
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-| Git Recipe storage functions
Recipes are stored in a bare git repository. The repository is created with
'openOrCreateRepo' which returns the Repository which is passed to all of
the other functions.
-}
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.Customization
import BDCS.API.Recipe
import BDCS.API.Utils(caseInsensitive, maybeThrow)
import BDCS.API.Workspace
import Control.Conditional(ifM, whenM)
import qualified Control.Exception as CE
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)
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
-- | Errors that can be thrown by the BDCS.API.Recipes functions.
data GitError =
OpenRepoError -- ^ Repo open error
| CreateRepoError -- ^ Problem creating a new repo
| CreateBlobError -- ^ New Blob error
| CreateCommitError -- ^ Error creating a commit
| CreateBranchError -- ^ New Branch error
| BranchNameError -- ^ Branch name error, eg. doesn't exist
| WriteTreeError -- ^ Tree writing error
| GetIndexError -- ^ Error getting the repository error
| GetHeadError -- ^ Error getting the repository head
| RefLookupError -- ^ Error looking up a ref. eg. doesn't exist
| TreeBuilderError -- ^ Problem creating a Tree Builder for a Tree.
| GetByNameError -- ^ Problem getting a Tree by name
| GetNameError -- ^ Problem getting a Tree Entry by name
| GetTargetError -- ^ Error getting ref. target
| GetTimeError -- ^ Problem getting the time from the Signature
| GetTimeZoneError -- ^ Problem getting the timezone from the Signature
| GetTreeError -- ^ Error getting Commit Tree
| GetTreeIdError -- ^ Error getting commit Tree Id
| GetCommitterError -- ^ Error getting the committer's Signature
| GetMessageError -- ^ Error getting commit message
| GetParentsError -- ^ Problem getting commit's parents
| LookupError -- ^ Error looking up a commit
| LookupBlobError -- ^ Error looking up a Blob OId
| LookupBranchError -- ^ Branch error, eg. doesn't exist
| LookupCommitError -- ^ Commit error, eg. commit doesn't exist
| LookupTagError -- ^ Error looking up a Tag. eg. doesn't exist
| LookupTreeError -- ^ Tree Lookup error. eg. tree id doesn't exist
| LookupReferenceError -- ^ Problem looking up a reference
| RevparseError -- ^ Problem parsing a revision spec
| BuilderWriteError -- ^ Tree Builder write error
| BuilderInsertError -- ^ Tree Builder insert error
| GetEntryIdError -- ^ Error getting a tree entry id
| GetIdError -- ^ Problem getting object's id
| GetRawBlobError -- ^ Error getting the raw Blob content
| GetTargetIdError -- ^ Error getting Tag Id from a tag object
| NewOIdError -- ^ Problem creating a new OId from a string
| NewOptionsError -- ^ Error creating a new Options object
| NewTimeValError -- ^ Error creating a new TimeVal object
| NewTreeError -- ^ Problem creating a new diff Tree
| NewSignatureError -- ^ Error creating a new Signature
| NewWalkerError -- ^ Error creating a new revision Walker object
| OIdError -- ^ Error creating a String from an OId
deriving (Eq, Show)
instance CE.Exception GitError
-- | Get the branch's HEAD Commit
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
--
-- Can throw 'LookupBranchError' or 'LookupCommitError'
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
-- | Prepare for a commit
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@builder@]: Tree to add the commit to
--
-- Returns a tuple of information used when making a commit
--
-- Can throw 'BuilderWriteError', 'LookupTreeError', 'NewSignatureError'
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)
-- | Open a Git repository, or create the initial repository if one doesn't exist
--
-- [@path@]: Path to the git repository
--
-- The bare git repository is created in ./git underneath path
-- If the directory doesn't look like an existing git repo (no ./git/HEAD file) then a new
-- bare repository is created.
--
-- Can throw 'OpenRepoError', 'CreateRepoError', 'NewSignatureError', 'GetIndexError',
-- 'WriteTreeError', 'LookupTreeError', or 'CreateCommitError'
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
-- Make an empty initial commit
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
-- | Lookup the Branch name or create a new branch and return a Git.Branch
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
--
-- Can throw 'GetHeadError', 'RefLookupError', or 'CreateBranchError'
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
-- | Convert a Branch object to an OId
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
--
-- Can throw 'BranchNameError', 'LookupReferenceError', or 'GetTargetError'
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
-- | Make a new commit to a repository's branch
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@filename@]: Filename of the commit
-- [@message@]: Commit message
-- [@content@]: Data to be written to the commit
--
-- Returns the OId of the new commit.
--
-- Can throw 'CreateBlobError', 'GetTreeError', 'TreeBuilderError', 'BuilderInsertError', or 'CreateCommitError'
writeCommit :: Git.Repository -> T.Text -> T.Text -> T.Text -> BS.ByteString -> IO Git.OId
writeCommit repo branch filename message content = do
-- TODO Create the branch if it doesn't already exist (using findOrCreateBranch)
parent_commit <- headCommit repo branch
blob_id <- Git.repositoryCreateBlobFromBuffer repo content >>= maybeThrow CreateBlobError
-- Use treebuilder to make a new entry for this filename and blob: repositoryCreateTreeBuilderFromTree
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
-- | Read a commit and return a ByteString of the content
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@filename@]: Filename of the commit
-- [@commit@]: Commit hash to read, or Nothing to read the HEAD
--
-- TODO Return the commit message too
readCommit :: Git.Repository -> T.Text -> T.Text -> Maybe T.Text -> IO (T.Text, BS.ByteString)
readCommit repo branch filename Nothing = do
commits <- listCommits repo branch filename
let spec = T.pack $ printf "%s:%s" (cdCommit $ head commits) filename
raw <- readCommitSpec repo spec
return (cdCommit $ head commits, raw)
readCommit repo _ filename (Just commit) = do
let spec = T.pack $ printf "%s:%s" commit filename
raw <- readCommitSpec repo spec
return (commit, raw)
-- | Read a commit using a revspec, return the ByteString content
--
-- [@repo@]: Open git repository
-- [@spec@]: revspec to read.
--
-- eg. \:\ or \:\
--
-- Can throw 'RevparseError', 'GetIdError', 'LookupBlobError', or 'GetRawBlobError'
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
-- | Get the filename for a Blob tree entry
--
-- [@tree@]: The commit's Tree object
-- [@idx@]: Entry index to get
--
-- Can throw 'GetTreeError', or 'GetNameError'
getFilename :: Git.Tree -> Word32 -> IO (Maybe T.Text)
getFilename tree idx = do
entry <- Git.treeGet tree idx >>= maybeThrow GetTreeError
-- Only allow Blob and BlobExecutable
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
{-# ANN getFilenames ("HLint: ignore Eta reduce"::String) #-}
-- | Get a list of the Blob tree entry filenames
--
-- [@tree@]: The commit's Tree object
-- [@idx@]: Entry index to get
--
-- This is limited to entries of type Blob and BlobExecutable
getFilenames :: Git.Tree -> Word32 -> IO [T.Text]
getFilenames tree idx = getFilenames' tree [] idx
-- | Build the list of filenames from the tree entries
--
-- [@tree@]: The commit's Tree object
-- [@filenames@]: The accumulated list of filenames
-- [@idx@]: Entry index to get
getFilenames' :: Git.Tree -> [T.Text] -> Word32 -> IO [T.Text]
getFilenames' _ filenames 0 = return filenames
getFilenames' tree filenames idx = getFilename tree (idx-1) >>= \case
Just name -> getFilenames' tree (name:filenames) (idx-1)
Nothing -> getFilenames' tree filenames (idx-1)
-- | List the files on a branch
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
listBranchFiles :: Git.Repository -> T.Text -> IO [T.Text]
listBranchFiles repo branch =
headCommit repo branch >>= listCommitFiles repo
-- | List the files in a commit
--
-- [@repo@]: Open git repository
-- [@commit@]: The commit to get the files from
--
-- Can throw 'GetTreeIdError', or 'LookupTreeError'
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
-- | Delete a recipe from a branch
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@recipe_name@]: The recipe name to delete (not the filename)
deleteRecipe :: Git.Repository -> T.Text -> T.Text -> IO Git.OId
deleteRecipe repo branch recipe_name = deleteFile repo branch (recipeTomlFilename $ T.unpack recipe_name)
-- | Delete a file from a branch
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@filename@]: The recipe filename to delete
--
-- Can throw `GetTreeError`, 'TreeBuilderError', or 'CreateCommitError'
deleteFile :: Git.Repository -> T.Text -> T.Text -> IO Git.OId
deleteFile repo branch filename = do
parent_commit <- headCommit repo branch
-- Use treebuilder to modify the tree
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
{-# ANN revertRecipe ("HLint: ignore Eta reduce"::String) #-}
-- | Revert a recipe to a previous commit
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@recipe_name@]: The recipe name to revert (not the filename)
-- [@commit@]: The commit hash string to revert to
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
-- | Revert a recipe file to a previous commit
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@filename@]: The recipe filename to revert
-- [@commit@]: The commit hash string to revert to
--
-- Can throw 'NewOIdError'
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
-- | Revert a recipe file to a previous commit
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@filename@]: The recipe filename to revert
-- [@commit@]: The commit object to revert to
--
-- Can throw 'LookupCommitError', 'GetTreeError', 'GetByNameError', 'GetEntryIdError', 'GetTreeError',
-- '', 'OIdError', 'CreateCommitError'
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
-- Use treebuilder to modify the tree
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 "%s reverted to commit %s" filename commit
Git.repositoryCreateCommit repo ref sig sig encoding message tree [parent_commit] >>= maybeThrow CreateCommitError
-- | File commit details
data CommitDetails =
CommitDetails { cdCommit :: T.Text -- ^ Hash string
, cdTime :: T.Text -- ^ Timestamp in ISO 8601 format
, cdMessage :: T.Text -- ^ Commit message, separated by \n
, cdRevision :: Maybe Int -- ^ Recipe revision number
} deriving (Show, Eq)
-- JSON instances for CommitDetails
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{..}
-- | List the commits for a recipe
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@recipe_name@]: Recipe name (not filename)
--
-- Returns a list of 'CommitDetails'
listRecipeCommits :: Git.Repository -> T.Text -> T.Text -> IO [CommitDetails]
listRecipeCommits repo branch recipe_name = listCommits repo branch (recipeTomlFilename $ T.unpack recipe_name)
-- | List the commits for a filename
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@filename@]: Recipe filename
--
-- Returns a list of 'CommitDetails'
--
-- Can throw 'NewWalkerError'
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
-- | Get the commit details for a filename
--
-- [@repo@]: Open git repository
-- [@revwalk@]: Git revwalk object
-- [@branch@]: Branch name
-- [@filename@]: Recipe filename
-- [@details@]: Accumulated 'CommitDetails' for the filename
-- [@next_id@]: Next commit OId
--
-- This is a recursive function that accumulates the details for the filename,
-- returning when there are no more commits to examine.
--
-- Can throw 'LookupCommitError', 'GetParentsError', 'GetTreeError', 'GetMessageError',
-- 'OIdError', 'GetCommitterError', 'GetTimeError'
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_parents-1]
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
-- Fill in a commit record
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
-- convert the datetime to UTC
utctime <- GLib.dateTimeToUtc datetime
-- Here are two other obvious ways of
-- Pull the values out of the datetime directly instead of converting
-- to a timeval, because
-- 1) converting to/from a timeval can fail (!!)
-- 2) the annotations for g_date_time_to_timeval are busted so
-- the binding ends up relying on side effects
--
-- g_date_time_format doesn't cut it either, since it can't print microseconds
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
-- Print it out in the same format as g_time_val_to_iso8601
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
-- | Determine if there were changes between a file's commit and its parent
--
-- [@repo@]: Open git repository
-- [@filename@]: Filename to check
-- [@commit_tree@]: The filename's commit Tree
-- [@parent_commit@]: The parent commit to check
--
-- Return True if there were changes, False otherwise
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
-- | Find the revision tag pointing to a specific commit
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@filename@]: Recipe filename
-- [@commit_id@]: The commit OId
--
-- The Tag is of the form refs/tags/\/\/r\
-- There should only be one result.
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
-- | Return True if the tag is on the commit
isCommitTag :: T.Text -> IO Bool
isCommitTag tag = do
-- Find the commit for this tag and check that it matches commit_id
-- If so, return the branch/filename/r* part of the tag
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
-- | Get the revision number from a git tag
--
-- [@mtag@]: The tag string to extract the revision from
--
-- The Tag is of the form refs/tags/\/\/r\
--
-- Returns the revision from the tag, or Nothing
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
-- Get the digits after the final r
let rs = elemIndices 'r' tag
if null rs
then Nothing
else readMaybe $ drop (last rs + 1) tag
-- | Tag a recipe's most recent commit
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@recipe_name@]: Recipe name (not filename)
--
-- Returns True if it is successful
tagRecipeCommit :: Git.Repository -> T.Text -> T.Text -> IO Bool
tagRecipeCommit repo branch recipe_name = tagFileCommit repo branch (recipeTomlFilename $ T.unpack recipe_name)
-- | Tag a file's most recent commit
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@filename@]: Recipe filename
--
-- This uses git tags, of the form refs/tags/\/\/r\
-- Only the most recent recipe commit can be tagged to prevent out of order tagging.
-- Revisions start at 1 and increment for each new commit that is tagged.
-- If the commit has already been tagged it will return False.
--
-- Can throw 'NewSignatureError', 'NewOIdError', 'LookupError'
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 there are no commits, or the most recent one has already been tagged, return False
if null commits || isFirstCommit commits rev_commit
then return False
else tagNewestCommit (head commits) rev_commit
where
-- | Tag the most recent commit
tagNewestCommit :: CommitDetails -> Maybe CommitDetails -> IO Bool
tagNewestCommit last_commit rev_commit = do
-- What revision is this? rev_commit may be Nothing, or cdRevision may be Nothing. Use 1 for those cases
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
-- | Find the last revision in the commits and return it
findLastRev :: [CommitDetails] -> Maybe CommitDetails
findLastRev []= Nothing
findLastRev (x:xs) = case cdRevision x of
Nothing -> findLastRev xs
Just _ -> Just x
-- | Is the revision commit the most recent one?
--
-- If it is, then we cannot make a new tag.
-- If it is not, or there is no rev_commit, we can tag a new one.
isFirstCommit :: [CommitDetails] -> Maybe CommitDetails -> Bool
isFirstCommit _ Nothing = False
isFirstCommit [] _ = False
isFirstCommit (c:_) (Just commit) = commit == c
-- | Commit a Recipe TOML file
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@filename@]: Recipe filename
--
-- Returns the OId of the new commit
commitRecipeFile :: Git.Repository -> T.Text -> FilePath -> IO Git.OId
commitRecipeFile repo branch filename = do
toml_in <- TIO.readFile filename
let erecipe = parseRecipe toml_in
-- XXX Handle errors
let recipe = head $ rights [erecipe]
commitRecipe repo branch recipe
-- | Commit a Recipe record to a branch
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@recipe@]: Recipe record
--
-- If there is already an existing recipe this will bump or replace the
-- version number depending on what the new recipe contains. See the rules
-- in 'bumpVersion'
commitRecipe :: Git.Repository -> T.Text -> Recipe -> IO Git.OId
commitRecipe repo branch recipe = do
old_version <- getOldVersion (T.pack $ rName recipe)
-- Bump the recipe's version
let erecipe = recipeBumpVersion recipe old_version
-- XXX Handle errors
let recipe' = head $ rights [erecipe]
-- Update the workspace with the new commit
workspaceWrite repo branch recipe'
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
-- | Commit recipes from a directory, if they don't already exist
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@directory@]: Directory to read the recipes from
--
-- This reads all files ending in .toml from the directory, skipping recipes that
-- are already in the branch.
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
-- | Read a Recipe from a commit
--
-- [@repo@]: Open git repository
-- [@branch@]: Branch name
-- [@recipe_name@]: Recipe name (not filename)
-- [@commit@]: The commit hash string to read
--
-- If the recipe isn't found it returns a Left
readRecipeCommit :: Git.Repository -> T.Text -> T.Text -> Maybe T.Text -> IO (Either String (T.Text, Recipe))
readRecipeCommit repo branch recipe_name commit = do
-- Is this file in the branch?
branch_files <- listBranchFiles repo branch
if filename `notElem` branch_files
then return $ Left (printf "%s is not present on branch %s" filename branch)
else do
(commit_id, recipe_toml) <- readCommit repo branch filename commit
case (parseRecipe . decodeUtf8) recipe_toml of
Left err -> return $ Left err
Right recipe -> return $ Right (commit_id, recipe)
where
filename = recipeTomlFilename $ T.unpack recipe_name
-- | print the OId
--
-- [@oid@]: The OId to print
--
-- Used for debugging
printOId :: Git.OId -> IO ()
printOId oid =
Git.oIdToString oid >>= print
-- | Type of Diff Entry
--
-- Used by RecipeDiffEntry's old and new fields
data RecipeDiffType =
Name {rdtName :: String} -- ^ Name changed
| Description {rdtDescription :: String} -- ^ Description changed
| Version {rdtVersion :: Maybe String} -- ^ Version changed
| Module {rdtModule :: RecipeModule} -- ^ Module version changed, added, or removed
| Package {rdtPackage :: RecipeModule} -- ^ Package version changed, added, or removed
| None -- ^ Used for added and removed
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) ]
-- | A difference entry
--
-- This uses RecipeDiffType to indicate the type of difference between
-- recipe fields.
--
-- If old is set and new is None it means the entry was removed
-- If old is None and new is set it means the entry was added
-- If both are set then old the the old content and new is the new content
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{..}
-- | Find the differences between two recipes
--
-- [@oldRecipe@]: The old version of the Recipe
-- [@newRecipe@]: The new version of the Recipe
--
-- This calculates the differences between the recipes, returning a list of 'RecipeDiffEntry'.
-- The order is always the same, Name, Description, Version, removed Modules, added Modules,
-- removed Packages, added Packages, and then packages with different versions.
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
-- | Return a list of the modules/packages that have been added
--
-- diff_f is a function that returns a RecipeDiffEntry (eg. module_added, package_added)
-- o and m are lists of the old and new RecipeModules
added_diff :: (RecipeModule -> Maybe RecipeDiffEntry) -> [RecipeModule] -> [RecipeModule] -> [Maybe RecipeDiffEntry]
added_diff diff_f o n = map (diff_f . new_m) added_m
where
-- | Return a list of the added module names
added_m :: [String]
added_m = sortBy caseInsensitive $ toList $ module_names n `difference` module_names o
-- | Lookup a recipe module name in the list of new modules
new_m :: String -> RecipeModule
new_m m = get_module m n
-- | Return a list of the modules/packages that have been removed
--
-- diff_f is a function that returns a RecipeDiffEntry (eg. module_removed, package_removed)
-- o and m are lists of the old and new RecipeModules
removed_diff :: (RecipeModule -> Maybe RecipeDiffEntry) -> [RecipeModule] -> [RecipeModule] -> [Maybe RecipeDiffEntry]
removed_diff diff_f o n = map (diff_f . old_m) removed_m
where
-- | Return a list of the removed module names
removed_m :: [String]
removed_m = sortBy caseInsensitive $ toList $ module_names o `difference` module_names n
-- | Lookup a recipe module name in the list of old modules
old_m :: String -> RecipeModule
old_m m = get_module m o
-- | Return a list of changes to modules/packages that are in both old and new lists
--
-- diff_f is a function that returns a RecipeDiffEntry (eg. module_diff, package_diff)
-- o and m are lists of the old and new RecipeModules
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
-- | Return a list of the module names that are in both lists
same_m :: [String]
same_m = sortBy caseInsensitive $ toList $ module_names o `intersection` module_names n
-- | Lookup a recipe module name in the list of old modules
old_m :: String -> RecipeModule
old_m m = get_module m o
-- | Lookup a recipe module name in the list of old modules
new_m :: String -> RecipeModule
new_m m = get_module m n
-- | Check the recipe name for a change
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))
-- | Check the recipe description for a change
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))
-- | Check the recipe version for a change
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)
-- | Check the module for a different version
--
-- Returns a Module RecipeDiffType with the module details
module_diff :: RecipeModule -> RecipeModule -> Maybe RecipeDiffEntry
module_diff o n =
if rmVersion o == rmVersion n then Nothing else
Just $ RecipeDiffEntry (Module o) (Module n)
-- | Check the package for a different version
--
-- Returns a Package RecipeDiffType with the module details
package_diff :: RecipeModule -> RecipeModule -> Maybe RecipeDiffEntry
package_diff o n =
if rmVersion o == rmVersion n then Nothing else
Just $ RecipeDiffEntry (Package o) (Package n)
-- | Return an entry with a removed module
module_removed :: RecipeModule -> Maybe RecipeDiffEntry
module_removed o = Just $ RecipeDiffEntry (Module o) None
-- | Return an entry with a removed package
package_removed :: RecipeModule -> Maybe RecipeDiffEntry
package_removed o = Just $ RecipeDiffEntry (Package o) None
-- | Return an entry with an added module
module_added :: RecipeModule -> Maybe RecipeDiffEntry
module_added n = Just $ RecipeDiffEntry None (Module n)
-- | Return an entry with an added package
package_added :: RecipeModule -> Maybe RecipeDiffEntry
package_added n = Just $ RecipeDiffEntry None (Package n)
-- ! Return a Set of the module/package names
module_names :: [RecipeModule] -> Set String
module_names modules = fromList $ map rmName modules
-- | Get the recipe module from the list
--
-- Only call this with module names that are known to be in the list
get_module :: String -> [RecipeModule] -> RecipeModule
get_module module_name module_list = fromJust $ find (\e -> rmName e == module_name) module_list
-- =========================
-- Test Functions Below Here
--
-- These functions exist here because there is no way (that I know of) to setup a framework in
-- Spec and run a series of tests in order that depend on a temporary Git repository.
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.*"}],
rCustomization = emptyCustomization
}
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 CE.Exception TestError
-- | Run the Git repository tests with a temporary directory
runGitRepoTests :: IO Bool
runGitRepoTests = withTempDirectory "/var/tmp/" "bdcsgit-test" testGitRepo
-- | Test the Git repository functions
testGitRepo :: FilePath -> IO Bool
testGitRepo tmpdir = do
Git.init
repo <- openOrCreateRepo tmpdir
-- Commit a file to the repo
putStrLn " - Committing http-server.toml"
void $ commitRecipeFile repo "master" "./tests/recipes/http-server.toml"
-- Commit a directory to the repo
putStrLn " - Committing a directory of recipes"
void $ commitRecipeDirectory repo "master" "./tests/recipes/"
-- Commit a Recipe record to the repo
putStrLn " - Committing a Recipe record"
void $ commitRecipe repo "master" testRecipe
-- Check that the testRecipe's version was not bumped on 1st save
putStrLn " - Checking Recipe Version"
erecipe <- readRecipeCommit repo "master" "test-server" Nothing
let recipe = snd $ head $ rights [erecipe]
unless (testRecipe == recipe) (CE.throwIO $ RecipeMismatchError [testRecipe, recipe])
-- Check that saving a changed recipe, with the same version, bumps it.
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
-- Check that the version was bumped on the 2nd save
putStrLn " - Checking Modified Recipe's Version"
erecipe' <- readRecipeCommit repo "master" "test-server" Nothing
let recipe' = snd $ head $ rights [erecipe']
unless (new_recipe1 {rVersion = Just "0.1.3"} == recipe') (CE.throwIO $ RecipeMismatchError [new_recipe1, recipe'])
-- Check that saving a changed recipe, with a completely different version, uses it without bumping.
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
-- Check that the version was used as-is
putStrLn " - Checking Modified Recipe's Version"
erecipe'' <- readRecipeCommit repo "master" "test-server" Nothing
let recipe'' = snd $ head $ rights [erecipe'']
unless (new_recipe2 == recipe'') (CE.throwIO $ RecipeMismatchError [new_recipe2, recipe''])
-- List the files on master
putStrLn " - Listing the committed files"
files <- listBranchFiles repo "master"
unless (files == testFiles) (CE.throwIO $ FileListError files)
-- Get the commits to http-server.toml
putStrLn " - List commits to http-server.toml"
http_commits <- listCommits repo "master" "http-server.toml"
-- Should be 1 commit
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) (CE.throwIO $ HttpCommitError http_commits)
-- delete http-server.toml file
putStrLn " - Delete the http-server.toml file"
void $ deleteRecipe repo "master" "http-server"
-- List the files on master
putStrLn " - Check that http-server.toml has been deleted"
files2 <- listBranchFiles repo "master"
unless (files2 == testFiles2) (CE.throwIO $ FileListError files2)
-- Revert the delete
commit_id <- Git.oIdNewFromString (cdCommit $ head http_commits) >>= maybeThrow NewOIdError
revert_id <- revertFileCommit repo "master" "http-server.toml" commit_id
-- List the files on master
putStrLn " - Check that http-server.toml has been restored"
files3 <- listBranchFiles repo "master"
unless (files3 == testFiles) (CE.throwIO $ FileListError files3)
-- tag a commit
putStrLn " - Tag most recent commit of http-server.toml"
ok <- tagRecipeCommit repo "master" "http-server"
unless ok (CE.throwIO TagCommitError)
-- list the commits and check for the tag
putStrLn " - Check the Tag"
commits <- listCommits repo "master" "http-server.toml"
let revision = cdRevision (head commits)
unless (revision == Just 1) (CE.throwIO $ CommitRevisionError commits)
-- Make sure the first listed commit is the reverted commit
let top_commit = cdCommit $ head commits
revert_hash <- fromJust <$> Git.oIdToString revert_id
unless (top_commit == revert_hash) (CE.throwIO ChangesOrderError)
return True
-- | Run the Workspace tests with a temporary directory
runWorkspaceTests :: IO Bool
runWorkspaceTests = withTempDirectory "/var/tmp/" "bdcsws-test" testWorkspace
-- | Test the Workspace functions
testWorkspace :: FilePath -> IO Bool
testWorkspace tmpdir = do
Git.init
repo <- openOrCreateRepo tmpdir
-- Write the Recipe to workspace for master branch
putStrLn " - Write testRecipe to Workspace for master branch"
workspaceWrite repo "master" testRecipe
-- Read the Recipe, does it match?
putStrLn " - Read Recipe from Workspace for master branch"
recipe <- workspaceRead repo "master" "test-server" >>= maybeThrow RecipeReadError
unless (testRecipe == recipe) (CE.throwIO $ RecipeMismatchError [testRecipe, recipe])
-- Delete the Recipe, is it gone?
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) (CE.throwIO $ DeleteFailedError filename)
return True