{-# 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.---- XXX This currently does not work as advertised and the monads leak-- memory. So far, I'm at a loss why this happens.moduleStorage.Hashed.Monad(virtualTreeIO,virtualTreeMonad,readFile,writeFile,createDirectory,rename,unlink,fileExists,directoryExists,exists,withDirectory,tree,TreeState,TreeMonad,TreeIO,runTreeMonad,PathSet,initialState,replaceItem)whereimportPreludehiding(readFile,writeFile)importStorage.Hashed.AnchoredPathimportStorage.Hashed.TreeimportStorage.Hashed.HashimportControl.Monad.Error(catchError,throwError,MonadError)importSystem.Directory(createDirectoryIfMissing,doesFileExist)importSystem.FilePath((</>))importData.List(inits)importData.Int(Int64)importData.Maybe(isNothing,isJust)importCodec.Compression.GZip(decompress,compress)importqualifiedData.ByteString.Lazy.Char8asBLimportqualifiedData.ByteString.Char8asBSimportControl.Monad.RWS.StrictimportqualifiedData.SetasStypePathSet=S.SetAnchoredPath-- | 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::PathSet,changesize::Int64,sync::PathSet->TreeMonadm()}-- | 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::(MonadErrorem)=>AnchoredPath->ma->maexpandTo::(MonadErrorem)=>AnchoredPath->m()-- | Grab content of a file in the current Tree at the given path.readFile::(MonadErrorem)=>AnchoredPath->mBL.ByteString-- | Check for existence of a node (file or directory, doesn't matter).exists::(MonadErrorem)=>AnchoredPath->mBool-- | Check for existence of a directory.directoryExists::(MonadErrorem)=>AnchoredPath->mBool-- | Check for existence of a file.fileExists::(MonadErrorem)=>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::(MonadErrorem)=>AnchoredPath->BL.ByteString->m()createDirectory::(MonadErrorem)=>AnchoredPath->m()unlink::(MonadErrorem)=>AnchoredPath->m()rename::(MonadErrorem)=>AnchoredPath->AnchoredPath->m()initialState::Treem->(PathSet->TreeMonadm())->TreeStateminitialStatets=TreeState{tree=t,changed=S.empty,changesize=0,sync=s}flush::(Monadm)=>TreeMonadm()flush=docurrent<-getmodify$\st->st{changed=S.empty,changesize=0}synccurrent(changedcurrent)runTreeMonad::(Monadm)=>TreeMonadma->TreeStatem->m(a,Treem)runTreeMonadactioninitial=doletaction'=dox<-actionflushreturnx(out,final,_)<-runRWSTaction'(AnchoredPath[])initialreturn(out,treefinal)-- | 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::(Monadm)=>TreeMonadma->Treem->m(a,Treem)virtualTreeMonadactiont=runTreeMonadaction$initialStatet(\_->return())virtualTreeIO::TreeIOa->TreeIO->IO(a,TreeIO)virtualTreeIO=virtualTreeMonadreplaceItem::(MonadErrorem,Monadm)=>AnchoredPath->Maybe(TreeItemm)->TreeMonadm()replaceItempathitem=dopath'<-(`catPaths`path)`fmap`currentDirectorymodify$\st->st{tree=modifyTree(treest)path'item}-- | Internal. Mark a given path as changed, so the next sync will flush the-- modified object to disk.markChanged::(Functorm,Monadm)=>AnchoredPath->TreeMonadm()markChangedp=dox<-getsize<-lift$casefindFile(treex)pofJustb->BL.length`fmap`readBlobbNothing->return0put$x{changed=S.unionpaths(changedx),changesize=changesizex+size}wherepaths=let(AnchoredPathx)=pinS.fromList$mapAnchoredPath$initsx-- | If buffers are becoming large, sync, otherwise do nothing.maybeFlush::(Monadm)=>TreeMonadm()maybeFlush=dox<-getschangesizewhen(x>100*1024*1024)$flushinstance(Monadm,MonadErrorem)=>TreeRO(TreeMonadm)whereexpandTop=dot<-getstreecasefindtpofNothing->dot'<-lift$expandPathtp`catchError`\_->returntmodify$\st->st{tree=t'}_->return()fileExistsp=doexpandTop(isJust.(flipfindFilep))`fmap`getstreedirectoryExistsp=doexpandTop(isJust.(flipfindTreep))`fmap`getstreeexistsp=doexpandTop(isJust.(flipfindp))`fmap`getstreereadFilep=doexpandTopt<-getstreeletf=findFiletpcasefofNothing->fail$"No such file "++showpJustx->lift(readBlobx)currentDirectory=askwithDirectorydir=local(\old->old`catPaths`dir)instance(Functorm,Monadm,MonadErrorem)=>TreeRW(TreeMonadm)wherewriteFilepcon=doexpandTopreplaceItemp(Justblob)markChangedpmaybeFlushwhereblob=File$Blob(returncon)hashhash=sha256concreateDirectoryp=doexpandTopreplaceItemp$Just$SubTreeemptyTreeunlinkp=doexpandTopreplaceItempNothingrenamefromto=doexpandTofromtr<-getstreeletitem=findtrfromfound_to=findtrtounless(isNothingfound_to)$fail$"Error renaming: destination "++showto++" exists."unless(isNothingitem)$doreplaceItemtoitemreplaceItemfromNothing