{-# 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
import Data.List ( (\\) )

-- imports from darcs
import Progress ( setProgressMode )
import Darcs.Patch (RepoPatch, commute, invert, description)
import Darcs.Email (readEmail)
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.Patch.Set ( PatchSet, newset2RL )
import Darcs.Hopefully (PatchInfoAnd, hopefully, hopefullyM, info, n2pia,
                        conscientiously)
import Darcs.Witnesses.Ordered (FL(..), RL(..), MyEq(unsafeCompare), mapFL_FL,
                                mapRL_RL, concatRL,
                                (:>)(..), (:>>)(..), (:\/:)(..),
                                mapFL, mapRL, reverseRL)
import Darcs.Patch.Bundle (makeBundle, scanBundle)
import Darcs.Patch.Info (PatchInfo(..), humanFriendly, isInverted,
                         makeFilename, piAuthor, piDate, piLog, piName)
import Darcs.RepoPath (AbsolutePath, makeAbsolute, FilePathLike(..),
                       rootDirectory)
import Darcs.Patch.Depends ( findUncommon, findCommonWithThem )
import Darcs.Repository (Repository)
import Darcs.Repository.Merge (considerMergeToWorking)
import Darcs.Repository.Internal (SealedPatchSet, readRepo,
                                  withRepositoryDirectory)
import Darcs.Witnesses.Sealed (Sealed(..))
import Darcs.Patch.Prim (fromPrim)
import qualified Printer as P (errorDoc, text, ($$), renderPS, renderString,
                               vcat)
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 $ piDate i
             , p_name       = PatchGroupID (piName i)
             , p_author     = piAuthor i
             , p_darcsLog   = piLog i
             , p_log        = []
             , p_inverted   = isInverted 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 $ makeFilename (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 :: forall p . RepoPatch p => Repository p -> IO a
      run repository = do
        let ps = bundleData
        repoPatches <- readRepo repository
        bundlePatchesEither <- getPatchBundle opts ps
        bundlePatches <- case bundlePatchesEither of
          Right (Sealed t) -> return t
          Left err -> fail err
        let ((common :: PatchSet p) :>> _) = findCommonWithThem repoPatches bundlePatches
        -- all patches that are in "them" and not in "common" need to
        -- be available; check that
        let common_i = mapRL info $ newset2RL common
            them_i = mapRL info $ newset2RL bundlePatches
            required = them_i \\ common_i -- FIXME quadratic?
            check :: RL (PatchInfoAnd p) -> [PatchInfo] -> IO ()
            check (p :<: ps') bad = case hopefullyM p of
              Nothing | info p `elem` required -> check ps' (info p : bad)
              _ -> check ps' bad
            check NilRL [] = return ()
            check NilRL bad = fail . P.renderString $ P.vcat $ map humanFriendly bad ++
                              [P.text "\nFATAL: Cannot apply this bundle. We are missing the above patches." ]
        check (newset2RL bundlePatches) []
        (repoPatches':\/:bundlePatches') <- return $ findUncommon repoPatches bundlePatches
        let bundlePatches'' =
                mapFL_FL (n2pia . conscientiously
                          (P.text ("We cannot process this patch "
                                   ++ "bundle, since we're "
                                   ++ "missing:") P.$$))
                       $ bundlePatches'
        fun repository bundlePatches''

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 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

getPatchBundle :: RepoPatch p => [DarcsFlag] -> B.ByteString
                 -> IO (Either String (SealedPatchSet p))
getPatchBundle opts fps = do
    mps <- verifyPS opts $ readEmail 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 $ scanBundle ps
      (Nothing, Just ps) -> return $ scanBundle ps
      -- We use careful_scanBundle 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_scanBundle ps1 of
                              Left _ -> return $ careful_scanBundle ps2
                              Right x -> return $ Right x
          where careful_scanBundle ps =
                    case scanBundle ps of
                    Left e -> case scanBundle $ 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 $ piDate i
                   , sp_name       = PatchGroupID (piName i)
                   , sp_author     = piAuthor i
                   , sp_darcsLog   = piLog i
                   , sp_inverted   = isInverted 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 <- readRepo repository
              let l = mapRL makeSimplePatch (newset2RL patches)
              mapM forceSimplePatch l
              return (Right l)
    where
      forceSimplePatch p =
          do evaluate $ unPatchID (sp_id p)
             return p