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 Data.Typeable
import Control.Monad
import Control.Concurrent.MVar

type Dir hash = M.Map EntName (ModePerm, TreeSt hash)

type TreeVar hash = MVar (Dir hash)

data TreeSt hash =
      TreeRef (Ref hash)
    | TreeLoaded (TreeVar hash)

type WorkTree hash = MVar (TreeSt hash)

data EntType = EntDirectory | EntFile | EntExecutable
    deriving (Show,Eq)

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

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

-- | delete a path from a working tree
--
-- if the path doesn't exist, no error is raised
workTreeDelete :: (Typeable hash, HashAlgorithm hash)
               => Git hash
               -> WorkTree hash
               -> 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 :: (Typeable hash, HashAlgorithm hash)
            => Git hash
            -> WorkTree hash
            -> EntPath
            -> (EntType, Ref hash)
            -> IO ()
workTreeSet git wt path (entType, entRef) = diveFromRoot git wt path dive
  where --dive :: TreeVar hash -> 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 :: HashAlgorithm hash => Git hash -> WorkTree hash -> IO (Ref hash)
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 :: (Typeable hash, HashAlgorithm hash) => Git hash -> Ref hash -> IO (TreeVar hash)
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 :: (Typeable hash, HashAlgorithm hash)
              => Git hash
              -> EntName
              -> TreeVar hash
              -> (Dir hash -> IO (Dir hash, Either (TreeVar hash) a))
              -> IO (Either (TreeVar hash) 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 :: (Typeable hash, HashAlgorithm hash)
             => Git hash
             -> WorkTree hash
             -> EntPath
             -> (TreeVar hash -> 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