WorkTree.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- |
-- Module      : Data.Git.WorkTree
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unix
--
-- a load-on-demand, write-on-demand working tree.
--
module Data.Git.WorkTree
    ( WorkTree
    , EntType(..)
    -- * Create new work trees
    , workTreeNew
    , workTreeFrom
    -- * Modifications methods
    , 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.ByteString as B

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)

-- | Create a new worktree
workTreeNew :: IO WorkTree
workTreeNew = newMVar M.empty >>= newMVar . TreeLoaded

-- | Create a worktree from a tree reference.
workTreeFrom :: Ref -> IO WorkTree
workTreeFrom ref = newMVar (TreeRef ref)

-- | delete a path from a working tree
--
-- if the path doesn't exist, no error is raised
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 ()

-- | Set a file in this working tree to a specific ref.
--
-- The ref should point to a valid blob or tree object, and
-- it's safer to write the referenced tree or blob object first.
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
                            -- create an empty tree
                            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 ()

{-
workTreeFlushAt :: Git -> WorkTree -> EntPath -> IO ()
workTreeFlushAt git wt path = do
    undefined
-}

-- | Flush the worktree by creating all the necessary trees in the git store
-- and return the root ref of the work tree.
workTreeFlush :: Git -> WorkTree -> IO Ref
workTreeFlush git wt = do
    -- write all the trees that need to be written
    -- switch to modifyMVar
    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)

----- helpers -----

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) -> -- check perm to see if it is a directory
                case treeSt of
                    TreeRef ref -> do
                        -- replace the ref by a loaded tree
                        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
        -- switch to modifyMVar
        wtVal   <- takeMVar wt
        current <- case wtVal of
                    TreeLoaded var -> return var
                    TreeRef ref      -> loadTreeVar git ref
        putMVar wt $ TreeLoaded current
        dive current path