--  Copyright (C) 2002-2014 David Roundy, Petr Rockai, Owen Stephens
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

{-# LANGUAGE OverloadedStrings #-}

module Darcs.UI.Commands.Convert.Export ( convertExport ) where

import Darcs.Prelude hiding ( readFile, lex )

import Control.Exception (finally)
import Control.Monad (forM_, unless, void, when)
import Control.Monad.State.Strict (gets)
import Control.Monad.Trans (liftIO)

import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.ByteString.Lazy.UTF8 as BLU
import Data.Char (isSpace)
import Data.IORef (modifyIORef, newIORef, readIORef)
import Data.Maybe (catMaybes, fromJust)
import System.Time (toClockTime)

import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )
import Darcs.Patch ( RepoPatch, apply, effect, listTouchedFiles )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Effect ( Effect )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..)
    , nullFL
    )
import Darcs.Patch.Witnesses.Sealed
    ( FlippedSeal(..)
    , flipSeal
    , unsealFlipped
    )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )

import Darcs.Patch.Info
    ( PatchInfo
    , isTag
    , piAuthor
    , piDate
    , piLog
    , piName
    )
import Darcs.Patch.RepoType ( IsRepoType(..) )
import Darcs.Patch.Set ( patchSet2FL, inOrderTags )

import Darcs.Repository
    ( RepoJob(..)
    , Repository
    , readRepo
    , repoCache
    , withRepository
    )
import Darcs.Repository.Cache (HashedDir(HashedPristineDir))
import Darcs.Repository.Pristine (readHashedPristineRoot)
import Darcs.Repository.HashedIO (cleanHashdir)
import Darcs.Repository.Paths (pristineDirPath)

import Darcs.UI.Commands
    ( DarcsCommand(..)
    , amInRepository
    , nodefaults
    , withStdOpts
    )
import Darcs.UI.Commands.Convert.Util
    ( Marks
    , addMark
    , emptyMarks
    , getMark
    , lastMark
    , readMarks
    , writeMarks
    , patchHash
    )
import Darcs.UI.Completion (noArgs)
import Darcs.UI.Flags ( DarcsFlag , useCache )
import Darcs.UI.Options
    ( (?)
    , (^)
    , defaultFlags
    , ocheck
    , odesc
    , parseFlags
    )
import qualified Darcs.UI.Options.All as O

import Darcs.Util.DateTime ( formatDateTime, fromClockTime )
import Darcs.Util.Path
    ( AbsolutePath
    , AnchoredPath(..)
    , anchorPath
    , appendPath
    )
import Darcs.Util.Printer ( Doc, text )
import Darcs.Util.Tree
    ( Tree
    , emptyTree
    , findTree
    , listImmediate
    )
import Darcs.Util.Tree.Hashed ( hashedTreeIO )

import Darcs.Util.Tree.Monad ( TreeIO )
import qualified Darcs.Util.Tree.Monad as T
    ( directoryExists
    , fileExists
    , readFile
    , tree
    )


convertExportHelp :: Doc
convertExportHelp :: Doc
convertExportHelp = [Char] -> Doc
text forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
 [ [Char]
"This command enables you to export darcs repositories into git."
 , [Char]
""
 , [Char]
"For a one-time export you can use the recipe:"
 , [Char]
""
 , [Char]
"    $ cd repo"
 , [Char]
"    $ git init ../mirror"
 , [Char]
"    $ darcs convert export | (cd ../mirror && git fast-import)"
 , [Char]
""
 , [Char]
"For incremental export using marksfiles:"
 , [Char]
""
 , [Char]
"    $ cd repo"
 , [Char]
"    $ git init ../mirror"
 , [Char]
"    $ touch ../mirror/git.marks"
 , [Char]
"    $ darcs convert export --read-marks darcs.marks --write-marks darcs.marks"
 , [Char]
"       | (cd ../mirror && git fast-import --import-marks=git.marks --export-marks=git.marks)"
 , [Char]
""
 , [Char]
"In the case of incremental export, be careful to never amend, delete or"
 , [Char]
"reorder patches in the source darcs repository."
 , [Char]
""
 , [Char]
"Also, be aware that exporting a darcs repo to git will not be exactly"
 , [Char]
"faithful in terms of history if the darcs repository contains conflicts."
 , [Char]
""
 , [Char]
"Limitations:"
 , [Char]
""
 , [Char]
"  * Empty directories are not supported by the fast-export protocol."
 , [Char]
"  * Unicode filenames are currently not correctly handled."
 , [Char]
"    See http://bugs.darcs.net/issue2359 ."
 ]

