Forks.hs

{-# LANGUAGE ScopedTypeVariables, TypeFamilies, CPP #-}
module DarcsDen.Handler.Repository.Forks where

import Darcs.Patch.PatchInfoAnd (hopefully, info)
import Darcs.Patch.Depends (findUncommon)
import Darcs.Patch.Info (makeFilename)
import Darcs.Patch (getdeps)
import Darcs.Patch.Permutations
import Darcs.Repository
    ( RepoJob(..)
    , applyToWorking
    , finalizeRepositoryChanges
    , identifyRepositoryFor
    , invalidateIndex
    , readRepo
    , tentativelyMergePatches
#ifdef DARCS28
    , withGutsOf
#endif
    , withRepoLock
    )
import qualified Darcs.Repository as R (Repository)
#ifdef DARCS28
import Darcs.Utils (withCurrentDirectory)
import Darcs.CommandsAux (checkPaths)
import Darcs.Flags as DUF (DarcsFlag(SkipConflicts))
import Darcs.SelectChanges (filterOutConflicts)
import Darcs.Witnesses.Ordered
import Darcs.Witnesses.Sealed
#else
import Darcs.Util.File (withCurrentDirectory)
import Darcs.Patch.Witnesses.Ordered ((:\/:)(..), (:>)(..), lengthFL, reverseFL, mapRL)
import Darcs.Patch.Witnesses.Sealed
import Darcs.UI.CommandsAux (checkPaths)
import qualified Darcs.Repository.Flags as DRF
import Darcs.Repository.State (filterOutConflicts)
#endif

import DarcsDen.Handler.Repository.Changes
import DarcsDen.State.Repository
import DarcsDen.State.Session
import DarcsDen.State.Util

data Fork =
    Fork
        { fRepo :: Repository
        , fPatches :: [PatchLog]
        } deriving (Show)

getUpstreamChanges :: Repository -> IO (Maybe Fork)
getUpstreamChanges r = withParent (getForkChanges r) r

getDownstreamChanges :: Repository -> IO (Maybe Fork)
getDownstreamChanges r = withParent (flip getForkChanges r) r

-- Get patches that are in rOther but not r
getForkChanges :: Repository -> Repository -> IO Fork
getForkChanges rOther r = do
    let pdir = repoDir (rOwner rOther) (rName rOther)
        cdir = repoDir (rOwner r) (rName r)
#ifdef DARCS28
    withCurrentDirectory pdir $ withRepoLock [] $ RepoJob $ \(pr :: R.Repository p wR wU wR) -> do
      cr <- identifyRepositoryFor pr cdir
#else
    withCurrentDirectory pdir $ withRepoLock DRF.NoDryRun DRF.YesUseCache DRF.YesUpdateWorking DRF.NoUMask $ RepoJob $ \(pr :: R.Repository p wR wU wR) -> do
      cr <- identifyRepositoryFor pr DRF.YesUseCache cdir
#endif
      pps <- readRepo pr
      cps <- readRepo cr
      let cs = case findUncommon pps cps of
                 _ :\/: them ->
                   let depends = map (\(p, ds) -> (makeFilename p, ds)) (findAllDeps (reverseFL them))
                   in mapRL
                        (\p ->
                           let l = toLog (info p, getdeps (hopefully p))
                           in case lookup (makeFilename (info p)) depends of
                                Just ds -> l{pDepends = map (take 20 . makeFilename) ds}
                                Nothing -> l)
                        (reverseFL them)
      changes <- findUsers cs
      return $ Fork r changes

mergePatches :: Repository -> Repository -> [String] -> Session -> IO Bool
mergePatches rDest r ps s = do
#ifdef DARCS28
    withCurrentDirectory (origin rDest) $ withRepoLock [] $ RepoJob $ \(pr :: R.Repository p wR wU wR) -> do
        cr <- identifyRepositoryFor pr fork
#else
    withCurrentDirectory (origin rDest) $ withRepoLock DRF.NoDryRun DRF.YesUseCache DRF.YesUpdateWorking DRF.NoUMask $ RepoJob $ \(pr :: R.Repository p wR wU wR) -> do
        cr <- identifyRepositoryFor pr DRF.YesUseCache fork
#endif

        pps <- readRepo pr
        cps <- readRepo cr

        case findUncommon pps cps of
            us :\/: them ->
                case partitionFL ((`elem` ps) . take 20 . makeFilename . info) them of
                    chosen :> _ -> do
#ifdef DARCS28
                        (conflicts, Sealed merge) <- filterOutConflicts [DUF.SkipConflicts] (reverseFL us) pr chosen
#else
                        (conflicts, Sealed merge) <- filterOutConflicts (reverseFL us) pr chosen
#endif

                        if conflicts || lengthFL merge < length ps
                            then do
                                flip warn s . unwords $
                                    [ "Patches for fork"
                                    , "\"" ++ rOwner r ++ "/" ++ rName r ++ "\""
                                    , "could not be applied cleanly and have been skipped."
                                    ]
                                return False
                            else do

                        checkPaths [] merge

#ifdef DARCS28
                        Sealed pw <- tentativelyMergePatches pr "pull" [] us merge
#else
                        Sealed pw <- tentativelyMergePatches pr "pull" DRF.NoAllowConflicts DRF.YesUpdateWorking DRF.NoExternalMerge DRF.NoWantGuiPause DRF.GzipCompression DRF.NormalVerbosity (DRF.UseIndex, DRF.ScanKnown) us merge
#endif
                        invalidateIndex pr
#ifdef DARCS28
                        withGutsOf pr $ do
                            finalizeRepositoryChanges pr
                            applyToWorking pr [] pw
                            return ()
#else
                        finalizeRepositoryChanges pr DRF.YesUpdateWorking DRF.GzipCompression
                        applyToWorking pr DRF.NormalVerbosity pw
#endif
                        return True
  where
    origin p = repoDir (rOwner p) (rName p)
    fork = repoDir (rOwner r) (rName r)

canView :: Maybe String -> Repository -> Bool
canView _ Repository{rIsPrivate=False} = True
canView (Just user) r | user == rOwner r || user `elem` rMembers r = True
canView _ _ = False

canMerge :: Maybe String -> Repository -> Bool
canMerge Nothing _     = False
canMerge (Just user) r = user == rOwner r || user `elem` rMembers r