module Data.Git.WorkTree
( WorkTree
, EntType(..)
, workTreeNew
, workTreeFrom
, workTreeDelete
, workTreeSet
, workTreeFlush
) where
import Data.Git.Ref
import Data.Git.Types
import Data.Git.Storage.Object
import Data.Git.Storage
import Data.Git.Repository
import qualified Data.Map as M
import Control.Monad
import Control.Concurrent.MVar
type Dir = M.Map EntName (ModePerm, TreeSt)
type TreeVar = MVar Dir
data TreeSt = TreeRef Ref | TreeLoaded TreeVar
type WorkTree = MVar TreeSt
data EntType = EntDirectory | EntFile | EntExecutable
deriving (Show,Eq)
workTreeNew :: IO WorkTree
workTreeNew = newMVar M.empty >>= newMVar . TreeLoaded
workTreeFrom :: Ref -> IO WorkTree
workTreeFrom ref = newMVar (TreeRef ref)
workTreeDelete :: Git -> WorkTree -> EntPath -> IO ()
workTreeDelete git wt path = diveFromRoot git wt path dive
where dive _ [] = error "internal error: delete: empty dive"
dive varCurrent [file] = modifyMVar_ varCurrent (return . M.delete file)
dive varCurrent (x:xs) = do
evarChild <- loadOrGetTree git x varCurrent $ \m -> return (m, Right ())
case evarChild of
Left varChild -> dive varChild xs
Right () -> return ()
workTreeSet :: Git -> WorkTree -> EntPath -> (EntType, Ref) -> IO ()
workTreeSet git wt path (entType, entRef) = diveFromRoot git wt path dive
where dive :: TreeVar -> EntPath -> IO ()
dive _ [] = error "internal error: set: empty dive"
dive varCurrent [file] = modifyMVar_ varCurrent (return . M.insert file (entTypeToPerm entType, TreeRef entRef))
dive varCurrent (x:xs) = do
evarChild <- loadOrGetTree git x varCurrent $ \m -> do
v <- newMVar M.empty
return (M.insert x (entTypeToPerm EntDirectory, TreeLoaded v) m, Left v)
case evarChild of
Left varChild -> dive varChild xs
Right () -> return ()
workTreeFlush :: Git -> WorkTree -> IO Ref
workTreeFlush git wt = do
wtVal <- takeMVar wt
case wtVal of
TreeRef ref -> putMVar wt wtVal >> return ref
TreeLoaded var -> do
ref <- writeTreeRecursively (TreeLoaded var)
putMVar wt $ TreeRef ref
return ref
where writeTreeRecursively (TreeRef ref) = return ref
writeTreeRecursively (TreeLoaded var) = do
c <- readMVar var
ents <- forM (M.toList c) $ \(bs, (mperm, entSt)) -> do
ref <- writeTreeRecursively entSt
return (mperm, bs, ref)
setTree ents
setTree ents = setObject git (toObject $ Tree ents)
loadTreeVar :: Git -> Ref -> IO TreeVar
loadTreeVar git treeRef = do
(Tree ents) <- getTree git treeRef
let t = foldr (\(m,b,r) acc -> M.insert b (m,TreeRef r) acc) M.empty ents
newMVar t
entTypeToPerm :: EntType -> ModePerm
entTypeToPerm EntDirectory = ModePerm 0o040000
entTypeToPerm EntExecutable = ModePerm 0o100755
entTypeToPerm EntFile = ModePerm 0o100644
loadOrGetTree :: Git -> EntName -> TreeVar -> (Dir -> IO (Dir, Either TreeVar a)) -> IO (Either TreeVar a)
loadOrGetTree git x varCurrent onMissing =
modifyMVar varCurrent $ \m -> do
case M.lookup x m of
Nothing -> onMissing m
Just (_, treeSt) ->
case treeSt of
TreeRef ref -> do
var <- loadTreeVar git ref
return (M.adjust (\(perm,_) -> (perm, TreeLoaded var)) x m, Left var)
TreeLoaded var -> return (m, Left var)
diveFromRoot :: Git -> WorkTree -> EntPath
-> (TreeVar -> EntPath -> IO ())
-> IO ()
diveFromRoot git wt path dive
| path == [] = return ()
| otherwise = do
wtVal <- takeMVar wt
current <- case wtVal of
TreeLoaded var -> return var
TreeRef ref -> loadTreeVar git ref
putMVar wt $ TreeLoaded current
dive current path