{-| This module defines a simple way to serialize state as a nested file
  hierarchy saved in a Git repository.
-}

{-# Language DeriveFunctor #-}
{-# Language LambdaCase #-}
{-# Language OverloadedStrings #-}
{-# Language RecordWildCards #-}
{-# Language ViewPatterns #-}

module Restless.Git
  ( Path (..)
  , File (..)
  , make
  , save
  , load
  ) where

import Control.Monad          (void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString        (ByteString)
import Data.Foldable          (toList)
import Data.Map               (Map)
import Data.Monoid            ((<>))
import Data.Set               (Set)
import Data.Text              (Text, unpack)
import Data.Text.Encoding     (decodeUtf8)
import HSH                    (run, (-|-))

import qualified Data.ByteString  as BS
import qualified Data.Set         as Set
import qualified Data.Map         as Map

-- | A fact path is something like "\/0123...abc\/storage\/0x1".
-- It has some number of directories and a file name.
data Path = Path [ByteString] ByteString
  deriving (Eq, Ord, Show)

-- | A file is a serialized value with a path.
data File = File { filePath :: Path, fileData :: ByteString }
  deriving (Eq, Ord, Show)

data Tree a = Tree (Map ByteString (Tree a)) (Map ByteString a)
  deriving (Functor, Show)

instance Monoid (Tree a) where
  mempty =
    Tree mempty mempty
  mappend (Tree a b) (Tree c d) =
    Tree (Map.unionWith mappend a c)
         (Map.union b d)

-- | Initialize an empty repository at the given path.
make
  :: (Monad m, MonadIO m)
  => FilePath -> m ()
make repo = liftIO $ do
  void $ git repo "init" []
  void $ git repo "commit" ["-am", "initialize", "--allow-empty"]

-- | Save a set of files to an initialized repository and commit this
-- tree to the master branch with a given commit message.
save
  :: (Monad m, MonadIO m)
  => FilePath -> Text -> Set File -> m ()
save dst message files = liftIO $ do
  tree <-
    saveTree dst (treeFromFiles files)
  parent <-
    latestCommitOid dst defaultRef
  commit <-
    createCommit dst parent tree (unpack message)

  updateReference dst defaultRef commit

  return ()

-- | Load a set of files from a repository's master branch.
load :: (Monad m, MonadIO m) => FilePath -> m (Set File)
load src = liftIO $ do
  ls <- git src "ls-tree" ["-r", "-z", defaultRef]
  Set.fromList <$> mapM (loadFile src) (filter (/= "") (BS.split 0 ls))


-- Internal

treeFromFiles :: Foldable t => t File -> Tree ByteString
treeFromFiles = foldMap singletonTree . toList

singletonTree :: File -> Tree ByteString
singletonTree (File {..}) =
  case filePath of
    Path [] name ->
      Tree mempty (Map.singleton name fileData)
    Path (x:xs) name ->
      let subtree = singletonTree (File (Path xs name) fileData)
      in Tree (Map.singleton x subtree) mempty

data ObjectType = TreeObject | BlobObject
  deriving Show

newtype SHA1 = SHA1 ByteString
  deriving Show

data MkTree =
  MkTree (Map ByteString (ObjectType, SHA1))
  deriving Show

serializeMkTree :: MkTree -> ByteString
serializeMkTree (MkTree m) =
  mconcat . map (uncurry mkTreeLine) . Map.toList $ m

mkTreeLine :: ByteString -> (ObjectType, SHA1) -> ByteString
mkTreeLine name (TreeObject, SHA1 sha1) =
  "040000 tree " <> sha1 <> "\t" <> name <> "\0"
mkTreeLine name (BlobObject, SHA1 sha1) =
  "100644 blob " <> sha1 <> "\t" <> name <> "\0"

saveTree :: FilePath -> Tree ByteString -> IO SHA1
saveTree dst (Tree folders files) = do
  trees <- mapM (fmap ((,) TreeObject) . saveTree dst) folders
  blobs <- mapM (fmap ((,) BlobObject) . createBlob dst) files
  let input = serializeMkTree (MkTree (trees <> blobs))
  asSHA1 <$> run ((\() -> input) -|- git' dst "mktree" ["-z"])

asSHA1 :: ByteString -> SHA1
asSHA1 = SHA1 . fst . BS.break (== 0xa)

defaultRef :: String
defaultRef = "refs/heads/master"

git :: String -> String -> [String] -> IO ByteString
git repo cmd args = do
  x <- run $ ("git" :: String, ["-C", repo] ++ (cmd : args))
  return x

sha1String :: SHA1 -> String
sha1String (SHA1 bs) = unpack (decodeUtf8 bs)

createCommit :: FilePath -> SHA1 -> SHA1 -> String -> IO SHA1
createCommit dst parent tree message =
  asSHA1 <$>
    git dst "commit-tree"
      ["-p", sha1String parent, "-m", message, sha1String tree]

updateReference :: String -> String -> SHA1 -> IO ()
updateReference dst ref next =
  void $ git dst "update-ref" [ref, sha1String next]

git' :: FilePath -> String -> [String] -> (String, [String])
git' repo cmd args =
  ("git" :: String, ["-C", repo] ++ (cmd : args))

createBlob :: String -> ByteString -> IO SHA1
createBlob dst bytes =
  asSHA1 <$> run ((\() -> bytes) -|- git' dst "hash-object" ["--stdin", "-w"])

loadFile :: FilePath -> ByteString -> IO File
loadFile src line = do
  let
    (a, b) = BS.splitAt 52 line
    sha1   = SHA1 (BS.drop 12 a)
    name   = BS.take (BS.length b - 1) (BS.drop 1 b)
    path   =
      case BS.split 0x2f name of
        []    -> error "empty file name"
        parts -> Path (init parts) (last parts)

  bytes <- git src "cat-file" ["blob", sha1String sha1]
  return (File path bytes)

latestCommitOid :: FilePath -> String -> IO SHA1
latestCommitOid dst ref =
  asSHA1 <$> git dst "rev-parse" [ref]