convertExport :: DarcsCommand
convertExport :: DarcsCommand
convertExport = DarcsCommand
    { commandProgramName :: [Char]
commandProgramName = [Char]
"darcs"
    , commandName :: [Char]
commandName = [Char]
"export"
    , commandHelp :: Doc
commandHelp = Doc
convertExportHelp
    , commandDescription :: [Char]
commandDescription = [Char]
"Export a darcs repository to a git-fast-import stream"
    , commandExtraArgs :: Int
commandExtraArgs = Int
0
    , commandExtraArgHelp :: [[Char]]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
fastExport
    , commandPrereq :: [DarcsFlag] -> IO (Either [Char] ())
commandPrereq = [DarcsFlag] -> IO (Either [Char] ())
amInRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [[Char]] -> IO [[Char]]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [[Char]] -> IO [[Char]]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [[Char]] -> IO [[Char]]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [[Char]] -> IO [[Char]]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
convertExportAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> a)
convertExportBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
  a
  (Maybe [Char]
   -> Maybe [Char]
   -> Maybe [Char]
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
convertExportOpts
    , commandCheckOptions :: [DarcsFlag] -> [[Char]]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [[Char]]
ocheck forall {a}.
DarcsOption
  a
  (Maybe [Char]
   -> Maybe [Char]
   -> Maybe [Char]
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
convertExportOpts
    }
  where
    convertExportBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> a)
convertExportBasicOpts = PrimDarcsOption (Maybe [Char])
O.repoDir forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ forall a. DarcsOption a (Maybe [Char] -> Maybe [Char] -> a)
O.marks
    convertExportAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
convertExportAdvancedOpts = forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
O.network
    convertExportOpts :: DarcsOption
  a
  (Maybe [Char]
   -> Maybe [Char]
   -> Maybe [Char]
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
convertExportOpts = forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> a)
convertExportBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
convertExportAdvancedOpts

fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
fastExport (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [[Char]]
_ = do
  Marks
marks <- case forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption (Maybe [Char])
O.readMarks [DarcsFlag]
opts of
    Maybe [Char]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Marks
emptyMarks
    Just [Char]
f  -> [Char] -> IO Marks
readMarks [Char]
f
  Marks
newMarks <-
    forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$ forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repo -> forall (rt :: RepoType) (p :: * -> * -> *) r u.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p r u r -> Marks -> IO Marks
fastExport' Repository rt p wR wU wR
repo Marks
marks
  case forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption (Maybe [Char])
O.writeMarks [DarcsFlag]
opts of
    Maybe [Char]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just [Char]
f  -> [Char] -> Marks -> IO ()
writeMarks [Char]
f Marks
newMarks

fastExport' :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
            => Repository rt p r u r -> Marks -> IO Marks
fastExport' :: forall (rt :: RepoType) (p :: * -> * -> *) r u.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p r u r -> Marks -> IO Marks
fastExport' Repository rt p r u r
repo Marks
marks = do
  [Char] -> IO ()
putStrLn [Char]
"progress (reading repository)"
  PatchSet rt p Origin r
patchset <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p r u r
repo
  IORef Marks
marksref <- forall a. a -> IO (IORef a)
newIORef Marks
marks
  let patches :: FL (PatchInfoAnd rt p) Origin r
patches = forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet rt p Origin r
patchset
      tags :: [PatchInfo]
tags = forall (rt :: RepoType) (p :: * -> * -> *) wS wX.
PatchSet rt p wS wX -> [PatchInfo]
inOrderTags PatchSet rt p Origin r
patchset
      mark :: (PatchInfoAnd rt p) x y -> Int -> TreeIO ()
      mark :: forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> Int -> TreeIO ()
mark PatchInfoAnd rt p x y
p Int
n = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"mark :" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
n
                             forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Marks
marksref forall a b. (a -> b) -> a -> b
$ \Marks
m -> Marks -> Int -> ByteString -> Marks
addMark Marks
m Int
n (forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash PatchInfoAnd rt p x y
p)
      -- apply a single patch to build the working tree of the last exported version
      checkOne :: (RepoPatch p, ApplyState p ~ Tree)
               => Int -> (PatchInfoAnd rt p) x y -> TreeIO ()
      checkOne :: forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int -> PatchInfoAnd rt p x y -> TreeIO ()
checkOne Int
n PatchInfoAnd rt p x y
p = do forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply PatchInfoAnd rt p x y
p
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p x y
p Bool -> Bool -> Bool
||
                                (Marks -> Int -> Maybe ByteString
getMark Marks
marks Int
n forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash PatchInfoAnd rt p x y
p))) forall a b. (a -> b) -> a -> b
$
                          forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"FATAL: Marks do not correspond: expected " forall a. [a] -> [a] -> [a]
