{-# LANGUAGE ParallelListComp #-}-- | This module implements an "object storage". This is a directory on disk-- containing a content-addressed storage. This is useful for storing all kinds-- of things, particularly filesystem trees, or darcs pristine caches and patch-- objects. However, this is an abstract, flat storage: no tree semantics are-- provided. You just need to provide a reference-collecting functionality,-- computing a list of references for any given object. The system provides-- transparent garbage collection and packing.moduleStorage.Hashed.Packed(Format(..),Block,OS-- * Basic operations.,hatch,compact,repack,lookup-- * Creating and loading.,create,load-- * Low-level.,format,blockLookup,live,hatchery,mature,roots,references,rootdir)whereimportPreludehiding(lookup,read)importStorage.Hashed.AnchoredPath()importStorage.Hashed.Tree()importStorage.Hashed.UtilsimportStorage.Hashed.HashimportControl.Monad(forM,forM_,unless)importControl.Applicative((<$>))importSystem.FilePath((</>),(<.>))importSystem.Directory(createDirectoryIfMissing,removeFile,getDirectoryContents)importBundled.Posix(fileExists,isDirectory,getFileStatus)importqualifiedData.ByteString.Lazy.Char8asBLimportqualifiedData.ByteString.Char8asBSimportData.Maybe(listToMaybe,catMaybes,isNothing)importData.Binary(encode,decode)importqualifiedData.SetasSimportqualifiedData.MapasMimportData.List(sort)importData.Int(Int64)-- | On-disk format for object storage: we implement a completely loose format-- (one file per object), a compact format stored in a single append-only file-- and an immutable \"pack\" format.dataFormat=Loose|Compact|Packderiving(Show,Eq)loose_dirs::[[Char]]loose_dirs=letchars=['0'..'9']++['a'..'f']in[[a,b]|a<-chars,b<-chars]loosePath::OS->Hash->FilePathloosePath_NoHash=error"No path for NoHash!"loosePathoshash=lethash'=BS.unpack(encodeBase16hash)inrootdiros</>"hatchery"</>take2hash'</>drop2hash'looseLookup::OS->Hash->IO(MaybeFileSegment)looseLookup_NoHash=returnNothinglooseLookuposhash=doletpath=loosePathoshashexist<-fileExists<$>getFileStatuspathreturn$ifexistthenJust(path,Nothing)elseNothing-- | Object storage block. When used as a hatchery, the loose or compact format-- are preferable, while for mature space, the pack format is more useful.dataBlock=Block{blockLookup::Hash->IO(MaybeFileSegment),size::Int64,format::Format}-- | Object storage. Contains a single \"hatchery\" and possibly a number of-- mature space blocks, usually in form of packs. It also keeps a list of root-- pointers and has a way to extract pointers from objects (externally-- supplied). These last two things are used to implement a simple GC.dataOS=OS{hatchery::Block,mature::[Block],roots::[Hash],references::FileSegment->IO[Hash],rootdir::FilePath}-- | Reduce number of packs in the object storage. This may both recombine-- packs to eliminate dead objects and join some packs to form bigger packs.repack::OS->IOOSrepack_=error"repack undefined"-- | Add new objects to the object storage (i.e. put them into hatchery). It is-- safe to call this even on objects that are already present in the storage:-- such objects will be skipped.hatch::OS->[BL.ByteString]->IOOShatchosblobs=doprocessed<-mapMsieveblobswrite[(h,b)|(True,h,b)<-processed]wherewritebits=caseformat(hatcheryos)ofLoose->doforMbits$\(hash,blob)->doBL.writeFile(loosePathoshash)blobreturnosCompact->error"hatch/compact undefined"_->fail"Hatchery must be either Loose or Compact."sieveblob=dolethash=sha256blobabsent<-isNothing<$>lookuposhashreturn(absent,hash,blob)-- | Move things from hatchery into a (new) pack.compact::OS->IOOScompactos=doobjects<-liveos[hatcheryos]block<-createPackos(M.toListobjects)cleanupreturn$os{mature=block:matureos}wherecleanup=caseformat(hatcheryos)ofLoose->forM_loose_dirs$nuke.((rootdiros</>"hatchery")</>)Compact->removeFile(rootdiros</>"hatchery")>>return()_->fail"Hatchery must be either Loose or Compact."nukedir=mapM(removeFile.(dir</>))=<<(Prelude.filter(`notElem`[".",".."])`fmap`getDirectoryContentsdir)blocksLookup::[Block]->Hash->IO(Maybe(Hash,FileSegment))blocksLookupblockshash=dosegment<-cat`fmap`mapM(flipblockLookuphash)blocksreturn$casesegmentofNothing->NothingJustseg->Just(hash,seg)wherecat=listToMaybe.catMaybeslookup::OS->Hash->IO(MaybeFileSegment)lookuposhash=dores<-blocksLookup(hatcheryos:matureos)hashreturn$caseresofNothing->NothingJust(_,seg)->Justseg-- | Create an empty object storage in given directory, with a hatchery of-- given format. The directory is created if needed, but is assumed to be-- empty.create::FilePath->Format->IOOScreatepathfmt=docreateDirectoryIfMissingTruepathinitHatcheryloadpathwhereinitHatchery|fmt==Loose=domkdirhatchpathforMloose_dirs$mkdir.(hatchpath</>)|fmt==Compact=error"create/mkHatchery Compact undefined"mkdir=createDirectoryIfMissingFalsehatchpath=path</>"hatchery"load::FilePath->IOOSloadpath=dohatch_stat<-getFileStatus$path</>"hatchery"letis_os=fileExistshatch_statis_dir=isDirectoryhatch_statunlessis_os$fail$path++" is not an object storage!"let_hatchery=Block{blockLookup=lookos,format=ifis_dirthenLooseelseCompact,size=undefined}os=OS{hatchery=_hatchery,rootdir=path,mature=packs,roots=_roots,references=undefined}look|format_hatchery==Loose=looseLookup|otherwise=undefinedpacks=[]-- FIXME read packs_roots=[]-- FIXME read root pointersreturnosreadPack::FilePath->IOBlockreadPackfile=dobits<-readSegment(file,Nothing)letcount=decode(BL.take8$bits)_lookupNoHash__=returnNothing_lookuphash@(SHA256rawhash)firstfinal=doletmiddle=first+((final-first)`div`2)res<-case(comparerawhash(hashoffirst),comparerawhash(hashofmiddle),comparerawhash(hashoffinal))of(LT,_,_)->returnNothing(_,_,GT)->returnNothing(EQ,_,_)->return$Just(segoffirst)(_,_,EQ)->return$Just(segoffinal)(GT,EQ,LT)->return$Just(segofmiddle)(GT,GT,LT)|middle/=final->_lookuphashmiddlefinal(GT,LT,LT)|first/=middle->_lookuphashfirstmiddle(_,_,_)->returnNothingreturnresheaderofi=BL.take51$BL.drop(8+i*51)bitshashofi=BS.concat$BL.toChunks$BL.take32$headerofisegofi=(file,Just(count*51+8+from,sz))wherefrom=decode(BL.take8$BL.drop33$headerofi)sz=decode(BL.take8$BL.drop42$headerofi)return$Block{size=BL.lengthbits,format=Pack,blockLookup=\h->_lookuph0(count-1)}createPack::OS->[(Hash,FileSegment)]->IOBlockcreatePackosbits=docontents<-mapMreadSegment(mapsndbits)letoffsets=scanl(+)0$mapBL.lengthcontentsheaderbits=[BL.concat[BL.fromChunks[rawhash],BL.pack"@",encodeoffset,BL.pack"!",encode$BL.lengthstring,BL.pack"\n"]|(SHA256rawhash,_)<-bits|string<-contents|offset<-offsets]header=BL.concat$(encode$lengthbits):sortheaderbitsblob=BL.concat$header:contentshash=sha256blobpath=rootdiros</>BS.unpack(encodeBase16hash)<.>"bin"BL.writeFilepathblobreadPackpath-- | Build a map of live objects (i.e. those reachable from the given roots) in-- a given list of Blocks.live::OS->[Block]->IO(M.MapHashFileSegment)liveosblocks=reachable(referencesos)(blocksLookupblocks)(S.fromList$rootsos)