%  Copyright (C) 2006 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}
module Darcs.Repository.HashedRepo ( revert_tentative_changes, finalize_tentative_changes,
                    add_to_tentative_inventory, remove_from_tentative_inventory,
                    read_repo, read_repo_lazily,
                    write_inventory, copy_repo,
                    writeHashFile, readHashFile
                  ) where

import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO ( stderr, hPutStrLn )
import Data.List ( delete )
import Control.Monad ( unless, when )

import Workaround ( renameFile, getCurrentDirectory, createDirectoryIfMissing )
import Darcs.Flags ( DarcsFlag( Lazy, Ephemeral, VerifyHash ) )
import Darcs.Patch.Set ( PatchSet )
import Darcs.Repository.DarcsRepo ( absolute_dir )
import Darcs.Repository.Prefs ( Cache, fetchFileUsingCache, unionCaches, repo2cache )
import Darcs.Hopefully ( Hopefully, actuallyHashed, extractHash, hopefully, unavailable )
import Darcs.Patch ( Patch, showPatch, patch2patchinfo, readPatch,
                     readPatchLazily )
import Darcs.Patch.Depends ( commute_to_end, slightly_optimize_patchset )
import Darcs.Patch.Info ( PatchInfo, showPatchInfo, readPatchInfo )
import FastPackedString ( PackedString, readFilePS, writeFilePS, nullPS,
                          tailPS, lengthPS,
                          packString, breakOnPS, unpackPS, dropWhitePS )
import Printer ( Doc, hcat, ($$), text )
import SHA1 ( sha1PS )
import Darcs.External ( copyLocal, copyFileOrUrl,
                        fetchFilePS, Cachable( Uncachable ) )
import Darcs.Lock ( writeBinFile, withTemp, writeDocBinFile, appendBinFile, appendDocBinFile )
import Darcs.Utils ( withCurrentDirectory )
#include "impossible.h"

revert_tentative_changes :: IO ()
revert_tentative_changes =
    do readFilePS "_darcs/hashed_inventory" >>= writeFilePS "_darcs/tentative_hashed_inventory"
       writeBinFile "_darcs/tentative_pristine" ""

finalize_tentative_changes :: IO ()
finalize_tentative_changes = renameFile "_darcs/tentative_hashed_inventory" "_darcs/hashed_inventory"

add_to_tentative_inventory :: [DarcsFlag] -> Patch -> IO FilePath
add_to_tentative_inventory _ p =
    do hash <- withCurrentDirectory "_darcs/patches" $ writeHashFile $ showPatch p
       let pinf = fromJust $ patch2patchinfo p
       appendDocBinFile ("_darcs/tentative_hashed_inventory") $ showPatchInfo pinf
       appendBinFile ("_darcs/tentative_hashed_inventory") $ "\nhash: " ++ hash ++ "\n"
       return $ "_darcs/patches/" ++ hash

remove_from_tentative_inventory :: Cache -> [DarcsFlag] -> [Patch] -> IO ()
remove_from_tentative_inventory cache opts to_remove =
    do allpatches <- read_tentative_repo cache opts "."
       let (_, skipped) = commute_to_end to_remove allpatches
       okay <- simple_remove_from_tentative_inventory cache opts
               (map (fromJust . patch2patchinfo) $ to_remove ++ skipped)
       unless okay $ bug "bug in remove_from_tentative_inventory"
       add_to_tentative_inventory opts `mapM_` skipped

simple_remove_from_tentative_inventory :: Cache -> [DarcsFlag] -> [PatchInfo] -> IO Bool
simple_remove_from_tentative_inventory cache opts pis = do
    inv <- read_tentative_repo cache opts "."
    case cut_inv pis inv of
      Nothing -> return False
      Just inv' -> do write_tentative_inventory inv'
                      return True
    where cut_inv [] x = Just x
          cut_inv x ([]:rs) = cut_inv x rs
          cut_inv xs (((pinf,_):r):rs) | pinf `elem` xs = cut_inv (pinf `delete` xs) (r:rs)
          cut_inv _ _ = Nothing

writeHashFile :: Doc -> IO String
writeHashFile d = withTemp $ \f -> do writeDocBinFile f d
                                      hash <- sha1PS `fmap` readFilePS f
                                      renameFile f hash
                                      return hash

readHashFile :: Cache -> [DarcsFlag] -> String -> String -> IO (String,PackedString)
readHashFile cache opts subdir hash =
    do (fn,hf) <- fetchFileUsingCache cache subdir hash
       when (VerifyHash `elem` opts && sha1PS hf /= hash) $
            fail $ "Hash failed hash:  "++ fn
       return (fn,hf)

read_repo :: Cache -> [DarcsFlag] -> String -> IO PatchSet
read_repo cache opts d = do
  realdir <- absolute_dir d
  read_repo_private cache opts False realdir "hashed_inventory" `catch`
              (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)
                        ioError e)

read_tentative_repo :: Cache -> [DarcsFlag] -> String -> IO PatchSet
read_tentative_repo cache opts d = do
  realdir <- absolute_dir d
  read_repo_private cache opts False realdir "tentative_hashed_inventory" `catch`
              (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)
                        ioError e)

read_repo_lazily :: Cache -> [DarcsFlag] -> String -> IO PatchSet
read_repo_lazily cache opts d = do
  realdir <- absolute_dir d
  read_repo_private cache opts True realdir "hashed_inventory" `catch`
              (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)
                        ioError e)

