{-# LANGUAGE ScopedTypeVariables, BangPatterns, TypeSynonymInstances, UndecidableInstances #-}-- | An experimental monadic interface to Tree mutation. The main idea is to-- simulate IO-ish manipulation of real filesystem (that's the state part of-- the monad), and to keep memory usage down by reasonably often dumping the-- intermediate data to disk and forgetting it. The monad interface itself is-- generic, and a number of actual implementations can be used. This module-- provides just 'virtualTreeIO' that never writes any changes, but may trigger-- filesystem reads as appropriate.moduleStorage.Hashed.Monad(virtualTreeIO,virtualTreeMonad,readFile,writeFile,createDirectory,rename,copy,unlink,fileExists,directoryExists,exists,withDirectory,currentDirectory,tree,TreeState,TreeMonad,TreeIO,runTreeMonad,initialState,replaceItem)whereimportPreludehiding(readFile,writeFile)importStorage.Hashed.AnchoredPathimportStorage.Hashed.TreeimportStorage.Hashed.HashimportControl.Applicative((<$>))importData.List(sortBy)importData.Int(Int64)importData.Maybe(isNothing,isJust)importqualifiedData.ByteString.Lazy.Char8asBLimportControl.Monad.RWS.StrictimportqualifiedData.SetasSimportqualifiedData.MapasMtypeChanged=M.MapAnchoredPath(Int64,Int64)-- size, age-- | Internal state of the 'TreeIO' monad. Keeps track of the current Tree-- content, unsync'd changes and a current working directory (of the monad).dataTreeStatem=TreeState{tree::!(Treem),changed::!Changed,changesize::!Int64,maxage::!Int64,updateHash::TreeItemm->mHash,update::AnchoredPath->TreeItemm->TreeMonadm(TreeItemm)}-- | A 'TreeIO' monad. A sort of like IO but it keeps a 'TreeState' around as well,-- which is a sort of virtual filesystem. Depending on how you obtained your-- 'TreeIO', the actions in your virtual filesystem get somehow reflected in the-- actual real filesystem. For 'virtualTreeIO', nothing happens in real-- filesystem, however with 'plainTreeIO', the plain tree will be updated every-- now and then, and with 'hashedTreeIO' a darcs-style hashed tree will get-- updated.typeTreeMonadm=RWSTAnchoredPath()(TreeStatem)mtypeTreeIO=TreeMonadIOclass(Functorm,Monadm)=>TreeROmwherecurrentDirectory::mAnchoredPathwithDirectory::AnchoredPath->ma->maexpandTo::AnchoredPath->mAnchoredPath-- | Grab content of a file in the current Tree at the given path.readFile::AnchoredPath->mBL.ByteString-- | Check for existence of a node (file or directory, doesn't matter).exists::AnchoredPath->mBool-- | Check for existence of a directory.directoryExists::AnchoredPath->mBool-- | Check for existence of a file.fileExists::AnchoredPath->mBoolclassTreeROm=>TreeRWmwhere-- | Change content of a file at a given path. The change will be-- eventually flushed to disk, but might be buffered for some time.writeFile::AnchoredPath->BL.ByteString->m()createDirectory::AnchoredPath->m()unlink::AnchoredPath->m()rename::AnchoredPath->AnchoredPath->m()copy::AnchoredPath->AnchoredPath->m()initialState::Treem->(TreeItemm->mHash)->(AnchoredPath->TreeItemm->TreeMonadm(TreeItemm))->TreeStateminitialStatetuhu=TreeState{tree=t,changed=M.empty,changesize=0,updateHash=uh,maxage=0,update=u}flush::(Functorm,Monadm)=>TreeMonadm()flush=docurrent<-getchanged'<-mapfst<$>M.toList<$>getschangeddirs'<-getstree>>=\t->return[path|(path,SubTrees)<-listt]modify$\st->st{changed=M.empty,changesize=0}forM_(changed'++dirs'++[AnchoredPath[]])flushItemrunTreeMonad'::(Functorm,Monadm)=>TreeMonadma->TreeStatem->m(a,Treem)runTreeMonad'actioninitial=do(out,final,_)<-runRWSTaction(AnchoredPath[])initialreturn(out,treefinal)runTreeMonad::(Functorm,Monadm)=>TreeMonadma->TreeStatem->m(a,Treem)runTreeMonadactioninitial=doletaction'=dox<-actionflushreturnxrunTreeMonad'action'initial-- | Run a TreeIO action without storing any changes. This is useful for-- running monadic tree mutations for obtaining the resulting Tree (as opposed-- to their effect of writing a modified tree to disk). The actions can do both-- read and write -- reads are passed through to the actual filesystem, but the-- writes are held in memory in a form of modified Tree.virtualTreeMonad::(Functorm,Monadm)=>TreeMonadma->Treem->m(a,Treem)virtualTreeMonadactiont=runTreeMonad'action$initialStatet(\_->returnNoHash)(\_x->returnx)virtualTreeIO::TreeIOa->TreeIO->IO(a,TreeIO)virtualTreeIO=virtualTreeMonad-- | Modifies an item in the current Tree. This action keeps an account of the-- modified data, in changed and changesize, for subsequent flush-- operations. Any modifications (as in "modifyTree") are allowed.modifyItem::(Functorm,Monadm)=>AnchoredPath->Maybe(TreeItemm)->TreeMonadm()modifyItempathitem=dopath'<-(`catPaths`path)`fmap`currentDirectoryage<-getsmaxagechanged'<-getschangedletgetsize(Just(Fileb))=lift(BL.length`fmap`readBlobb)getsize_=return0size<-getsizeitemletchange=caseM.lookuppath'changed'ofNothing->sizeJust(oldsize,_)->size-oldsizemodify$\st->st{tree=modifyTree(treest)path'item,changed=M.insertpath'(size,age)(changedst),maxage=age+1,changesize=(changesizest+change)}renameChangedfromto=modify$\st->st{changed=rename'$changedst}whererename'=M.fromList.maprenameone.M.toListrenameone(x,d)|from`isPrefix`x=(to`catPaths`relativefromx,d)|otherwise=(x,d)relative(AnchoredPathfrom)(AnchoredPathx)=AnchoredPath$drop(lengthfrom)x-- | Replace an item with a new version without modifying the content of the-- tree. This does not do any change tracking. Ought to be only used from a-- 'sync' implementation for a particular storage format. The presumed use-case-- is that an existing in-memory Blob is replaced with a one referring to an-- on-disk file.replaceItem::(Functorm,Monadm)=>AnchoredPath->Maybe(TreeItemm)->TreeMonadm()replaceItempathitem=dopath'<-(`catPaths`path)`fmap`currentDirectorymodify$\st->st{tree=modifyTree(treest)path'item}flushItem::forallem.(Monadm,Functorm)=>AnchoredPath->TreeMonadm()flushItempath=docurrent<-getstreecasefindcurrentpathofNothing->return()-- vanished, do nothingJustx->doy<-fixHashxnew<-getsupdate>>=($y).($path)replaceItempath(Justnew)wherefixHash::TreeItemm->TreeMonadm(TreeItemm)fixHashf@(File(BlobconNoHash))=dohash<-getsupdateHash>>=\x->lift$xfreturn$File$BlobconhashfixHash(SubTrees)|treeHashs==NoHash=getsupdateHash>>=\f->SubTree<$>lift(addMissingHashesfs)fixHashx=returnx-- | If buffers are becoming large, sync, otherwise do nothing.flushSome::(Monadm,Functorm)=>TreeMonadm()flushSome=dox<-getschangesizewhen(x>megs100)$doremaining<-go=<<sortByage<$>M.toList<$>getschangedmodify$\s->s{changed=M.fromListremaining}wherego[]=return[]go((path,(size,age_)):chs)=dox<-(\s->s-size)<$>getschangesizeflushItempathmodify$\s->s{changesize=x}if(x>megs50)thengochselsereturn$chsmegs=(*(1024*1024))age(_,(_,a))(_,(_,b))=compareabinstance(Functorm,Monadm)=>TreeRO(TreeMonadm)whereexpandTop=dot<-getstreep'<-(`catPaths`p)`fmap`askletamend=dot'<-lift$expandPathtp'modify$\st->st{tree=t'}casefindtp'ofNothing->amendJust(Stub__)->amend_->return()returnp'fileExistsp=dop'<-expandTop(isJust.(flipfindFilep'))`fmap`getstreedirectoryExistsp=dop'<-expandTop(isJust.(flipfindTreep'))`fmap`getstreeexistsp=dop'<-expandTop(isJust.(flipfindp'))`fmap`getstreereadFilep=dop'<-expandTopt<-getstreeletf=findFiletp'casefofNothing->fail$"No such file "++showp'Justx->lift(readBlobx)currentDirectory=askwithDirectorydiract=dodir'<-expandTodirlocal(\old->dir')actinstance(Functorm,Monadm)=>TreeRW(TreeMonadm)wherewriteFilepcon=doexpandTopmodifyItemp(Justblob)flushSomewhereblob=File$Blob(returncon)hashhash=NoHash-- we would like to say "sha256 con" here, but due-- to strictness of Hash in Blob, this would often-- lead to unnecessary computation which would then-- be discarded anyway; we rely on the sync-- implementation to fix up any NoHash occurrencescreateDirectoryp=doexpandTopmodifyItemp$Just$SubTreeemptyTreeunlinkp=doexpandTopmodifyItempNothingrenamefromto=dofrom'<-expandTofromto'<-expandTototr<-getstreeletitem=findtrfrom'found_to=findtrto'unless(isNothingfound_to)$fail$"Error renaming: destination "++showto++" exists."unless(isNothingitem)$domodifyItemfromNothingmodifyItemtoitemrenameChangedfromtocopyfromto=dofrom'<-expandTofromto'<-expandTototr<-getstreeletitem=findtrfrom'unless(isNothingitem)$modifyItemtoitem