{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, MultiParamTypeClasses,
             TypeSynonymInstances, ViewPatterns, FlexibleInstances #-}
module Repository ( gorsvetRO, gorsvetRW, readRepository, initRepository, manifest, demanifest
                  , gsdir, objdir, formatObj ) where

import Prelude hiding ( catch )
import Control.Applicative( (<$>) )
import Control.Monad( forM, when, forM_ )
import Control.Monad.CatchIO( catch )
import Control.Exception ( SomeException )
import Control.Monad.Trans ( liftIO )
import Control.Monad.IO.Class ( MonadIO )
import Control.Monad.State ( gets, evalStateT, modify )
import Data.Patch.ObjectMap
import Data.Patch.EncodeWhite
import Data.Maybe ( fromJust )
import Data.List ( sort )
import Data.Path ( (</>), (+/+), relative, AbsRel, Path, SubPath, root, parent, Split(..)
                 , pathToBS, ioAbsolute, parsePathBS, currentDir  )
import qualified Data.Path as P ( file )

import System.Random ( randomIO )
import System.FSLib.IO
import System.FSLib.Hash
import System.FSLib.StoreMonad
import System.FSLib.Tree ( Tree )
import qualified System.FSLib.Tree as Tree
import qualified System.FSLib.Index as I
import System.FSLib.PlainTree( readPlainTree )

import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Binary.Put
import Data.Binary.Get

import Types
import UUID

import Debug.Trace

gsdir = relative </> ".gorsvet"
gssub :: SubPath
gssub = root </> ".gorsvet"
objdir = gsdir </> "hashed"
metafile = gsdir </> "meta"
index = gsdir </> "index"

instance (FixedSize x, FixedSize y) => FixedSize (x, y) where
  fixedSize _ = fixedSize (undefined :: x) + fixedSize (undefined :: y)
  toBS (x, y) = B.concat [toBS x, toBS y]
  fromBS str = (fromBS $ B.take xsize str, fromBS $ B.drop xsize str)
     where xsize = fixedSize (undefined :: x)

instance FixedSize ObjectType where
  fixedSize _ = 1
  toBS TDirectory = "D"
  toBS TText = "T"
  toBS TBinary = "B"
  toBS TClipboard = "C"
  fromBS "D" = TDirectory
  fromBS "T" = TText
  fromBS "B" = TBinary
  fromBS "C" = TClipboard
  fromBS x = error $ "Bad ObjectType " ++ show x

instance FixedSize Hash where
  fixedSize _ = 32
  toBS (SHA256 x) = x
  fromBS = SHA256

instance (Eq k, Ord k, LoadMonad m, FixedSize k, FixedSize v) => Load (M.Map k v) m where
  load hash =
    do bits <- loadBS hash
       return $ M.fromAscList . map constr $ parse bits
     where parse s | B.null s = []
                   | otherwise = (B.take klen s, B.take vlen $ B.drop (klen + 1) s) :
                                 parse (B.drop (vlen + klen + 2) s)
           constr (u, h) = (fromBS u, fromBS h)
           klen = fixedSize (undefined :: k)
           vlen = fixedSize (undefined :: v)

instance (StoreMonad m, FixedSize k, FixedSize v) => Store (M.Map k v) m where
  store m = storeBL bits
    where bits = BL.concat $ map item $ M.toAscList m
          item (k, v) = BL.fromChunks [toBS k, " ", toBS v, "\n"]

objtype (Directory _) = TDirectory
objtype (Blob _ t _) = t

serialise :: (Functor m, Monad m) => Object m -> m BL.ByteString
serialise (Blob bits _ _) = BL.fromChunks <$> (:[]) <$> bits
serialise (Directory con) = return . runPut $ mapM_ entry $ M.toAscList con
  where entry (name, UUID uuid) = do
          putByteString uuid
          putWord32be $ fromIntegral (B.length name)
          putByteString name

parse :: (Monad m) => ObjectType -> B.ByteString -> Object m
parse TDirectory b = Directory . M.fromAscList $ runGet entries (BL.fromChunks [b])
  where entries = do
          rem <- remaining
          case rem of
            0 -> return []
            _ -> do uuid <- getBytes 32
                    len <- getWord32be
                    name <- getBytes (fromIntegral len)
                    rest <- entries
                    return $ (name, UUID uuid) : rest
parse t b = Blob (return b) t NoHash -- FIXME NoHash

instance LoadMonad Gorsvet where
  loadBS t = do us <- getCurrentDirectory -- FIXME expensive?
                paths <- (us:) <$> gets gsRemotes
                fetch paths
    where h = encodeBase16 t
          p = objdir </> B.take 2 h </> B.drop 2 h
          fetch [] = fail $ "Object " ++ BC.unpack h ++ " not found."
          fetch (base:other) = do
            found <- doesFileExist $ base +/+ p
            case found of
              True -> readFileBS $ base +/+ p
              False -> fetch other

instance StoreMonad Gorsvet where
  storeBS t = do let sha = sha256 t
                     name = encodeBase16 sha
                 writeFileBS (objdir </> B.take 2 name </> B.drop 2 name) t
                 return sha

formatObj :: (Functor m, Monad m) => Object m -> m String
formatObj (Blob x _ _) = BC.unpack <$> x
formatObj (Directory con) = return $ unlines (map line $ M.toList con)
  where line (name, id) = formatUUID id ++ " | " ++ BC.unpack name

instance forall m. (MonadIO m, LoadMonad m, StoreMonad m) => Load (ObjectMap m) m where
  load hash =
    do manifest <- load hash
       return $ make manifest
    where make :: M.Map UUID (ObjectType, Hash) -> ObjectMap m
          make manifest = ObjectMap get put list flush omstore
             where list = return $ M.keysSet manifest
                   put uuid obj = do bits <- serialise obj
                                     hash <- storeBL bits
                                     return $ make $ M.insert uuid (objtype obj, hash) manifest
                   -- get :: UUID -> m' (Maybe (Object m'))
                   get uuid = case M.lookup uuid manifest of
                     Nothing -> return Nothing
                     Just (_, NoHash) -> return Nothing
                     Just (t, h) -> Just <$> parse t <$> loadBS h
                   flush = fail "Flush not supported." 
                   omstore = store manifest

