%  Copyright (C) 2002-2004 David Roundy
%
%  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; if not, write to the Free Software Foundation,
%  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
\chapter{SlurpDirectory}

\section{Introduction}

SlurpDirectory is intended to give a nice lazy way of traversing directory
trees.

\begin{code}
module SlurpDirectory ( Slurpy( ), FileContents, empty_slurpy,
                        slurp, mmap_slurp, slurp_unboring, co_slurp,
                        mmap_slurp_file,
                        slurp_name, is_file, is_dir,
                        get_filecontents, get_dircontents, get_mtime,
                        get_length, get_slurp,
                        slurp_write_and_read_dirty,
                        slurp_write_dirty, slurp_write, launder_slurpy,
                        slurp_runfunc,
                        slurp_addfile, slurp_removefile,
                        slurp_adddir, slurp_removedir, slurp_move,
                        slurp_remove,
                        slurp_modfile, slurp_hasfile, slurp_hasdir,
                        slurp_has_anycase, wait_a_moment, undefined_time,
                        undefined_size,
                        slurp_has,
                        readFileLinesPS,
                        doesFileReallyExist, doesDirectoryReallyExist,
                      ) where

import IO
import Directory hiding ( getCurrentDirectory, renameFile )
import Workaround ( getCurrentDirectory, renameFile )
import DarcsUtils ( withCurrentDirectory )
import System.IO.Unsafe ( unsafeInterleaveIO )
import List ( sort )
import Monad ( when, unless, liftM )
import Char ( toLower )
import Posix ( EpochTime, getFileStatus, modificationTime,
               sleep, FileOffset, fileSize,
               setFileTimes, epochTime,
             )
import Foreign.C.String
import Control.Exception ( block )

import Maybe ( catMaybes )

import AntiMemo ( AntiMemo, antimemoize, readAntiMemo )
import FastPackedString
import FileName ( FileName, fn2fp, fp2fn, fn2s, norm_path, break_on_dir,
                  own_name, super_name,
                )
import Lock ( writeToFile )
import DarcsUtils ( catchall )
#include "impossible.h"

data Slurpy = SlurpDir FileName (Maybe (IO ())) [Slurpy]
            | SlurpFile FileName Bool (EpochTime,FileOffset) FileContents
type FileContents = (AntiMemo [PackedString],Maybe PackedString)

slurp :: FilePath -> IO Slurpy
mmap_slurp_file :: FilePath -> FilePath -> IO Slurpy
mmap_slurp :: FilePath -> IO Slurpy
slurp_unboring :: (FilePath->Bool) -> FilePath -> IO Slurpy
empty_slurpy :: Slurpy
empty_slurpy = SlurpDir (fp2fn ".") nopatch []
slurp_name :: Slurpy -> FilePath
is_file :: Slurpy -> Bool
is_dir :: Slurpy -> Bool

get_filecontents :: Slurpy -> FileContents
get_dircontents :: Slurpy -> [Slurpy]
get_mtime :: Slurpy -> EpochTime
get_length :: Slurpy -> FileOffset

instance Eq Slurpy where
    s1 == s2 = (slurp_name s1) == (slurp_name s2)
instance Ord Slurpy where
    s1 <= s2 = (slurp_name s1) <= (slurp_name s2)
\end{code}

Here are a few access functions.

\begin{code}
slurp_name (SlurpFile f _ _ _) = fn2fp f
slurp_name (SlurpDir d _ _) = fn2fp d
slurp_setname :: FileName -> Slurpy -> Slurpy
slurp_setname f (SlurpDir _ b c) = SlurpDir f b c
slurp_setname f (SlurpFile _ b m c) = SlurpFile f b m c

is_file (SlurpDir _ _ _) = False
is_file (SlurpFile _ _ _ _) = True

is_dir (SlurpDir _ _ _) = True
is_dir (SlurpFile _ _ _ _) = False

get_filecontents (SlurpFile _ _ _ c) = c
get_filecontents _ = bug "Can't get_filecontents on SlurpDir."

get_dircontents (SlurpDir _ _ c) = sort c
get_dircontents _ = bug "Can't get_dircontents on SlurpFile."