read_repo_private :: Cache -> [DarcsFlag] -> Bool -> FilePath -> FilePath -> IO PatchSet
read_repo_private cache opts am_lazy d iname =
 do inventories <- read_inventory_private cache opts (d++"/_darcs") iname
    let parse (_,h) = do (fn,ps) <- readHashFile cache opts "_darcs/patches" h
                         return $
                            if am_lazy
                            then actuallyHashed h $ fst $ readPatchLazily ps
                            else hopefullyNoParseError h fn $
                                 fst `fmap` readPatch ps
    read_patches parse `mapM` inventories
    where hopefullyNoParseError :: String -> String -> Maybe Patch -> Hopefully Patch
          hopefullyNoParseError h _ (Just x) = actuallyHashed h x
          hopefullyNoParseError _ s Nothing = unavailable $ "Couldn't parse file "++s
          read_patches :: ((PatchInfo,String) -> IO (Hopefully Patch))
                       -> [(PatchInfo,String)] -> IO [(PatchInfo, Hopefully Patch)]
          read_patches _ [] = return []
          read_patches parse ((i,h):is) = do
              mp <- unsafeInterleaveIO $ parse (i,h) `catch`
                    \e -> return $ unavailable $ show e
              rest <- read_patches parse is
              return $ (i,mp) : rest

write_tentative_inventory :: PatchSet -> IO ()
write_tentative_inventory = write_either_inventory "tentative_hashed_inventory"

write_inventory :: PatchSet -> IO ()
write_inventory = write_either_inventory "hashed_inventory"

copy_repo :: Cache -> [DarcsFlag] -> String -> String -> IO ()
copy_repo cache opts inr outr = do
    createDirectoryIfMissing False (outr++"/_darcs/inventories")
    copyFileOrUrl (inr++"/_darcs/hashed_inventory") (outr++"/_darcs/hashed_inventory")
                  Uncachable -- no need to copy anything but hashed_inventory!
    if Lazy `elem` opts || Ephemeral `elem` opts
      then appendBinFile (outr++"/_darcs/prefs/sources") (show $ repo2cache inr `unionCaches` cache)
      else do ps <- read_repo_lazily cache opts outr
              -- The following touches all the patches, to ensure that they've been
              -- copied over strictly.  :(
              mapM_ (\x -> seq (hopefully x) $ return ()) $ concat ps

write_either_inventory :: String -> PatchSet -> IO ()
write_either_inventory iname x =
    do createDirectoryIfMissing False "_darcs/inventories"
       hsh <- write_inventory_private $ slightly_optimize_patchset x
       case hsh of
         Nothing -> writeBinFile ("_darcs/"++iname) ""
         Just h -> copyLocal ("_darcs/inventories/"++h) ("_darcs/"++iname)

write_inventory_private :: PatchSet -> IO (Maybe String)
write_inventory_private [] = return Nothing
write_inventory_private [[]] = return Nothing
write_inventory_private ([]:_) = -- This shouldn't be possible, so best to check...
    bug "malformed PatchSet in HashedRepo.write_inventory_private"
write_inventory_private (x:xs) =
  do resthash <- write_inventory_private xs
     cd <- getCurrentDirectory
     let pdir = cd ++ "/_darcs/patches/"
         idir = cd ++ "/_darcs/inventories/"
         write_patch_if_necesary (pinf, hp) =
             case extractHash hp of
             Right h -> return (pinf, h)
             Left p -> fmap (\h -> (pinf,h)) $
                       withCurrentDirectory pdir $ writeHashFile $ showPatch p
     inventory <- write_patch_if_necesary `mapM` x
     let inventorylist = hcat (map pihash $ reverse inventory)
         inventorycontents = case resthash of
                             Just lasthash -> text ("Starting with inventory:\n"++lasthash) $$
                                              inventorylist
                             _ -> inventorylist
     hash <- withCurrentDirectory idir $ writeHashFile inventorycontents
     return $ Just hash

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

read_inventory_private :: Cache -> [DarcsFlag] -> String -> String
                       -> IO [[(PatchInfo, String)]]
read_inventory_private cache opts d iname = do
    i <- 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) | lengthPS h == 40 ->
                      do r <- unsafeInterleaveIO $ read_inventories
                              cache opts (unpackPS h)
                         return (r,thisinv)
                    _ -> fail $ "Bad hash in " ++ d ++ "/_darcs/" ++ iname
                  _ -> return ([],i)
    pis <- return $ reverse $ read_patch_ids str
    return $ pis : rest

read_inventories :: Cache -> [DarcsFlag] -> String -> IO [[(PatchInfo, String)]]
read_inventories cache opts ihash = do
    (fn,i) <- readHashFile cache opts "_darcs/inventories" ihash
    (rest,str) <- case breakOnPS '\n' i of
                  (swt,pistr) | swt == packString "Starting with inventory:" ->
                    case breakOnPS '\n' $ tailPS pistr of
                    (h,thisinv) | lengthPS h == 40 ->
                      do r <- unsafeInterleaveIO $
                              read_inventories cache opts (unpackPS h)
                         return (r,thisinv)
                    _ -> fail $ "Bad hash in file " ++ fn
                  _ -> return ([],i)
    pis <- return $ reverse $ read_patch_ids str
    return $ pis : 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)

{-
read_patch_ids :: (Stringalike s, ParserM m, Monad (m s)) => Bool -> m s [(PatchInfo, PackedString)]
read_patch_ids
          = do mn <- maybe_work readPatchInfo
               case mn of
                   Nothing -> return []
                   Just n ->
                       do d <- read_depends
                          Just p <- readPatch' want_eof
                          return $ NamedP n d p
-}
\end{code}
