{- |
Module : Data.FileStore.Git
Copyright : Copyright (C) 2009 John MacFarlane
License : BSD 3
Maintainer : John MacFarlane <jgm@berkeley.edu>
Stability : alpha
Portability : GHC 6.10 required
A versioned filestore implemented using git.
Normally this module should not be imported: import
"Data.FileStore" instead.
-}moduleData.FileStore.Git(gitFileStore)whereimportData.FileStore.TypesimportData.Maybe(mapMaybe)importData.List.Split(endByOneOf)importSystem.ExitimportData.Time.Clock.POSIX(posixSecondsToUTCTime)importData.FileStore.Utils(withSanityCheck,hashsMatch,runShellCommand,escapeRegexSpecialChars,withVerifyDir)importData.ByteString.Lazy.UTF8(toString)importqualifiedData.ByteString.LazyasBimportqualifiedText.ParserCombinators.ParsecasPimportCodec.Binary.UTF8.String(encodeString)importControl.Monad(when)importSystem.FilePath((</>))importSystem.Directory(createDirectoryIfMissing,doesDirectoryExist,executable,getPermissions,setPermissions)importControl.Exception(throwIO)importPaths_filestore-- | Return a filestore implemented using the git distributed revision control system-- (<http://git-scm.com/>).gitFileStore::FilePath->FileStoregitFileStorerepo=FileStore{initialize=gitInitrepo,save=gitSaverepo,retrieve=gitRetrieverepo,delete=gitDeleterepo,rename=gitMoverepo,history=gitLogrepo,latest=gitLatestRevIdrepo,revision=gitGetRevisionrepo,index=gitIndexrepo,directory=gitDirectoryrepo,search=gitSearchrepo,idsMatch=consthashsMatchrepo}-- | Run a git command and return error status, error output, standard output. The repository-- is used as working directory.runGitCommand::FilePath->String->[String]->IO(ExitCode,String,B.ByteString)runGitCommandrepocommandargs=doletenv=Just[("GIT_DIFF_OPTS","-u100000")](status,err,out)<-runShellCommandrepoenv"git"(command:args)return(status,toStringerr,out)-- | Initialize a repository, creating the directory if needed.gitInit::FilePath->IO()gitInitrepo=doexists<-doesDirectoryExistrepowhenexists$withVerifyDirrepo$throwIORepositoryExistscreateDirectoryIfMissingTruerepo(status,err,_)<-runGitCommandrepo"init"[]ifstatus==ExitSuccessthendo-- Add the post-update hook, so that changes made remotely via git-- will be reflected in the working directory.postupdatepath<-getDataFileName$"extra"</>"post-update"postupdatecontents<-B.readFilepostupdatepathletpostupdate=repo</>".git"</>"hooks"</>"post-update"B.writeFilepostupdatepostupdatecontentsperms<-getPermissionspostupdatesetPermissionspostupdate(perms{executable=True})-- Set up repo to allow push to current branch(status',err',_)<-runGitCommandrepo"config"["receive.denyCurrentBranch","ignore"]ifstatus'==ExitSuccessthenreturn()elsethrowIO$UnknownError$"git config failed:\n"++err'elsethrowIO$UnknownError$"git-init failed:\n"++err-- | Commit changes to a resource. Raise 'Unchanged' exception if there were-- no changes.gitCommit::FilePath->[FilePath]->Author->String->IO()gitCommitreponamesauthorlogMsg=do(statusCommit,errCommit,_)<-runGitCommandrepo"commit"$["--author",authorNameauthor++" <"++authorEmailauthor++">","-m",logMsg]++namesifstatusCommit==ExitSuccessthenreturn()elsethrowIO$ifnullerrCommitthenUnchangedelseUnknownError$"Could not git commit "++unwordsnames++"\n"++errCommit-- | Save changes (creating file and directory if needed), add, and commit.gitSave::Contentsa=>FilePath->FilePath->Author->Description->a->IO()gitSavereponameauthorlogMsgcontents=dowithSanityCheckrepo[".git"]name$B.writeFile(repo</>encodeStringname)$toByteStringcontents(statusAdd,errAdd,_)<-runGitCommandrepo"add"[name]ifstatusAdd==ExitSuccessthengitCommitrepo[name]authorlogMsgelsethrowIO$UnknownError$"Could not git add '"++name++"'\n"++errAdd-- | Retrieve contents from resource.gitRetrieve::Contentsa=>FilePath->FilePath->MaybeRevisionId-- ^ @Just@ revision ID, or @Nothing@ for latest->IOagitRetrievereponamerevid=doletobjectName=caserevidofNothing->"HEAD:"++nameJustrev->rev++":"++name-- Check that the object is a file (blob), not a directory (tree)(_,_,output)<-runGitCommandrepo"cat-file"["-t",objectName]when(take4(toStringoutput)/="blob")$throwIONotFound(status',err',output')<-runGitCommandrepo"cat-file"["-p",objectName]ifstatus'==ExitSuccessthenreturn$fromByteStringoutput'elsethrowIO$UnknownError$"Error in git cat-file:\n"++err'-- | Delete a resource from the repository.gitDelete::FilePath->FilePath->Author->Description->IO()gitDeletereponameauthorlogMsg=withSanityCheckrepo[".git"]name$do(statusAdd,errRm,_)<-runGitCommandrepo"rm"[name]ifstatusAdd==ExitSuccessthengitCommitrepo[name]authorlogMsgelsethrowIO$UnknownError$"Could not git rm '"++name++"'\n"++errRm-- | Change the name of a resource.gitMove::FilePath->FilePath->FilePath->Author->Description->IO()gitMoverepooldNamenewNameauthorlogMsg=do_<-gitLatestRevIdrepooldName-- will throw a NotFound error if oldName doesn't exist(statusAdd,err,_)<-withSanityCheckrepo[".git"]newName$runGitCommandrepo"mv"[oldName,newName]ifstatusAdd==ExitSuccessthengitCommitrepo[oldName,newName]authorlogMsgelsethrowIO$UnknownError$"Could not git mv "++oldName++" "++newName++"\n"++err-- | Return revision ID for latest commit for a resource.gitLatestRevId::FilePath->FilePath->IORevisionIdgitLatestRevIdreponame=do(revListStatus,_,output)<-runGitCommandrepo"rev-list"["--max-count=1","HEAD","--",name]-- we need to check separately to make sure the resource hasn't been removed-- from the repository:(catStatus,_,_)<-runGitCommandrepo"cat-file"["-e","HEAD:"++name]ifrevListStatus==ExitSuccess&&catStatus==ExitSuccessthendoletresult=takeWhile(`notElem`"\n\r \t")$toStringoutputifnullresultthenthrowIONotFoundelsereturnresultelsethrowIONotFound-- | Get revision information for a particular revision ID, or latest revision.gitGetRevision::FilePath->RevisionId->IORevisiongitGetRevisionreporevid=do(status,_,output)<-runGitCommandrepo"whatchanged"["-z","--pretty=format:"++gitLogFormat,"--max-count=1",revid]ifstatus==ExitSuccessthencaseP.parseparseGitLog""(toStringoutput)ofLefterr'->throwIO$UnknownError$"error parsing git log: "++showerr'Right[r]->returnrRight[]->throwIONotFoundRightxs->throwIO$UnknownError$"git rev-list returned more than one result: "++showxselsethrowIONotFound-- | Get a list of all known files inside and managed by a repository.gitIndex::FilePath->IO[FilePath]gitIndexrepo=withVerifyDirrepo$do(status,_err,output)<-runGitCommandrepo"ls-tree"["-r","-t","-z","HEAD"]ifstatus==ExitSuccessthenreturn$mapMaybe(lineToFilename.words).endByOneOf['\0'].toString$outputelsereturn[]-- if error, will return empty list-- note: on a newly initialized repo, 'git ls-tree HEAD' returns an errorwherelineToFilename(_:"blob":_:rest)=Just$unwordsrestlineToFilename_=Nothing-- | Get list of resources in one directory of the repository.gitDirectory::FilePath->FilePath->IO[Resource]gitDirectoryrepodir=withVerifyDir(repo</>dir)$do(status,_err,output)<-runGitCommandrepo"ls-tree"["-z","HEAD:"++dir]ifstatus==ExitSuccessthenreturn$map(lineToResource.words)$endByOneOf['\0']$toStringoutputelsereturn[]-- if error, this will return empty list-- note: on a newly initialized repo, 'git ls-tree HEAD:' returns an errorwherelineToResource(_:"blob":_:rest)=FSFile$unwordsrestlineToResource(_:"tree":_:rest)=FSDirectory$unwordsrestlineToResource_=error"Encountered an item that is neither blob nor tree in git ls-tree"-- | Uses git-grep to search repository. Escape regex special characters, so the pattern-- is interpreted as an ordinary string.gitSearch::FilePath->SearchQuery->IO[SearchMatch]gitSearchrepoquery=doletopts=["-I","-n","--null"]++["--ignore-case"|queryIgnoreCasequery]++["--all-match"|queryMatchAllquery]++["--word-regexp"|queryWholeWordsquery](status,errOutput,output)<-runGitCommandrepo"grep"(opts++concatMap(\term->["-e",escapeRegexSpecialCharsterm])(queryPatternsquery))casestatusofExitSuccess->return$mapparseMatchLine$lines$toStringoutputExitFailure1->return[]-- status of 1 means no matches in recent versions of gitExitFailure_->throwIO$UnknownError$"git grep returned error status.\n"++errOutput-- Auxiliary function for searchResultsparseMatchLine::String->SearchMatchparseMatchLinestr=SearchMatch{matchResourceName=fname,matchLineNumber=ifnot(nullln)thenreadlnelseerror$"parseMatchLine: "++str,matchLine=cont}where(fname,xs)=break(=='\NUL')strrest=drop1xs-- for some reason, NUL is used after line number instead of-- : when --match-all is passed to git-grep.(ln,ys)=span(`elem`['0'..'9'])restcont=drop1ys-- drop : or NUL after line number{-
-- | Uses git-diff to get a dif between two revisions.
gitDiff :: FilePath -> FilePath -> RevisionId -> RevisionId -> IO String
gitDiff repo name from to = do
(status, _, output) <- runGitCommand repo "diff" [from, to, name]
if status == ExitSuccess
then return $ toString output
else do
-- try it without the path, since the error might be "not in working tree" for a deleted file
(status', err', output') <- runGitCommand repo "diff" [from, to]
if status' == ExitSuccess
then return $ toString output'
else throwIO $ UnknownError $ "git diff returned error:\n" ++ err'
-}gitLogFormat::StringgitLogFormat="%H%n%ct%n%an%n%ae%n%B%n%x00"-- | Return list of log entries for the given time frame and list of resources.-- If list of resources is empty, log entries for all resources are returned.gitLog::FilePath->[FilePath]->TimeRange->IO[Revision]gitLogreponames(TimeRangembSincembUntil)=do(status,err,output)<-runGitCommandrepo"whatchanged"$["-z","--pretty=format:"++gitLogFormat]++(casembSinceofJustsince->["--since='"++showsince++"'"]Nothing->[])++(casembUntilofJusttil->["--until='"++showtil++"'"]Nothing->[])++["--"]++namesifstatus==ExitSuccessthencaseP.parseparseGitLog""(toStringoutput)ofLefterr'->throwIO$UnknownError$"Error parsing git log.\n"++showerr'Rightparsed->returnparsedelsethrowIO$UnknownError$"git whatchanged returned error status.\n"++err---- Parsers to parse git log into Revisions.--parseGitLog::P.Parser[Revision]parseGitLog=P.manyTillgitLogEntryP.eofwholeLine::P.GenParserCharstStringwholeLine=P.manyTillP.anyCharP.newlinenonblankLine::P.GenParserCharstStringnonblankLine=P.notFollowedByP.newline>>wholeLinenullChar::P.GenParserCharst()nullChar=P.satisfy(=='\0')>>return()gitLogEntry::P.ParserRevisiongitLogEntry=dorev<-nonblankLinedate<-nonblankLineauthor<-wholeLineemail<-wholeLinesubject<-P.manyTillP.anyCharnullCharP.spaceschanges<-P.manyTillgitLogChange(P.eofP.<|>nullChar)letstripTrailingNewlines=reverse.dropWhile(=='\n').reversereturnRevision{revId=rev,revDateTime=posixSecondsToUTCTime$realToFrac(readdate::Integer),revAuthor=Author{authorName=author,authorEmail=email},revDescription=stripTrailingNewlinessubject,revChanges=changes}gitLogChange::P.ParserChangegitLogChange=doline<-P.manyTillP.anyCharnullCharletchangeType=take1$reverselinefile'<-P.manyTillP.anyCharnullCharcasechangeTypeof"A"->return$Addedfile'"M"->return$Modifiedfile'"D"->return$Deletedfile'_->return$Modifiedfile'