-- Copyright (C) 2003 David Roundy---- This program 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 2, or (at your option)-- any later version.---- This program 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 this program; see the file COPYING. If not, write to-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,-- Boston, MA 02110-1301, USA.{-# LANGUAGE CPP, ForeignFunctionInterface #-}moduleDarcs.Lock(withLock,withLockCanFail,withTemp,withOpenTemp,withStdoutTemp,withTempDir,withPermDir,withDelayedDir,withNamedTemp,writeToFile,appendToFile,writeBinFile,writeLocaleFile,writeDocBinFile,appendBinFile,appendDocBinFile,readBinFile,readLocaleFile,readDocBinFile,writeAtomicFilePS,gzWriteAtomicFilePS,gzWriteAtomicFilePSs,gzWriteDocFile,rmRecursive,removeFileMayNotExist,canonFilename,maybeRelink,worldReadableTemp,tempdirLoc,editText,environmentHelpTmpdir,environmentHelpKeepTmpdir)whereimportPreludehiding(catch)importData.List(inits)importData.Maybe(isJust,listToMaybe)importSystem.Exit(exitWith,ExitCode(..))importSystem.IO(openBinaryFile,openBinaryTempFile,hClose,hPutStr,Handle,IOMode(WriteMode,AppendMode),hFlush,stdout)importSystem.IO.Error(isDoesNotExistError,isAlreadyExistsError)importControl.Exception.Extensible(bracket,throwIO,catch,try,SomeException)importSystem.Directory(removeFile,removeDirectory,doesFileExist,doesDirectoryExist,getDirectoryContents,createDirectory,getTemporaryDirectory,)importSystem.FilePath.Posix(splitDirectories)importWorkaround(renameFile)importDarcs.Utils(withCurrentDirectory,maybeGetEnv,firstJustIO,runEditor)importControl.Monad(unless,when)importDarcs.URL(isRelative)importDarcs.Utils(catchall,addToErrorLoc)importDarcs.RepoPath(AbsolutePath,FilePathLike,toFilePath,getCurrentDirectory,setCurrentDirectory)importByteStringUtils(gzWriteFilePSs,decodeLocale,encodeLocale)importqualifiedData.ByteStringasB(null,readFile,writeFile,hPut,ByteString)importqualifiedData.ByteString.Char8asBC(unpack)importDarcs.SignalHandler(withSignalsBlocked)importPrinter(Doc,hPutDoc,packedString,empty,renderPSs)importDarcs.Global(atexit,darcsdir)importDarcs.Compat(mkStdoutTemp,canonFilename,maybeRelink,atomicCreate,sloppyAtomicCreate)importSystem.Posix.Files(getSymbolicLinkStatus,isDirectory,fileMode,getFileStatus,setFileMode)importSystem.Posix(sleep)#include "impossible.h"withLock::String->IOa->IOareleaseLock::String->IO()withLocksjob=bracket(getlocks30)releaseLock(\_->job)-- | Tries to perform some task if it can obtain the lock,-- Otherwise, just gives up without doing the taskwithLockCanFail::String->IOa->IO(Either()a)withLockCanFailsjob=bracket(takeLocks)(\l->whenl$releaseLocks)(\l->iflthenjob>>=(return.Right)elsereturn$Left())getlock::String->Int->IOStringgetlockl0=doputStrLn$"Couldn't get lock "++lexitWith$ExitFailure1getlocklbadtl=dol<-canonFilenamelbadgotit<-takeLocklifgotitthenreturnlelsedoputStrLn$"Waiting for lock "++lhFlushstdout-- for Windowsdone<-sleep2ifdone==0thengetlockl(tl-1)elsegetlockl0removeFileMayNotExist::FilePathLikep=>p->IO()removeFileMayNotExistf=catchNonExistence(removeFile$toFilePathf)()catchNonExistence::IOa->a->IOacatchNonExistencejobnonexistval=catchjob$\e->ifisDoesNotExistErrorethenreturnnonexistvalelseioErrorereleaseLocks=removeFileMayNotExiststakeLock::FilePathLikep=>p->IOBooltakeLockfp=doatomicCreate$toFilePathfpreturnTrue`catch`\e->ifisAlreadyExistsErrorethenreturnFalseelsedopwd<-getCurrentDirectorythrowIO$addToErrorLoce("takeLock "++toFilePathfp++" in "++toFilePathpwd)takeFile::FilePath->IOBooltakeFilefp=dosloppyAtomicCreatefpreturnTrue`catch`\e->ifisAlreadyExistsErrorethenreturnFalseelsedopwd<-getCurrentDirectorythrowIO$addToErrorLoce("takeFile "++fp++" in "++toFilePathpwd)-- |'withTemp' safely creates an empty file (not open for writing) and-- returns its name.---- The temp file operations are rather similar to the locking operations, in-- that they both should always try to clean up, so exitWith causes trouble.withTemp::(String->IOa)->IOawithTemp=bracketget_empty_fileremoveFileMayNotExistwhereget_empty_file=do(f,h)<-openBinaryTempFile".""darcs"hClosehreturnf-- |'withOpenTemp' creates a temporary file, and opens it.-- Both of them run their argument and then delete the file. Also,-- both of them (to my knowledge) are not susceptible to race conditions on-- the temporary file (as long as you never delete the temporary file; that-- would reintroduce a race condition).withOpenTemp::((Handle,String)->IOa)->IOawithOpenTemp=bracketget_empty_filecleanup-- Warning: A do-notation statement discarded a result of type Either SomeException ().wherecleanup(h,f)=do_<-try(hCloseh)::IO(EitherSomeException())removeFileMayNotExistfget_empty_file=invert`fmap`openBinaryTempFile".""darcs"invert(a,b)=(b,a)withStdoutTemp::(String->IOa)->IOawithStdoutTemp=bracket(mkStdoutTemp"stdout_")removeFileMayNotExisttempdirLoc::IOFilePathtempdirLoc=firstJustIO[readBinFile(darcsdir++"/prefs/tmpdir")>>=return.Just.head.words>>=chkdir,maybeGetEnv"DARCS_TMPDIR">>=chkdir,getTemporaryDirectory>>=chkdir.Just,getCurrentDirectorySansDarcs,return$Just"."-- always returns a Just]>>=return.fromJustwherechkdirNothing=returnNothingchkdir(Justd)=doesDirectoryExistd>>=return.\e->ifethenJust(d++"/")elseNothingenvironmentHelpTmpdir::([String],[String])environmentHelpTmpdir=(["DARCS_TMPDIR","TMPDIR"],["Darcs often creates temporary directories. For example, the `darcs","diff' command creates two for the working trees to be diffed. By","default temporary directories are created in /tmp, or if that doesn't","exist, in _darcs (within the current repo). This can be overridden by","specifying some other directory in the file _darcs/prefs/tmpdir or the","environment variable $DARCS_TMPDIR or $TMPDIR."])getCurrentDirectorySansDarcs::IO(MaybeFilePath)getCurrentDirectorySansDarcs=doc<-getCurrentDirectoryreturn$listToMaybe$drop5$reverse$takeWhileno_darcs$inits$toFilePathcwhereno_darcsx=not$darcsdir`elem`splitDirectoriesxdataWithDirKind=Perm|Temp|DelayedwithDir::WithDirKind->String->(AbsolutePath->IOa)->IOawithDir_""_=bug"withDir called with empty directory name"withDirkindabs_or_relative_namejob=doabsolute_name<-ifisRelativeabs_or_relative_namethenfmap(++abs_or_relative_name)tempdirLocelsereturnabs_or_relative_nameformerdir<-getCurrentDirectorybracket(create_directoryabsolute_name0)(\dir->dosetCurrentDirectoryformerdirk<-keep_tmpdirunlessk$docasekindofPerm->return()Temp->rmRecursive(toFilePathdir)Delayed->atexit$rmRecursive(toFilePathdir))jobwherenewnamename0=namenewnamenamen=name++"-"++showncreate_directory::FilePath->Int->IOAbsolutePathcreate_directorynamen=docreateDirectory$newnamenamensetCurrentDirectory$newnamenamengetCurrentDirectory`catch`(\e->ifisAlreadyExistsErrorethencreate_directoryname(n+1)elsethrowIOe)keep_tmpdir=isJust`fmap`maybeGetEnv"DARCS_KEEP_TMPDIR"environmentHelpKeepTmpdir::([String],[String])environmentHelpKeepTmpdir=(["DARCS_KEEP_TMPDIR"],["If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will","not remove the temporary directories it creates. This is intended","primarily for debugging Darcs itself, but it can also be useful, for","example, to determine why your test preference (see `darcs setpref')","is failing when you run `darcs record', but working when run manually."])-- |'withPermDir' is like 'withTempDir', except that it doesn't-- delete the directory afterwards.withPermDir::String->(AbsolutePath->IOa)->IOawithPermDir=withDirPerm-- |'withTempDir' creates an empty directory and then removes it when it-- is no longer needed. withTempDir creates a temporary directory. The-- location of that directory is determined by the contents of-- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if-- that doesn't exist then whatever your operating system considers to be a-- a temporary directory (e.g. @$TMPDIR@ under Unix, @$TEMP@ under-- Windows).---- If none of those exist it creates the temporary directory-- in the current directory, unless the current directory is under a _darcs-- directory, in which case the temporary directory in the parent of the highest-- _darcs directory to avoid accidentally corrupting darcs's internals.-- This should not fail, but if it does indeed fail, we go ahead and use the-- current directory anyway. If @$DARCS_KEEP_TMPDIR@ variable is set-- temporary directory is not removed, this can be useful for debugging.withTempDir::String->(AbsolutePath->IOa)->IOawithTempDir=withDirTempwithDelayedDir::String->(AbsolutePath->IOa)->IOawithDelayedDir=withDirDelayeddoesDirectoryReallyExist::FilePath->IOBooldoesDirectoryReallyExistf=catchNonExistence(isDirectory`fmap`getSymbolicLinkStatusf)FalsermRecursive::FilePath->IO()rmRecursived=doisd<-doesDirectoryReallyExistdifnotisdthenremoveFiledelsedoconts<-actual_dir_contentswithCurrentDirectoryd$mapM_rmRecursivecontsremoveDirectorydwhereactual_dir_contents=-- doesn't include . or ..doc<-getDirectoryContentsdreturn$filter(/=".")$filter(/="..")cworldReadableTemp::String->IOStringworldReadableTempf=wrt0wherewrt::Int->IOStringwrt100=fail$"Failure creating temp named "++fwrtn=letf_new=f++"-"++shownindook<-takeFilef_newifokthenreturnf_newelsewrt(n+1)withNamedTemp::String->(String->IOa)->IOawithNamedTempn=bracketget_empty_fileremoveFileMayNotExistwhereget_empty_file=worldReadableTempneditText::String->B.ByteString->IOB.ByteStringeditTextdesctxt=withNamedTempdesc$\f->doB.writeFileftxt-- Warning: A do-notation statement discarded a result of type ExitCode._<-runEditorfB.readFilefreadBinFile::FilePathLikep=>p->IOStringreadBinFile=fmapBC.unpack.B.readFile.toFilePath-- | Reads a file. Differs from readBinFile in that it interprets the file in-- the current locale instead of as ISO-8859-1.readLocaleFile::FilePathLikep=>p->IOStringreadLocaleFilef=decodeLocale`fmap`B.readFile(toFilePathf)readDocBinFile::FilePathLikep=>p->IODocreadDocBinFilefp=dops<-B.readFile$toFilePathfpreturn$ifB.nullpsthenemptyelsepackedStringpsappendBinFile::FilePathLikep=>p->String->IO()appendBinFilefs=appendToFilef$\h->hPutStrhsappendDocBinFile::FilePathLikep=>p->Doc->IO()appendDocBinFilefd=appendToFilef$\h->hPutDochdwriteBinFile::FilePathLikep=>p->String->IO()writeBinFilefs=writeToFilef$\h->hPutStrhs-- | Writes a file. Differs from writeBinFile in that it writes the string-- encoded with the current locale instead of what GHC thinks is right.writeLocaleFile::FilePathLikep=>p->String->IO()writeLocaleFilefs=writeToFilef$\h->B.hPuth(encodeLocales)writeDocBinFile::FilePathLikep=>p->Doc->IO()writeDocBinFilefd=writeToFilef$\h->hPutDochdwriteAtomicFilePS::FilePathLikep=>p->B.ByteString->IO()writeAtomicFilePSfps=writeToFilef$\h->B.hPuthpsgzWriteAtomicFilePS::FilePathLikep=>p->B.ByteString->IO()gzWriteAtomicFilePSfps=gzWriteAtomicFilePSsf[ps]gzWriteAtomicFilePSs::FilePathLikep=>p->[B.ByteString]->IO()gzWriteAtomicFilePSsfpss=withSignalsBlocked$withNamedTemp(toFilePathf)$\newf->dogzWriteFilePSsnewfpssalready_exists<-doesFileExist$toFilePathfwhenalready_exists$domode<-fileMode`fmap`getFileStatus(toFilePathf)setFileModenewfmode`catchall`return()renameFilenewf(toFilePathf)gzWriteDocFile::FilePathLikep=>p->Doc->IO()gzWriteDocFilefd=gzWriteAtomicFilePSsf$renderPSsdwriteToFile::FilePathLikep=>p->(Handle->IO())->IO()writeToFilefjob=withSignalsBlocked$withNamedTemp(toFilePathf)$\newf->dobracket(openBinaryFilenewfWriteMode)hClosejobalready_exists<-doesFileExist(toFilePathf)whenalready_exists$domode<-fileMode`fmap`getFileStatus(toFilePathf)setFileModenewfmode`catchall`return()renameFilenewf(toFilePathf)appendToFile::FilePathLikep=>p->(Handle->IO())->IO()appendToFilefjob=withSignalsBlocked$bracket(openBinaryFile(toFilePathf)AppendMode)hClosejob