++
                                 forall a. Show a => a -> [Char]
show (Marks -> Int -> Maybe ByteString
getMark Marks
marks Int
n) forall a. [a] -> [a] -> [a]
++ [Char]
", got " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BC.unpack (forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash PatchInfoAnd rt p x y
p)
      -- build the working tree of the last version exported by convert --export
      check :: (RepoPatch p, ApplyState p ~ Tree)
            => Int -> FL (PatchInfoAnd rt p) x y -> TreeIO (Int,  FlippedSeal( FL (PatchInfoAnd rt p)) y) 
      check :: forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
check Int
_ FL (PatchInfoAnd rt p) x y
NilFL = forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1, forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
      check Int
n allps :: FL (PatchInfoAnd rt p) x y
allps@(PatchInfoAnd rt p x wY
p:>:FL (PatchInfoAnd rt p) wY y
ps)
        | Int
n forall a. Ord a => a -> a -> Bool
<= Marks -> Int
lastMark Marks
marks = forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int -> PatchInfoAnd rt p x y -> TreeIO ()
checkOne Int
n PatchInfoAnd rt p x wY
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
check (forall (p :: * -> * -> *) (rt :: RepoType) x y.
Effect p =>
[PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next [PatchInfo]
tags Int
n PatchInfoAnd rt p x wY
p) FL (PatchInfoAnd rt p) wY y
ps
        | Int
n forall a. Ord a => a -> a -> Bool
> Marks -> Int
lastMark Marks
marks = forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n, forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd rt p) x y
allps)
        | Marks -> Int
lastMark Marks
marks forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1, forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd rt p) x y
allps)
        | Bool
