-- 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.{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}#include "gadts.h"moduleDarcs.Repository.HashedIO(HashedIO,copyHashed,copyPartialsHashed,cleanHashdir,RW(RW)-- only exported to make warning go away)whereimportDarcs.Global(darcsdir)importqualifiedData.SetasSetimportSystem.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.Repository.Cache(Cache(..),fetchFileUsingCache,writeFileUsingCache,peekInCache,speculateFileUsingCache,okayHash,cleanCachesWithHint,HashedDir(..),hashedDir)importDarcs.RepoPath(FilePathLike,toFilePath)importDarcs.Patch.ApplyMonad(ApplyMonad(..))importDarcs.Flags(Compression(..))importDarcs.Lock(writeAtomicFilePS,removeFileMayNotExist)importDarcs.Utils(withCurrentDirectory)importProgress(debugMessage,tediousSize,finishedOneIO)importDarcs.Patch.FileName(FileName,normPath,fp2fn,fn2fp,fn2niceps,niceps2fn,breakOnDir,ownName,superName)importByteStringUtils(linesPS,unlinesPS)importqualifiedData.ByteStringasB(ByteString,length,empty)importqualifiedData.ByteString.Char8asBC(unpack,pack)importStorage.Hashed.Darcs(readDarcsHashedDir,darcsLocation,decodeDarcsHash,decodeDarcsSize)importStorage.Hashed.Tree(ItemType(..),Tree)importDarcs.CommandsAux-- | @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)++"/"fetchFileUsingCachecsubdirhashdataHashDirrp=HashDir{permissions::!r,cache::!Cache,compress::!Compression,rootHash::!String}typeHashedIOp=StateT(HashDirRWp)IOdataRW=RW{-
class Readable r where
isRO :: r -> Bool
isRO = const False
instance Readable RW
instance Readable RO where
isRO RO = True
-}mWithCurrentDirectory::FileName->HashedIOpa->HashedIOpamWithCurrentDirectoryfnj|fn'==fp2fn""=j|otherwise=casebreakOnDirfn'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'=normPathfnmInCurrentDirectory::FileName->HashedIOpa->HashedIOpamInCurrentDirectoryfnj|fn'==fp2fn""=j|otherwise=casebreakOnDirfn'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'=normPathfninstanceApplyMonad(HashedIOp)TreewheretypeApplyMonadBase(HashedIOp)=IOmDoesDirectoryExistfn=dothing<-identifyThingfncasethingofJust(D,_)->returnTrue_->returnFalsemReadFilePSfn=mInCurrentDirectory(superNamefn)$doc<-readrootcasegetaF(ownNamefn)cofNothing->fail$" file don't exist... "++fn2fpfnJusth->readhashhmCreateDirectoryfn=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->HashedIOp(Maybe(ObjType,String))identifyThingfn|fn'==fp2fn""=doh<-getsrootHashreturn$Just(D,h)|otherwise=casebreakOnDirfn'ofNothing->getanyfn'`fmap`readrootJust(d,fn'')->doc<-readrootcasegetaDdcofNothing->returnNothingJusth->inhh$identifyThingfn''wherefn'=normPathfnmakeThing::FileName->(ObjType,String)->HashedIOp()makeThingfn(o,h)=mWithCurrentDirectory(superName$normPathfn)$setao(ownName$normPathfn)h`fmap`readroot>>=writerootrmThing::FileName->HashedIOp()rmThingfn=mWithCurrentDirectory(superName$normPathfn)$doc<-readrootletc'=filter(\(_,x,_)->x/=ownName(normPathfn))ciflengthc'==lengthc-1thenwriterootc'elsefail"obj doesn't exist in rmThing"readhash::String->HashedIOpB.ByteStringreadhashh=doc<-getscachez<-lift$unsafeInterleaveIO$readHashFilecHashedPristineDirhlet(_,out)=zreturnoutwithh::String->HashedIOpa->HashedIOp(String,a)withhhj=dohd<-getput$hd{rootHash=h}x<-jh'<-getsrootHashputhdreturn(h',x)inh::String->HashedIOpa->HashedIOpainhhj=dohd<-getput$hd{rootHash=h}x<-jputhdreturnxreadroot::HashedIOp[(ObjType,FileName,String)]readroot=dohaveitalready<-peekrootcc<-getsrootHash>>=readdirwhen(nothaveitalready)$speculateccreturnccwherespeculate::[(a,b,String)]->HashedIOq()speculatec=docac<-getscachemapM_(\(_,_,z)->lift$speculateFileUsingCachecacHashedPristineDirz)cpeekroot::HashedIOpBoolpeekroot=doHashDir_c_h<-getlift$peekInCachecHashedPristineDirhwriteroot::[(ObjType,FileName,String)]->HashedIOp()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->HashedIOp[(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)]->HashedIOpStringwritedirc=writeHashFilecpswherecps=unlinesPS$concatMap(\(o,d,h)->[showOo,fn2nicepsd,BC.packh])c++[B.empty]showOD=dirshowOF=filewriteHashFile::B.ByteString->HashedIOpStringwriteHashFileps=doc<-getscachecompr<-getscompresslift$writeFileUsingCacheccomprHashedPristineDirpscopyHashed::String->Cache->Compression->String->IO()-- Warning: A do-notation statement discarded a result of type ((), HashDir RO ghc-primcopyHashedkccomprz=do_<-runStateTcph$HashDir{permissions=RW,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)=ifisMaliciousSubPath(fn2fpn)thenfail("Caught malicious path: "++fn2fpn)elsedolift$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)-- Warning: A do-notation statement discarded a result of type ((), HashDir RO ghc-prim_<-runStateT(cp$fp2fn$toFilePathff)$HashDir{permissions=RW,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()cleanHashdir::Cache->HashedDir->[String]->IO()cleanHashdircdir_hashroots=do-- we'll remove obsolete bits of "dir"debugMessage$"Cleaning out "++(hashedDirdir_)++"..."lethashdir=darcsdir++"/"++(hashedDirdir_)++"/"listoneh=doletsize=decodeDarcsSize$BC.packhhash=decodeDarcsHash$BC.packhx<-readDarcsHashedDirhashdir(size,hash)letsubs=[fst$darcsLocation""(s,h')|(TreeType,_,s,h')<-x]hashes=h:[fst$darcsLocation""(s,h')|(_,_,s,h')<-x](hashes++).concat<$>mapMlistonesubshs<-set.concat<$>mapMlistonehashrootsfs<-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