%  Copyright (C) 2007 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.

\begin{code}
{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
#include "gadts.h"
module Darcs.Repository.HashedIO ( HashedIO, applyHashed,
                                   copyHashed, syncHashed, copyPartialsHashed, listHashedContents,
                                   slurpHashed, hashSlurped ) where

import System.Posix.Types ( EpochTime )
import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift )
import Control.Monad ( when )
import Data.Maybe ( isJust )
import System.IO.Unsafe ( unsafeInterleaveIO )

import Workaround ( createDirectoryIfMissing )
import Darcs.SlurpDirectory ( Slurpy(..), withSlurpy, undefined_time, undefined_size )
import Darcs.Repository.Prefs ( Cache, fetchFileUsingCache, writeFileUsingCache,
                                peekInCache, speculateFileUsingCache,
                                findFileMtimeUsingCache, setFileMtimeUsingCache )
import Darcs.Patch ( Patchy, apply )
import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )
import Darcs.Flags ( DarcsFlag )
import Darcs.Lock ( writeAtomicFilePS )
import Darcs.Utils ( withCurrentDirectory )
import Darcs.Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO, progress )
import FileName ( FileName, norm_path, fp2fn, fn2fp, fn2niceps, niceps2fn,
                  break_on_dir, own_name, super_name )
import FastPackedString ( PackedString, packString, unpackPS, linesPS, unlinesPS, nilPS, lengthPS )
import SHA1 ( sha1PS )

readHashFile :: Cache -> String -> String -> IO (String,PackedString)
readHashFile c subdir hash =
    do debugMessage $ "Reading hash file "++hash++" from "++subdir++"/"
       fetchFileUsingCache c subdir hash

