module Storage.Hashed
    ( -- * Obtaining Trees.
    --
    -- | Please note that Trees obtained this way will contain Stub
    -- items. These need to be executed (they are IO actions) in order to be
    -- accessed. Use 'expand' to do this. However, many operations are
    -- perfectly fine to be used on a stubbed Tree (and it is often more
    -- efficient to do everything that can be done before expanding a Tree).
    readPlainTree, readDarcsHashed, readDarcsPristine

    -- * Blob access.
    , read, readSegment

    -- * Writing trees.
    , writePlainTree

    -- * Unsafe functions for the curious explorer.
    --
    -- | These are more useful for playing within ghci than for real, serious
    -- programs. They generally trade safety for conciseness. Please use
    -- responsibly. Don't kill innocent kittens.
    , floatPath, printPath ) where

import Prelude hiding ( catch, read, lines )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import Storage.Hashed.AnchoredPath
import Storage.Hashed.Utils
import Storage.Hashed.Darcs
import Storage.Hashed.Tree( Tree( listImmediate ), TreeItem(..), ItemType(..)
                          , Blob(..), emptyTree, makeTree, makeTreeWithHash
                          , list, read, find )
import System.FilePath( (</>), splitDirectories, normalise
                      , dropTrailingPathSeparator )
import System.Directory( getDirectoryContents, doesFileExist
                       , doesDirectoryExist, createDirectoryIfMissing )
import Codec.Compression.GZip( decompress )
import Control.Monad( forM_, unless )
import Bundled.Posix( getFileStatus, isDirectory, FileStatus )

------------------------
-- For explorers
--

-- | Take a relative FilePath and turn it into an AnchoredPath. The operation
-- is unsafe and if you break it, you keep both pieces. More useful for
-- exploratory purposes (ghci) than for serious programming.
floatPath :: FilePath -> AnchoredPath
floatPath = AnchoredPath . map (Name . BS.pack)
              . splitDirectories
              . normalise . dropTrailingPathSeparator

-- | Take a relative FilePath within a Tree and print the contents of the
-- object there. Useful for exploration, less so for serious programming.
printPath :: Tree -> FilePath -> IO ()
printPath t p = print' $ find t (floatPath p)
    where print' Nothing = putStrLn $ "ERROR: No object at " ++ p
          print' (Just (File b)) = do
            putStrLn $ "== Contents of file " ++ p ++ ":"
            BL.unpack `fmap` read b >>= putStr
          print' (Just (SubTree t')) = do
            putStrLn $ "== Listing Tree " ++ p ++ " (immediates only):"
            putStr $ unlines $ map BS.unpack $ listNames t'
          print' (Just (Stub _ _)) =
            putStrLn $ "== (not listing stub at " ++ p ++ ")"
          listNames t' = [ n | (Name n, _) <- listImmediate t' ]

readPlainDir :: FilePath -> IO [(FilePath, FileStatus)]
readPlainDir dir =
    withCurrentDirectory dir $ do
      items <- getDirectoryContents "."
      sequence [ do st <- getFileStatus s
                    return (s, st)
                 | s <- items, not $ s `elem` [ ".", ".." ] ]

-- | Read in a plain directory hierarchy from a filesystem. NB. The 'read'
-- function on Blobs with such a Tree is susceptible to file content
-- changes. Since we use mmap in 'read', this will break referential
-- transparency and produce unexpected results. Please always make sure that
-- all parallel access to the underlying filesystem tree never mutates
-- files. Unlink + recreate is fine though (in other words, the sync/write
-- operations below are safe).
readPlainTree :: FilePath -> IO Tree
readPlainTree dir = do
  items <- readPlainDir dir
  let subs = [
       let name = nameFromFilePath name'
        in if isDirectory status
              then (name,
                    Stub (readPlainTree (dir </> name')) Nothing)
              else (name, File $
                    Blob (readBlob name) Nothing)
            | (name', status) <- items ]
  return $ makeTree subs
    where readBlob (Name name) = readSegment (dir </> BS.unpack name, Nothing)

-- | Read and parse a darcs-style hashed directory listing from a given @dir@
-- and with a given @hash@.
readDarcsHashedDir :: FilePath -> Hash -> IO [(ItemType, Name, Hash)]
readDarcsHashedDir dir h = do
  compressed <- BL.readFile (dir </> BS.unpack (darcsFormatHash h))
  let content = decompress compressed
      lines = BL.split '\n' content
  return $ if BL.null compressed
              then []
              else parse lines
    where
      parse (t:n:h':r) = (parse' t,
                          Name $ BS.pack $ darcsDecodeWhite (BL.unpack n),
                          makeHash hash) : parse r
          where hash = BS.concat $ BL.toChunks h'
      parse _ = []
      parse' x
          | x == BL.pack "file:" = BlobType
          | x == BL.pack "directory:" = TreeType
          | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL.unpack x

-- | Read in a darcs-style hashed tree. This is mainly useful for reading
-- \"pristine.hashed\". You need to provide the root hash you are interested in
-- (found in _darcs/hashed_inventory).
readDarcsHashed :: FilePath -> Hash -> IO Tree
readDarcsHashed dir root = do
  items <- readDarcsHashedDir dir root
  subs <- sequence [
           case tp of
             BlobType -> return (d, File $
                                      Blob (readBlob h) (Just h))
             TreeType ->
                 do let t = readDarcsHashed dir h
                    return (d, Stub t (Just h))
           | (tp, d, h) <- items ]
  return $ makeTreeWithHash subs root
    where location h = (dir </> BS.unpack (darcsFormatHash h), Nothing)
          readBlob = fmap decompress . readSegment . location

-- | Read in a darcs pristine tree. Handles the plain and hashed pristine
-- cases. Does not (and will not) handle the no-pristine case, since that
-- requires replaying patches. Cf. 'readDarcsHashed' and 'readPlainTree' that
-- are used to do the actual 'Tree' construction.
readDarcsPristine :: FilePath -> IO Tree
readDarcsPristine dir = do
  let darcs = dir </> "_darcs"
      h_inventory = darcs </> "hashed_inventory"
  repo <- doesDirectoryExist darcs
  unless repo $ fail $ "Not a darcs repository: " ++ dir
  hashed <- doesFileExist h_inventory
  if hashed
     then do inv <- BS.readFile h_inventory
             let lines = BS.split '\n' inv
             case lines of
               [] -> return emptyTree
               (pris_line:_) ->
                   let hash = makeHash $ BS.drop 9 pris_line
                    in readDarcsHashed (darcs </> "pristine.hashed") hash
     else readPlainTree $ darcs </> "pristine"

-- | Write out *full* tree to a plain directory structure. If you instead want
-- to make incremental updates, refer to "Monad.plainTreeIO".
writePlainTree :: Tree -> FilePath -> IO ()
writePlainTree t dir = do
  createDirectoryIfMissing True dir
  forM_ (list t) write
    where write (p, File b) = write' p b
          write (p, SubTree _) =
              createDirectoryIfMissing True (anchorPath dir p)
          write _ = return ()
          write' p b = read b >>= BL.writeFile (anchorPath dir p)