Pristine.lhs

%  Copyright (C) 2002-2005 David Roundy
%  Copyright (C) 2004 Juliusz Chroboczek
%
%  This program is free software; you can redistribute it and/or modify
%  it under the terms of the GNU General Public License as published by
%  the Free Software Foundation; either version 2, or (at your option)
%  any later version.
%
%  This program is distributed in the hope that it will be useful,
%  but WITHOUT ANY WARRANTY; without even the implied warranty of
%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
%  GNU General Public License for more details.
%
%  You should have received a copy of the GNU General Public License
%  along with this program; see the file COPYING.  If not, write to
%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
%  Boston, MA 02110-1301, USA.


\begin{code}
{-# OPTIONS_GHC -cpp #-}
#include "gadts.h"
module Darcs.Repository.Pristine ( Pristine, flagsToPristine, nopristine,
                 createPristine, removePristine, identifyPristine,
                 checkPristine, slurpPristine,
                 applyPristine, createPristineFromWorking,
                 syncPristine, replacePristine, getPristinePop,
                 pristineDirectory, pristineToFlagString,
                 easyCreatePristineDirectoryTree,
                 easyCreatePartialsPristineDirectoryTree
               ) where

import Data.Maybe ( isJust )
import Control.Monad ( when, liftM )
import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist,
                   renameDirectory, removeFile )
import Darcs.Lock ( rm_recursive, writeBinFile )
import Darcs.Diff ( cmp, sync )
import Workaround ( getCurrentDirectory )
import Darcs.SlurpDirectory ( Slurpy,  mmap_slurp, co_slurp )
import Darcs.Utils ( catchall )

import Darcs.PopulationData ( Population, getPopFrom )
import Darcs.Flags ( DarcsFlag( PristinePlain, PristineNone, UseHashedInventory, UseFormat2 ) )
import Darcs.IO ( WriteableDirectory(mWithCurrentDirectory) )
import Darcs.Patch ( Patchy, apply )
import Darcs.Patch.Info ( PatchInfo )
import FileName ( fp2fn )
import FastPackedString ( nilPS )
import SHA1 ( sha1PS )
import Darcs.External ( cloneTree, cloneTreeExcept, clonePartialsTree )
import Darcs.Repository.InternalTypes ( Pristine(..) )
import Darcs.Global ( darcsdir )
#include "impossible.h"

nopristine :: Pristine
nopristine = NoPristine "aack?"

pristineName :: String
pristineName = "pristine"

identifyPristine :: IO (Pristine)
identifyPristine = do mp <- reallyIdentifyPristine
                      case mp of
                          Nothing -> fail "Pristine tree doesn't exist."
                          Just pristine -> return pristine

reallyIdentifyPristine :: IO (Maybe Pristine)
reallyIdentifyPristine = 
    do dir <- findpristine doesDirectoryExist ""
       none <- findpristine doesFileExist ".none"
       hashinv <- doesFileExist $ darcsdir++"/hashed_inventory"
       hashpris <- doesDirectoryExist hashedPristineDirectory
       case (dir, none, hashinv && hashpris) of
           (Nothing, Nothing, False) -> return Nothing
           (Just n, Nothing, False) ->
               return (Just (PlainPristine n))
           (Nothing, Just n, False) ->
               return (Just (NoPristine n))
           (Nothing, Nothing, True) ->
               return (Just HashedPristine)
           _ -> fail "Multiple pristine trees."
    where findpristine fn ext =
              do e1 <- fn n1
                 e2 <- fn n2
                 case (e1, e2) of
                     (False, False) -> return Nothing
                     (True, False) -> return (Just n1)
                     (False, True) -> return (Just n2)
                     (True, True) -> fail "Multiple pristine trees."
              where  n1 = darcsdir++"/pristine" ++ ext
                     n2 = darcsdir++"/current" ++ ext

flagsToPristine :: [DarcsFlag] -> Pristine
flagsToPristine fs | UseFormat2 `elem` fs || UseHashedInventory `elem` fs = HashedPristine
flagsToPristine (PristineNone : _) = NoPristine (darcsdir++"/" ++ pristineName ++ ".none")
flagsToPristine (PristinePlain : _) = PlainPristine (darcsdir++"/" ++ pristineName)
flagsToPristine (_ : t) = flagsToPristine t
flagsToPristine [] = flagsToPristine [PristinePlain]