instance (StoreMonad m) => Store (ObjectMap m) m where
  store = omStore

instance (FixedSize v, LoadMonad m) => Load [v] m where
  load hash = map fromBS <$> chunks <$> loadBS hash
    where chunks b
            | B.null b = []
            | otherwise = case B.splitAt (fixedSize (undefined :: v)) b of (x, y) -> x : chunks y

instance StoreMonad m => Store [Hash] m where
  store = storeBS . B.concat . map toBS

readRepository :: (FsRO m, LoadMonad m, StoreMonad m, AbsRel ar) => Path ar -> m (Repository m)
readRepository base =
  do items <- map parseitem <$> BC.lines <$> readFileBS (base +/+ metafile)
     let item x = case lookup x items of
           Nothing -> fail $ "Corrupt .gorsvet/meta: field " ++ show x ++ " missing"
           Just y -> return y
     pristine <- load =<< item "pristine" -- $ readObjectMap p_pristine
     shadow <- load =<< item "shadow"
     inv <- load =<< item "inventory"
     ord <- load =<< item "order"
     return $ Repository { rPristine = pristine
                         , rShadow = shadow
                         , rInventory = inv
                         , rOrder = ord }
  where parseitem x = case BC.split ':' x of
          [x, y] -> (x, decodeBase64u $ BC.drop 1 y)

writeRepository :: (FsRW m, LoadMonad m, StoreMonad m) => Repository m -> m ()
writeRepository repo =
  do pristine <- store $ rPristine repo
     shadow <- store $ rShadow repo
     inv <- store $ rInventory repo
     ord <- store $ rOrder repo
     writeMeta pristine shadow inv ord

initRepository :: IO' ()
initRepository = evalStateT (runGorsvetT go) (GorsvetState {})
  where go = do createDirectory gsdir
                createDirectory objdir
                let letters = "0123456789abcdef"
                    bins = [ [x, y] | x <- letters, y <- letters ]
                forM bins $ \bin -> createDirectory (objdir </> BC.pack bin)
                eh <- storeBS B.empty
                em <- store $ M.fromList [(rootUUID, (TDirectory, eh))]
                writeMeta em em eh eh

