HashedRepo.lhs

%  Copyright (C) 2006-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.
\chapter{Hashed inventory format}
\label{hashed_format}

The hashed inventory format is similar to the ``DarcsRepo'' format (see
Chapter~\ref{repository_format}), but I haven't gotten around to
documenting it.

\begin{code}
{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
#include "gadts.h"
module Darcs.Repository.HashedRepo ( revert_tentative_changes, finalize_tentative_changes,
                                     slurp_pristine, sync_repo, clean_pristine,
                                     copy_pristine, copy_partials_pristine, pristine_from_working,
                                     apply_to_tentative_pristine, replacePristine,
                                     add_to_tentative_inventory, remove_from_tentative_inventory,
                                     read_repo, write_and_read_patch,
                                     write_tentative_inventory, copy_repo, slurp_all_but_darcs
                                   ) where

import System.Directory ( getDirectoryContents, doesFileExist )
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO ( stderr, hPutStrLn )
import Data.List ( delete, (\\) )
import Control.Monad ( unless )

import Workaround ( renameFile, createDirectoryIfMissing )
import Darcs.Flags ( DarcsFlag )
import Darcs.Patch.Set ( PatchSet, SealedPatchSet )
import Darcs.FilePathUtils ( absolute_dir )
import Darcs.Repository.Prefs ( Cache, fetchFileUsingCache, speculateFileUsingCache, writeFileUsingCache,
                                unionCaches, cleanCaches, repo2cache, okayHash, takeHash )
import Darcs.Repository.HashedIO ( applyHashed, slurpHashed, hashSlurped, listHashedContents,
                                   copyHashed, syncHashed, copyPartialsHashed )
import Darcs.Repository.InternalTypes ( Repository(..), extractCache )
import Darcs.Hopefully ( PatchInfoAnd, patchInfoAndPatch, n2pia, info,
                         extractHash, createHashed )
import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, slurp_remove, slurp )
import Darcs.Patch ( RepoPatch, Patchy, Named, showPatch, patch2patchinfo, readPatch )
import Darcs.Patch.Depends ( commute_to_end, slightly_optimize_patchset )
import Darcs.Patch.Info ( PatchInfo, showPatchInfo, human_friendly, readPatchInfo )
import Darcs.Patch.Ordered ( unsafeCoerceP, (:<)(..) )
import FileName ( fp2fn )
import FastPackedString ( PackedString, nilPS, nullPS, readFilePS,
                          gzReadFilePS, takePS, dropPS, dropWhilePS,
                          tailPS, lengthPS,
                          packString, breakOnPS, unpackPS, dropWhitePS )
import Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text, invisiblePS )
import SHA1 ( sha1PS )
import Darcs.External ( copyFileOrUrl, cloneFile, fetchFilePS, Cachable( Uncachable ) )
import Darcs.Lock ( writeBinFile, writeDocBinFile, writeAtomicFilePS, appendBinFile, appendDocBinFile,
                    removeFileMayNotExist )
import Darcs.Utils ( withCurrentDirectory )
import Darcs.Progress ( beginTedious, tediousSize, endTedious, debugMessage, finishedOneIO )
#include "impossible.h"
import Darcs.Patch.Ordered ( FL(..), RL(..),
                             mapRL, mapFL, lengthRL )
import Darcs.Sealed ( Sealed(..), seal, unseal )
import Darcs.Global ( darcsdir )

revert_tentative_changes :: IO ()
revert_tentative_changes =
    do cloneFile (darcsdir++"/hashed_inventory") (darcsdir++"/tentative_hashed_inventory")
       i <- gzReadFilePS (darcsdir++"/hashed_inventory")
       writeBinFile (darcsdir++"/tentative_pristine") $ "pristine:" ++ inv2pris i

finalize_tentative_changes :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO ()
finalize_tentative_changes r opts =
    do let t = darcsdir++"/tentative_hashed_inventory"
       -- first let's optimize it...
       debugMessage "Optimizing the inventory..."
       ps <- read_tentative_repo r opts "."
       write_tentative_inventory (extractCache r) opts ps
       -- then we'll add in the pristine cache,
       i <- gzReadFilePS t
       p <- gzReadFilePS $ darcsdir++"/tentative_pristine"
       writeDocBinFile t $ pris2inv (inv2pris p) i
       -- and rename it to its final value
       renameFile t $ darcsdir++"/hashed_inventory"
       -- note: in general we can't clean the pristine cache, because a
       -- simultaneous get might be in progress

