-- 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. {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} #include "gadts.h" module Darcs.Repository.Pristine ( Pristine, flagsToPristine, nopristine, createPristine, removePristine, identifyPristine, slurpPristine, applyPristine, createPristineFromWorking, syncPristine, replacePristine, replacePristineFromSlurpy, 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 ( sync ) import Workaround ( getCurrentDirectory ) import Darcs.SlurpDirectory ( Slurpy, mmap_slurp, co_slurp, writeSlurpy ) import Darcs.Utils ( catchall ) import Darcs.PopulationData ( Population, getPopFrom ) import Darcs.Flags ( DarcsFlag( PristinePlain, PristineNone ) ) import Darcs.Repository.Format ( RepoFormat, format_has, RepoProperty(HashedInventory) ) import Darcs.IO ( WriteableDirectory(mWithCurrentDirectory) ) import Darcs.Patch ( Patchy, apply ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.FileName ( fp2fn ) import qualified Data.ByteString as B (empty) import Darcs.RepoPath ( FilePathLike, toFilePath ) 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] -> RepoFormat -> Pristine flagsToPristine _ rf | format_has HashedInventory rf = HashedPristine flagsToPristine (PristineNone : _) _ = NoPristine (darcsdir++"/" ++ pristineName ++ ".none") flagsToPristine (PristinePlain : _) _ = PlainPristine (darcsdir++"/" ++ pristineName) flagsToPristine (_ : t) rf = flagsToPristine t rf flagsToPristine [] rf = flagsToPristine [PristinePlain] rf 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 B.empty) "" 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 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." replacePristineFromSlurpy :: Slurpy -> Pristine -> IO () replacePristineFromSlurpy _ (NoPristine _) = return () replacePristineFromSlurpy s (PlainPristine n) = do rm_recursive nold `catchall` return () writeSlurpy s ntmp renameDirectory n nold renameDirectory ntmp n return () where nold = darcsdir ++ "/" ++ pristineName ++ "-old" ntmp = darcsdir ++ "/" ++ pristineName ++ "-tmp" replacePristineFromSlurpy _ 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 :: FilePathLike fp => [fp] -> Pristine -> FilePath -> IO Bool easyCreatePartialsPristineDirectoryTree _ (NoPristine _) _ = return False easyCreatePartialsPristineDirectoryTree prefs (PlainPristine n) p = clonePartialsTree n p (map toFilePath prefs) >> return True easyCreatePartialsPristineDirectoryTree _ HashedPristine _ = bug "HashedPristine is not implemented yet."