Monad.hs

{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ViewPatterns               #-}

{-|
Functionality we're currently missing (an assuredly incomplete list):

* @.git@ textfile (gitdir: some-path)
* using $GIT_DIRECTORY
* @objects/info/alternates@ or $GIT_ALTERNATE_OBJECT_DIRECTORIES
-}

module Data.Git.Monad
    (
    -- * The Git Monad
      MonadGit(..)
    , GitT
    , Git
    , runGit
    , runGitT

    -- * Repository Management
    , initRepo
    , repoPath

    -- * Object Reading
    , findBlob
    , findTag
    , findTree
    , findTreeish
    , findCommit
    , grepCommit
    , resolveSha
    , resolveBlob

    -- * Object Writing
    , writeBlob
    , writeTree
    , writeCommit
    , writeTag

    -- * Writing Packfiles
    , packing

    -- * Ref Handling
    , readBranch
    , readHead
    , writeBranch
    , writeHead
    , detachHead
    , listBranches
    , readPackedRefs
    , peelRef
    , peeled
    ) where

import           Prelude hiding (fail)
import           Codec.Compression.Zlib
import           Control.Monad.Catch
import           Control.Monad.Fail
import           Control.Monad.State hiding (fail)
import           Control.Monad.Trans.Maybe
import qualified Data.ByteString               as B
import qualified Data.ByteString.Builder       as BB
import qualified Data.ByteString.Lazy          as BL
import           Data.Foldable
import           Data.Map                      (Map)
import qualified Data.Map                      as M
import qualified Data.Set                      as S
import           System.IO.Error               (isDoesNotExistError)
import           System.Posix.Directory.Traversals (traverseDirectory)
import           System.Posix.FilePath
import           System.Posix.Files.ByteString

import Data.Git.Formats
import Data.Git.Hash
import Data.Git.Internal.FileUtil
import Data.Git.Internal.Object (parseObject)
import Data.Git.Internal.Pack (isPackIndex)
import Data.Git.Internal.Parsers
import Data.Git.Internal.Types  (GitConf(..), GitT(..))
import Data.Git.Object
import Data.Git.Pack
import Data.Git.Paths
import Data.Git.Ref
import Data.Git.RefName
import Data.Git.Types

-- | Monads that let you work with git repositories.
class Monad m => MonadGit m where
    -- | Try to look up an object by its 'Sha1'.
    lookupSha    :: Sha1 -> m (Maybe Object)
    -- | Write an 'Object' to storage, returning its 'Sha1'.  We should have the law:
    --   @
    --     writeObject o >>= \s -> flushObjects >> lookupSha s == return (Just o)
    --   @
    writeObject  :: Object -> m Sha1
    -- | Flush written 'Object's to disk.  Defaults to a no-op.
    flushObjects :: m ()
    flushObjects = return ()
    -- | Try to get the 'Sha1' from a 'Ref'.
    lookupRef    :: Ref -> m (Maybe Sha1)
    -- | A 'Map' from 'Ref's to the 'Sha1's at which they point, optionally.  An instance may choose
    --   not to provide hashes for some 'Ref's (e.g., only providing hashes for packed refs, but not
    --   loose ones).
    listRefs     :: m (Map Ref (Maybe Sha1))
    -- | Write a 'Ref' to the given 'Sha1'.
    writeRef     :: Ref -> Sha1 -> m ()
    -- | Write a symref from the first argument to the second.
    writeSymRef :: Ref -- ^ write a symref here
                -> Ref -- ^ pointing to here
                -> m ()
    -- | Register a packfile with git so it knows to search it.
    --   Primarily a support function for PackingT, and perhaps should be seperated out.
    registerPack :: PackFile -> m ()

findThing :: MonadGit m => (Object -> Maybe a) -> Sha1 -> m (Maybe a)
findThing thing s = lookupSha s >>= return . maybe Nothing thing

-- | Lookup a 'Sha1'.  'Nothing' when the object does not exist or is not a 'Blob'.
findBlob :: MonadGit m => Sha1 -> m (Maybe Blob)
findBlob = findThing asBlob

-- | Lookup a 'Sha1'.  'Nothing' when the object does not exist or is not a 'Tree'.
findTree :: MonadGit m => Sha1 -> m (Maybe Tree)
findTree = findThing asTree

-- | Lookup a 'Sha1'.  'Nothing' when the object does not exist or is not a 'Commit'.
findCommit :: MonadGit m => Sha1 -> m (Maybe Commit)
findCommit = findThing asCommit

-- | Lookup a 'Sha1'.  'Nothing' when the object does not exist or is not a 'Tag'.
findTag :: MonadGit m => Sha1 -> m (Maybe Tag)
findTag = findThing asTag

findTreeishSha :: MonadGit m => Sha1 -> m (Maybe Sha1)
findTreeishSha s = lookupSha s >>= \case
                                   Just (TreeObj   _) -> return $ Just s
                                   Just (CommitObj c) -> return . Just $ commitTree c
                                   Just (TagObj    t) -> findTreeishSha $ tagObject t
                                   _                  -> return Nothing

-- | A "treeish" is an object that can be recursively dereferenced to a 'Tree'.  This includes
--   'Tree's themselves, 'Commit's, and (usually) 'Tag's.
findTreeish :: MonadGit m => Sha1 -> m (Maybe Tree)
findTreeish s = lookupSha s >>= \case
                                Just (TreeObj   t) -> return      $ Just t
                                Just (CommitObj c) -> findTree    $ commitTree c
                                Just (TagObj    t) -> findTreeish $ tagObject t
                                _                  -> return Nothing

-- | Given a 'Sha1' that refers to a tree-ish (see 'findTreeish') and a list of path components,
--   find the 'Sha1' of the object in the tree at that path.
resolveSha :: (MonadFail m, MonadGit m) => Sha1 -> [PathComponent] -> m (Maybe Sha1)
resolveSha s [] = findTreeishSha s
resolveSha s p  = runMaybeT $ do t <- MaybeT (findTreeish s)
                                 go t p
    where go _ []            = fail "empty path should not occur in this part of resolveSha, wasn't a Treeish?"
          go (Tree t) [b]    = MaybeT . return $ lookupThing b t
          go (Tree t) (d:bs) = do dir  <- MaybeT . return $ M.lookup (Entry d TreeMode) t
                                  t'   <- MaybeT $ findTree dir
                                  go t' bs
          lookupThing b t = msum [ M.lookup (Entry b m) t | m <- modes ]
          modes           = [ BlobMode, ExecMode, TreeMode, SubmMode, LinkMode ]

-- | As 'resolveSha', expecting a 'Blob' at the given location.
resolveBlob :: (MonadFail m, MonadGit m) => Sha1 -> [PathComponent] -> m (Maybe Blob)
resolveBlob s p = runMaybeT $ do b <- MaybeT $ resolveSha s p
                                 MaybeT $ findBlob b

-- | Search through the 'Commit' with the given 'Sha1' and its ancestors, for the first commit
--   satisfying the given predicate.
grepCommit :: MonadGit m => (Commit -> Bool) -> Sha1 -> m (Maybe Sha1)
grepCommit f ref = do
  jc <- findCommit ref
  case jc of
    Just c -> do
      ps <- grepCommit f `mapM` commitParents c
      return $ if f c then Just ref else asum ps
    -- TODO: Shallow checkout?
    Nothing -> pure Nothing

-- | Write a 'Blob', returning its 'Sha1'.
writeBlob :: MonadGit m => Blob -> m Sha1
writeBlob = writeObject . BlobObj

-- | Write a 'Tree', returning its 'Sha1'.
writeTree :: MonadGit m => Tree -> m Sha1
writeTree = writeObject . TreeObj

-- | Write a 'Commit', returning its 'Sha1'.
writeCommit :: MonadGit m => Commit -> m Sha1
writeCommit = writeObject . CommitObj

-- | Write a 'Tag', returning its 'Sha1'.
writeTag :: MonadGit m => Tag -> m Sha1
writeTag = writeObject . TagObj

-- | Read a 'Sha1' out of a branch (in @refs/heads/@)
readBranch :: MonadGit m => RefName -> m (Maybe Sha1)
readBranch = lookupRef . Branch

-- | Set a branch (in @refs/heads/@) to a particular 'Sha1'.
writeBranch :: MonadIO m => RefName -> Sha1 -> GitT m ()
writeBranch p = writeRef (Branch p)

-- | Read the 'Sha1' in @HEAD@
readHead :: MonadGit m => m (Maybe Sha1)
readHead = lookupRef HEAD

-- | Set @HEAD@ to a specific 'Sha1'.  Leaves the repo in a "detached HEAD" state.
detachHead :: MonadGit m => Sha1 -> m ()
detachHead = writeRef HEAD

-- | Point @HEAD@ at a 'Ref'
writeHead :: MonadGit m => Ref -> m ()
writeHead = writeSymRef HEAD

-- | List all branches.
listBranches :: MonadGit m => m (S.Set RefName)
listBranches = listRefs >>= \rs -> return $ S.fromList [b | (Branch b, _) <- M.toList rs]

-- | Attempt to peel (recursively dereference) a ref (usually a tag) down to the 'Sha1' of a non-tag
--   object.  TODO: improve this documentation.
peelRef :: MonadGit m => Ref -> m (Maybe Sha1)
peelRef (TagRef _ (Just s)) = return (Just s)
peelRef r                   = do
  s <- lookupRef r
  o <- maybe (pure Nothing) findTag s
  maybe (pure s) chaseTag o
      where chaseTag Tag {tagType=tt, tagObject=to}
                | tt == TagType = findTag to >>= maybe (pure Nothing) chaseTag
                | otherwise    = return $ Just to

-- | The peeled version of a 'Ref'.
peeled :: MonadGit m => Ref -> m Ref
peeled t@(TagRef rn Nothing) = TagRef rn <$> peelRef t
peeled t                     = return t

-- | A concrete 'MonadGit' instance writing loose objects.
instance MonadIO m => MonadGit (GitT m) where
    lookupSha s  = do
      s' <- getLooseSha s
      maybe (gets $ msum . fmap (`findPackSha` s) . packs) (return . parseMaybe parseObject) s'

    writeObject  = writeLooseObject
    lookupRef r  = do
      path <- repoPath r
      ref  <- liftIO $ readRefFile path
      case ref of
        Nothing          -> (join . fmap (lookup r)) <$> readPackedRefs
        Just (ShaRef s)  -> return $ Just s
        Just (SymRef r') -> lookupRef r'
    listRefs     = do
      prs <- maybe mempty M.fromList <$> readPackedRefs
      lrs <- looseRefs
      return $ lrs `M.union` (Just <$> prs)
    writeRef r s = do
      path <- repoPath r
      liftIO . createRawDirectoryIfMissing True . takeDirectory $ path
      liftIO . writeRawFileS path . flip B.snoc 10 . getSha1Hex . toHex $ s
    writeSymRef from to = do
      fromPath <- repoPath from
      liftIO . createRawDirectoryIfMissing True . takeDirectory $ fromPath
      liftIO . writeRawFileS fromPath . flip B.snoc 10 . B.append "ref: " $ inRepo to
    registerPack p = GitT $ modify (\g -> g { packs = p:(packs g) })

getLooseSha :: MonadIO m => Sha1 -> GitT m (Maybe BL.ByteString)
getLooseSha s = do
  p <- repoPath $ looseObjectPath s
  mwhenFileExists p (liftIO . fmap decompress . readRawFileL $ p)

writeLooseSha :: MonadIO m => Sha1 -> BL.ByteString -> GitT m Sha1
writeLooseSha s bs = do p <- repoPath $ looseObjectPath s
                        liftIO $ createRawDirectoryIfMissing True (takeDirectory p)
                                   >> writeRawFileL p bs
                                   >> return s

writeLooseObject :: MonadIO m => Object -> GitT m Sha1
writeLooseObject o = writeLooseSha (sha1 b) (compress b)
    where b = BB.toLazyByteString . buildLooseObject $ o

packIndices :: MonadIO m => GitT m [RawFilePath]
packIndices = do
  pd <- repoPath packDir
  liftIO . handleJust (guard . isDoesNotExistError) (const $ return []) .
         fmap (filter isPackIndex) . getRawDirectoryContents $ pd

addPackFile :: MonadIO m => RawFilePath -> GitT m ()
addPackFile fp = do gc <- get
                    pd <- repoPath packDir
                    pf <- liftIO $ readPackFile (pd </> dropExtension fp)
                    put gc { packs = pf : packs gc }

loadPackFiles :: MonadIO m => GitT m ()
loadPackFiles = packIndices >>= mapM_ addPackFile

-- | Read this repository's @packed-refs@ file, if it's there.
--
--   NB: Loose refs have priority over packed refs, so if (for example) a branch exists both loose
--   and packed in the repository and is associated with different hashes, it points to whatever the
--   loose one says.  *However*, this function intentionally  does *not* honor that.
readPackedRefs :: MonadIO m => GitT m (Maybe [(Ref, Sha1)])
readPackedRefs = repoPath packedRefsPath >>= liftIO . readPackedRefsFile

looseBranches, looseTags, looseRemotes, looseRefs :: MonadIO m => GitT m (Map Ref (Maybe Sha1))
looseBranches = findLooseRefs "refs/heads"
looseTags     = findLooseRefs "refs/tags"
looseRemotes  = findLooseRefs "refs/remotes"
looseRefs     = fold <$> sequence [looseBranches, looseTags, looseRemotes]

findLooseRefs :: MonadIO m => RawFilePath -> GitT m (Map Ref (Maybe Sha1))
findLooseRefs p = do path <- gets gitDir
                     whenFileExists (path </> p) mempty $ do
                       liftIO . withRawCurrentDirectory path $
                           traverseDirectory addBranch mempty p
    where addBranch acc (mkRef -> Just ref) = do -- strip of the leading "./"
            reg <- isRegularFile <$> getFileStatus (inRepo ref)
            return $ if reg then M.insert ref Nothing acc else acc
          addBranch acc _ = return acc

-- | Like the instance for 'GitT', but writing packfiles.
instance (MonadGit m, MonadIO m) => MonadGit (PackingT m) where
    lookupSha           = lift . lookupSha
    writeObject         = packObject
    lookupRef           = lift . lookupRef
    listRefs            = lift listRefs
    writeRef r s        = lift $ writeRef r s
    writeSymRef from to = lift $ writeSymRef from to
    flushObjects        = flushPackFile registerPack
    registerPack        = lift . registerPack

-- | Run a 'GitT' computation, writing objects to a packfile instead of loose.
--   Currently objects are not findable until flushObjects is called.
packing :: MonadIO m => PackingT (GitT m) a -> GitT m a
packing git = do
  template <- repoPath $ packDir </> "pack-"
  runPackingT registerPack template git

-- | Minimal rendition of @git init@.  When given 'Nothing', creates a @.git/@ the current working
--   directory.  When given @'Just' path@, initializes a repository at @path@.  Thus, @initRepo Nothing
--   == initRepo (Just ".git")@.
initRepo :: Maybe RawFilePath -> IO ()
initRepo Nothing  = initRepo $ Just ".git"
initRepo (Just d) = do
  createRawDirectoryIfMissing True d
  withRawCurrentDirectory d $ do
    createRawDirectoryIfMissing False "refs"
    createRawDirectoryIfMissing False "objects"
    writeRawFileS "HEAD" "ref: refs/heads/master"

-- | Do some git computations in the given git directory.
runGitT :: MonadIO m => RawFilePath -> GitT m a -> m a
runGitT p git = evalStateT (unGitT $ loadPackFiles >> git) conf
    where conf = GitConf p []

-- | Do some git computations in the given git directory.
runGit :: RawFilePath -> Git a -> IO a
runGit = runGitT