clean_pristine :: Repository p C(r u t) -> IO ()
clean_pristine r@(Repo d opts _ _) = withCurrentDirectory d $
   do -- we'll remove obsolete bits of our pristine cache
      debugMessage "Cleaning out the pristine cache..."
      i <- gzReadFilePS (darcsdir++"/hashed_inventory")
      hs <- listHashedContents "Cleaning pristine cache" (extractCache r) opts $ inv2pris i
      let hashdir = darcsdir++"/pristine.hashed/"
      fs <- filter okayHash `fmap` getDirectoryContents hashdir
      mapM_ (removeFileMayNotExist . (hashdir++)) (fs \\ hs)
      -- and also clean out any global caches.
      debugMessage "Cleaning out any global caches..."
      cleanCaches (extractCache r) "pristine.hashed"

add_to_tentative_inventory :: RepoPatch p => Cache -> [DarcsFlag] -> PatchInfoAnd p C(x y) -> IO FilePath
add_to_tentative_inventory c opts p =
    do hash <- snd `fmap` write_patch_if_necesary c opts p
       appendDocBinFile (darcsdir++"/tentative_hashed_inventory") $ showPatchInfo $ info p
       appendBinFile (darcsdir++"/tentative_hashed_inventory") $ "\nhash: " ++ hash ++ "\n"
       return $ darcsdir++"/patches/" ++ hash

remove_from_tentative_inventory :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag]
                                -> FL (Named p) C(x t) -> IO ()
remove_from_tentative_inventory repo opts to_remove =
       -- FIXME: This algorithm should be *far* simpler.  All we need do is
       -- to to remove the patches from a patchset and then write that
       -- patchset.  The commutation behavior of PatchInfoAnd should track
       -- which patches need to be rewritten for us.
    do allpatches <- read_tentative_repo repo opts "."
       skipped :< _ <- return $ commute_to_end to_remove allpatches
       okay <- simple_remove_from_tentative_inventory repo opts
               (mapFL patch2patchinfo to_remove ++ mapFL patch2patchinfo skipped)
       unless okay $ bug "bug in HashedRepo.remove_from_tentative_inventory"
       sequence_ $ mapFL (add_to_tentative_inventory (extractCache repo) opts . n2pia) skipped

simple_remove_from_tentative_inventory :: forall p C(r u t). RepoPatch p =>
                                          Repository p C(r u t) -> [DarcsFlag] -> [PatchInfo] -> IO Bool
simple_remove_from_tentative_inventory repo opts pis = do
    inv <- read_tentative_repo repo opts "."
    case cut_inv pis inv of
      Nothing -> return False
      Just (Sealed inv') -> do write_tentative_inventory (extractCache repo) opts inv'
                               return True
    where cut_inv :: [PatchInfo] -> PatchSet p C(x) -> Maybe (SealedPatchSet p)
          cut_inv [] x = Just $ seal x
          cut_inv x (NilRL:<:rs) = cut_inv x rs
          cut_inv xs ((hp:<:r):<:rs) | info hp `elem` xs = cut_inv (info hp `delete` xs) (r:<:rs)
          cut_inv _ _ = Nothing

writeHashFile :: Cache -> [DarcsFlag] -> String -> Doc -> IO String
writeHashFile c opts subdir d = do debugMessage $ "Writing hash file to "++subdir
                                   writeFileUsingCache c opts subdir $ renderPS d

read_repo :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> String -> IO (PatchSet p C(r))
read_repo repo opts d = do
  realdir <- absolute_dir d
  Sealed ps <- read_repo_private repo opts realdir "hashed_inventory" `catch`
                 (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)
                           ioError e)
  return $ unsafeCoerceP ps

read_tentative_repo :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> String -> IO (PatchSet p C(t))
read_tentative_repo repo opts d = do
  realdir <- absolute_dir d
  Sealed ps <- read_repo_private repo opts realdir "tentative_hashed_inventory" `catch`
                 (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)
                           ioError e)
  return $ unsafeCoerceP ps

