{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}

module DPM.Core.Darcs (

  PatchBundleContent(..), ConflictMap,

  readPatchBundle, apply, getPatchesInRepo, conflictsBundleWithRepo

) where

import Prelude hiding (catch)
import qualified Data.ByteString as B (ByteString, init, null, readFile, length)
import qualified Data.ByteString.Char8 as BC (last)
import Data.Maybe (fromJust)
import System.FilePath (dropExtensions)
import Control.Exception (SomeException, ErrorCall(..), IOException,
                          handle, fromException, evaluate, catch, catches,
                          Handler(..))
import System.IO
import System.IO.Error (ioeGetErrorString)
import System.Process
import System.Exit
import System.Directory
import Control.Monad ( filterM, when )
import qualified Data.List as List
import Text.PrettyPrint
import Data.Convertible
import HSH

-- imports from darcs
import Progress ( setProgressMode )
import Darcs.Patch (RepoPatch, commute, invert, description)
import Darcs.Email (read_email)
import Darcs.Commands (commandCommand)
import qualified Darcs.Commands.Apply
import Darcs.External (signString, verifyPS)
import Darcs.Flags (DarcsFlag(Unified, WorkRepoDir, FixFilePath, Quiet, Verbose,
                              NoAllowConflicts, Interactive, Test, OnePattern))
import Darcs.Patch.MatchData ( PatchMatch(..) )
import Darcs.Hopefully (PatchInfoAnd, hopefully, info, n2pia,
                        conscientiously)
import Darcs.Witnesses.Ordered (FL(..), RL(..), MyEq(unsafeCompare), mapFL_FL,
                                  mapRL_RL, concatRL, (:>)(..), (:\/:)(..),
                                  mapFL, mapRL, reverseRL,
                                  unsafeUnRL)
import Darcs.Patch.Bundle (make_bundle, scan_bundle)
import Darcs.Patch.Depends (get_common_and_uncommon_or_missing)
import Darcs.Patch.Info (PatchInfo(..), human_friendly,
                         make_filename, pi_author, pi_date, pi_log, pi_name)
import Darcs.RepoPath (AbsolutePath, makeAbsolute, FilePathLike(..),
                       rootDirectory)
import Darcs.Repository (Repository)
import Darcs.Repository.Merge (considerMergeToWorking)
import Darcs.Repository.Internal (SealedPatchSet, read_repo,
                                  slurp_recorded, withRepositoryDirectory)
import Darcs.Witnesses.Sealed (Sealed(..))
import Darcs.Patch.Prim (fromPrim)
import qualified Printer as P (errorDoc, text, ($$), renderPS)
import ByteStringUtils (linesPS, unlinesPS)

-- DPM imports
import DPM.Core.DataTypes (PatchData(..), Patch(..), SimplePatch(..),
                           PatchID(PatchID), unPatchID,
                           PatchGroupID(PatchGroupID),
                           PatchState(PatchStateUNDECIDED))
import DPM.Core.Utils ( execCommand )

data DependsOn a = DependsOn { do_patch :: a
                             , do_directDeps :: [a]
                             , do_transDeps :: [a] }
                 deriving Show

type ConflictMap = [(PatchID, [PatchID])]

makePatch :: RepoPatch p => ConflictMap -> DependsOn (PatchInfoAnd p) -> Patch
makePatch conflicts (DependsOn p ps _) =
    let i = info p
        pid = getPatchID p
    in Patch { p_id         = pid
             , p_date       = convert $ pi_date i
             , p_name       = PatchGroupID (pi_name i)
             , p_author     = pi_author i
             , p_darcsLog   = pi_log i
             , p_log        = []
             , p_inverted   = is_inverted i
             , p_state      = PatchStateUNDECIDED
             , p_tags       = []
             , p_dependents = map getPatchID ps
             }

computeDependencies :: RepoPatch p => FL (PatchInfoAnd p)
                    -> [DependsOn (PatchInfoAnd p)]
computeDependencies fl = worker fl []
    where worker NilFL deps = reverse deps
          worker (p :>: ps) deps =
              let (rdir, rtrans) = getDeps p deps
                  directDeps = reverse rdir
                  transDeps = List.nubBy unsafeCompare $ reverse rtrans
              in worker ps (DependsOn p directDeps transDeps : deps)
          getDeps :: RepoPatch p => PatchInfoAnd p
                  -> [DependsOn (PatchInfoAnd p)]
                  -> ([PatchInfoAnd p], [PatchInfoAnd p])
          getDeps p [] = ([], [])
          getDeps p (DependsOn q qs qsTrans : rest) =
              case commute (q :> p) of
                 Just _ ->  -- p does NOT depend on q
                     getDeps p rest
                 Nothing -> -- p depends on q
                     let rest' = filter (\ (DependsOn x _ _) ->
                                           not (any (unsafeCompare x) qs))
                                        rest
                         (otherDirect, otherTrans) = getDeps p rest'
                     in (q : otherDirect, q : qsTrans ++ otherTrans)