writeMeta :: (FsRW m, LoadMonad m, StoreMonad m) => Hash -> Hash -> Hash -> Hash -> m ()
writeMeta pristine shadow inv ord = writeFileBS metafile meta
  where item n h = BC.concat [ n, ": ", encodeBase64u h ]
        meta = BC.unlines $ [ item "pristine" pristine
                            , item "shadow" shadow
                            , item "inventory" inv
                            , item "order" ord ]

data ShadowIndex = ShadowIndex | ShadowNoIndex
data ShadowHeuristics = ShadowDetectNothing | ShadowDetectAdds | ShadowDetectMoves

readIndex :: Gorsvet I.Index
readIndex = error "XXX readIndex"

objectTree :: forall m. (Functor m, Monad m) => ObjectMap m -> UUID -> m (Tree m)
objectTree om root = object root >>= \o -> case o of
  Tree.Stub x _ -> x
  Tree.SubTree t -> return t
  _ -> fail "Bug in objectTree."
  where object :: UUID -> m (Tree.TreeItem m)
        object uuid = omGet om uuid >>= \o -> case o of
          Nothing -> fail $ "Dangling object link at " ++ show uuid
          Just (Directory d) -> return $ Tree.Stub tree NoHash
            where tree = Tree.makeTree <$>
                           sequence [ object id >>= \x -> return (name, x)
                                    | (name, id) <- M.toList d ]
          Just (Blob b _ h) -> return $ Tree.File (Tree.Blob b h)

diredit :: (B.ByteString -> UUID -> DirContent -> DirContent)
           -> SubPath -> UUID -> Gorsvet ()
diredit edit path uuid = do
  dir_obj <- findPath (parent path) rootUUID =<< shadow
  case dir_obj of
    Just (dirid, Directory dir) -> do
      let dir' = case P.file path of
            (_ :/: basename) -> edit basename uuid dir
            _ -> dir -- XXX?
      editShadow dirid $ Directory dir'
      return ()
    Nothing -> fail $ "No directory at: " ++ show (parent path)

manifest = diredit M.insert
demanifest = diredit $ \dir _ map -> M.delete dir map

updateShadowFrom :: ShadowHeuristics -> Tree Gorsvet -> Tree Gorsvet -> Gorsvet ()
updateShadowFrom heur sh w =
  do (sh', w') <- Tree.diffTrees sh w
     sequence $ Tree.zipTrees update sh' w'
     return ()
  where update path Nothing (Just x) = toShadow path x
        update path (Just x) Nothing = findUUID path >>= \x -> case x of
          (Just uuid) -> demanifest path uuid
          Nothing -> return () -- the object is already unreachable; not a problem
        update path (Just x) (Just y) = toShadow path y
        toShadow path x = do
          uuid <- findUUID path
          newid <- makeUUID
          useid <- case uuid of
            Nothing -> makedir newid >> manifest path newid >> return newid
            Just x -> return x
          makeObject useid x
        makedir id = editShadow id $ Directory M.empty
        makeObject _ (Tree.SubTree _) = return ()
        makeObject uuid (Tree.File b@(Tree.Blob _ h)) =
          editShadow uuid $ Blob (Tree.readBlob b) TText h


updateShadow :: ShadowIndex -> ShadowHeuristics -> Gorsvet ()
updateShadow shidx shheur =
  do let interesting p -- TODO, make this filtering optional and configurable
           | BC.null pbs = False -- HUH?
           | p == gssub = False
           | p == root </> "_darcs" = False
           | BC.last pbs == '~' = False
           | otherwise = True
           where pbs = pathToBS p
     everything <- Tree.filter (\p _ -> interesting p) <$> readPlainTree relative
     shadowtree <- Tree.expand =<< (\x -> objectTree x rootUUID) =<< shadow
     working <- case (shidx, shheur) of
       (ShadowNoIndex, ShadowDetectNothing) -> return $ Tree.restrict shadowtree everything
       (ShadowNoIndex, _) -> return everything
       -- (ShadowIndex, ShadowDetectNothing) -> getindex
       -- (ShadowIndex, _) -> (everything `Tree.overlay`) <$> getindex
     updateShadowFrom shheur shadowtree working

