-- Copyright (C) 2007 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; if not, write to the Free Software Foundation,-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.{-# OPTIONS_GHC -cpp -fglasgow-exts #-}{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}#include "gadts.h"moduleDarcs.Repository.HashedIO(HashedIO,applyHashed,copyHashed,copyPartialsHashed,listHashedContents,slurpHashedPristine,writeHashedPristine,clean_hashdir)whereimportDarcs.Global(darcsdir)importqualifiedData.SetasSetimportqualifiedData.MapasMapimportSystem.Directory(getDirectoryContents,createDirectoryIfMissing)importControl.Monad.State(StateT,runStateT,modify,get,put,gets,lift)importControl.Monad(when)importControl.Applicative((<$>))importData.Maybe(isJust)importSystem.IO.Unsafe(unsafeInterleaveIO)importDarcs.SlurpDirectory.Internal(Slurpy(..),SlurpyContents(..),map_to_slurpies,slurpies_to_map)importDarcs.SlurpDirectory(withSlurpy,undefined_size)importDarcs.Repository.Cache(Cache,fetchFileUsingCache,writeFileUsingCache,peekInCache,speculateFileUsingCache,okayHash,cleanCachesWithHint,HashedDir(..),hashedDir)importDarcs.Patch(Patchy,apply)importDarcs.RepoPath(FilePathLike,toFilePath)importDarcs.IO(ReadableDirectory(..),WriteableDirectory(..))importDarcs.Flags(DarcsFlag,Compression(..),compression)importDarcs.Lock(writeAtomicFilePS,removeFileMayNotExist)importDarcs.Utils(withCurrentDirectory)importProgress(debugMessage,beginTedious,endTedious,tediousSize,finishedOneIO,progress)importDarcs.Patch.FileName(FileName,norm_path,fp2fn,fn2fp,fn2niceps,niceps2fn,break_on_dir,own_name,superName)importByteStringUtils(linesPS,unlinesPS)importqualifiedData.ByteStringasB(ByteString,length,empty)importqualifiedData.ByteString.Char8asBC(unpack,pack)importSHA1(sha1PS)-- | @readHashFile c subdir hash@ reads the file with hash @hash@ in dir subdir,-- fetching it from 'Cache' @c@ if needed.readHashFile::Cache->HashedDir->String->IO(String,B.ByteString)readHashFilecsubdirhash=dodebugMessage$"Reading hash file "++hash++" from "++(hashedDirsubdir)++"/"fetchFileUsingCachecsubdirhashapplyHashed::Patchyq=>Cache->[DarcsFlag]->String->qC(xy)->IOStringapplyHashedcfshp=dos<-slurpHashedPristinec(compressionfs)hletms=withSlurpys$applyfspcasemsofLefte->faileRight(s',())->writeHashedPristinec(compressionfs)s'{-
applyHashed c fs h p = do (_,hd) <- runStateT (apply fs p) $
HashDir { permissions = RW, cache = c,
options = fs, rootHash = h }
return $ rootHash hd
-}dataHashDirrp=HashDir{permissions::!r,cache::!Cache,compress::!Compression,rootHash::!String}typeHashedIOrp=StateT(HashDirrp)IOdataRO=ROdataRW=RW{-
class Readable r where
isRO :: r -> Bool
isRO = const False
instance Readable RW
instance Readable RO where
isRO RO = True
-}instanceReadableDirectory(HashedIOrp)wheremDoesDirectoryExistfn=dothing<-identifyThingfncasethingofJust(D,_)->returnTrue_->returnFalsemDoesFileExistfn=dothing<-identifyThingfncasethingofJust(F,_)->returnTrue_->returnFalsemInCurrentDirectoryfnj|fn'==fp2fn""=j|otherwise=casebreak_on_dirfn'ofNothing->doc<-readrootcasegetaDfn'cofNothing->fail"dir doesn't exist mInCurrentDirectory..."Justh->inhhjJust(d,fn'')->doc<-readrootcasegetaDdcofNothing->fail"dir doesn't exist..."Justh->inhh$mInCurrentDirectoryfn''jwherefn'=norm_pathfnmGetDirectoryContents=map(\(_,f,_)->f)`fmap`readrootmReadFilePSfn=mInCurrentDirectory(superNamefn)$doc<-readrootcasegetaF(own_namefn)cofNothing->fail$" file don't exist... "++fn2fpfnJusth->readhashhinstanceWriteableDirectory(HashedIORWp)wheremWithCurrentDirectoryfnj|fn'==fp2fn""=j|otherwise=casebreak_on_dirfn'ofNothing->doc<-readrootcasegetaDfn'cofNothing->fail"dir doesn't exist in mWithCurrentDirectory..."Justh->do(h',x)<-withhhjwriteroot$setaDfn'h'creturnxJust(d,fn'')->doc<-readrootcasegetaDdcofNothing->fail"dir doesn't exist..."Justh->do(h',x)<-withhh$mWithCurrentDirectoryfn''jwriteroot$setaDdh'creturnxwherefn'=norm_pathfnmSetFileExecutable__=return()mWriteFilePSfnps=domexists<-identifyThingfncasemexistsofJust(D,_)->fail"can't write file over directory"_->doh<-writeHashFilepsmakeThingfn(F,h)mCreateDirectoryfn=doh<-writeHashFileB.emptyexists<-isJust`fmap`identifyThingfnwhenexists$fail"can't mCreateDirectory over an existing object."makeThingfn(D,h)mRenameon=donexists<-isJust`fmap`identifyThingnwhennexists$fail"mRename failed..."mx<-identifyThingo-- for backwards compatibility accept rename of nonexistent files.casemxofNothing->return()Justx->dormThingomakeThingnxmRemoveDirectory=rmThingmRemoveFilef=dox<-mReadFilePSfwhen(B.lengthx/=0)$fail$"Cannot remove non-empty file "++fn2fpfrmThingfidentifyThing::FileName->HashedIOrp(Maybe(ObjType,String))identifyThingfn|fn'==fp2fn""=doh<-getsrootHashreturn$Just(D,h)|otherwise=casebreak_on_dirfn'ofNothing->getanyfn'`fmap`readrootJust(d,fn'')->doc<-readrootcasegetaDdcofNothing->returnNothingJusth->inhh$identifyThingfn''wherefn'=norm_pathfnmakeThing::FileName->(ObjType,String)->HashedIORWp()makeThingfn(o,h)=mWithCurrentDirectory(superName$norm_pathfn)$setao(own_name$norm_pathfn)h`fmap`readroot>>=writerootrmThing::FileName->HashedIORWp()rmThingfn=mWithCurrentDirectory(superName$norm_pathfn)$doc<-readrootletc'=filter(\(_,x,_)->x/=own_name(norm_pathfn))ciflengthc'==lengthc-1thenwriterootc'elsefail"obj doesn't exist in rmThing"readhash::String->HashedIOrpB.ByteStringreadhashh=doc<-getscachez<-lift$unsafeInterleaveIO$readHashFilecHashedPristineDirhlet(_,out)=zreturnoutreadTediousHash::String->String->HashedIOrpB.ByteStringreadTediousHashkh=dolift$finishedOneIOkhreadhashhwithh::String->HashedIORWpa->HashedIORWp(String,a)withhhj=dohd<-getput$hd{rootHash=h}x<-jh'<-getsrootHashputhdreturn(h',x)inh::String->HashedIOrpa->HashedIOrpainhhj=dohd<-getput$hd{rootHash=h}x<-jputhdreturnxsafeInterleave::HashedIOROpa->HashedIOrpasafeInterleavejob=doHashDir_ccomprh<-getz<-lift$unsafeInterleaveIO$runStateTjob(HashDir{permissions=RO,cache=c,compress=compr,rootHash=h})let(x,_)=zreturnxreadroot::HashedIOrp[(ObjType,FileName,String)]readroot=dohaveitalready<-peekrootcc<-getsrootHash>>=readdirwhen(nothaveitalready)$speculateccreturnccwherespeculate::[(a,b,String)]->HashedIOrq()speculatec=docac<-getscachemapM_(\(_,_,z)->lift$speculateFileUsingCachecacHashedPristineDirz)cpeekroot::HashedIOrpBoolpeekroot=doHashDir_c_h<-getlift$peekInCachecHashedPristineDirhwriteroot::[(ObjType,FileName,String)]->HashedIOrp()writerootc=doh<-writedircmodify$\hd->hd{rootHash=h}dataObjType=F|DderivingEq-- | @geta objtype name stuff@ tries to get an object of type @objtype@ named @name@-- in @stuff@.geta::ObjType->FileName->[(ObjType,FileName,String)]->MaybeStringgetaofc=do(o',h)<-getanyfcifo==o'thenJusthelseNothinggetany::FileName->[(ObjType,FileName,String)]->Maybe(ObjType,String)getany_[]=Nothinggetanyf((o,f',h):_)|f==f'=Just(o,h)getanyf(_:r)=getanyfrseta::ObjType->FileName->String->[(ObjType,FileName,String)]->[(ObjType,FileName,String)]setaofh[]=[(o,f,h)]setaofh((_,f',_):r)|f==f'=(o,f,h):rsetaofh(x:xs)=x:setaofhxsreaddir::String->HashedIOrp[(ObjType,FileName,String)]readdirhash=(parsed.linesPS)`fmap`readhashhashwhereparsed(t:n:h:rest)|t==dir=(D,niceps2fnn,BC.unpackh):parsedrest|t==file=(F,niceps2fnn,BC.unpackh):parsedrestparsed_=[]dir::B.ByteStringdir=BC.pack"directory:"file::B.ByteStringfile=BC.pack"file:"writedir::[(ObjType,FileName,String)]->HashedIOrpStringwritedirc=writeHashFilecpswherecps=unlinesPS$concatMap(\(o,d,h)->[showOo,fn2nicepsd,BC.packh])c++[B.empty]showOD=dirshowOF=filewriteHashFile::B.ByteString->HashedIOrpStringwriteHashFileps=doc<-getscachecompr<-getscompresslift$writeFileUsingCacheccomprHashedPristineDirps-- |Create a Slurpy representing the pristine content determined by the-- supplied root hash (which uniquely determines the pristine tree)slurpHashedPristine::Cache->Compression->String->IOSlurpyslurpHashedPristineccomprh=fst`fmap`runStateTslh(HashDir{permissions=RO,cache=c,compress=compr,rootHash=h})slh::HashedIOrpSlurpyslh=doc<-readroothroot<-getsrootHashlift$beginTediousksafeInterleave$(Slurpyrootdir.SlurpDir(Justhroot).slurpies_to_map)`fmap`mapMslcwheresl(F,n,h)=dops<-safeInterleave$readTediousHashkhletlen=iflengthh==75thenread(take10h)elseundefined_sizereturn$Slurpyn$SlurpFile(Justh,0,len)pssl(D,n,h)=inhh$doc<-readrootlift$tediousSizek(lengthc)lift$finishedOneIOkh(Slurpyn.SlurpDir(Justh).slurpies_to_map)`fmap`mapMslck="Reading pristine"rootdir::FileNamerootdir=fp2fn"."-- |Write contents of a Slurpy into hashed pristine. Only files that have not-- not yet been hashed (that is, the hash corresponding to their content is-- already present in hashed pristine) will be written out, so it is efficient-- to use this function to update existing pristine cache. Note that the-- pristine root hash will *not* be updated. You need to do that manually.writeHashedPristine::Cache->Compression->Slurpy->IOStringwriteHashedPristineccomprsl=dobeginTediouskh<-fst`fmap`runStateT(hslsl)(HashDir{permissions=RW,cache=c,compress=compr,rootHash=sha1PSB.empty})endTediouskreturnhwherehsl(Slurpy_(SlurpDir(Justh)_))=returnhhsl(Slurpy_(SlurpDirNothingss))=dolift$tediousSizek(Map.sizess)mapMhs(map_to_slurpiesss)>>=writedirhsl(Slurpy_(SlurpFile(Justh,_,_)_))=returnhhsl(Slurpy_(SlurpFile_x))=writeHashFilexhs(Slurpyd(SlurpDir(Justh)_))=progressk$return(D,d,h)hss@(Slurpyd(SlurpDirNothing_))=doh<-hslslift$finishedOneIOkhreturn(D,d,h)hs(Slurpyf(SlurpFile(Justh,_,_)_))=progressk$return(F,f,h)hss@(Slurpyf(SlurpFile__))=doh<-hslslift$finishedOneIOkhreturn(F,f,h)k="Writing pristine"copyHashed::String->Cache->Compression->String->IO()copyHashedkccomprz=dorunStateTcph$HashDir{permissions=RO,cache=c,compress=compr,rootHash=z}return()wherecph=docc<-readrootlift$tediousSizek(lengthcc)mapM_cpcccp(F,n,h)=dops<-readhashhlift$finishedOneIOk(fn2fpn)lift$writeAtomicFilePS(fn2fpn)pscp(D,n,h)=dolift$createDirectoryIfMissingFalse(fn2fpn)lift$finishedOneIOk(fn2fpn)lift$withCurrentDirectory(fn2fpn)$copyHashedkccomprhcopyPartialsHashed::FilePathLikefp=>Cache->Compression->String->[fp]->IO()copyPartialsHashedccomprroot=mapM_(copyPartialHashedccomprroot)copyPartialHashed::FilePathLikefp=>Cache->Compression->String->fp->IO()copyPartialHashedccomprrootff=docreateDirectoryIfMissingTrue(basename$toFilePathff)runStateT(cp$fp2fn$toFilePathff)$HashDir{permissions=RO,cache=c,compress=compr,rootHash=root}return()wherebasename=reverse.dropWhile('/'/=).dropWhile('/'==).reversecpf=domt<-identifyThingfcasemtofJust(D,h)->dolift$createDirectoryIfMissingTrue(fn2fpf)lift$withCurrentDirectory(fn2fpf)$copyHashed""ccomprhJust(F,h)->dops<-readhashhlift$writeAtomicFilePS(fn2fpf)psNothing->return()-- | Seems to list all hashes reachable from "root".listHashedContents::String->Cache->String->IO[String]listHashedContentskcroot=dobeginTediousktediousSizek1x<-fst`fmap`runStateT(lhc(D,fp2fn".",root))(HashDirROcNoCompressionroot)endTediouskreturnxwherelhc::(ObjType,FileName,String)->HashedIOra[String]lhc(D,dname,d)=doxs<-inhd$readrootlift$finishedOneIOk(fn2fpdname)lift$tediousSizek(length$filter(\(x,_,_)->x==D)xs)hcxs<-mapMlhcxsreturn(d:concathcxs)lhc(F,_,h)=return[h]clean_hashdir::Cache->HashedDir->[String]->IO()clean_hashdircdir_hashroots=do-- we'll remove obsolete bits of "dir"debugMessage$"Cleaning out "++(hashedDirdir_)++"..."lethashdir=darcsdir++"/"++(hashedDirdir_)++"/"hs<-set.concat<$>mapM(listHashedContents"cleaning up..."c)hashrootsfs<-set.filterokayHash<$>getDirectoryContentshashdirmapM_(removeFileMayNotExist.(hashdir++))(unset$fs`Set.difference`hs)-- and also clean out any global caches.debugMessage"Cleaning out any global caches..."cleanCachesWithHintcdir_(unset$fs`Set.difference`hs)whereset=Set.fromList.mapBC.packunset=mapBC.unpack.Set.toList