takeFL _ NilFL = NilFL
takeFL n (x:>:xs) | n <= 0 = NilFL
                  | otherwise = x :>: (takeFL (n-1) xs)

getPatchID :: RepoPatch p => PatchInfoAnd p -> PatchID
getPatchID p = PatchID (dropExtensions $ make_filename (info p))

exceptionAsString :: SomeException -> String
exceptionAsString e =
    case fromException e of
      Just (ErrorCall s) -> s
      _ ->
          case fromException e of
            Just (ioExc :: IOException) ->
                ioeGetErrorString ioExc
            _ -> show e

computeConflicts :: (RepoPatch p) => Repository p -> [PatchData]
                 -> FL (PatchInfoAnd p)
                 -> IO ConflictMap
computeConflicts repository possibleConflicts fl =
    return $ mapFL (\p -> (getPatchID p, [])) fl
-- FIXME: implement properly
{-
    do patches <- mapM asPatch possibleConflicts
       worker patches fl
    where
      worker _ NilFL = return []
      worker patches (p :>: ps) =
          do conflicts <- filterM (hasConflicts p) patches
             rest <- worker patches ps
             return $ (getPatchID p, map getPatchID conflicts) : rest
      opts = [NoAllowConflicts, Quiet]
      asPatch pd =
          do eitherP <- get_patch_bundle opts (pd_content pd)
             case eitherP of
               Right (Sealed ((t:<:_):<:_)) -> return t
               Left err -> fail err
      hasConflicts p1 p2 =
          do Sealed prim <- considerMergeToWorking repository
                                                   "'dpm[computeConflicts]'"
                                                   opts
                                                   (singleFL p1)
                                                   (singleFL p2)
             case prim of
               NilFL -> return True
               _ -> return False
          `catch` (\(e::SomeException) -> return True)
-}

singleFL :: a -> FL a
singleFL x = x :>: NilFL

-- FIXME: meta information (location of individual patches in the bundle ...)
-- missing
data PatchBundleContent = PatchBundleContent { pbc_patches   :: [Patch]
                                             , pbc_conflicts :: ConflictMap }
                        deriving Show

processPatchBundle :: forall a . String -> [DarcsFlag] -> B.ByteString
                   ->  (forall p . RepoPatch p =>
                                   Repository p
                                -> [PatchInfo]           -- common patches
                                -> RL (PatchInfoAnd p)   -- extra repo patches
                                -> FL (PatchInfoAnd p)   -- bundle patches
                                -> IO a)
                   -> IO a
processPatchBundle repoDir opts bundleData fun =
    bracketCD repoDir (withRepositoryDirectory opts "." run)
    where
      run :: RepoPatch p => Repository p -> IO a
      run repository = do
        let ps = bundleData
        repoPatches <- read_repo repository
        bundlePatchesEither <- get_patch_bundle opts ps
        bundlePatches <- case bundlePatchesEither of
          Right (Sealed t) -> return t
          Left err -> fail err
        (common, repoPatches':\/:bundlePatches') <-
            case get_common_and_uncommon_or_missing (repoPatches, bundlePatches)
            of
              Left pinfo ->
                  if pinfo `elem` mapRL info (concatRL repoPatches)
                  then cannotApplyPartialRepo pinfo ""
                  else cannotApplyMissing pinfo
              Right x -> return x
        let bundlePatches'' =
                mapFL_FL (n2pia . conscientiously
                          (P.text ("We cannot process this patch "
                                   ++ "bundle, since we're "
                                   ++ "missing:") P.$$))
                       $ reverseRL $ bundlePatches'
        fun repository common repoPatches' bundlePatches''
      cannotApplyMissing pinfo
               = P.errorDoc $ P.text ("Cannot apply this patch bundle, "
                                      ++ "since we're missing:")
                           P.$$ human_friendly pinfo
      cannotApplyPartialRepo pinfo e
               = P.errorDoc $ P.text ("Cannot apply this patch bundle, "
                                      ++ "this is a \"--partial repository")
                         P.$$ P.text "We don't have the following patch:"
                         P.$$ human_friendly pinfo P.$$ P.text e

conflictsBundleWithRepo :: String -> B.ByteString -> IO Bool
conflictsBundleWithRepo repoDir bundleData = return False
{- FIXME: implement properly
    do setProgressMode False
       let opts = [NoAllowConflicts]
       handle (\(e::SomeException) -> return True) $
         processPatchBundle repoDir opts bundleData $
           \repository common repoPatches bundlePatches ->
               do considerMergeToWorking repository
                               "dpm[conflictsBundleWithRepo]"
                               opts
                               (reverseRL $ head $ unsafeUnRL repoPatches)
                               bundlePatches
                  return False
-}