get_mtime (SlurpFile _ _ m _) = fst m
get_mtime _ = bug "can't get_mtime on SlurpDir."
get_length (SlurpFile _ _ m _) = snd m
get_length _ = bug "can't get_length on SlurpDir."

getModTime :: FilePath -> IO (EpochTime, FileOffset)
getModTime f = do stat <- getFileStatus f
                  return (modificationTime stat, fileSize stat)

nopatch :: Maybe (IO ())
nopatch = Nothing

undefined_time :: EpochTime
undefined_time = -1
undefined_size :: FileOffset
undefined_size = -1
undef_time_size :: (EpochTime, FileOffset)
undef_time_size = (undefined_time, undefined_size)

wait_a_moment :: IO ()
wait_a_moment = do { sleep 1; return () }
    -- HACKERY: In ghc 6.1, sleep has the type signature IO Int; it
    -- returns an integer just like sleep(3) does. To stay compatible
    -- with older versions, though, we just ignore sleep's return
    -- value. Hackery, like I said.

foreign import ccall unsafe "static compat.h isnt_symlink" isnt_symlink
    :: CString -> IO Int

doesFileReallyExist :: FilePath -> IO Bool
doesFileReallyExist f = do
    fe <- doesFileExist f
    if not fe then return False
       else withCString f $ \cf-> do notsym <- isnt_symlink cf
                                     return $ notsym /= 0
doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist f = do
    fe <- doesDirectoryExist f
    if not fe then return False
       else withCString f $ \cf-> do notsym <- isnt_symlink cf
                                     return $ notsym /= 0
\end{code}

slurp is how we get a slurpy in the first place...

\begin{code}
slurp = slurp_unboring (\_->True)
mmap_slurp = genslurp True (\_->True)
slurp_unboring = genslurp False
genslurp :: Bool -> (FilePath -> Bool)
         -> FilePath -> IO Slurpy
genslurp usemm nb dirname = do
    isdir <- doesDirectoryExist $! dirname
    former_dir <- getCurrentDirectory
    if isdir
       then withCurrentDirectory dirname $
            do actualname <- getCurrentDirectory
               Just slurpy <- genslurp_helper usemm nb actualname "" "."
               return slurpy
       else fromJust `liftM` genslurp_helper usemm nb former_dir "" dirname

genslurp_helper :: Bool -> (FilePath -> Bool)
                -> FilePath -> String -> String -> IO (Maybe Slurpy)
