%  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}
module Pristine ( Pristine, flagsToPristine, nopristine,
                 createPristine, removePristine, identifyPristine,
                 checkPristine, slurpPristine,
                 applyPristine, createPristineFromWorking,
                 syncPristine, replacePristine, getPristinePop,
                 pristineDirectory, pristineToFlagString,
                 easyCreatePristineDirectoryTree,
                 easyCreatePartialsPristineDirectoryTree
               ) where

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

import PatchInfo ( PatchInfo )
import PopulationData ( Population, getPopFrom )
import DarcsFlags ( DarcsFlag( PristinePlain, PristineNone ) )
import DarcsIO ( WriteableDirectory(mWithCurrentDirectory) )
import Patch ( Patch, apply )
import FileName ( fp2fn )
import External ( cloneTree, cloneTreeExcept, clonePartialsTree )

data Pristine
  = NoPristine !String
  | PlainPristine !String
  | HashedPristine !String

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"
       hash <- findpristine doesFileExist ".hash"
       case (dir, none, hash) of
           (Nothing, Nothing, Nothing) -> return Nothing
           (Just n, Nothing, Nothing) ->
               return (Just (PlainPristine n))
           (Nothing, Just n, Nothing) ->
               return (Just (NoPristine n))
           (Nothing, Nothing, Just n) ->
               return (Just (HashedPristine n))
           _ -> 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 = "_darcs/pristine" ++ ext
                     n2 = "_darcs/current" ++ ext

flagsToPristine :: [DarcsFlag] -> Pristine
flagsToPristine (PristinePlain : _) =
    PlainPristine ("_darcs/" ++ pristineName)
flagsToPristine (PristineNone : _) =
    NoPristine ("_darcs/" ++ pristineName ++ ".none")
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 -> do writeBinFile n "Do not delete this file.\n"
                              return p
           PlainPristine n -> do createDirectory n
                                 return p
           HashedPristine _ -> fail "HashedPristine is not implemented yet."

removePristine :: Pristine -> IO ()
removePristine (NoPristine n) = removeFile n
removePristine (PlainPristine n) = rm_recursive n
removePristine (HashedPristine _) = 
    fail "HashedPristine is not implemented yet."

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

applyPristine :: Pristine -> Patch -> 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 _) _ =
    fail "HashedPristine is not implemented yet."

createPristineFromWorking :: Pristine -> IO ()
createPristineFromWorking (NoPristine _) = return ()
createPristineFromWorking (PlainPristine n) = cloneTreeExcept ["_darcs"] "." n
createPristineFromWorking (HashedPristine _) =
    fail "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 _) =
    fail "HashedPristine is not implemented yet."

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 = "_darcs/" ++ pristineName ++ "-old"
replacePristine _ (HashedPristine _) = 
    fail "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 _) = 
    error "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 _) _ =
    error "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 _) _ =
    error "HashedPristine is not implemented yet."
\end{code}

