1 -- Copyright (C) 2002-2005 David Roundy 2 -- Copyright (C) 2004 Juliusz Chroboczek 3 -- 4 -- This program is free software; you can redistribute it and/or modify 5 -- it under the terms of the GNU General Public License as published by 6 -- the Free Software Foundation; either version 2, or (at your option) 7 -- any later version. 8 -- 9 -- This program is distributed in the hope that it will be useful, 10 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 11 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 -- GNU General Public License for more details. 13 -- 14 -- You should have received a copy of the GNU General Public License 15 -- along with this program; see the file COPYING. If not, write to 16 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 17 -- Boston, MA 02110-1301, USA. 18 19 {-# OPTIONS_GHC -cpp #-} 20 {-# LANGUAGE CPP #-} 21 22 #include "gadts.h" 23 24 module Darcs.Repository.Pristine ( Pristine, flagsToPristine, nopristine, 25 createPristine, removePristine, identifyPristine, 26 slurpPristine, 27 applyPristine, createPristineFromWorking, 28 syncPristine, replacePristineFromSlurpy, 29 getPristinePop, 30 pristineDirectory, pristineToFlagString, 31 easyCreatePristineDirectoryTree, 32 easyCreatePartialsPristineDirectoryTree 33 ) where 34 35 import Data.Maybe ( isJust ) 36 import Control.Monad ( when, liftM ) 37 import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist, 38 renameDirectory, removeFile ) 39 import Darcs.Lock ( rm_recursive, writeBinFile ) 40 import Darcs.Diff ( sync ) 41 import Workaround ( getCurrentDirectory ) 42 import Darcs.SlurpDirectory ( Slurpy, mmap_slurp, co_slurp, writeSlurpy ) 43 import Darcs.Utils ( catchall ) 44 45 import Darcs.PopulationData ( Population, getPopFrom ) 46 import Darcs.Flags ( DarcsFlag( PristinePlain, PristineNone ) ) 47 import Darcs.Repository.Format ( RepoFormat, format_has, 48 RepoProperty(HashedInventory) ) 49 import Darcs.IO ( WriteableDirectory(mWithCurrentDirectory) ) 50 import Darcs.Patch ( Patchy, apply ) 51 import Darcs.Patch.Info ( PatchInfo ) 52 import Darcs.Patch.FileName ( fp2fn ) 53 import qualified Data.ByteString as B (empty) 54 import Darcs.RepoPath ( FilePathLike, toFilePath ) 55 import SHA1 ( sha1PS ) 56 import Darcs.External ( cloneTree, cloneTreeExcept, clonePartialsTree ) 57 import Darcs.Repository.InternalTypes ( Pristine(..) ) 58 import Darcs.Global ( darcsdir ) 59 #include "impossible.h" 60 61 nopristine :: Pristine 62 nopristine = NoPristine "aack?" 63 64 pristineName :: String 65 pristineName = "pristine" 66 67 identifyPristine :: IO (Pristine) 68 identifyPristine = do mp <- reallyIdentifyPristine 69 case mp of 70 Nothing -> fail "Pristine tree doesn't exist." 71 Just pristine -> return pristine 72 73 reallyIdentifyPristine :: IO (Maybe Pristine) 74 reallyIdentifyPristine = 75 do dir <- findpristine doesDirectoryExist "" 76 none <- findpristine doesFileExist ".none" 77 hashinv <- doesFileExist $ darcsdir++"/hashed_inventory" 78 hashpris <- doesDirectoryExist hashedPristineDirectory 79 case (dir, none, hashinv && hashpris) of 80 (Nothing, Nothing, False) -> return Nothing 81 (Just n, Nothing, False) -> 82 return (Just (PlainPristine n)) 83 (Nothing, Just n, False) -> 84 return (Just (NoPristine n)) 85 (Nothing, Nothing, True) -> 86 return (Just HashedPristine) 87 _ -> fail "Multiple pristine trees." 88 where findpristine fn ext = 89 do e1 <- fn n1 90 e2 <- fn n2 91 case (e1, e2) of 92 (False, False) -> return Nothing 93 (True, False) -> return (Just n1) 94 (False, True) -> return (Just n2) 95 (True, True) -> fail "Multiple pristine trees." 96 where n1 = darcsdir++"/pristine" ++ ext 97 n2 = darcsdir++"/current" ++ ext 98 99 flagsToPristine :: [DarcsFlag] -> RepoFormat -> Pristine 100 flagsToPristine _ rf | format_has HashedInventory rf = HashedPristine 101 flagsToPristine (PristineNone : _) _ = NoPristine (darcsdir++"/" ++ pristineName ++ ".none") 102 flagsToPristine (PristinePlain : _) _ = PlainPristine (darcsdir++"/" ++ pristineName) 103 flagsToPristine (_ : t) rf = flagsToPristine t rf 104 flagsToPristine [] rf = flagsToPristine [PristinePlain] rf 105 106 createPristine :: Pristine -> IO Pristine 107 createPristine p = 108 do oldpristine <- reallyIdentifyPristine 109 when (isJust oldpristine) $ fail "Pristine tree already exists." 110 case p of 111 NoPristine n -> writeBinFile n "Do not delete this file.\n" 112 PlainPristine n -> createDirectory n 113 HashedPristine -> do createDirectory hashedPristineDirectory 114 writeFile (hashedPristineDirectory++"/"++sha1PS B.empty) "" 115 return p 116 117 hashedPristineDirectory :: String 118 hashedPristineDirectory = darcsdir++"/pristine.hashed" 119 120 removePristine :: Pristine -> IO () 121 removePristine (NoPristine n) = removeFile n 122 removePristine (PlainPristine n) = rm_recursive n 123 removePristine HashedPristine = rm_recursive hashedPristineDirectory 124 125 slurpPristine :: Pristine -> IO (Maybe Slurpy) 126 slurpPristine (PlainPristine n) = do cwd <- getCurrentDirectory 127 slurpy <- mmap_slurp (cwd ++ "/" ++ n) 128 return (Just slurpy) 129 slurpPristine (NoPristine _) = return Nothing 130 slurpPristine HashedPristine = 131 bug "HashedPristine is not implemented yet." 132 133 applyPristine :: Patchy p => Pristine -> p C(x y) -> IO () 134 applyPristine (NoPristine _) _ = return () 135 -- We don't need flags for now, since we don't care about 136 -- SetScriptsExecutable for the pristine cache. 137 applyPristine (PlainPristine n) p = 138 mWithCurrentDirectory (fp2fn n) $ apply [] p 139 applyPristine HashedPristine _ = 140 bug "3 HashedPristine is not implemented yet." 141 142 createPristineFromWorking :: Pristine -> IO () 143 createPristineFromWorking (NoPristine _) = return () 144 createPristineFromWorking (PlainPristine n) = cloneTreeExcept [darcsdir] "." n 145 createPristineFromWorking HashedPristine = 146 bug "HashedPristine is not implemented yet." 147 148 syncPristine :: Pristine -> IO () 149 syncPristine (NoPristine _) = return () 150 syncPristine (PlainPristine n) = 151 do ocur <- mmap_slurp n 152 owork <- co_slurp ocur "." 153 sync n ocur owork 154 syncPristine HashedPristine = return () -- FIXME this should be implemented! 155 156 replacePristineFromSlurpy :: Slurpy -> Pristine -> IO () 157 replacePristineFromSlurpy _ (NoPristine _) = return () 158 replacePristineFromSlurpy s (PlainPristine n) = 159 do rm_recursive nold 160 `catchall` return () 161 writeSlurpy s ntmp 162 renameDirectory n nold 163 renameDirectory ntmp n 164 return () 165 where nold = darcsdir ++ "/" ++ pristineName ++ "-old" 166 ntmp = darcsdir ++ "/" ++ pristineName ++ "-tmp" 167 replacePristineFromSlurpy _ HashedPristine = 168 bug "HashedPristine is not implemented yet." 169 170 getPristinePop :: PatchInfo -> Pristine -> IO (Maybe Population) 171 getPristinePop pinfo (PlainPristine n) = 172 Just `liftM` getPopFrom n pinfo 173 getPristinePop _ _ = return Nothing 174 175 pristineDirectory :: Pristine -> Maybe String 176 pristineDirectory (PlainPristine n) = Just n 177 pristineDirectory _ = Nothing 178 179 pristineToFlagString :: Pristine -> String 180 pristineToFlagString (NoPristine _) = "--no-pristine-tree" 181 pristineToFlagString (PlainPristine _) = "--plain-pristine-tree" 182 pristineToFlagString HashedPristine = 183 bug "HashedPristine is not implemented yet." 184 185 easyCreatePristineDirectoryTree :: Pristine -> FilePath -> IO Bool 186 easyCreatePristineDirectoryTree (NoPristine _) _ = return False 187 easyCreatePristineDirectoryTree (PlainPristine n) p 188 = cloneTree n p >> return True 189 easyCreatePristineDirectoryTree HashedPristine _ = 190 bug "HashedPristine is not implemented yet." 191 192 easyCreatePartialsPristineDirectoryTree :: FilePathLike fp => [fp] -> Pristine 193 -> FilePath -> IO Bool 194 easyCreatePartialsPristineDirectoryTree _ (NoPristine _) _ = return False 195 easyCreatePartialsPristineDirectoryTree prefs (PlainPristine n) p 196 = clonePartialsTree n p (map toFilePath prefs) >> return True 197 easyCreatePartialsPristineDirectoryTree _ HashedPristine _ = 198 bug "HashedPristine is not implemented yet." 199