otherwise = forall a. HasCallStack => a
undefined
  ((Int
n, FlippedSeal (FL (PatchInfoAnd rt p)) r
patches'), Tree IO
tree') <- forall a. TreeIO a -> Tree IO -> [Char] -> IO (a, Tree IO)
hashedTreeIO (forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
check Int
1 FL (PatchInfoAnd rt p) Origin r
patches) forall (m :: * -> *). Tree m
emptyTree [Char]
pristineDirPath
  let patches'' :: FL (PatchInfoAnd rt p) wB wC
patches'' = forall (a :: * -> * -> *) b wZ.
(forall wX wY. a wX wY -> b) -> FlippedSeal a wZ -> b
unsealFlipped forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP FlippedSeal (FL (PatchInfoAnd rt p)) r
patches'
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. TreeIO a -> Tree IO -> [Char] -> IO (a, Tree IO)
hashedTreeIO (forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
[PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO ()
dumpPatches [PatchInfo]
tags forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> Int -> TreeIO ()
mark Int
n forall {wB} {wC}. FL (PatchInfoAnd rt p) wB wC
patches'') Tree IO
tree' [Char]
pristineDirPath
  forall a. IORef a -> IO a
readIORef IORef Marks
marksref
 forall a b. IO a -> IO b -> IO a
`finally` do
  [Char] -> IO ()
putStrLn [Char]
"progress (cleaning up)"
  Maybe PristineHash
current <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Maybe PristineHash)
readHashedPristineRoot Repository rt p r u r
repo
  Cache -> HashedDir -> [PristineHash] -> IO ()
cleanHashdir (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p r u r
repo) HashedDir
HashedPristineDir forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe PristineHash
current]
  [Char] -> IO ()
putStrLn [Char]
"progress done"

dumpPatches ::  (RepoPatch p, ApplyState p ~ Tree)
            =>  [PatchInfo]
            -> (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ())
            -> Int -> FL (PatchInfoAnd rt p) x y -> TreeIO ()
dumpPatches :: forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
[PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO ()
dumpPatches [PatchInfo]
_ forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
_ Int
_ FL (PatchInfoAnd rt p) x y
NilFL = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"progress (patches converted)"
dumpPatches [PatchInfo]
tags forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark Int
n (PatchInfoAnd rt p x wY
p:>:FL (PatchInfoAnd rt p) wY y
ps) = do
  forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply PatchInfoAnd rt p x wY
p
  if forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p x wY
p Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
> Int
0
     then forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpTag PatchInfoAnd rt p x wY
p Int
n
     else do forall (rt :: RepoType) (p :: * -> * -> *) x y.
(forall (p0 :: * -> * -> *) x0 y0.
 PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpPatch forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark PatchInfoAnd rt p x wY
p Int
n
             [AnchoredPath] -> TreeIO ()
dumpFiles forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles PatchInfoAnd rt p x wY
p
  forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
[PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO ()
dumpPatches [PatchInfo]
tags forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark (forall (p :: * -> * -> *) (rt :: RepoType) x y.
Effect p =>
[PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next [PatchInfo]
tags Int
n PatchInfoAnd rt p x wY
p) FL (PatchInfoAnd rt p) wY y
ps

dumpTag :: (PatchInfoAnd rt p) x y  -> Int -> TreeIO () 
dumpTag :: forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpTag PatchInfoAnd rt p x y
p Int
n =
  [ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"progress TAG " forall a. [a] -> [a] -> [a]
++ forall {rt :: RepoType} {p :: * -> * -> *} {wA} {wB}.
PatchInfoAndG rt p wA wB -> [Char]
cleanTagName PatchInfoAnd rt p x y
p
           , [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"tag " forall a. [a] -> [a] -> [a]
++ forall {rt :: RepoType} {p :: * -> * -> *} {wA} {wB}.
PatchInfoAndG rt p wA wB -> [Char]
cleanTagName PatchInfoAnd rt p x y
p -- FIXME is this valid?
           , [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"from :" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
n forall a. Num a => a -> a -> a
- Int
1)
           , [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]
"tagger", forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> [Char]
patchAuthor PatchInfoAnd rt p x y
p, forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> [Char]
patchDate PatchInfoAnd rt p x y
p]
           -- -3 == (-4 for "TAG " and +1 for newline)
           , [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"data "
                 forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ByteString -> Int64
BL.length (forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p) forall a. Num a => a -> a -> a
- Int64
3)
           , Int64 -> ByteString -> ByteString
BL.drop Int64
4 forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p ]
   where
     -- FIXME forbidden characters and subsequences in tags:
     -- https://www.kernel.org/pub/software/scm/git/docs/git-check-ref-format.html
     cleanTagName :: PatchInfoAndG rt p wA wB -> [Char]
cleanTagName = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
cleanup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
4 forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> [Char]
piName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info
         where cleanup :: Char -> Char
cleanup Char
x | Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
bad = Char
'_'
                         | Bool
otherwise = Char
x
               bad :: String
               bad :: [Char]
bad = [Char]
" ~^:"

dumpFiles :: [AnchoredPath] -> TreeIO ()
dumpFiles :: [AnchoredPath] -> TreeIO ()
dumpFiles [AnchoredPath]
files = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [AnchoredPath]
files forall a b. (a -> b) -> a -> b
$ \AnchoredPath
file -> do
  let quotedPath :: [Char]
quotedPath = [Char] -> [Char]
quotePath forall a b. (a -> b) -> a -> b
$ [Char] -> AnchoredPath -> [Char]
anchorPath [Char]
"" AnchoredPath
file
  Bool
isfile <- forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
T.fileExists AnchoredPath
file
  Bool
isdir <- forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
T.directoryExists AnchoredPath
file
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isfile forall a b. (a -> b) -> a -> b
$ do ByteString
bits <- forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m ByteString
T.readFile AnchoredPath
file
                   [ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"M 100644 inline " forall a. [a] -> [a] -> [a]
++ [Char]
quotedPath
                            , [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"data " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ByteString -> Int64
BL.length ByteString
bits)
                            , ByteString
bits ]
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isdir forall a b. (a -> b) -> a -> b
$ do -- Always delete directory before dumping its contents. This fixes
                  -- a corner case when a same patch moves dir1 to dir2, and creates
                  -- another directory dir1.
                  -- As we always dump its contents anyway this is not more costly.
                  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"D " forall a. [a] -> [a] -> [a]
++ [Char]
quotedPath
                  Tree IO
tt <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall (m :: * -> *). TreeState m -> Tree m
T.tree -- ick
                  let subs :: [AnchoredPath]
subs = [ AnchoredPath
file AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
n | (Name
n, TreeItem IO
_) <-
                                  forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree Tree IO
tt AnchoredPath
file ]
                  [AnchoredPath] -> TreeIO ()
dumpFiles [AnchoredPath]
subs
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isfile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isdir) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"D " forall a. [a] -> [a] -> [a]
++ [Char]
quotedPath
  where
    -- |quotePath escapes and quotes paths containing newlines, double-quotes
    -- or backslashes.
    quotePath :: FilePath -> String
    quotePath :: [Char] -> [Char]
quotePath [Char]
path = case forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ([Char], Bool) -> ([Char], Bool)
escapeChars ([Char]
"", Bool
False) [Char]
path of
        ([Char]
_, Bool
False) -> [Char]
path
        ([Char]
path', Bool
True) -> [Char] -> [Char]
quote [Char]
path'

    quote :: [Char] -> [Char]
quote [Char]
str = [Char]
"\"" forall a. [a] -> [a] -> [a]
++ [Char]
str forall a. [a] -> [a] -> [a]
++ [Char]
"\""

    escapeChars :: Char -> ([Char], Bool) -> ([Char], Bool)
escapeChars Char
c ([Char]
processed, Bool
haveEscaped) = case Char -> ([Char], Bool)
escapeChar Char
c of
        ([Char]
escaped, Bool
didEscape) ->
            ([Char]
escaped forall a. [a] -> [a] -> [a]
++ [Char]
processed, Bool
didEscape Bool -> Bool -> Bool
|| Bool
haveEscaped)

    escapeChar :: Char -> ([Char], Bool)
escapeChar Char
c = case Char
c of
        Char
'\n' -> ([Char]
"\\n", Bool
True)
        Char
'\r' -> ([Char]
"\\r", Bool
True)
        Char
'"'  -> ([Char]
"\\\"", Bool
True)
        Char
'\\' -> ([Char]
"\\\\", Bool
True)
        Char
_    -> ([Char
c], Bool
False)


dumpPatch ::  (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ())
          -> (PatchInfoAnd rt p) x y -> Int
          -> TreeIO ()
dumpPatch :: forall (rt :: RepoType) (p :: * -> * -> *) x y.
(forall (p0 :: * -> * -> *) x0 y0.
 PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpPatch forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark PatchInfoAnd rt p x y
p Int
n =
  do [ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"progress " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
n forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ PatchInfo -> [Char]
piName (forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p)
              , ByteString
"commit refs/heads/master" ]
     forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark PatchInfoAnd rt p x y
p Int
n
     [ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"committer " forall a. [a] -> [a] -> [a]
++ forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> [Char]
patchAuthor PatchInfoAnd rt p x y
p forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> [Char]
patchDate PatchInfoAnd rt p x y
p
              , [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"data " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ByteString -> Int64
BL.length forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p)
              , forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p ]
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ [ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"from :" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
n forall a. Num a => a -> a -> a
- Int
1) ]

dumpBits :: [BL.ByteString] -> TreeIO ()
dumpBits :: [ByteString] -> TreeIO ()
dumpBits = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
BLC.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> ByteString
BL.intercalate ByteString
"\n"

-- patchAuthor attempts to fixup malformed author strings
-- into format: "Name <Email>"
-- e.g.
-- <john@home>      -> john <john@home>
-- john@home        -> john <john@home>
-- john <john@home> -> john <john@home>
-- john <john@home  -> john <john@home>
-- <john>           -> john <unknown>
patchAuthor :: (PatchInfoAnd rt p) x y -> String
patchAuthor :: forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> [Char]
patchAuthor PatchInfoAnd rt p x y
p
 | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
author = [Char] -> [Char]
unknownEmail [Char]
"unknown"
 | Bool
otherwise = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'<') [Char]
author of
               -- No name, but have email (nothing spanned)
               ([Char]
"", [Char]
email) -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'@') (forall a. [a] -> [a]
tail [Char]
email) of
                   -- Not a real email address (no @).
                   ([Char]
n, [Char]
"") -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'>') [Char]
n of
                       ([Char]
name, [Char]
_) -> [Char] -> [Char]
unknownEmail [Char]
name
                   -- A "real" email address.
                   ([Char]
user, [Char]
rest) -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
'>') (forall a. [a] -> [a]
tail [Char]
rest) of
                       ([Char]
dom, [Char]
_) -> [Char] -> [Char] -> [Char]
mkAuthor [Char]
user forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
emailPad ([Char]
user forall a. [a] -> [a] -> [a]
++ [Char]
"@" forall a. [a] -> [a] -> [a]
++ [Char]
dom)
               -- No email (everything spanned)
               ([Char]
_, [Char]
"") -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'@') [Char]
author of
                   ([Char]
n, [Char]
"") -> [Char] -> [Char]
unknownEmail [Char]
n
                   ([Char]
name, [Char]
_) -> [Char] -> [Char] -> [Char]
mkAuthor [Char]
name forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
emailPad [Char]
author
               -- Name and email
               ([Char]
n, [Char]
rest) -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'>') forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [Char]
rest of
                   ([Char]
email, [Char]
_) -> [Char]
n forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
emailPad [Char]
email
 where
   author :: [Char]
author = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ PatchInfo -> [Char]
piAuthor (forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p)
   unknownEmail :: [Char] -> [Char]
unknownEmail = forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> [Char] -> [Char]
mkAuthor [Char]
"<unknown>"
   emailPad :: [Char] -> [Char]
emailPad [Char]
email = [Char]
"<" forall a. [a] -> [a] -> [a]
++ [Char]
email forall a. [a] -> [a] -> [a]
++ [Char]
">"
   mkAuthor :: [Char] -> [Char] -> [Char]
mkAuthor [Char]
name [Char]
email = [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
email

patchDate :: (PatchInfoAnd rt p) x y -> String
patchDate :: forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> [Char]
patchDate = [Char] -> UTCTime -> [Char]
formatDateTime [Char]
"%s +0000" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClockTime -> UTCTime
fromClockTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. CalendarTime -> ClockTime
toClockTime forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  PatchInfo -> CalendarTime
piDate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info

patchMessage :: (PatchInfoAnd rt p) x y -> BLU.ByteString
patchMessage :: forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p = [ByteString] -> ByteString
BL.concat [ [Char] -> ByteString
BLU.fromString (PatchInfo -> [Char]
piName forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p)
                           , case [[Char]] -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> [[Char]]
piLog forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p of
                                 [Char]
"" -> ByteString
BL.empty
                                 [Char]
plog -> [Char] -> ByteString
BLU.fromString ([Char]
"\n\n" forall a. [a] -> [a] -> [a]
++ [Char]
plog)
                           ]

inOrderTag :: (Effect p) => [PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag :: forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p wX wZ
p = PatchInfo -> Bool
isTag (forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wX wZ
p) Bool -> Bool -> Bool
&& forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wX wZ
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PatchInfo]
tags Bool -> Bool -> Bool
&& forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL (forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect PatchInfoAnd rt p wX wZ
p)

next :: (Effect p) => [PatchInfo] -> Int ->  PatchInfoAnd rt p x y -> Int
next :: forall (p :: * -> * -> *) (rt :: RepoType) x y.
Effect p =>
[PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next [PatchInfo]
tags Int
n PatchInfoAnd rt p x y
p = if forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p x y
p then Int
n else Int
n forall a. Num a => a -> a -> a
+ Int
1