{-# LANGUAGE BangPatterns #-}-- | A few darcs-specific utility functions. These are used for reading and-- writing darcs and darcs-compatible hashed trees.moduleStorage.Hashed.DarcswhereimportPreludehiding(lookup)importSystem.FilePath((</>))importSystem.Directory(doesFileExist)importCodec.Compression.GZip(decompress,compress)importControl.Applicative((<$>))importqualifiedData.ByteString.Char8asBS8importqualifiedData.ByteString.Lazy.Char8asBL8importqualifiedData.ByteString.LazyasBLimportqualifiedData.ByteStringasBSimportData.List(sortBy)importData.Char(chr,ord,isSpace)importData.Maybe(fromJust)importqualifiedData.SetasSimportControl.Monad.State.StrictimportStorage.Hashed.Treehiding(lookup)importqualifiedStorage.Hashed.TreeasTreeimportStorage.Hashed.AnchoredPathimportStorage.Hashed.UtilsimportStorage.Hashed.HashimportStorage.Hashed.PackedimportStorage.Hashed.Monad----------------------------------------------------------------------- Utilities for coping with the darcs directory format.---- | 'darcsDecodeWhite' interprets the Darcs-specific \"encoded\" filenames-- produced by 'darcsEncodeWhite'---- > darcsDecodeWhite "hello\32\there" == "hello there"-- > darcsDecodeWhite "hello\92\there" == "hello\there"-- > darcsDecodeWhite "hello\there" == error "malformed filename"darcsDecodeWhite::String->FilePathdarcsDecodeWhite('\\':cs)=casebreak(=='\\')csof(theord,'\\':rest)->chr(readtheord):darcsDecodeWhiterest_->error"malformed filename"darcsDecodeWhite(c:cs)=c:darcsDecodeWhitecsdarcsDecodeWhite""=""-- | 'darcsEncodeWhite' translates whitespace in filenames to a darcs-specific-- format (backslash followed by numerical representation according to 'ord').-- Note that backslashes are also escaped since they are used in the encoding.---- > darcsEncodeWhite "hello there" == "hello\32\there"-- > darcsEncodeWhite "hello\there" == "hello\92\there"darcsEncodeWhite::FilePath->StringdarcsEncodeWhite(c:cs)|isSpacec||c=='\\'='\\':(show$ordc)++"\\"++darcsEncodeWhitecsdarcsEncodeWhite(c:cs)=c:darcsEncodeWhitecsdarcsEncodeWhite[]=[]darcsEncodeWhiteBS::BS8.ByteString->BS8.ByteStringdarcsEncodeWhiteBS=BS8.pack.darcsEncodeWhite.BS8.unpackdecodeDarcsHash::BS8.ByteString->HashdecodeDarcsHashbs=caseBS8.split'-'bsof[s,h]|BS8.lengths==10->decodeBase16h_->decodeBase16bsdecodeDarcsSize::BS8.ByteString->MaybeIntdecodeDarcsSizebs=caseBS8.split'-'bsof[s,_]|BS8.lengths==10->casereads(BS8.unpacks)of[(x,_)]->Justx_->Nothing_->NothingdarcsLocation::FilePath->(MaybeInt,Hash)->FileSegmentdarcsLocationdir(s,h)=(dir</>(prefixs++BS8.unpack(encodeBase16h)),Nothing)whereprefixNothing=""prefix(Justs')=formatSizes'++"-"formatSizes'=letn=shows'inreplicate(10-lengthn)'0'++n------------------------------------------------ Darcs directory format.--darcsFormatDir::Treem->MaybeBL8.ByteStringdarcsFormatDirt=BL8.fromChunks<$>concat<$>mapMstring(sortBycmp$listImmediatet)wherecmp(Namea,_)(Nameb,_)=compareabstring(Namename,item)=doheader<-caseitemofFile_->Just$BS8.pack"file:\n"SubTree_->Just$BS8.pack"directory:\n"Stub__->Nothinghash<-caseitemHashitemofNoHash->Nothingx->Just$encodeBase16xreturn$[header,darcsEncodeWhiteBSname,BS8.singleton'\n',hash,BS8.singleton'\n']darcsParseDir::BL8.ByteString->[(ItemType,Name,MaybeInt,Hash)]darcsParseDircontent=parse(BL8.split'\n'content)whereparse(t:n:h':r)=(headert,Name$BS8.pack$darcsDecodeWhite(BL8.unpackn),decodeDarcsSizehash,decodeDarcsHashhash):parserwherehash=BS8.concat$BL8.toChunksh'parse_=[]headerx|x==BL8.pack"file:"=BlobType|x==BL8.pack"directory:"=TreeType|otherwise=error$"Error parsing darcs hashed dir: "++BL8.unpackx------------------------------------------ Utilities.---- | Compute a darcs-compatible hash value for a tree-like structure.darcsTreeHash::Treem->HashdarcsTreeHasht=casedarcsFormatDirtofNothing->NoHashJustx->sha256x-- The following two are mostly for experimental use in Packed.darcsUpdateDirHashes::Treem->TreemdarcsUpdateDirHashes=updateSubtreesupdatewhereupdatet=t{treeHash=darcsTreeHasht}darcsUpdateHashes::(Monadm,Functorm)=>Treem->m(Treem)darcsUpdateHashes=updateTreeupdatewhereupdate(SubTreet)=return.SubTree$t{treeHash=darcsTreeHasht}update(Fileblob@(Blobcon_))=dohash<-sha256<$>readBlobblobreturn$File(Blobconhash)darcsAddMissingHashes::(Monadm,Functorm)=>Treem->m(Treem)darcsAddMissingHashes=updateTreeupdatewhereupdate(SubTreet)=return.SubTree$t{treeHash=darcsTreeHasht}update(Fileblob@(BlobconNoHash))=dohash<-sha256<$>readBlobblobreturn$File(Blobconhash)updatex=returnx--------------------------------------------- Reading darcs pristine data---- | Read and parse a darcs-style hashed directory listing from a given @dir@-- and with a given @hash@.readDarcsHashedDir::FilePath->(MaybeInt,Hash)->IO[(ItemType,Name,MaybeInt,Hash)]readDarcsHashedDirdirh=doexist<-doesFileExist$fst(darcsLocationdirh)unlessexist$fail$"error opening "++fst(darcsLocationdirh)compressed<-readSegment$darcsLocationdirhletcontent=decompresscompressedreturn$ifBL8.nullcompressedthen[]elsedarcsParseDircontent-- | Read in a darcs-style hashed tree. This is mainly useful for reading-- \"pristine.hashed\". You need to provide the root hash you are interested in-- (found in _darcs/hashed_inventory).readDarcsHashed::FilePath->(MaybeInt,Hash)->IO(TreeIO)readDarcsHashed_(_,NoHash)=fail"Cannot readDarcsHashed NoHash"readDarcsHasheddirroot@(_,hash)=doitems'<-readDarcsHashedDirdirrootsubs<-sequence[casetpofBlobType->return(d,File$Blob(readBlob'(s,h))h)TreeType->dolett=readDarcsHasheddir(s,h)return(d,Stubth)|(tp,d,s,h)<-items']return$makeTreeWithHashsubshashwherereadBlob'=fmapdecompress.readSegment.darcsLocationdir------------------------------------------------------ Writing darcs-style hashed trees.---- | Write a Tree into a darcs-style hashed directory.writeDarcsHashed::TreeIO->FilePath->IOHashwriteDarcsHashedtree'dir=dot<-darcsUpdateDirHashes<$>expandtree'sequence_[dump=<<readBlobb|(_,Fileb)<-listt]letdirs=darcsFormatDirt:[darcsFormatDird|(_,SubTreed)<-listt]os'<-mapMdump$mapfromJustdirsreturn$darcsTreeHashtwheredumpbits=doletname=dir</>BS8.unpack(encodeBase16$sha256bits)exist<-doesFileExistnameunlessexist$BL.writeFilename(compressbits)-- | Create a hashed file from a 'FilePath' and content. In case the file exists-- it is kept untouched and is assumed to have the right content. XXX Corrupt-- files should be probably renamed out of the way automatically or something-- (probably when they are being read though).fsCreateHashedFile::FilePath->BL8.ByteString->TreeIO()fsCreateHashedFilefncontent=liftIO$doexist<-doesFileExistfnunlessexist$BL.writeFilefncontent-- | Run a 'TreeIO' @action@ in a hashed setting. The @initial@ tree is assumed-- to be fully available from the @directory@, and any changes will be written-- out to same. Please note that actual filesystem files are never removed.hashedTreeIO::TreeIOa-- ^ action->TreeIO-- ^ initial->FilePath-- ^ directory->IO(a,TreeIO)hashedTreeIOactiontdir=dorunTreeMonadaction$initialStatetsyncHashedwheresyncHashedch=dohashed<-liftIO.darcsAddMissingHashes=<<getstreemodify$\st->st{tree=hashed}forM_(reverse$S.toListch)$\c->docurrent<-getstreecasefindcurrentcofJust(Fileb)->updateFilecbJust(SubTrees)->updateSubcs_->return()-- the file could have disappeared in the meantimeupdateFilepathb@(Blob_!h)=docontent<-liftIO$readBlobbletfn=dir</>BS8.unpack(encodeBase16h)nblob=File$Blob(decompress<$>rblob)hrblob=BL.fromChunks<$>return<$>BS.readFilefnnewcontent=compresscontentfsCreateHashedFilefnnewcontentreplaceItempath(Justnblob)updateSubpaths=dolet!hash=darcsTreeHashsJustdirdata=darcsFormatDirsfn=dir</>BS8.unpack(encodeBase16hash)ns=SubTree(s{treeHash=hash})fsCreateHashedFilefn(compressdirdata)replaceItempath(Justns)---------------------------------------------------------------- Reading and writing packed pristine. EXPERIMENTAL.------ | Read a Tree in the darcs hashed format from an object storage. This is-- basically the same as readDarcsHashed from Storage.Hashed, but uses an-- object storage instead of traditional darcs filesystem layout. Requires the-- tree root hash as a starting point.readPackedDarcsPristine::OS->Hash->IO(TreeIO)readPackedDarcsPristineosroot=doitems'<-darcsParseDir<$>grabrootsubs<-sequence[casetpofBlobType->return(d,File$fileh)TreeType->lett=readPackedDarcsPristineoshinreturn(d,Stubth)|(tp,d,_,h)<-items']return$makeTreeWithHashsubsrootwherefileh=Blob(grabh)hgrabhash=domaybeseg<-lookuposhashcasemaybesegofNothing->fail$"hash "++BS8.unpack(encodeBase16hash)++" not available"Justseg->readSegmentseg-- | Write a Tree into an object storage, using the darcs-style directory-- formatting (and therefore darcs-style hashes). Gives back the object storage-- and the root hash of the stored Tree. NB. The function expects that the Tree-- comes equipped with darcs-style hashes already!writePackedDarcsPristine::TreeIO->OS->IO(OS,Hash)writePackedDarcsPristinetree'os=dot<-darcsUpdateDirHashes<$>expandtree'files<-sequence[readBlobb|(_,Fileb)<-listt]letdirs=darcsFormatDirt:[darcsFormatDird|(_,SubTreed)<-listt]os'<-hatchos$files++(mapfromJustdirs)return(os',darcsTreeHasht)storePackedDarcsPristine::TreeIO->OS->IO(OS,Hash)storePackedDarcsPristinetree'os=do(os',root)<-writePackedDarcsPristinetree'osreturn$(os'{roots=root:rootsos'-- FIXME we probably don't want to override the references-- thing completely here...,references=darcsPristineRefs},root)darcsPristineRefs::FileSegment->IO[Hash]darcsPristineRefsfs=docon<-(darcsParseDir<$>readSegmentfs)`catch`\_->return[]return$![hash|(_,_,_,hash)<-con,validhash]wherevalidNoHash=Falsevalid_=True