readPatchBundle :: String -> B.ByteString
                -> IO (Either String PatchBundleContent)
readPatchBundle repoDir bundleData =
    do setProgressMode True
       let opts = []
       handle (\ e -> return (Left (exceptionAsString e))) $
         processPatchBundle repoDir opts bundleData $
           \repository common repoPatches bundlePatches ->
             do let deps = computeDependencies bundlePatches
                conflicts <- return []
                -- conflicts <- computeConflicts repository possibleConflicts
                --                               bundlePatches
                let res = PatchBundleContent {
                            pbc_patches = map (makePatch conflicts) deps,
                            pbc_conflicts = conflicts
                          }
                -- force the patches to reveal errors lazily embedded inside
                -- them
                forceResult res
                return $ Right res
         where
           forceResult res =
                do mapM forcePatch (pbc_patches res)
                   forceConflicts (pbc_conflicts res)
           forcePatch p =
               do evaluate $ length $ unPatchID (p_id p)
                  return p
           forceConflicts = evaluate . length . show

get_patch_bundle :: RepoPatch p => [DarcsFlag] -> B.ByteString
                 -> IO (Either String (SealedPatchSet p))
get_patch_bundle opts fps = do
    mps <- verifyPS opts $ read_email fps
    mops <- verifyPS opts fps
    case (mps, mops) of
      (Nothing, Nothing) ->
          return $ Left "Patch bundle not properly signed, or gpg failed."
      (Just ps, Nothing) -> return $ scan_bundle ps
      (Nothing, Just ps) -> return $ scan_bundle ps
      -- We use careful_scan_bundle only below because in either of the two
      -- above case we know the patch was signed, so it really shouldn't
      -- need stripping of CRs.
      (Just ps1, Just ps2) -> case careful_scan_bundle ps1 of
                              Left _ -> return $ careful_scan_bundle ps2
                              Right x -> return $ Right x
          where careful_scan_bundle ps =
                    case scan_bundle ps of
                    Left e -> case scan_bundle $ stripCrPS ps of
                              Right x -> Right x
                              _ -> Left e
                    x -> x
                stripCrPS :: B.ByteString -> B.ByteString
                stripCrPS ps = unlinesPS $ map stripline $ linesPS ps
                stripline p | B.null p = p
                            | BC.last p == '\r' = B.init p
                            | otherwise = p

apply :: FilePath -> Doc -> PatchID -> Bool -> Bool -> FilePath
      -> IO (Either String ())
apply repoDir patchName patchID runTests interactive patchFile =
    do setProgressMode False
       cur <- getCurrentDirectory
       let current = makeAbsolute rootDirectory cur
           opts = [FixFilePath current current, NoAllowConflicts] ++
                  (if runTests then [Test] else []) ++
                  (if interactive
                      then [Interactive]
                      else [OnePattern (PatternMatch ("hash " ++
                                                      unPatchID patchID))])
           args = [patchFile]
       when interactive $
            do putStrLn ("Using darcs interactive apply command for "
                         ++ "the following patch:")
               putStrLn (show patchName)
               putStrLn ""
       bracketCD repoDir $
           do commandCommand Darcs.Commands.Apply.apply opts args
              hFlush stdout
              hFlush stderr
              return (Right ())
       `catches`
       [Handler (\(e::ExitCode) ->
                     case e of
                       ExitSuccess -> return $ Right ()
                       ExitFailure n ->
                           return $ Left ("darcs exited with exit code " ++
                                          show n))
       ,Handler (\e -> return $ Left (exceptionAsString e))]

makeSimplePatch :: RepoPatch p => PatchInfoAnd p -> SimplePatch
makeSimplePatch p =
    let i = info p
    in SimplePatch { sp_id         = getPatchID p
                   , sp_date       = convert $ pi_date i
                   , sp_name       = PatchGroupID (pi_name i)
                   , sp_author     = pi_author i
                   , sp_darcsLog   = pi_log i
                   , sp_inverted   = is_inverted i
                   }

getPatchesInRepo :: FilePath -> IO (Either String [SimplePatch])
getPatchesInRepo repoDir =
    do setProgressMode True
       let opts = []
       handle (\e -> return (Left (exceptionAsString e))) $
         withRepositoryDirectory opts repoDir $ \repository ->
           do patches <- read_repo repository
              let l = mapRL makeSimplePatch (concatRL patches)
              mapM forceSimplePatch l
              return (Right l)
    where
      forceSimplePatch p =
          do evaluate $ unPatchID (sp_id p)
             return p