{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Distribution.Skete.Storage.GitFat (
    GitFatConfig(..)
  , GitFat
  ) where

import           Prelude hiding (lookup, fail)

import qualified Control.Monad.Catch as E
import           Control.Monad.Fail
import           Control.Monad.Trans
import           Data.Maybe
import qualified Data.Set as Set
import qualified Data.ByteString.Lazy as BL
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           Data.Time
import qualified Data.Map as Map
import qualified Data.ListTrie.Map.Ord as LT
import qualified Data.Git as Git
import qualified Data.Git.FileTree as Git
import qualified Data.Git.EditTree as Git
import           Data.String
import           Data.Yaml
import           Distribution.Skete.Storage.Interface
import           System.Posix.FilePath
import           System.Filesystem.PathComponent
import           Text.Read (readMaybe)

newtype GitFatConfig = GFC RawFilePath
                       deriving (Read, Show, Ord, Eq)

newtype GitFat p a = GitFat { runGF :: Git.Git a }
    deriving (Functor, Applicative, Monad, MonadIO, E.MonadThrow, E.MonadCatch, MonadFail)

data PhantomGitRef p = PGR { pgrRef :: Git.Sha1, pgrPV :: PackageVersion }

pkgBranch :: PackageVersion -> Git.RefName
pkgBranch = fromJust . Git.refName . TE.encodeUtf8 . pvName

lookup' :: PackageVersion -> GitFat p (Maybe Git.Sha1)
lookup' = GitFat . Git.readBranch . pkgBranch

mkCommit :: [Git.Sha1] -> Either Git.Sha1 (Git.FileTree Git.FileData) -> Text -> UTCTime -> GitFat p Git.Sha1
mkCommit ps dt msg now = GitFat $ do
    tr <- either return Git.buildFileTree dt
    Git.writeCommit $
      Git.Commit { Git.commitTree = tr
                 , Git.commitParents = ps
                 , Git.commitAuthor = autoCommitter now
                 , Git.commitCommitter = autoCommitter now
                 , Git.commitMessage = BL.fromStrict . TE.encodeUtf8 $ msg
                 }
  where
    autoCommitter :: UTCTime -> (Git.Contact, Git.Date)
    autoCommitter = (,) (Git.Contact (fromString "auto importer") mempty) . Git.utcTimeToDate

-- Labels start with @ so that they can't be confused with packages
packageSetPrefix :: Text
packageSetPrefix = "@"

branchLabel :: PackageSet -> Git.RefName
branchLabel = fromJust . Git.refName . TE.encodeUtf8 . (<>) packageSetPrefix

instance SketeStorage GitFatConfig (GitFat p) (PhantomGitRef p) where
    storage (GFC r) = liftIO . Git.runGit r . runGF

    add' pid cd now dt = do
        mp <- lookup' pid
        ref <- mkCommit (maybeToList mp) (Right dt)
              (printCommitMessage $ CommitData (Add pid) (Just . toJSON $ cd)) now
        GitFat $ Git.writeBranch (pkgBranch pid) ref
        return $ PGR ref pid

    lookup pid = do
        r <- lookup' pid
        mr <- GitFat . maybe (return Nothing) (Git.grepCommit $ go . fmap sketeData . parseCommitMessage) $ r
        return $ PGR <$> mr <*> pure pid
      where
        go (Just (Add pv)) = pv == pid
        go _ = False

    versionFiles (PGR ref _) = GitFat $ do
      ms <- Git.resolveSha ref []
      maybe (return mempty) Git.loadFileTree ms

    versionFile (PGR r _) fp = do
      fmap Git.getBlob <$> GitFat (Git.resolveBlob r fp)

    labels =
      mapMaybe (T.stripPrefix packageSetPrefix . TE.decodeUtf8 . Git.getRefName) . Set.toList <$> (GitFat Git.listBranches)

    label' (PGR r pid@(PV pn pv)) m l now = do
        -- To link the history we MUST have the old state.
        mobh <- GitFat . Git.readBranch . branchLabel $ l
        -- Now, our tree must be the composite of our addition and whatever the old tree was, or mempty if it wasn't.
        a <- case mobh of
          Nothing -> return $ mempty
          Just obh -> do
            mot <- GitFat $ traverse (Git.loadEditTree . Git.commitTree) =<< Git.findCommit obh
            case mot of
              Nothing -> fail "Couldn't read in old tree"
              Just ot -> return $ ot
        b <- GitFat . Git.editTree a $ do
          tp <- mapM (pathComponent . TE.encodeUtf8) [T.take 1 pn, pn, T.pack $ show pv]
          Git.cdCreating' tp $ do
            Git.createFiles $ m
        c <- GitFat $ Git.writeEditTree b
        cr <- mkCommit (maybeToList mobh ++ [r]) -- We want obh on the left for readability of the graph.
                       (Left c)
                       (printCommitMessage $ CommitData (Label pid l) Nothing) now
        GitFat $ Git.writeBranch (branchLabel l) cr

    labelData l (PV pn pv) = do
      path <- mapM (pathComponent . TE.encodeUtf8) [T.take 1 pn, pn, T.pack $ show pv]
      retrieveMeta l path

    list l =
      (GitFat $ Git.readBranch (branchLabel l)) >>= maybe (return []) (\r -> do
        t <- GitFat $ Git.loadFileTree r
        return $ flip mapMaybe (LT.toList t) (\case
                (_:pns:pvs:_, _) -> do
                   pv <- readMaybe . T.unpack . TE.decodeUtf8 . getPC $ pvs
                   return $ PV (TE.decodeUtf8 . getPC $ pns) pv
                _ -> Nothing))

    versionData (PGR r _) = do
      Just cmt <- GitFat $ Git.findCommit r
      return $ parseCommitMessage cmt >>= clientData >>= parseMaybe parseJSON

    packageData ps pn = do
      path <- mapM (pathComponent . TE.encodeUtf8) [T.take 1 pn, pn, ".meta"]
      retrieveMeta ps path

    labelPackage' l pn mm now = do
      -- To link the history we MUST have the old state.
      mobh <- GitFat . Git.readBranch . branchLabel $ l
      -- Now, our tree must be the composite of our addition and whatever the old tree was, or mempty if it wasn't.
      a <- case mobh of
        Nothing -> return $ mempty
        Just obh -> do
          mot <- GitFat $ traverse (Git.loadEditTree . Git.commitTree) =<< Git.findCommit obh
          case mot of
            Nothing -> fail "Couldn't read in old tree"
            Just ot -> return $ ot
      b <- GitFat . Git.editTree a $ do
        Git.cdCreating (joinPath . map TE.encodeUtf8 $ [T.take 1 pn, pn, ".meta"]) $ do
          Git.createFiles $ mm
      c <- GitFat $ Git.writeEditTree b
      cr <- mkCommit (maybeToList mobh)
                     (Left c)
                     (printCommitMessage $ CommitData (Annotate pn l) Nothing) now
      GitFat $ Git.writeBranch (branchLabel l) cr

retrieveMeta :: PackageSet -> [PathComponent] -> (GitFat p) (Maybe MetaMap)
retrieveMeta l path = do
  mobh <- GitFat $ Git.readBranch (branchLabel l)
  s <- case mobh of
    Nothing -> (liftIO $ print ("no branch head!"::String)) >> return Nothing
    Just obh -> GitFat $ Git.resolveSha obh path
  mdt  <- traverse (GitFat . Git.loadFileTree) s
  return $ fmap (\dt -> Map.fromList [ (fn, BL.toStrict bytes) | ([fn], (bytes,_)) <- LT.toList dt]) mdt