createPristine :: Pristine -> IO Pristine
createPristine p = 
    do oldpristine <- reallyIdentifyPristine
       when (isJust oldpristine) $ fail "Pristine tree already exists."
       case p of
           NoPristine n -> writeBinFile n "Do not delete this file.\n"
           PlainPristine n -> createDirectory n
           HashedPristine -> do createDirectory hashedPristineDirectory
                                writeFile (hashedPristineDirectory++"/"++sha1PS nilPS) ""
       return p

hashedPristineDirectory :: String
hashedPristineDirectory = darcsdir++"/pristine.hashed"

removePristine :: Pristine -> IO ()
removePristine (NoPristine n) = removeFile n
removePristine (PlainPristine n) = rm_recursive n
removePristine HashedPristine = rm_recursive hashedPristineDirectory

checkPristine :: FilePath -> Pristine -> IO Bool
checkPristine _ (NoPristine _) = return True
checkPristine path (PlainPristine n) = do cwd <- getCurrentDirectory
                                          cmp (cwd ++ "/" ++ n) path
checkPristine _ HashedPristine = 
    bug "HashedPristine is not implemented yet."

slurpPristine :: Pristine -> IO (Maybe Slurpy)
slurpPristine (PlainPristine n) = do cwd <- getCurrentDirectory
                                     slurpy <- mmap_slurp (cwd ++ "/" ++ n)
                                     return (Just slurpy)
slurpPristine (NoPristine _) = return Nothing
slurpPristine HashedPristine =
    bug "HashedPristine is not implemented yet."

applyPristine :: Patchy p => Pristine -> p C(x y) -> IO ()
applyPristine (NoPristine _) _ = return ()
-- We don't need flags for now, since we don't care about
-- SetScriptsExecutable for the pristine cache.
applyPristine (PlainPristine n) p =
    mWithCurrentDirectory (fp2fn n) $ apply [] p
applyPristine HashedPristine _ =
    bug "3 HashedPristine is not implemented yet."

createPristineFromWorking :: Pristine -> IO ()
createPristineFromWorking (NoPristine _) = return ()
createPristineFromWorking (PlainPristine n) = cloneTreeExcept [darcsdir] "." n
createPristineFromWorking HashedPristine =
    bug "HashedPristine is not implemented yet."

syncPristine :: Pristine -> IO ()
syncPristine (NoPristine _) = return ()
syncPristine (PlainPristine n) =
    do ocur <- mmap_slurp n
       owork <- co_slurp ocur "."
       sync n ocur owork
syncPristine HashedPristine = return () -- FIXME this should be implemented!

replacePristine :: FilePath -> Pristine -> IO ()
replacePristine _ (NoPristine _) = return ()
replacePristine newcur (PlainPristine n) =
    do rm_recursive nold
           `catchall` return ()
       renameDirectory n nold
       renameDirectory newcur n
       return ()
           where nold = darcsdir ++ "/" ++ pristineName ++ "-old"
replacePristine _ HashedPristine =
    bug "HashedPristine is not implemented yet."

getPristinePop :: PatchInfo -> Pristine -> IO (Maybe Population)
getPristinePop pinfo (PlainPristine n) =
    Just `liftM` getPopFrom n pinfo
getPristinePop _ _ = return Nothing

pristineDirectory :: Pristine -> Maybe String
pristineDirectory (PlainPristine n) = Just n
pristineDirectory _ = Nothing

pristineToFlagString :: Pristine -> String
pristineToFlagString (NoPristine _) = "--no-pristine-tree"
pristineToFlagString (PlainPristine _) = "--plain-pristine-tree"
pristineToFlagString HashedPristine =
    bug "HashedPristine is not implemented yet."

easyCreatePristineDirectoryTree :: Pristine -> FilePath -> IO Bool
easyCreatePristineDirectoryTree (NoPristine _) _ = return False
easyCreatePristineDirectoryTree (PlainPristine n) p
 = cloneTree n p >> return True
easyCreatePristineDirectoryTree HashedPristine _ =
    bug "HashedPristine is not implemented yet."

easyCreatePartialsPristineDirectoryTree :: [FilePath] -> Pristine -> FilePath
                                        -> IO Bool
easyCreatePartialsPristineDirectoryTree _ (NoPristine _) _ = return False
easyCreatePartialsPristineDirectoryTree prefs (PlainPristine n) p
 = clonePartialsTree n p prefs >> return True
easyCreatePartialsPristineDirectoryTree _ HashedPristine _ =
    bug "HashedPristine is not implemented yet."
\end{code}