applyHashed :: Patchy q => Cache -> [DarcsFlag] -> String -> q C(x y) -> IO String
applyHashed c fs h p = do s <- slurpHashed c fs h
                          let ms = withSlurpy s $ apply fs p
                          case ms of
                            Left e -> fail e
                            Right (s', ()) -> hashSlurped c fs s'
{-
applyHashed c fs h p = do (_,hd) <- runStateT (apply fs p) $
                                    HashDir { permissions = RW, cache = c,
                                              options = fs, rootHash = h }
                          return $ rootHash hd
-}

data HashDir r p = HashDir { permissions :: !r, cache :: !Cache,
                             options :: ![DarcsFlag], rootHash :: !String }
type HashedIO r p = StateT (HashDir r p) IO

data RO = RO
data RW = RW
{-
class Readable r where
    isRO :: r -> Bool
    isRO = const False
instance Readable RW
instance Readable RO where
    isRO RO = True
-}

instance ReadableDirectory (HashedIO r p) where
    mDoesDirectoryExist fn = do thing <- identifyThing fn
                                case thing of Just (D,_) -> return True
                                              _ -> return False
    mDoesFileExist fn = do thing <- identifyThing fn
                           case thing of Just (F,_) -> return True
                                         _ -> return False
    mInCurrentDirectory fn j | fn' == fp2fn "" = j
                             | otherwise =
                                 case break_on_dir fn' of
                                 Nothing -> do c <- readroot
                                               case geta D fn' c of
                                                 Nothing -> fail "dir doesn't exist mInCurrentDirectory..."
                                                 Just h -> inh h j
                                 Just (d,fn'') -> do c <- readroot
                                                     case geta D d c of
                                                       Nothing -> fail "dir doesn't exist..."
                                                       Just h -> inh h $ mInCurrentDirectory fn'' j
        where fn' = norm_path fn
    mGetDirectoryContents = map (\ (_,f,_) -> f) `fmap` readroot
    mReadFilePS fn = mInCurrentDirectory (super_name fn) $ do
                                          c <- readroot
                                          case geta F (own_name fn) c of
                                            Nothing -> fail $ " file don't exist... "++ fn2fp fn
                                            Just h -> readhash h

instance WriteableDirectory (HashedIO RW p) where
    mWithCurrentDirectory fn j
        | fn' == fp2fn "" = j
        | otherwise =
            case break_on_dir fn' of
            Nothing -> do c <- readroot
                          case geta D fn' c of
                            Nothing -> fail "dir doesn't exist in mWithCurrentDirectory..."
                            Just h -> do (h',x) <- withh h j
                                         writeroot $ seta D fn' h' c
                                         return x
            Just (d,fn'') -> do c <- readroot
                                case geta D d c of
                                  Nothing -> fail "dir doesn't exist..."
                                  Just h -> do (h',x) <- withh h $ mWithCurrentDirectory fn'' j
                                               writeroot $ seta D d h' c
                                               return x
        where fn' = norm_path fn
    mSetFileExecutable _ _ = return ()
    mWriteFilePS fn ps = do mexists <- identifyThing fn
                            case mexists of
                              Just (D,_) -> fail "can't write file over directory"
                              _ -> do h <- writeHashFile ps
                                      makeThing fn (F,h)
    mCreateDirectory fn = do h <- writeHashFile nilPS
                             exists <- isJust `fmap` identifyThing fn
                             when exists $ fail "can't mCreateDirectory over an existing object."
                             makeThing fn (D,h)
    mRename o n = do nexists <- isJust `fmap` identifyThing n
                     when nexists $ fail "mRename failed..."
                     mx <- identifyThing o
                     -- for backwards compatibility accept rename of nonexistent files.
                     case mx of Nothing -> return ()
                                Just x -> do rmThing o
                                             makeThing n x
    mRemoveDirectory = rmThing
    mRemoveFile f = do x <- mReadFilePS f
                       when (lengthPS x /= 0) $
                            fail $ "Cannot remove non-empty file "++fn2fp f
                       rmThing f

identifyThing :: FileName -> HashedIO r p (Maybe (ObjType,String))
identifyThing fn | fn' == fp2fn "" = do h <- gets rootHash
                                        return $ Just (D, h)
                 | otherwise = case break_on_dir fn' of
                               Nothing -> getany fn' `fmap` readroot
                               Just (d,fn'') -> do c <- readroot
                                                   case geta D d c of
                                                     Nothing -> return Nothing
                                                     Just h -> inh h $ identifyThing fn''
        where fn' = norm_path fn

makeThing :: FileName -> (ObjType,String) -> HashedIO RW p ()
makeThing fn (o,h) = mWithCurrentDirectory (super_name $ norm_path fn) $
                     seta o (own_name $ norm_path fn) h `fmap` readroot >>= writeroot

rmThing :: FileName -> HashedIO RW p ()
rmThing fn = mWithCurrentDirectory (super_name $ norm_path fn) $
             do c <- readroot
                let c' = filter (\(_,x,_)->x/= own_name (norm_path fn)) c
                if length c' == length c - 1
                  then writeroot c'
                  else fail "obj doesn't exist in rmThing"

readhash :: String -> HashedIO r p PackedString
readhash h = do c <- gets cache
                z <- lift $ unsafeInterleaveIO $ readHashFile c "pristine.hashed" h
                let (_,out) = z
                return out

readTediousHash :: String -> String -> HashedIO r p PackedString
readTediousHash k h = do lift $ finishedOneIO k h
                         readhash h

gethashmtime :: String -> HashedIO r p EpochTime
gethashmtime h = do HashDir _ c _ _ <- get
                    lift $ unsafeInterleaveIO $ findFileMtimeUsingCache c "pristine.hashed" h

withh :: String -> HashedIO RW p a -> HashedIO RW p (String,a)
withh h j = do hd <- get
               put $ hd { rootHash = h }
               x <- j
               h' <- gets rootHash
               put hd
               return (h',x)

inh :: String -> HashedIO r p a -> HashedIO r p a
inh h j = do hd <- get
             put $ hd { rootHash = h }
             x <- j
             put hd
             return x

safeInterleave :: HashedIO RO p a -> HashedIO r p a
safeInterleave job = do HashDir _ c opts h <- get
                        z <- lift $ unsafeInterleaveIO $ runStateT job
                             (HashDir { permissions = RO, cache = c, options = opts, rootHash = h })
                        let (x,_) = z
                        return x

readroot :: HashedIO r p [(ObjType, FileName, String)]
readroot = do haveitalready <- peekroot
              cc <- gets rootHash >>= readdir
              when (not haveitalready) $ speculate cc
              return cc
    where speculate :: [(a,b,String)] -> HashedIO r q ()
          speculate c = do cac <- gets cache
                           mapM_ (\(_,_,z) -> lift $ speculateFileUsingCache cac "pristine.hashed" z) c
          peekroot :: HashedIO r p Bool
          peekroot = do HashDir _ c _ h <- get
                        lift $ peekInCache c "pristine.hashed" h

writeroot :: [(ObjType, FileName, String)] -> HashedIO r p ()
writeroot c = do h <- writedir c
                 modify $ \hd -> hd { rootHash = h }

data ObjType = F | D deriving Eq

geta :: ObjType -> FileName -> [(ObjType, FileName, String)] -> Maybe String
geta o f c = do (o',h) <- getany f c
                if o == o' then Just h else Nothing

getany :: FileName -> [(ObjType, FileName, String)] -> Maybe (ObjType,String)
getany _ [] = Nothing
getany f ((o,f',h):_) | f == f' = Just (o,h)
getany f (_:r) = getany f r

seta :: ObjType -> FileName -> String -> [(ObjType, FileName, String)] -> [(ObjType, FileName, String)]
seta o f h [] = [(o,f,h)]
seta o f h ((_,f',_):r) | f == f' = (o,f,h):r
seta o f h (x:xs) = x : seta o f h xs

readdir :: String -> HashedIO r p [(ObjType, FileName, String)]
readdir hash = (parsed . linesPS) `fmap` readhash hash
    where parsed (t:n:h:rest) | t == dir = (D, niceps2fn n, unpackPS h) : parsed rest
                              | t == file = (F, niceps2fn n, unpackPS h) : parsed rest
          parsed _ = []
dir :: PackedString
dir = packString "directory:"
file :: PackedString
file = packString "file:"


writedir :: [(ObjType, FileName, String)] -> HashedIO r p String
writedir c = writeHashFile cps
    where cps = unlinesPS $ concatMap (\ (o,d,h) -> [showO o,fn2niceps d,packString h]) c++[nilPS]
          showO D = dir
          showO F = file

writeHashFile :: PackedString -> HashedIO r p String
writeHashFile ps = do c <- gets cache
                      opts <- gets options
                      lift $ writeFileUsingCache c opts "pristine.hashed" ps

slurpHashed :: Cache -> [DarcsFlag] -> String -> IO Slurpy
slurpHashed c opts h = fst `fmap` runStateT slh
                                  (HashDir { permissions = RO, cache = c,
                                             options = opts, rootHash = h })

slh :: HashedIO r p Slurpy
slh = do c <- readroot
         hroot <- gets rootHash
         lift $ beginTedious k
         safeInterleave $ SlurpDir rootdir (Just hroot) `fmap` mapM sl c
    where sl (F,n,h) = do ps <- safeInterleave $ readTediousHash k h
                          t <- gethashmtime h
                          let len = if length h == 75 then read (take 10 h)
                                                      else undefined_size
                          return $ SlurpFile n (Just h, t, len) ps
          sl (D,n,h) = inh h $ do c <- readroot
                                  lift $ tediousSize k (length c)
                                  lift $ finishedOneIO k h
                                  SlurpDir n (Just h) `fmap` mapM sl c
          k = "Reading pristine"

rootdir :: FileName
rootdir = fp2fn "."

hashSlurped :: Cache -> [DarcsFlag] -> Slurpy -> IO String
hashSlurped c opts sl = do beginTedious k
                           h <- fst `fmap` runStateT (hsl sl)
                                        (HashDir { permissions = RW, cache = c,
                                                   options = opts, rootHash = sha1PS nilPS })
                           endTedious k
                           return h
    where hsl (SlurpDir _ (Just h) _) = return h
          hsl (SlurpDir _ Nothing ss) = do lift $ tediousSize k (length ss)
                                           mapM hs ss >>= writedir
          hsl (SlurpFile _ (Just h,_,_) _) = return h
          hsl (SlurpFile _ _ x) = writeHashFile x
          hs (SlurpDir d (Just h) _) = progress k $ return (D, d, h)
          hs s@(SlurpDir d Nothing _) = do h <- hsl s
                                           lift $ finishedOneIO k h
                                           return (D, d, h)
          hs (SlurpFile f (Just h,_,_) _) = progress k $ return (F, f, h)
          hs s@(SlurpFile f _ _) = do h <- hsl s
                                      lift $ finishedOneIO k h
                                      return (F, f, h)
          k = "Writing pristine"

grab :: FileName -> Slurpy -> Maybe Slurpy
grab _ (SlurpFile _ _ _) = Nothing
grab fn (SlurpDir _ _ ss) = g ss where g [] = Nothing
                                       g (s@(SlurpDir fn' _ _):_) | fn' == fn = Just s
                                       g (s@(SlurpFile fn' _ _):_) | fn' == fn = Just s
                                       g (_:x) = g x

syncHashed :: Cache -> Slurpy -> String -> IO ()
syncHashed c s r = do runStateT sh $ HashDir {permissions=RW, cache=c, options=[], rootHash=r}
                      return ()
    where sh = do cc <- readroot
                  lift $ tediousSize k (length cc)
                  mapM_ sh' cc
          sh' (D,n,h) = case progress k $ grab n s of
                        Just s' -> lift $ syncHashed c s' h
                        Nothing -> return ()
          sh' (F,n,h) = case progress k $ grab n s of
                        Just (SlurpFile _ (_,t',l) x) ->
                            do t <- lift $ findFileMtimeUsingCache c "pristine.hashed" h
                               when (t' /= undefined_time && t' /= t) $
                                    do ps <- readhash h
                                       when (lengthPS ps == fromIntegral l && ps == x) $
                                            lift $ setFileMtimeUsingCache c "pristine.hashed" h t'
                        _ -> return ()
          k = "Synchronizing pristine"

copyHashed :: String -> Cache -> [DarcsFlag] -> String -> IO ()
copyHashed k c opts z = do runStateT cph $ HashDir { permissions = RO, cache = c,
                                                     options = opts, rootHash = z }
                           return ()
    where cph = do cc <- readroot
                   lift $ tediousSize k (length cc)
                   mapM_ cp cc
          cp (F,n,h) = do ps <- readhash h
                          lift $ finishedOneIO k (fn2fp n)
                          lift $ writeAtomicFilePS (fn2fp n) ps
          cp (D,n,h) = do lift $ createDirectoryIfMissing False (fn2fp n)
                          lift $ finishedOneIO k (fn2fp n)
                          lift $ withCurrentDirectory (fn2fp n) $ copyHashed k c opts h

copyPartialsHashed :: Cache -> [DarcsFlag] -> String -> [FilePath] -> IO ()
copyPartialsHashed c opts root = mapM_ (copyPartialHashed c opts root)

copyPartialHashed :: Cache -> [DarcsFlag] -> String -> FilePath -> IO ()
copyPartialHashed c opts root ff =
    do createDirectoryIfMissing True (basename ff)
       runStateT (cp $ fp2fn ff) $ HashDir { permissions = RO, cache = c,
                                             options=opts, rootHash = root }
       return ()
 where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse
       cp f = do mt <- identifyThing f
                 case mt of
                   Just (D,h) -> do lift $ createDirectoryIfMissing True (fn2fp f)
                                    lift $ withCurrentDirectory (fn2fp f) $ copyHashed "" c opts h
                   Just (F,h) -> do ps <- readhash h
                                    lift $ writeAtomicFilePS (fn2fp f) ps
                   Nothing -> return ()

listHashedContents :: String -> Cache -> [DarcsFlag] -> String -> IO [String]
listHashedContents k c opts root =
    do beginTedious k
       tediousSize k 1
       x <- fst `fmap` runStateT (lhc (D,fp2fn ".",root)) (HashDir RO c opts root)
       endTedious k
       return x
    where lhc :: (ObjType, FileName, String) -> HashedIO r a [String]
          lhc (D,dname,d) = do xs <- inh d $ readroot
                               lift $ finishedOneIO k (fn2fp dname)
                               lift $ tediousSize k (length $ filter (\(x,_,_) -> x == D) xs)
                               hcxs <- mapM lhc xs
                               return (d:concat hcxs)
          lhc (F,_,h) = return [h]

\end{code}