read_repo_private :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag]
                  -> FilePath -> FilePath -> IO (SealedPatchSet p)
read_repo_private repo opts d iname =
 do inventories <- read_inventory_private repo opts (d++"/"++darcsdir) iname
    parseinvs inventories
    where read_patches :: RepoPatch p => [(PatchInfo, String)] -> IO (Sealed (RL (PatchInfoAnd p) C(x)))
          read_patches [] = return $ seal NilRL
          read_patches allis@((i1,h1):is1) =
              lift2Sealed (\p rest -> i1 `patchInfoAndPatch` p :<: rest)
                          (rp is1)
                          (createHashed h1 (const $ speculate h1 allis >> parse i1 h1))
              where rp :: RepoPatch p => [(PatchInfo, String)] -> IO (Sealed (RL (PatchInfoAnd p) C(x)))
                    rp [] = return $ seal NilRL
                    rp [(i,h),(il,hl)] =
                        lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)
                                    (rp [(il,hl)])
                                    (createHashed h (const $ speculate h (reverse allis) >> parse i h))
                    rp ((i,h):is) = lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)
                                                (rp is)
                                                (createHashed h (parse i))
          speculate :: String -> [(PatchInfo, String)] -> IO ()
          speculate h is = do already_got_one <- doesFileExist (d++"/"++darcsdir++"/patches/"++h)
                              unless already_got_one $
                                     mapM_ (speculateFileUsingCache (extractCache repo) "patches" . snd) is
          parse :: Patchy p => PatchInfo -> String -> IO (Sealed (p C(x)))
          parse i h = do debugMessage ("Reading patch file: "++ show (human_friendly i))
                         (fn,ps) <- fetchFileUsingCache (extractCache repo) "patches" h
                         case readPatch ps of
                           Just (p,_) -> return p
                           Nothing -> fail $ unlines ["Couldn't parse file "++fn,
                                                      "which is patch",
                                                      renderString $ human_friendly i]
          parseinvs :: RepoPatch p => [[(PatchInfo, String)]] -> IO (SealedPatchSet p)
          parseinvs [] = return $ seal NilRL
          parseinvs (i:is) = lift2Sealed (:<:) (parseinvs is) (read_patches i)
          lift2Sealed :: (FORALL(y z) q C(y z) -> p C(x y) -> r C(x z))
                      -> IO (Sealed (p C(x))) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed (r C(x)))
          lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap` unsafeInterleaveIO iox
                                     Sealed y <- unseal seal `fmap` unsafeInterleaveIO ioy
                                     return $ seal $ f y x

write_and_read_patch :: RepoPatch p => Cache -> [DarcsFlag] -> PatchInfoAnd p C(x y)
                     -> IO (PatchInfoAnd p C(x y))
write_and_read_patch c opts p = do (i,h) <- write_patch_if_necesary c opts p
                                   Sealed x <- createHashed h (parse i)
                                   return $ patchInfoAndPatch i $ unsafeCoerceP x
    where parse i h = do debugMessage ("Reading patch file: "++ show (human_friendly i))
                         (fn,ps) <- fetchFileUsingCache c "patches" h
                         case readPatch ps of
                           Just (x,_) -> return x
                           Nothing -> fail $ unlines ["Couldn't parse patch file "++fn,
                                                      "which is",
                                                      renderString $ human_friendly i]

write_tentative_inventory :: RepoPatch p => Cache -> [DarcsFlag] -> PatchSet p C(x) -> IO ()
write_tentative_inventory c opts = write_either_inventory c opts "tentative_hashed_inventory"

copy_repo :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> String -> IO ()
copy_repo repo@(Repo outr _ _ _) opts inr = do
    createDirectoryIfMissing False (outr++"/"++darcsdir++"/inventories")
    copyFileOrUrl opts (inr++"/"++darcsdir++"/hashed_inventory") (outr++"/"++darcsdir++"/hashed_inventory")
                  Uncachable -- no need to copy anything but hashed_inventory!
    appendBinFile (outr++"/"++darcsdir++"/prefs/sources") (show $ repo2cache inr `unionCaches` extractCache repo)
    debugMessage "Done copying hashed inventory."

write_either_inventory :: RepoPatch p => Cache -> [DarcsFlag] -> String -> PatchSet p C(x) -> IO ()
write_either_inventory c opts iname x =
    do createDirectoryIfMissing False $ darcsdir++"/inventories"
       let k = "Writing inventory"
       beginTedious k
       tediousSize k (lengthRL x)
       hsh <- write_inventory_private k c opts $ slightly_optimize_patchset x
       endTedious k
       case hsh of
         Nothing -> writeBinFile (darcsdir++"/"++iname) ""
         Just h -> gzReadFilePS (darcsdir++"/inventories/"++h) >>= writeAtomicFilePS (darcsdir++"/"++iname)

write_inventory_private :: RepoPatch p => String -> Cache -> [DarcsFlag]
                        -> PatchSet p C(x) -> IO (Maybe String)
write_inventory_private _ _ _ NilRL = return Nothing
write_inventory_private _ _ _ (NilRL:<:NilRL) = return Nothing
write_inventory_private _ _ _ (NilRL:<:_) = -- This shouldn't be possible, so best to check...
    bug "malformed PatchSet in HashedRepo.write_inventory_private"
write_inventory_private k c opts (x:<:xs) =
  do resthash <- write_inventory_private k c opts xs
     finishedOneIO k (case resthash of Nothing -> ""; Just h -> h)
     inventory <- sequence $ mapRL (write_patch_if_necesary c opts) x
     let inventorylist = hcat (map pihash $ reverse inventory)
         inventorycontents = case resthash of
                             Just lasthash -> text ("Starting with inventory:\n"++lasthash) $$
                                              inventorylist
                             _ -> inventorylist
     hash <- writeHashFile c opts "inventories" inventorycontents
     return $ Just hash

write_patch_if_necesary :: RepoPatch p => Cache -> [DarcsFlag]
                        -> PatchInfoAnd p C(x y) -> IO (PatchInfo, String)
write_patch_if_necesary c opts hp =
    case extractHash hp of
    Right h -> return (info hp, h)
    Left p -> fmap (\h -> (info hp, h)) $ writeHashFile c opts "patches" $ showPatch p

pihash :: (PatchInfo,String) -> Doc
pihash (pinf,hash) = showPatchInfo pinf $$ text ("hash: " ++ hash ++ "\n")

read_inventory_private :: Repository p C(r u t) -> [DarcsFlag] -> String -> String
                       -> IO [[(PatchInfo, String)]]
read_inventory_private repo opts d iname = do
    i <- skip_pristine `fmap` fetchFilePS (d++"/"++iname) Uncachable
    (rest,str) <- case breakOnPS '\n' i of
                  (swt,pistr) | swt == packString "Starting with inventory:" ->
                    case breakOnPS '\n' $ tailPS pistr of
                    (h,thisinv) | okayHash $ unpackPS h ->
                      do r <- unsafeInterleaveIO $ read_inventories
                              (extractCache repo) opts (unpackPS h)
                         return (r,thisinv)
                    _ -> fail $ "Bad hash in " ++ d ++ "/"++darcsdir++"/" ++ iname
                  _ -> return ([],i)
    return $ reverse (read_patch_ids str) : rest

read_inventories :: Cache -> [DarcsFlag] -> String -> IO [[(PatchInfo, String)]]
read_inventories cache opts ihash = do
    (fn,i_and_p) <- fetchFileUsingCache cache "inventories" ihash
    let i = skip_pristine i_and_p
    (rest,str) <- case breakOnPS '\n' i of
                  (swt,pistr) | swt == packString "Starting with inventory:" ->
                    case breakOnPS '\n' $ tailPS pistr of
                    (h,thisinv) | okayHash $ unpackPS h ->
                      do r <- unsafeInterleaveIO $
                              read_inventories cache opts (unpackPS h)
                         return (r,thisinv)
                    _ -> fail $ "Bad hash in file " ++ fn
                  _ -> return ([],i)
    return $ reverse (read_patch_ids str) : rest

read_patch_ids :: PackedString -> [(PatchInfo, String)]
read_patch_ids inv | nullPS inv = []
read_patch_ids inv = case readPatchInfo inv of
                     Nothing -> []
                     Just (pinfo,r) ->
                         case readHash r of
                         Nothing -> []
                         Just (h,r') -> (pinfo,h) : read_patch_ids r'

readHash :: PackedString -> Maybe (String, PackedString)
readHash s = let s' = dropWhitePS s
                 (l,r) = breakOnPS '\n' s'
                 (kw,h) = breakOnPS ' ' l
             in if kw /= packString "hash:" || lengthPS h <= 1
                then Nothing
                else Just (unpackPS $ tailPS h,r)

apply_pristine :: Patchy q => Cache -> [DarcsFlag] -> String -> String -> q C(() ()) -> IO ()
apply_pristine c opts d iname p =
    do i <- gzReadFilePS (d++"/"++iname)
       h <- applyHashed c opts (inv2pris i) p
       writeDocBinFile (d++"/"++iname) $ pris2inv h i

apply_to_tentative_pristine :: Patchy q => Cache -> [DarcsFlag] -> q C(() ()) -> IO ()
apply_to_tentative_pristine c opts p = apply_pristine c opts "." (darcsdir++"/tentative_pristine") p

slurp_pristine :: Cache -> [DarcsFlag] -> String -> String -> IO Slurpy
slurp_pristine c opts d iname = do
    i <- fetchFilePS (d++"/"++iname) Uncachable
    slurp_pristine_private c opts i

slurp_pristine_private :: Cache -> [DarcsFlag] -> PackedString -> IO Slurpy
slurp_pristine_private c opts inv = case inv2pris inv of
                                    h | h == sha1PS nilPS -> return empty_slurpy
                                      | otherwise -> slurpHashed c opts h

pristine_from_working :: Cache -> [DarcsFlag] -> IO ()
pristine_from_working c opts = replacePristine c opts "."

replacePristine :: Cache -> [DarcsFlag] -> FilePath -> IO ()
replacePristine c opts d = do s <- slurp_all_but_darcs d
                              h <- hashSlurped c opts s
                              let t = darcsdir++"/hashed_inventory"
                              i <- gzReadFilePS t
                              writeDocBinFile t $ pris2inv h i

copy_pristine :: Cache -> [DarcsFlag] -> String -> String -> IO ()
copy_pristine c opts d iname = do
    i <- fetchFilePS (d++"/"++iname) Uncachable
    debugMessage $ "Copying hashed pristine tree: "++inv2pris i
    let k = "Copying pristine"
    beginTedious k
    copyHashed k c opts $ inv2pris i
    endTedious k

sync_repo :: Cache -> IO ()
sync_repo c = do i <- readFilePS $ darcsdir++"/hashed_inventory"
                 s <- slurp_all_but_darcs "."
                 beginTedious "Synchronizing pristine"
                 syncHashed c s $ inv2pris i
                 

copy_partials_pristine :: Cache -> [DarcsFlag] -> String -> String -> [FilePath] -> IO ()
copy_partials_pristine c opts d iname fps =
  do i <- fetchFilePS (d++"/"++iname) Uncachable
     copyPartialsHashed c opts (inv2pris i) fps

inv2pris :: PackedString -> String
inv2pris inv | takePS pristine_name_length inv == pristine_name =
                 case takeHash $ dropPS pristine_name_length inv of
                 Just (h,_) -> h
                 Nothing -> error "Bad hash in inventory!"
             | otherwise = sha1PS nilPS

pris2inv :: String -> PackedString -> Doc
pris2inv h inv = invisiblePS pristine_name <> text h $$ invisiblePS (skip_pristine inv)

pristine_name :: PackedString
pristine_name = packString "pristine:"

skip_pristine :: PackedString -> PackedString
skip_pristine ps
    | takePS pristine_name_length ps == pristine_name = dropPS 1 $ dropWhilePS (/= '\n') $
                                                        dropPS pristine_name_length ps
    | otherwise = ps

pristine_name_length :: Int
pristine_name_length = lengthPS pristine_name

slurp_all_but_darcs :: FilePath -> IO Slurpy
slurp_all_but_darcs d = do s <- slurp d
                           case slurp_remove (fp2fn $ "./"++darcsdir) s of
                             Nothing -> return s
                             Just s' -> return s'

\end{code}