data Update = UChanged SubPath (Maybe (Object Gorsvet)) (Maybe (Object Gorsvet)) | UIgnored
instance Eq Update where
  UIgnored == UIgnored = True
  UChanged x _ _ == UChanged y _ _ = x == y
  _ == _ = False

instance Ord Update where
  UIgnored `compare` UIgnored = EQ
  UIgnored `compare` _        = LT
  _        `compare` UIgnored = GT
  UChanged x _ _ `compare` UChanged y _ _ = x `compare` y

instance Show Update where
  show UIgnored = "ignored"
  show (UChanged x _ _) = "change " ++ show x

updateWorking :: ObjectMap Gorsvet -> ObjectMap Gorsvet -> Gorsvet ()
updateWorking old new =
  do all <- S.toList `fmap` omList new
     renames <- forM all $ \uuid -> do
       oldp <- pathFromUUID uuid rootUUID old
       newp <- pathFromUUID uuid rootUUID new
       return $ (oldp, newp)
     dorenames [ (x, y) | (Just x, Just y) <- renames, x /= y ] [] True
     updates <- dropWhile (== UIgnored) `fmap` sort `fmap` mapM getchange all
     forM_ updates doupdate

  where dorenames [] defer False = forM defer forcerename
        dorenames [] defer True = dorenames defer [] False
        dorenames ((old, new):rens) defer reduced =
          do ex <- doesExist new
             case ex of
               True -> dorenames rens ((old, new):defer) reduced
               False -> do forcerename (old, new)
                           dorenames rens defer True
        forcerename :: (FsRW m) => (SubPath, SubPath) -> m ()
        forcerename (old, new) =
          do ex <- doesExist new
             when ex $ stash new
             rename old new

        backup path True = return ()
        backup path False = do
          ex <- doesExist path
          when ex $ stash path
        stash path = do r <- liftIO randomIO
                        let path' = mkpath path r
                        rename path $ mkpath path r
                        liftIO . putStrLn $ "moved " ++ show path ++ " out of way, to " ++ show path'
                      `catch` \(e::SomeException) -> stash path -- or die trying...
        mkpath :: SubPath -> Int -> SubPath
        mkpath p r = fromJust $ parsePathBS (B.concat [pathToBS p, ".", BC.pack $ show r])

        doupdate :: Update -> Gorsvet ()
        doupdate (UChanged p old new) = do
          case old of -- move anything unexpected out of harm's way
            Just (Directory a) -> backup p =<< doesDirectoryExist p
            Just (Blob a _ _) ->
              do f <- doesFileExist p
                 case f of
                   True -> do ac <- a
                              bc <- readFileBS p
                              backup p (ac == bc)
            Nothing -> backup p False
          case new of -- write the new content
            Nothing -> remove p
            Just (Directory a) -> createDirectoryIfMissing False p
            Just (Blob b _ _) -> writeFileBS p =<< b

        getchange :: UUID -> Gorsvet Update
        getchange uuid = do
          pnew <- pathFromUUID uuid rootUUID new
          pold <- pathFromUUID uuid rootUUID old
          case (pnew, pold) of
            (Nothing, Nothing) -> return UIgnored
            (Nothing, Just x) -> getchange' x uuid
            (Just x, _) -> getchange' x uuid
        getchange' p uuid = do
          o <- omGet old uuid
          n <- omGet new uuid
          case (o, n) of
            (Just (Blob a _ _), Just (Blob b _ _)) -> do
              a' <- a; b' <- b
              return $ if a' /= b' then UChanged p o n else UIgnored
            (Just (Directory _), Just (Directory _)) -> return $ UIgnored -- dirs do not count
            _ -> return $ UChanged p o n

gorsvet' :: Gorsvet a -> IO a
gorsvet' act = enhancedIO $ evalStateT (runGorsvetT go) (GorsvetState { gsRemotes = [] })
  where go = do r <- readRepository currentDir
                modify $ \x -> x { gsRepository = r }
                updateShadow ShadowNoIndex ShadowDetectMoves
                act

gorsvetRO :: Gorsvet a -> IO a
gorsvetRO act = gorsvet' act

gorsvetRW :: Gorsvet a -> IO a
gorsvetRW act = gorsvet' $ do
  origsh <- shadow
  result <- act
  writeRepository =<< gets gsRepository
  updateWorking origsh =<< shadow
  return result