genslurp_helper usemm nb formerdir fullpath dirname =
    seq usemm $ seq nb $ seq fulldirname $ do
    isdir <- doesDirectoryReallyExist fulldirname
    if isdir || dirname == "."
       then do fnames <- getDirectoryContents fulldirname
               sl <- unsafeInterleaveIO $ liftM catMaybes $ sequence
                     $ map (\f -> genslurp_helper usemm nb
                                  fulldirname (fullpath///f) f)
                     $ filter (nb.(fullpath///)) $ filter not_hidden fnames
               return $ Just $ SlurpDir (fp2fn dirname) nopatch sl
       else do isfile <- doesFileReallyExist fulldirname
               if isfile
                  then do
                    ls <- if usemm
                          then unsafeInterleaveIO $
                               mmapFileLinesPSetc $ fulldirname
                          else unsafeInterleaveIO $
                               readFileLinesPSetc $ fulldirname
                    mtime <- getModTime $! fulldirname
                    return $ Just $ SlurpFile (fp2fn dirname) False mtime ls
                  else return Nothing -- This is probably a dangling symlink...
    where fulldirname = formerdir///dirname
not_hidden :: FilePath -> Bool
not_hidden "." = False
not_hidden ".." = False
not_hidden _ = True
(///) :: FilePath -> FilePath -> FilePath
(///) "" d = d
(///) d "." = d
(///) d subdir = d ++ "/" ++ subdir

co_slurp :: Slurpy -> FilePath -> IO Slurpy
co_slurp guide dirname = do
    isdir <- doesDirectoryExist $! dirname
    if isdir
       then withCurrentDirectory dirname $ do
              actualname <- getCurrentDirectory
              Just slurpy <- co_slurp_helper actualname guide
              return slurpy
       else error "Error coslurping!!! Please report this."

co_slurp_helper :: FilePath -> Slurpy -> IO (Maybe Slurpy)
co_slurp_helper former_dir (SlurpDir d _ c) = do
    isdir <- doesDirectoryReallyExist $! former_dir///fn2fp d
    if not isdir && fn2fp d /= "." -- Allow the root of the repo to be a symlink!
       then return Nothing
       else do sl <- sequence $
                     map (co_slurp_helper $ former_dir///fn2fp d) c
               return $ Just $ SlurpDir d nopatch $ catMaybes sl
co_slurp_helper former_dir (SlurpFile f _ _ _) = do
   isfile <- doesFileReallyExist $! former_dir///fn2fp f
   if isfile
     then do ls <- unsafeInterleaveIO $
                   readFileLinesPSetc $! former_dir /// (fn2fp f)
             mtime <- getModTime $! former_dir///fn2fp f
             return $ Just $ SlurpFile f False mtime ls
     else return Nothing
readFileLinesPSetc :: String -> IO FileContents
readFileLinesPSetc f = do ps <- readFilePS f
                          return (linesPS `antimemoize` ps, Just ps)
readFileLinesPS :: String -> IO [PackedString]
readFileLinesPS f = linesPS `liftM` readFilePS f
mmapFileLinesPSetc :: String -> IO FileContents
mmapFileLinesPSetc f = do ps <- mmapFilePS f
                          return (linesPS `antimemoize` ps, Just ps)
--mmapFileLinesPS :: String -> IO [PackedString]
--mmapFileLinesPS f = linesPS `liftM` mmapFilePS f
\end{code}

if you want to just slurp a single file, you can use mmap_slurp_file.
\begin{code}
mmap_slurp_file parentdir fil = sf $ ("./"++) $ fn2fp $ norm_path $ fp2fn fil
    where sf f = case break (=='/') f of
                 (_,"") -> do absd <- withCurrentDirectory parentdir $
                                        getCurrentDirectory
                              ls <- unsafeInterleaveIO $!
                                    mmapFileLinesPSetc $! absd///f
                              mtime <- getModTime $! absd///f
                              return $ SlurpFile (fp2fn f) False mtime ls
                 (d,'/':f') -> do s <- sf f'
                                  return $ SlurpDir (fp2fn d) nopatch [s]
                 _ -> impossible
\end{code}

It is important to be able to readily modify a slurpy.

\begin{code}
slurp_remove :: FileName -> Slurpy -> Maybe Slurpy
slurp_remove fname (SlurpDir dd pp cc) =
    Just $ SlurpDir dd pp $ catMaybes $ map (sr $! norm_path fname) cc
    where sr f s@(SlurpDir d p c) =
              if f == d then Nothing
              else case break_on_dir f of
                   Just (dn,fn) -> if dn /= d then Just s
                                   else Just $ SlurpDir d p $ catMaybes $
                                        map (sr fn) c
                   Nothing -> Just s
          sr f s@(SlurpFile f' _ _ _) | f == f' = Nothing
                                      | otherwise = Just s
slurp_remove _ _ = bug "slurp_remove only acts on SlurpDir's"

slurp_removefile :: FileName -> Slurpy -> Maybe Slurpy
slurp_removefile f s =
  if slurp_hasfile f s
  then case slurp_remove f s of
       Just (SlurpDir d p c) -> Just $ SlurpDir d (p `thendo`
                                                   rm_file (fn2fp f)) c
       _ -> impossible
  else Nothing
      where rm_file fp = removeFile fp
                         `catch` (\e->if isDoesNotExistError e
                                      then return ()
                                      else ioError e)
\end{code}

\begin{code}
slurp_move :: FileName -> FileName -> Slurpy -> Maybe Slurpy
slurp_move f f' s =
    if slurp_hasfile f s
    then slurp_movefile f f' s
    else if slurp_hasdir f s
         then slurp_movedir f f' s
         else Just s

slurp_movefile :: FileName -> FileName -> Slurpy -> Maybe Slurpy
slurp_movefile f f' s@(SlurpDir _ _ _) =
    if not (slurp_hasfile f' s) &&
       not (slurp_hasdir f' s) &&
       slurp_hasdir (super_name f') s
    then case get_slurp f s of
         Nothing -> Nothing
         Just sf ->
             case slurp_remove f s of
             Nothing -> Nothing
             Just (SlurpDir d p c) ->
                 Just $ addslurp f' (slurp_setname (own_name f') sf)
                           $ SlurpDir d (p `thendo`
                                         mv_file (fn2fp f) (fn2fp f')) c
             _ -> impossible
    else Nothing
    where mv_file f1 f2 = renameFile f1 f2 `catchall` return ()
slurp_movefile _ _ _ = bug "Don't call slurp_movefile on a SlurpFile!"


slurp_movedir :: FileName -> FileName -> Slurpy -> Maybe Slurpy
slurp_movedir f f' s@(SlurpDir _ _ _) =
    if not (slurp_hasfile f' s) &&
       not (slurp_hasdir f' s) &&
       slurp_hasdir (super_name f') s
    then case get_slurp f s of
         Nothing -> Nothing
         Just sf ->
             case slurp_remove f s of
             Nothing -> Nothing
             Just (SlurpDir d p c) ->
                 Just $ addslurp f'
                          (slurp_setname (own_name f') sf)
                          $ SlurpDir d (p `thendo`
                                        mv_dir (fn2fp f) (fn2fp f')) c
             _ -> impossible
    else Nothing
    where mv_dir f1 f2 = renameDirectory f1 f2 `catchall` return ()
slurp_movedir _ _ _ = bug "Don't call slurp_movedir on a SlurpFile!"

addslurp :: FileName -> Slurpy -> Slurpy -> Slurpy
addslurp fname s s' =
    addslurp_private (fp2fn ".") (norm_path fname) s'
    where addslurp_private _ _ (SlurpFile a b m c) = SlurpFile a b m c
          addslurp_private d f (SlurpDir d' p c)
              | d /= d' = SlurpDir d' p c
              | otherwise =
                  case break_on_dir f of
                  Just (dn,fn) -> SlurpDir d p $
                                  map (addslurp_private dn fn) c
                  Nothing -> SlurpDir d p (s:c)

get_slurp :: FileName -> Slurpy -> Maybe Slurpy
get_slurp f (SlurpFile f' b m c) =
    if f == f' then Just $ SlurpFile f b m c
    else Nothing
get_slurp f (SlurpDir d b c)
  | f == d = Just $ SlurpDir d b c
  | fn2s d == "." = case filter (/=Nothing) $ map (get_slurp $ norm_path f) c of
                    [] -> Nothing
                    [msf] -> msf
                    _ -> impossible
  | otherwise =
       case break_on_dir f of
       Just (dn,fn) ->
           if dn == d
               then case filter (/=Nothing) $ map (get_slurp fn) c of
                [] -> Nothing
                [msf] -> msf
                _ -> impossible
               else Nothing
       _ -> Nothing
\end{code}

\begin{code}
slurp_addfile :: FileName -> Slurpy -> Maybe Slurpy
slurp_addfile f s =
  if slurp_hasfile f s
  then slurp_modfile f (\_ -> Just (return [nilPS],Nothing)) s
  else if slurp_hasdir (super_name f) s
       then Just $ addslurp f
                (SlurpFile (own_name f) True
                 (undefined_time,0) (return [nilPS],Nothing)) s
       else Nothing
\end{code}

\begin{code}
slurp_removedir :: FileName -> Slurpy -> Maybe Slurpy
slurp_removedir f s =
    case get_slurp f s of
    Just (SlurpDir _ _ []) ->
        case slurp_remove f s of
        Just (SlurpDir d p c) -> Just $ SlurpDir d (p `thendo` rm_dir) c
        _ -> impossible
    _ -> Nothing
    where rm_dir = removeDirectory (fn2fp f) `catchall` return ()
\end{code}

\begin{code}
slurp_adddir :: FileName -> Slurpy -> Maybe Slurpy
slurp_adddir f s =
  if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s)
  then Nothing
  else slurp_runfunc (carefullyCreateDirectory (fn2fp f)) $
       addslurp f (SlurpDir (own_name f) nopatch []) s
      where carefullyCreateDirectory d = do isd <- doesDirectoryReallyExist d
                                            when (not isd) $ createDirectory d
\end{code}

Code to modify a given file in a slurpy.

\begin{code}
slurp_modfile :: FileName -> (FileContents -> Maybe FileContents)
              -> Slurpy -> Maybe Slurpy
slurp_modfile fname modify sl@(SlurpDir dd pp contents) =
  if not $ slurp_hasfile fname sl
  then Nothing
  else case sequence $ map (sm $ norm_path fname) contents of
       Nothing -> Nothing
       Just c' -> Just $ SlurpDir dd pp c'
    where sm :: FileName -> Slurpy -> Maybe Slurpy
          sm f s@(SlurpDir d p c) =
              case break_on_dir f of
              Nothing -> Just s
              Just (dn,fn) ->
                  if dn == d
                  then case sequence $ map (sm fn) c of
                       Nothing -> Nothing
                       Just c' -> Just $ SlurpDir d p c'
                  else Just s
          sm f s@(SlurpFile ff _ _ c)
              | f == ff = case modify c of
                          Nothing -> Nothing
                          Just c' -> Just $ SlurpFile ff True undef_time_size c'
              | otherwise = Just s
slurp_modfile f modify (SlurpFile f' _ _ c)
    | f == f' = case modify c of
                Nothing -> Nothing
                Just c' -> Just $ SlurpFile f True undef_time_size c'
slurp_modfile _ _ s = Just s
\end{code}

\begin{code}
slurp_hasfile :: FileName -> Slurpy -> Bool
slurp_hasfile f (SlurpFile f' _ _ _) = (norm_path f) == f'
slurp_hasfile fname (SlurpDir _ _ contents) =
    seq normed_name $ or $ map (slurp_hasfile_private normed_name) contents
    where normed_name = norm_path fname
          slurp_hasfile_private f (SlurpFile f' _ _ _) = f == f'
          slurp_hasfile_private f (SlurpDir d _ c)
              | f == d = False
              | otherwise =
                  case break_on_dir f of
                  Just (dn,fn) ->
                      if dn == d
                      then or $ map (slurp_hasfile_private fn) c
                      else False
                  _ -> False

slurp_has :: FilePath -> Slurpy -> Bool
slurp_has fname (SlurpDir _ _ contents) =
    seq normed_name $ or $ map (has_private normed_name) contents
    where normed_name = norm_path $ fp2fn fname
          has_private f (SlurpFile f' _ _ _) = f == f'
          has_private f (SlurpDir d _ c)
            | f == d = True
            | otherwise =
                case break_on_dir f of
                Just (dn,fn)
                    | dn == d -> or $ map (has_private fn) c
                    | otherwise -> False
                _ -> False
slurp_has f (SlurpFile f' _ _ _) = (norm_path $ fp2fn f) == f'

slurp_has_anycase :: FilePath -> Slurpy -> Bool
slurp_has_anycase fname (SlurpDir _ _ contents) =
  seq normed_name $ or $ map (hasany_private normed_name) contents
  where normed_name = norm_path $ fp2fn $ map toLower fname
        hasany_private f (SlurpFile f' _ _ _) = f == tolower f'
        hasany_private f (SlurpDir d _ c)
            | f == tolower d = True
            | otherwise =
                case break_on_dir f of
                Just (dn,fn) -> if tolower dn == tolower d
                                then or $ map (hasany_private fn) c
                                else False
                _ -> False
slurp_has_anycase f (SlurpFile f' _ _ _) =
    (norm_path $ fp2fn $ map toLower f) == tolower f'
tolower :: FileName -> FileName
tolower = fp2fn . (map toLower) . fn2fp

slurp_hasdir :: FileName -> Slurpy -> Bool
slurp_hasdir d _ | norm_path d == fp2fn "" = True
slurp_hasdir f (SlurpDir _ _ c) =
    seq f $ or $ map (slurp_hasdir_private $ norm_path f) c
slurp_hasdir _ _ = False

slurp_hasdir_private :: FileName -> Slurpy -> Bool
slurp_hasdir_private _ (SlurpFile _ _ _ _) = False
slurp_hasdir_private f (SlurpDir d _ c)
  | f == d = True
  | otherwise =
       case break_on_dir f of
       Just (dn,fn) ->
           if dn == d
           then or $ map (slurp_hasdir_private fn) c
           else False
       _ -> False
\end{code}

Code to output the dirty files from a slurpy.

\begin{code}
slurp_write :: Slurpy -> IO ()
slurp_write (SlurpDir d p ss) = block $ 
  do isdir <- doesDirectoryReallyExist $ fn2fp d
     unless isdir (createDirectory $ fn2fp d)
     withCurrentDirectory (fn2fp d) $
       do runpatch p
          sequence_ $ map slurp_write ss
slurp_write (SlurpFile f dirt (mt,_) ls) =
    do writeContents f ls
       when (not dirt) $ setModTime f mt

setModTime :: FileName -> EpochTime -> IO ()
setModTime _ ctime | ctime == undefined_time = return ()
setModTime fname ctime = do now <- epochTime
                            setFileTimes (fn2fp fname) now ctime
                                             `catchall` return ()
\end{code}

\begin{code}
slurp_runfunc :: IO () -> Slurpy -> Maybe Slurpy
slurp_runfunc f (SlurpDir d Nothing ss) =
    Just $ SlurpDir d (Just f) ss
slurp_runfunc f (SlurpDir d (Just p) ss) =
    Just $ SlurpDir d (Just $ p >> f) ss
slurp_runfunc _ _ = bug "Can only runfunc on a SlurpDir."
\end{code}

\begin{code}
runpatch :: Maybe (IO ()) -> IO ()
runpatch Nothing = return ()
runpatch (Just p) = p

thendo :: Maybe (IO ()) -> IO () -> Maybe (IO ())
Nothing `thendo` p = Just p
(Just a) `thendo` b = Just $ a >> b

slurp_write_dirty :: Slurpy -> IO ()
slurp_write_dirty (SlurpDir d p ss) = block $ 
  withCurrentDirectory (fn2fp d) $
    do runpatch p
       sequence_ $ map slurp_write_dirty ss

slurp_write_dirty (SlurpFile f dirt _ ls)
    | dirt == False = return ()
    | otherwise = writeContents f ls

slurp_write_and_read_dirty :: Slurpy -> IO Slurpy
slurp_write_and_read_dirty (SlurpDir d Nothing ss) = 
  block $
    do ss' <- withCurrentDirectory (fn2fp d) $ 
                (sequence $ map slurp_write_and_read_dirty ss)
       return $ SlurpDir d nopatch ss'
slurp_write_and_read_dirty s@(SlurpDir d _ _)
    = do withCurrentDirectory (fn2fp d) $ slurp_write_dirty s
         mmap_slurp $ fn2fp d
slurp_write_and_read_dirty s@(SlurpFile _ False _ _) = return s
slurp_write_and_read_dirty (SlurpFile f True _ ls)
    = do writeContents f ls
         mmap_slurp (fn2fp f)

writeContents :: FileName -> FileContents -> IO ()
writeContents f (pps, Nothing) =
    case readAntiMemo pps of
    [] -> writeToFile (fn2fp f) $ \_ -> return ()
    (s:ss) -> writeToFile (fn2fp f) $ \h ->
              do hPutPS h s
                 sequence_ $ map (\ps -> hPutChar h '\n' >> hPutPS h ps) ss
writeContents f (_, Just ps) = writeToFile (fn2fp f) $ \h -> hPutPS h ps
\end{code}

Code to flag all files as clean

\begin{code}
launder_slurpy :: Slurpy -> Slurpy
launder_slurpy (SlurpDir d _ ss) = SlurpDir d nopatch (map launder_slurpy ss)
launder_slurpy (SlurpFile f _ m ls) = SlurpFile f False m ls
\end{code}