diff --git a/DPM.cabal b/DPM.cabal --- a/DPM.cabal +++ b/DPM.cabal @@ -1,5 +1,5 @@ Name: DPM -Version: 0.2.0 +Version: 0.2.1 License: GPL License-File: LICENSE Copyright: (c) 2009-2010 Stefan Wehr @@ -20,7 +20,6 @@ Stability: Beta Cabal-Version: >= 1.6 Build-Type: Simple -Tested-with: GHC==6.10.4, GHC==6.12.1 flag test description: Enable the test configuration: Build the test @@ -60,7 +59,14 @@ Executable dpm Main-Is: CommandlineMain.hs Hs-Source-Dirs: src - Other-Modules: DPM.Core.Lexer, DPM.Core.QueryParser + Other-Modules: DPM.Core.Lexer, DPM.Core.QueryParser, + DPM.Core.Conflicts, DPM.Core.DataTypes, DPM.Core.Model, + DPM.Core.ReverseDependencies, DPM.Core.TestDarcs, + DPM.Core.DPM_Monad, DPM.Core.Email, DPM.Core.PatchBundleParser, + DPM.Core.ShortID, DPM.Core.Utils, DPM.Core.Darcs, DPM.Core.Storage, + DPM.UI.Commandline.ANSIColors, DPM.UI.Commandline.CDPM_Monad, + DPM.UI.Commandline.Commands, DPM.UI.Commandline.Interaction, + DPM.UI.Commandline.Main Build-Depends: darcs >= 2.4 , bytestring >= 0.9 , time diff --git a/dist/build/dpm/dpm-tmp/DPM/Core/Lexer.hs b/dist/build/dpm/dpm-tmp/DPM/Core/Lexer.hs --- a/dist/build/dpm/dpm-tmp/DPM/Core/Lexer.hs +++ b/dist/build/dpm/dpm-tmp/DPM/Core/Lexer.hs @@ -1,11 +1,12 @@ {-# OPTIONS -fglasgow-exts -cpp #-} {-# LINE 1 "src/DPM/Core/Lexer.x" #-} + {-# OPTIONS_GHC -w #-} module DPM.Core.Lexer (scan, Token(..)) where #if __GLASGOW_HASKELL__ >= 603 #include "ghcconfig.h" -#else +#elif defined(__GLASGOW_HASKELL__) #include "config.h" #endif #if __GLASGOW_HASKELL__ >= 503 @@ -21,6 +22,99 @@ #else import GlaExts #endif +{-# LINE 1 "templates/wrappers.hs" #-} +{-# LINE 1 "templates/wrappers.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +{-# LINE 18 "templates/wrappers.hs" #-} + +-- ----------------------------------------------------------------------------- +-- The input type + +{-# LINE 35 "templates/wrappers.hs" #-} + +{-# LINE 51 "templates/wrappers.hs" #-} + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + +{-# LINE 74 "templates/wrappers.hs" #-} + +-- ----------------------------------------------------------------------------- +-- Default monad + +{-# LINE 162 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + +{-# LINE 251 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + + +type AlexInput = (Char,String) + +alexGetChar (_, []) = Nothing +alexGetChar (_, c:cs) = Just (c, (c,cs)) + +alexInputPrevChar (c,_) = c + +-- alexScanTokens :: String -> [token] +alexScanTokens str = go ('\n',str) + where go inp@(_,str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError _ -> error "lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act (take len str) : go inp' + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + +{-# LINE 297 "templates/wrappers.hs" #-} + +{-# LINE 322 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + +{-# LINE 339 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + +{-# LINE 354 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + alex_base :: AlexAddr alex_base = AlexA# "\xf8\xff\xff\xff\xfd\xff\xff\xff\x02\x00\x00\x00\x07\x00\x00\x00\x1f\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x30\x00\x00\x00"# @@ -36,6 +130,7 @@ alex_accept = listArray (0::Int,11) [[],[],[(AlexAcc (alex_action_0))],[],[],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))]] {-# LINE 18 "src/DPM/Core/Lexer.x" #-} + data Token = TSpecial -- ':' | TNot -- '^' | TAnd -- ' ' @@ -48,17 +143,18 @@ scan :: String -> [Token] scan = alexScanTokens -alex_action_0 = \_ -> TOr -alex_action_1 = \_ -> TAnd -alex_action_2 = \_ -> TSpecial -alex_action_3 = \_ -> TNot -alex_action_4 = \_ -> TOpen -alex_action_5 = \_ -> TClose -alex_action_6 = TString -{-# LINE 1 "GenericTemplate.hs" #-} +alex_action_0 = \_ -> TOr +alex_action_1 = \_ -> TAnd +alex_action_2 = \_ -> TSpecial +alex_action_3 = \_ -> TNot +alex_action_4 = \_ -> TOpen +alex_action_5 = \_ -> TClose +alex_action_6 = TString +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "" #-} {-# LINE 1 "" #-} -{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} -- ----------------------------------------------------------------------------- -- ALEX TEMPLATE -- @@ -68,9 +164,9 @@ -- ----------------------------------------------------------------------------- -- INTERNALS and main scanner engine -{-# LINE 35 "GenericTemplate.hs" #-} +{-# LINE 35 "templates/GenericTemplate.hs" #-} -{-# LINE 45 "GenericTemplate.hs" #-} +{-# LINE 45 "templates/GenericTemplate.hs" #-} data AlexAddr = AlexA# Addr# @@ -248,56 +344,3 @@ -- used by wrappers iUnbox (I# (i)) = i -{-# LINE 1 "wrappers.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "wrappers.hs" #-} --- ----------------------------------------------------------------------------- --- Alex wrapper code. --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- The input type - -{-# LINE 44 "wrappers.hs" #-} - --- ----------------------------------------------------------------------------- --- Default monad - -{-# LINE 126 "wrappers.hs" #-} - --- ----------------------------------------------------------------------------- --- Basic wrapper - - -type AlexInput = (Char,String) - -alexGetChar (_, []) = Nothing -alexGetChar (_, c:cs) = Just (c, (c,cs)) - -alexInputPrevChar (c,_) = c - --- alexScanTokens :: String -> [token] -alexScanTokens str = go ('\n',str) - where go inp@(_,str) = - case alexScan inp 0 of - AlexEOF -> [] - AlexError _ -> error "lexical error" - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> act (take len str) : go inp' - - --- ----------------------------------------------------------------------------- --- Posn wrapper - --- Adds text positions to the basic model. - -{-# LINE 163 "wrappers.hs" #-} - --- ----------------------------------------------------------------------------- --- GScan wrapper - --- For compatibility with previous versions of Alex, and because we can. - diff --git a/dist/build/dpm/dpm-tmp/DPM/Core/QueryParser.hs b/dist/build/dpm/dpm-tmp/DPM/Core/QueryParser.hs --- a/dist/build/dpm/dpm-tmp/DPM/Core/QueryParser.hs +++ b/dist/build/dpm/dpm-tmp/DPM/Core/QueryParser.hs @@ -229,7 +229,7 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "" #-} -{-# LINE 1 "" #-} +{-# LINE 1 "" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp diff --git a/src/DPM/Core/Conflicts.hs b/src/DPM/Core/Conflicts.hs new file mode 100644 --- /dev/null +++ b/src/DPM/Core/Conflicts.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module DPM.Core.Conflicts ( + + Conflicts, PatchConflicts, + + emptyConflicts, addConflict, getConflicts, addConflictWithRepo, + conflictsWithRepo + +) where + +import qualified Data.List as List +import Data.Data ( Data ) +import Data.Typeable ( Typeable ) + +import DPM.Core.DataTypes ( PatchID ) + +data Conflicts a = Conflicts { c_pairs :: [(a,a)] + , c_withRepo :: [a] } + deriving (Eq,Ord,Show,Read,Data,Typeable) + +type PatchConflicts = Conflicts PatchID + +emptyConflicts :: Ord a => Conflicts a +emptyConflicts = Conflicts [] [] + +addConflict :: Ord a => Conflicts a -> (a, a) -> Conflicts a +addConflict c p = if p `elem` c_pairs c then c + else c { c_pairs = (p : c_pairs c) } + +addConflictWithRepo :: Ord a => Conflicts a -> a -> Conflicts a +addConflictWithRepo c x = if x `elem` c_withRepo c then c + else c { c_withRepo = x : c_withRepo c } + +conflictsWithRepo :: Ord a => Conflicts a -> a -> Bool +conflictsWithRepo c x = x `elem` c_withRepo c + +getConflicts :: Ord a => Conflicts a -> a -> [a] +getConflicts c key = List.nub (worker (c_pairs c) []) + where worker [] acc = reverse acc + worker ((x,y):rest) acc = + let acc1 = if x == key then y:acc else acc + acc2 = if y == key then x:acc1 else acc1 + in worker rest acc2 diff --git a/src/DPM/Core/DPM_Monad.hs b/src/DPM/Core/DPM_Monad.hs new file mode 100644 --- /dev/null +++ b/src/DPM/Core/DPM_Monad.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} + +module DPM.Core.DPM_Monad ( + + DPMConfig(..), DPM, DPMException(..), + + runDPM, bracketDPM, failIO, asIO, liftIO, debugDPM, + + DPMConfigAccess(..) + +) where + +import Prelude hiding ( catch ) +import Control.Monad +import Control.Monad.Reader +import Control.Exception +import System.FilePath +import System.IO +import Data.Typeable + +data DPMConfig = DPMConfig { cfg_modelFile :: FilePath + , cfg_patchesFile :: FilePath + , cfg_dataDir :: FilePath + , cfg_currentUser :: String + , cfg_fromAddress :: String + , cfg_reviewAddress :: Maybe String + , cfg_patchLog :: FilePath + , cfg_patchGroupLog :: FilePath + , cfg_lockFile :: FilePath + , cfg_reviewDir :: FilePath + , cfg_repoDir :: FilePath + , cfg_debug :: Bool } + +newtype DPM a = DPM { unDPM :: (ReaderT DPMConfig IO a) } + +data DPMException = DPMException String + deriving (Show,Read,Eq,Typeable) + +instance Exception DPMException where + +instance Monad DPM where + DPM a >>= f = DPM (a >>= (unDPM . f)) + return = DPM . return + fail errMsg = liftIO' $ throwIO (DPMException errMsg) + +failIO :: String -> IO a +failIO errMsg = throwIO (DPMException errMsg) + +instance MonadIO DPM where + liftIO io = + do r <- liftIO' (do x <- io + return (Right x) + `catch` + (\(e::IOException) -> return (Left (show e)))) + case r of + Right x -> return x + Left err -> fail ("I/O command failed: " ++ err) + +liftIO' :: IO a -> DPM a +liftIO' io = DPM (liftIO io) + +runDPM :: DPMConfig -> DPM a -> IO a +runDPM cfg (DPM r) = runReaderT r cfg + +bracketDPM :: DPM a -> (a -> DPM c) -> (a -> DPM c) -> DPM c +bracketDPM acquire release doWork = + do config <- getDPMConfig + liftIO $ bracket (run acquire config) + (\x -> run (release x) config) + (\x -> run (doWork x) config) + where run = runReaderT . unDPM + +asIO :: DPM a -> DPM (IO a) +asIO (DPM x) = + do config <- getDPMConfig + return $ runReaderT x config + +class Monad m => DPMConfigAccess m where + getDPMConfig :: m DPMConfig + getDPMConfigValue :: (DPMConfig -> a) -> m a + getDPMConfigValue f = + do config <- getDPMConfig + return (f config) + +instance DPMConfigAccess DPM where + getDPMConfig = DPM ask + +debugDPM :: String -> DPM () +debugDPM s = + do b <- getDPMConfigValue cfg_debug + when b $ liftIO $ hPutStrLn stderr ("[DPM Debug] " ++ s) diff --git a/src/DPM/Core/Darcs.hs b/src/DPM/Core/Darcs.hs new file mode 100644 --- /dev/null +++ b/src/DPM/Core/Darcs.hs @@ -0,0 +1,347 @@ +{-# 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 diff --git a/src/DPM/Core/DataTypes.hs b/src/DPM/Core/DataTypes.hs new file mode 100644 --- /dev/null +++ b/src/DPM/Core/DataTypes.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module DPM.Core.DataTypes where + +import Data.Time ( UTCTime ) +import Data.ByteString ( ByteString ) +import Data.Data ( Data ) +import Data.Typeable ( Typeable ) + +newtype PatchID = PatchID { unPatchID :: String } + deriving (Eq,Ord,Show,Read,Data,Typeable) + +data PatchState = PatchStateUNDECIDED + | PatchStateAPPLIED + | PatchStateDISCARDED ReasonDiscarded + deriving (Eq,Ord,Show,Read,Data,Typeable) + +data ReasonDiscarded = ReasonRejected + | ReasonObsolete + deriving (Eq,Ord,Show,Read,Data,Typeable) + +isDiscarded :: PatchState -> Bool +isDiscarded (PatchStateDISCARDED _) = True +isDiscarded _ = False + +data PatchTag = TagReviewed + deriving (Eq,Ord,Show,Read) + +data Patch = Patch + { p_id :: PatchID + , p_date :: UTCTime + , p_name :: PatchGroupID + , p_author :: String + , p_darcsLog :: [String] + , p_log :: [LogEntry] + , p_inverted :: Bool + , p_state :: PatchState + , p_tags :: [PatchTag] + , p_dependents :: [PatchID] + } deriving (Eq,Ord,Show,Read) + +isReviewed :: Patch -> Bool +isReviewed p = TagReviewed `elem` p_tags p + +data SimplePatch = SimplePatch + { sp_id :: PatchID + , sp_date :: UTCTime + , sp_name :: PatchGroupID + , sp_author :: String + , sp_darcsLog :: [String] + , sp_inverted :: Bool + } deriving (Eq,Ord,Show,Read) + +data LogEntry = LogEntry { log_time :: UTCTime + , log_user :: String + , log_modelChanged :: Bool + , log_message :: String } + deriving (Eq,Ord,Show,Read) + +data PatchData = PatchData { pd_id :: PatchID + , pd_content :: ByteString } + deriving (Eq,Ord,Show,Read) + + +newtype PatchGroupID = PatchGroupID { unPatchGroupID :: String } + deriving (Eq,Ord,Show,Read,Data,Typeable) + +data PatchGroupState = PatchGroupOpen | PatchGroupClosed + deriving (Eq,Ord,Show,Read) + +data PatchGroup a = PatchGroup { pg_id :: PatchGroupID + , pg_state :: PatchGroupState + , pg_patches :: [a] + , pg_complete :: Bool } + deriving (Eq,Ord,Show,Read) + +data Query = + QPrim String + | QAnd Query Query + | QOr Query Query + | QNot Query + | QState PatchState + | QGroupState PatchGroupState + | QPatchID String + | QReviewed + | QTrue + | QFalse + deriving (Eq,Show) + +queryTrue :: Query +queryTrue = QTrue + +queryFalse :: Query +queryFalse = QFalse diff --git a/src/DPM/Core/Email.hs b/src/DPM/Core/Email.hs new file mode 100644 --- /dev/null +++ b/src/DPM/Core/Email.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module DPM.Core.Email ( + + sendEmail, sendEmailSimple, readDarcsEmail, tagSubject, + getEditorCommand + +) where + +import Prelude hiding ( catch ) +import Text.PrettyPrint +import Control.Exception +import System.Environment +import System.IO +import System.Exit +import System.Process +import System.Directory +import qualified Data.ByteString as B +import qualified Darcs.Email +import qualified Data.List as List +import Text.Regex.Posix ((=~)) + +import DPM.Core.DataTypes +import DPM.Core.DPM_Monad +import DPM.Core.Utils ( findCommand, formatTime, darcsDateFormat ) + +-- FIXME: make this customizable +atTagLookupTable :: [(String, String)] +atTagLookupTable = [("stefan|wehr|sw@umidev\\.de", "@sw") + ,("david|leuschner|dl@umidev\\.de", "@dl") + ,("dirk|spöri|spoeri|ds@umidev\\.de", "@ds") + ,("johannes|weiss|jw@umidev\\.de", "@jw") + ,("gero|kriependorf|gk@umidev\\.de", "@gk") + ,("harald|fischjer|hf@umidev\\.de", "@hf")] + +lookupAtTag :: String -> String +lookupAtTag author = + case List.find (\(pat, _) -> author =~ pat) atTagLookupTable of + Just (_, tag) -> tag + Nothing -> "" + +tagSubject :: String -> Maybe String -> String -> String +tagSubject task mauthor s = + let prefix = case mauthor of + Nothing -> "" + Just author -> + case lookupAtTag author of + "" -> "" + s -> s ++ " " + in prefix ++ "[DPM:" ++ task ++ "] " ++ s + +sendEmailSimple :: Patch -> String -> DPM () +sendEmailSimple patch task = + do user <- getDPMConfigValue cfg_currentUser + fromAddress <- getDPMConfigValue cfg_fromAddress + repo <- getDPMConfigValue cfg_repoDir + liftIO $ + sendEmail fromAddress + (p_author patch) + [] + (tagSubject task Nothing + (unPatchGroupID (p_name patch))) + (show + (text "User" <+> quote user <+> text task <+> + text " your patch:" + $$ text "" $$ + text (formatTime darcsDateFormat (p_date patch)) <+> + text (p_author patch) $$ + text " *" <+> text (unPatchGroupID (p_name patch)) + $$ text "" $$ + text "ID:" <+> text (unPatchID (p_id patch)) + $$ text "" $$ + text "Repository:" <+> text repo + $$ text "" $$ + text "So long, and thanks for all the patches!\n")) + [] + where quote s = text "'" <> text s <> text "'" + +-- FIXME: implement properly +sendEmail :: String -> String -> [String] + -> String -> String -> [FilePath] -> IO () +sendEmail from to ccs subject body attachements = + do tmpDir <- getTemporaryDirectory + (tmpFile, handle) <- openTempFile tmpDir "dpm-email" + hPutStrLn handle $ "From: " ++ from + hPutStrLn handle $ "To: " ++ to + mapM (\cc -> hPutStrLn handle $ "Cc: " ++ cc) ccs + hPutStrLn handle $ "Subject: " ++ subject + hPutStrLn handle "" + hPutStr handle body + hClose handle + let args = ["-x", "-H", tmpFile] ++ + concatMap (\a -> ["-a", a]) attachements + cmd = "mutt" + -- rawSystem cmd args + (ecode, out, err) <- readProcessWithExitCode cmd args "" + hPutStr stderr err + hPutStr stdout out + case ecode of + ExitSuccess -> + putStrLn $ "Email sent." + ExitFailure n -> + hPutStrLn stderr $ "Sending email failed with exit code " ++ show n + +getEditorCommand :: IO FilePath +getEditorCommand = + do editor <- getEnv "EDITOR" `catch` (\(_::SomeException) -> return "vi") + either <- findCommand editor + case either of + Left _ -> return "/usr/bin/vi" + Right x -> return x + +readDarcsEmail :: B.ByteString -> B.ByteString +readDarcsEmail = Darcs.Email.read_email + +-- Local Variables: +-- coding: utf-8 +-- End: diff --git a/src/DPM/Core/Model.hs b/src/DPM/Core/Model.hs new file mode 100644 --- /dev/null +++ b/src/DPM/Core/Model.hs @@ -0,0 +1,987 @@ +{-# LANGUAGE RankNTypes, DeriveDataTypeable, TypeSynonymInstances #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} + +module DPM.Core.Model ( + + Model, emptyModel, + + Patch, PatchID, PatchState(..), Partial, + + addPatch, markAsReviewed, markAsDiscarded, markAsDiscarded', + markAsUndecided, markAsApplied, + closePatchGroup, openPatchGroup, getPatches, allConflicts, + + p_id, p_state, p_dependents, p_isReviewed, + + allHTFTests + +) where + +-- +-- This module serves as the model for the operations of the DPM. +-- + +import qualified Data.Map as Map +import qualified Data.List as List +import qualified Data.Set as Set +import Data.List ( (\\) ) +import Data.Maybe ( isJust ) +import Control.Monad.Error +import Text.Regex.Posix +import Data.Maybe ( mapMaybe ) + +import Data.Generics ( everywhere, mkT, extT ) +import Data.Data ( Data ) +import Data.Typeable ( Typeable ) + +import Test.Framework hiding ( Filter ) +import Test.Framework.Pretty + +import DPM.Core.Utils hiding ( allHTFTests ) +import DPM.Core.DataTypes ( PatchID(..), PatchGroupID(..), + PatchState(..), ReasonDiscarded(..), + PatchGroupState(..), PatchGroup(..), + Query(..), + queryTrue, queryFalse, isDiscarded ) +import DPM.Core.Conflicts +-- +-- The types defining the model +-- + +type Map = Map.Map +type Set = Set.Set + +data Model = Model { + m_closedGroups :: [ClosedPatchGroup] + , m_openGroups :: Map PatchGroupID OpenPatchGroup + , m_conflicts :: PatchConflicts + } + deriving (Eq,Show,Read,Data,Typeable) + +emptyModel :: Model +emptyModel = Model [] Map.empty emptyConflicts + +data ClosedPatchGroup = ClosedPatchGroup { + cpg_name :: PatchGroupID + , cpg_patches :: Either (PatchList APPLIED) (PatchList UNDECIDED) + } + deriving (Eq,Show,Read,Data,Typeable) + +data OpenPatchGroup = OpenPatchGroup { + opg_patches :: PatchList UNDECIDED + } + deriving (Eq,Show,Read,Data,Typeable) + +data PatchList a = PatchList (Maybe (Patch a)) [Patch DISCARDED] + deriving (Eq,Show,Read,Data,Typeable) + +type PatchName = PatchGroupID + +data Patch a = Patch { + p_id :: PatchID + , p_state :: a + , p_dependents :: [PatchID] + , p_isReviewed :: Bool + } + deriving (Eq,Ord,Show,Read,Data,Typeable) + +{- State transitions for patches. The diagram omits self-loops. + + APPLIED <------ UNDECIDED <------> DISCARDED +-} + + +data UNDECIDED = UNDECIDED deriving (Eq,Show,Read,Data,Typeable) +data APPLIED = APPLIED deriving (Eq,Show,Read,Data,Typeable) +data DISCARDED = DISCARDED ReasonDiscarded deriving (Eq,Show,Read,Data,Typeable) + +class PATCH_STATE a where + patchState :: a -> PatchState + +instance PATCH_STATE UNDECIDED where + patchState _ = PatchStateUNDECIDED + +instance PATCH_STATE APPLIED where + patchState _ = PatchStateAPPLIED + +instance PATCH_STATE DISCARDED where + patchState (DISCARDED r) = PatchStateDISCARDED r + +-- +-- The primitive operations +-- + +type Partial a = Either String a + +-- | Adds a new patch to the model. The operation fails if any of the +-- IDs in the 3rd parameter does not exist in the model. +addPatch :: Model + -> PatchID -- ^ ID of the new patch + -> PatchGroupID -- ^ Name of the new patch + -> [PatchID] -- ^ IDs of the patches the new patch depends on + -> [PatchID] -- ^ IDs of the patches the new patch conflicts with + -> Bool -- ^ True iff the new patch conflicts with the repo + -> Partial Model +addPatch model pid pname deps conflicts repoConflict = + let eitherModel = addPatch' model (Patch pid UNDECIDED deps False) pname + in case eitherModel of + Left err -> Left err + Right model' -> + let c = m_conflicts model' + c' = foldl addConflict c (zip (cycle [pid]) conflicts) + c'' = if repoConflict then addConflictWithRepo c' pid else c' + in Right $ model' { m_conflicts = c'' } + +-- Only internally used. +addPatch' :: Model -> Patch UNDECIDED -> PatchName -> Partial Model +addPatch' model patch pname = + assertModel model $ + let allPIDs = allPatchIDs model + in case p_dependents patch \\ allPIDs of + l@(_:_) -> Left ("The dependencies " ++ show l ++ + " are not contained in the model") + [] -> if p_id patch `elem` allPIDs + then Right model + else let openGroups = m_openGroups model + group = case Map.lookup pname + openGroups of + Just (OpenPatchGroup patches) -> + {- DPM already manges patches with the + same name and none if + these patches is in status APPLIED -} + let patches' = patch `plCons` patches + in OpenPatchGroup patches' + Nothing -> + {- DPM does not manage any patches with + the same name or one of the patches + with the same name is in status + APPLIED -} + OpenPatchGroup (plSingleton patch) + in Right $ model { m_openGroups = + Map.insert pname + group openGroups } + +-- | The operation fails if the patch with the ID given does not exist. +markAsReviewed :: Model -> PatchID -> Partial Model +markAsReviewed model pid = + assertModelAndPID model pid $ + everywhere (mkT (markPatch UNDECIDED) + `extT` markPatch APPLIED + `extT` markPatch (DISCARDED ReasonRejected) + `extT` markPatch (DISCARDED ReasonObsolete)) + model + where + markPatch :: a -> Patch a -> Patch a + markPatch _ p | p_id p == pid = p { p_isReviewed = True } + | otherwise = p + +-- | Marks the patch with the ID given as DISCARDED. The operation +-- fails if the patch with the ID given is in state APPLIED or does +-- not exist. +markAsDiscarded :: Model -> PatchID -> ReasonDiscarded -> Partial Model +markAsDiscarded = markAsDiscarded' True + +-- | Marks the patch with the ID given as DISCARDED. The check parameter +-- specifies whether the operation fails if the patch with the ID +-- given is in state APPLIED. In any case, the operation fails if the +-- patch with the ID given does not exist. +markAsDiscarded' :: Bool -> Model -> PatchID -> ReasonDiscarded -> Partial Model +markAsDiscarded' check model pid reason = + assertModel model $ + case findPatchInModel model pid of + Left e -> Left e + Right p -> + if p_state p == PatchStateAPPLIED && check + then Left ("Patch with ID " ++ show pid ++ " is in state APPLIED") + else Right $ everywhere (mkT markInPatchList') $ + everywhere (mkT markInPatchList) $ + everywhere (mkT markPatch) model + where + markPatch :: Patch DISCARDED -> Patch DISCARDED + markPatch p | p_id p == pid = p { p_state = DISCARDED reason } + | otherwise = p + markInPatchList :: PatchList UNDECIDED -> PatchList UNDECIDED + markInPatchList pl@(PatchList mp l) = + case mp of + Just p | p_id p == pid -> + PatchList Nothing (p { p_state = DISCARDED reason } : l) + _ -> pl + markInPatchList' :: PatchList APPLIED -> PatchList APPLIED + markInPatchList' pl@(PatchList mp l) = + case mp of + Just p | p_id p == pid -> + PatchList Nothing (p { p_state = DISCARDED reason } : l) + _ -> pl + +-- | Marks the patch with the ID given as UNDECIDED. Suppose this patch is p. +-- +-- * If the patch is contained in a patch group without a head patch +-- then p becomes the new head patch. +-- +-- * If the patch is contained in a patch group whose head patch is +-- in state UNDECIDED then p becomes the new head patch and the old head +-- patch is marked as DISCARDED. +-- * If the patch is contained in a patch group whose head patch is +-- in state APPLIED then a new, open patch group is created consisting +-- of only p. +-- +-- The operation fails if p is in state APPLIED or there exists no +-- patch with the ID given does not exists. +markAsUndecided :: Model -> PatchID -> Partial Model +markAsUndecided model pid = + assertModel model $ + case findPatchInModel model pid of + Left e -> Left e + Right p -> + if p_state p == PatchStateAPPLIED + then Left ("Patch with ID " ++ show pid ++ " is in state APPLIED") + else + let model' = everywhere (mkT markInPatchList + `extT` + deleteFromPatchList) + model + in case findPatchGroupOf model pid of + Left e -> Left e + Right (Right _) -> Right model' + Right (Left cpg) -> + if isPatchGroupApplied cpg + then addPatch' model' + (p { p_state = UNDECIDED }) + (cpg_name cpg) + else Right model' + where + deleteFromPatchList :: PatchList APPLIED -> PatchList APPLIED + deleteFromPatchList (PatchList mp l) = + PatchList mp (foldr (\ p acc -> if p_id p == pid then acc else p:acc) + [] l) + markInPatchList :: PatchList UNDECIDED -> PatchList UNDECIDED + markInPatchList pl@(PatchList mp l) = + case foldr (\ p (x,acc) -> if p_id p == pid + then (Just p, acc) + else (x, p:acc)) + (Nothing, []) l + of + (Nothing, _) -> pl + (Just p, l') -> + PatchList (Just (p { p_state = UNDECIDED })) + (l' ++ (case mp of + Just p' -> [p' { p_state = DISCARDED + ReasonObsolete }] + Nothing -> [])) + +-- | The operation fails if the patch with the ID given is in state +-- DISCARDED. Further, it fails if there exists a patch +-- on with the patch with the given ID depends but which is not in +-- state APPLIED. +markAsApplied :: Model -> PatchID -> Partial Model +markAsApplied model pid = + assertModel model $ + case findPatchInModel model pid of + Left e -> Left e + Right p -> + case () of + _| isDiscarded (p_state p) -> + Left ("Patch with ID " ++ show pid ++ " is in state " ++ + show (p_state p)) + | any (not . isApplied) (p_dependents p) -> + Left ("Patch with ID " ++ show pid ++ + " depends at least on one unapplied patch") + | p_state p == PatchStateAPPLIED -> + Right model + | otherwise -> -- patch is in state UNDECIDED + case findPatchGroupOf model pid of + Left e -> error ("markAsApplied: unexpected error: " ++ e) + Right (Left closed) -> + Right $ everywhere (mkT markInClosedPatchGroup) model + Right (Right (name, open)) -> + Right $ model { + m_openGroups = Map.delete name + (m_openGroups model) + ,m_closedGroups = m_closedGroups model + ++ + [ClosedPatchGroup + name + (Left + (markInPatchList + (opg_patches open))) + ] + } + where + markInPatchList :: PatchList UNDECIDED -> PatchList APPLIED + markInPatchList (PatchList (Just p) l) = + PatchList (Just (p { p_state = APPLIED })) l + markInPatchList pl = error ("markAsApplied.markInPatchList applied on " ++ + show pl) + markInClosedPatchGroup :: ClosedPatchGroup -> ClosedPatchGroup + markInClosedPatchGroup cpg = + case cpg_patches cpg of + Right pl@(PatchList (Just p) _) | p_id p == pid -> + cpg { cpg_patches = + Left (markInPatchList pl) + } + _ -> cpg + isApplied :: PatchID -> Bool + isApplied pid = + case findPatchInModel model pid of + Left e -> error ("markAsApplied.isApplied: unexpected error: " ++ + e) + Right p -> p_state p == PatchStateAPPLIED + + +-- | The operation fails if the patch group with the name given does +-- | not exist. +closePatchGroup :: Model -> PatchGroupID -> Partial Model +closePatchGroup model name = + assertModel model $ + case Map.lookup name (m_openGroups model) of + Just open -> Right $ + model { + m_closedGroups = m_closedGroups model ++ + [ClosedPatchGroup name (Right (opg_patches open))] + ,m_openGroups = Map.delete name (m_openGroups model) + } + Nothing -> + case List.find (\closed -> cpg_name closed == name) + (m_closedGroups model) + of + Just _ -> Right model + Nothing -> Left ("Model does not contain a patch group of name " + ++ show name) + +-- | Opens the patch group that contains the patch with the given +-- ID. The operation fails if there exists no patch with the ID +-- given or if the corresponding patch group contains a patch in +-- state APPLIED. +openPatchGroup :: Model -> PatchID -> Partial (Model, PatchGroupID) +openPatchGroup model pid = + assertModelAndPID' model pid $ + case findPatchGroupOf model pid of + Left err -> error err + Right (Right (pgid, _)) -> Right (model, pgid) + Right (Left cpg) -> + case cpg_patches cpg of + Left _ -> Left ("Cannot open patch group containing patch with " ++ + show pid ++ " because patch group " ++ show cpg ++ + " contains a patch in state APPLIED") + Right patches -> + let opg = OpenPatchGroup $ + case Map.lookup (cpg_name cpg) (m_openGroups model) of + Just (OpenPatchGroup patches') -> + patches `plConcat` patches' + Nothing -> + patches + in Right ( + model { + m_closedGroups = List.delete cpg (m_closedGroups model) + ,m_openGroups = Map.insert (cpg_name cpg) opg + (m_openGroups model) + }, + cpg_name cpg + ) + +getPatches :: Model -> [PatchGroup (Patch PatchState)] +getPatches model = + assertModel model $ + modelToPatchGroups model + +allConflicts :: Model -> PatchConflicts +allConflicts = m_conflicts + +-- +-- Auxiliaries +-- + +pgID :: String -> PatchGroupID +pgID = PatchGroupID + +assertModel' :: Model -> Set PatchID +assertModel' model = + let l = allPatchIDs model + in case foldr (\pid eset -> do set <- eset + if Set.member pid set + then Left ("Model contains " ++ show pid + ++ " more than once") + else Right $ Set.insert pid set) + (Right Set.empty) l + of Left e -> error e + Right set -> set + +assertModel :: Model -> a -> a +assertModel model x = assertModel' model `seq` x + +assertModelAndPID :: Model -> PatchID -> a -> Partial a +assertModelAndPID model pid x = + let set = assertModel' model + in if Set.member pid set + then Right x + else Left ("Unknown patch ID: " ++ show pid) + +assertModelAndPID' :: Model -> PatchID -> Partial a -> Partial a +assertModelAndPID' model pid px = + case assertModelAndPID model pid px of + Right x -> x + Left e -> Left e + +plCons :: Patch UNDECIDED -> PatchList UNDECIDED -> PatchList UNDECIDED +plCons p (PatchList Nothing l) = + PatchList (Just p) l +plCons p (PatchList (Just p') l) = + PatchList (Just p) (p' { p_state = DISCARDED ReasonObsolete } : l) + +plSingleton :: Patch UNDECIDED -> PatchList UNDECIDED +plSingleton p = PatchList (Just p) [] + +plConcat :: PatchList a -> PatchList a -> PatchList a +plConcat (PatchList (Just x) xs) pl = + PatchList (Just x) (xs ++ (case pl of + PatchList (Just y) ys -> + y { p_state = DISCARDED ReasonObsolete } : ys + PatchList Nothing ys -> ys)) +plConcat (PatchList Nothing xs) (PatchList (Just y) ys) = + PatchList (Just y) (xs ++ ys) +plConcat (PatchList Nothing xs) (PatchList Nothing ys) = + PatchList Nothing (xs ++ ys) + +allPatchIDs :: Model -> [PatchID] +allPatchIDs model = map p_id (flattenModel model) + +findPatchInModel :: Model -> PatchID -> Partial (Patch PatchState) +findPatchInModel model pid = + let allPatches = flattenModel model + in case findPatchInList pid allPatches of + Nothing -> Left ("Patch with ID " ++ show pid ++ " not found") + Just p -> Right p + +modelToPatchGroups :: Model -> [PatchGroup (Patch PatchState)] +modelToPatchGroups model = + map (\cpg -> PatchGroup (cpg_name cpg) + PatchGroupClosed + (case cpg_patches cpg of + Right l -> flattenPatchList l + Left l -> flattenPatchList l) + True) + (m_closedGroups model) + ++ + map (\ (name, opg) -> PatchGroup name + PatchGroupOpen + (flattenPatchList (opg_patches opg)) + True) + (Map.toList (m_openGroups model)) + +flattenModel :: Model -> [Patch PatchState] +flattenModel model = + concatMap flattenClosedPatchGroup (m_closedGroups model) ++ + concatMap flattenOpenPatchGroup (mapRange (m_openGroups model)) + +flattenClosedPatchGroup :: ClosedPatchGroup -> [Patch PatchState] +flattenClosedPatchGroup pg = + case cpg_patches pg of + Left pl -> flattenPatchList pl + Right pl -> flattenPatchList pl + +flattenOpenPatchGroup :: OpenPatchGroup -> [Patch PatchState] +flattenOpenPatchGroup pg = + flattenPatchList (opg_patches pg) + +flattenPatchList :: PATCH_STATE a => PatchList a -> [Patch PatchState] +flattenPatchList (PatchList head l) = + let l' = map convertPatch l + in case head of + Nothing -> l' + Just p -> convertPatch p : l' + +convertPatch :: PATCH_STATE a => Patch a -> Patch PatchState +convertPatch p = p { p_state = patchState (p_state p) } + +findPatchGroupOf :: Model -> PatchID -> Partial (Either ClosedPatchGroup + (PatchGroupID, + OpenPatchGroup)) +findPatchGroupOf model pid = + case msum (map (checkPatchGroup flattenClosedPatchGroup) + (m_closedGroups model)) of + Just cpg -> Right (Left cpg) + Nothing -> + case msum (map (checkPatchGroup' flattenOpenPatchGroup) + (Map.assocs (m_openGroups model))) of + Just x -> Right (Right x) + Nothing -> Left ("No patch group found that contains a patch " + ++ "with ID " ++ show pid) + where + checkPatchGroup :: (pg -> [Patch a]) -> pg -> Maybe pg + checkPatchGroup flattenFun pg = + if isJust (findPatchInList pid (flattenFun pg)) + then Just pg + else Nothing + checkPatchGroup' :: (pg -> [Patch a]) -> (PatchGroupID, pg) + -> Maybe (PatchGroupID, pg) + checkPatchGroup' f (name, pg) = + case checkPatchGroup f pg of + Just pg -> Just (name, pg) + Nothing -> Nothing + +findPatchInList :: PatchID -> [Patch a] -> Maybe (Patch a) +findPatchInList pid l = List.find (\p -> p_id p == pid) l + +mapRange :: Map k v -> [v] +mapRange m = map snd (Map.toList m) + +mapPL :: (forall b . Patch b -> Patch b) -> PatchList a -> PatchList a +mapPL f (PatchList (Just head) l) = PatchList (Just (f head)) (map f l) +mapPL f (PatchList Nothing l) = PatchList Nothing (map f l) + +isPatchGroupApplied :: ClosedPatchGroup -> Bool +isPatchGroupApplied cpg = case cpg_patches cpg of + Left _ -> True + _ -> False + +-- +-- Tests +-- + +-- FIXME: test conflict handling + +p1 = Patch (PatchID "p1") APPLIED [] True +p2 = Patch (PatchID "p2") (DISCARDED ReasonObsolete) [] False +p3 = Patch (PatchID "p3") (DISCARDED ReasonObsolete) [] True +p4 = Patch (PatchID "p4") APPLIED [p_id p1] True +p5 = Patch (PatchID "p5") (DISCARDED ReasonObsolete) [p_id p1] True +p6 = Patch (PatchID "p6") UNDECIDED [p_id p1, p_id p5] True +p7 = Patch (PatchID "p7") (DISCARDED ReasonObsolete) [p_id p1] False +p8 = Patch (PatchID "p8") (DISCARDED ReasonObsolete) [p_id p1] False +p9 = Patch (PatchID "p9") (DISCARDED ReasonObsolete) [p_id p2] False +p10 = Patch (PatchID "p10") (DISCARDED ReasonObsolete) [p_id p2, p_id p5] False +p11 = Patch (PatchID "p11") UNDECIDED [p_id p1, p_id p4] False +p12 = Patch (PatchID "p12") (DISCARDED ReasonObsolete) [p_id p1, p_id p4] True +p13 = Patch (PatchID "p13") (DISCARDED ReasonObsolete) [p_id p1, p_id p4] False +p14 = Patch (PatchID "p14") (DISCARDED ReasonRejected) [p_id p1, p_id p11] False +p15 = Patch (PatchID "p15") (DISCARDED ReasonObsolete) [p_id p1, p_id p11] True +p17 = Patch (PatchID "p17") (DISCARDED ReasonObsolete) [] True +p18 = Patch (PatchID "p18") UNDECIDED [] True +p19 = Patch (PatchID "p19") (DISCARDED ReasonObsolete) [] True + +p16 = Patch (PatchID "p16") UNDECIDED [] False + +invalidModel = Model + [ClosedPatchGroup (pgID "pg1") (Right $ PatchList (Just p6) [])] + (Map.fromList [(pgID "pg2", + OpenPatchGroup (PatchList (Just p6) []))]) + emptyConflicts +sampleModel = + Model + [ClosedPatchGroup (pgID "pg1") (Left $ PatchList (Just p1) [p2,p3]), + ClosedPatchGroup (pgID "pg2") (Left $ PatchList (Just p4) [p5]), + ClosedPatchGroup (pgID "pg2") (Right $ PatchList (Just p6) [p7,p8]), + ClosedPatchGroup (pgID "pg3") (Right $ PatchList Nothing [p9,p10]), + ClosedPatchGroup (pgID "pg4") (Right $ PatchList Nothing [p17]), + ClosedPatchGroup (pgID "pg4") (Right $ PatchList (Just p18) [p19])] + (Map.fromList + [(pgID "pg4", OpenPatchGroup (PatchList (Just p11) [p12,p13])), + (pgID "pg5", OpenPatchGroup (PatchList Nothing [p14,p15]))]) + emptyConflicts + +test_markAsReviewed = + do assertLeft $ markAsReviewed sampleModel (PatchID "foo") + assertThrowsSome $ markAsReviewed invalidModel (PatchID "p14") + m1 <- assertRight $ markAsReviewed sampleModel (PatchID "p14") + assertEqual (sampleModel { + m_openGroups = + Map.insert (pgID "pg5") + (OpenPatchGroup (PatchList Nothing + [p14 { p_isReviewed = True }, + p15])) + (m_openGroups sampleModel) + }) + m1 + m2 <- assertRight $ markAsReviewed sampleModel (PatchID "p2") + assertEqual (sampleModel { + m_closedGroups = + ClosedPatchGroup (pgID "pg1") + (Left $ PatchList (Just p1) + [p2 { p_isReviewed = True }, + p3]) + : tail (m_closedGroups sampleModel) + }) + m2 + m3 <- assertRight $ markAsReviewed sampleModel (PatchID "p1") + assertEqual sampleModel m3 + m4 <- assertRight $ markAsReviewed sampleModel (PatchID "p12") + assertEqual sampleModel m4 + +-- FIXME: add tests for conflicts + +test_addPatch = + do m0 <- assertRight $ addPatch sampleModel (PatchID "p1") (pgID "pg3") + [] [] False + assertEqual sampleModel m0 + m1 <- assertRight $ addPatch sampleModel (PatchID "p16") (pgID "pg5") + [] [] False + assertEqual (sampleModel { + m_openGroups = + Map.insert (pgID "pg5") + (OpenPatchGroup (PatchList (Just p16) [p14,p15])) + (m_openGroups sampleModel) + }) + m1 + m2 <- assertRight $ addPatch sampleModel (PatchID "p16") (pgID "pg4") + [] [] False + assertEqual (sampleModel { + m_openGroups = + Map.insert (pgID "pg4") + (OpenPatchGroup (PatchList (Just p16) + [p11 {p_state=(DISCARDED + ReasonObsolete)}, + p12, + p13])) + (m_openGroups sampleModel) + }) + m2 + m3 <- assertRight $ addPatch sampleModel (PatchID "p16") (pgID "pg1") + [] [] False + assertEqual (sampleModel { + m_openGroups = + Map.insert (pgID "pg1") + (OpenPatchGroup (PatchList (Just p16) [])) + (m_openGroups sampleModel) + }) + m3 + m4 <- assertRight $ addPatch sampleModel (PatchID "p16") (pgID "pg6") + [] [] False + assertEqual (sampleModel { + m_openGroups = + Map.insert (pgID "pg6") + (OpenPatchGroup (PatchList (Just p16) [])) + (m_openGroups sampleModel) + }) + m4 + assertLeft $ addPatch sampleModel (PatchID "p16") (pgID "pg6") + [PatchID "foo"] [] False + assertThrowsSome $ (addPatch invalidModel (PatchID "p16") + (pgID "pg6") [] [] False) + +test_markAsDiscarded = + do assertLeft $ markAsDiscarded sampleModel (PatchID "foo") ReasonObsolete + assertThrowsSome $ markAsDiscarded invalidModel (PatchID "p14") + ReasonObsolete + assertLeft $ markAsDiscarded sampleModel (PatchID "p4") ReasonObsolete + m0 <- assertRight $ markAsDiscarded sampleModel (PatchID "p2") + ReasonObsolete + assertEqual sampleModel m0 + m1 <- assertRight $ markAsDiscarded sampleModel (PatchID "p12") + ReasonObsolete + assertEqual sampleModel m1 + m2 <- assertRight $ markAsDiscarded sampleModel (PatchID "p6") + ReasonRejected + assertEqual (sampleModel { + m_closedGroups = + listReplaceAt 2 + (ClosedPatchGroup (pgID "pg2") + (Right $ PatchList Nothing + [p6 { p_state = (DISCARDED + ReasonRejected) }, + p7, p8])) + (m_closedGroups sampleModel) + }) + m2 + m3 <- assertRight $ markAsDiscarded sampleModel (PatchID "p11") + ReasonObsolete + assertEqual (sampleModel { + m_openGroups = + Map.insert (pgID "pg4") + (OpenPatchGroup (PatchList Nothing + [p11 { p_state = + (DISCARDED + ReasonObsolete) }, + p12, + p13])) + (m_openGroups sampleModel) + }) + m3 + m4 <- assertRight $ markAsDiscarded sampleModel (PatchID "p15") + ReasonRejected + assertEqual (sampleModel { + m_openGroups = + Map.insert (pgID "pg5") + (OpenPatchGroup (PatchList Nothing + [p14, + p15 { p_state = DISCARDED + ReasonRejected + }])) + (m_openGroups sampleModel) + }) + m4 + m5 <- assertRight $ markAsDiscarded sampleModel (PatchID "p14") + ReasonObsolete + assertEqual (sampleModel { + m_openGroups = + Map.insert (pgID "pg5") + (OpenPatchGroup (PatchList Nothing + [p14 { p_state = DISCARDED + ReasonObsolete + }, + p15])) + (m_openGroups sampleModel) + }) + m5 + +test_markAsUndecided = + do assertLeft $ markAsUndecided sampleModel (PatchID "foo") + assertThrowsSome $ markAsUndecided invalidModel (PatchID "p14") + assertLeft $ markAsUndecided sampleModel (PatchID "p4") + m0 <- assertRight $ markAsUndecided sampleModel (PatchID "p11") + assertEqual sampleModel m0 + m1 <- assertRight $ markAsUndecided sampleModel (PatchID "p2") + assertEqual (sampleModel { + m_openGroups = + Map.insert (pgID "pg1") + (OpenPatchGroup + (PatchList + (Just (p2 { p_state = UNDECIDED })) + [])) + (m_openGroups sampleModel) + , m_closedGroups = + ClosedPatchGroup (pgID "pg1") + (Left $ PatchList (Just p1) [p3]) + : tail (m_closedGroups sampleModel) + }) + m1 + m2 <- assertRight $ markAsUndecided sampleModel (PatchID "p7") + assertEqual (sampleModel { + m_closedGroups = + listReplaceAt 2 + (ClosedPatchGroup (pgID "pg2") + (Right $ PatchList + (Just (p7 { p_state = + UNDECIDED })) + [p8, p6 { p_state = + (DISCARDED + ReasonObsolete)}])) + (m_closedGroups sampleModel) + }) + m2 + m3 <- assertRight $ markAsUndecided sampleModel (PatchID "p9") + assertEqual (sampleModel { + m_closedGroups = + listReplaceAt 3 + (ClosedPatchGroup (pgID "pg3") + (Right $ PatchList + (Just (p9{p_state = + UNDECIDED})) + [p10])) + (m_closedGroups sampleModel) + }) + m3 + m4 <- assertRight $ markAsUndecided sampleModel (PatchID "p12") + assertEqual (sampleModel { + m_openGroups = + Map.insert (pgID "pg4") + (OpenPatchGroup (PatchList (Just (p12 {p_state = + UNDECIDED})) + [p13, + p11 {p_state=(DISCARDED + ReasonObsolete)} + ])) + (m_openGroups sampleModel) + }) + m4 + m5 <- assertRight $ markAsUndecided sampleModel (PatchID "p14") + assertEqual (sampleModel { + m_openGroups = + Map.insert (pgID "pg5") + (OpenPatchGroup (PatchList (Just (p14{p_state = + UNDECIDED})) + [p15])) + (m_openGroups sampleModel) + }) + m5 + return () + +test_markAsApplied = + do assertLeft $ markAsApplied sampleModel (PatchID "foo") + assertThrowsSome $ markAsApplied invalidModel (PatchID "p11") + assertLeft $ markAsApplied sampleModel (PatchID "p3") + assertLeft $ markAsApplied sampleModel (PatchID "p8") + assertLeft $ markAsApplied sampleModel (PatchID "p6") + assertLeft $ markAsApplied sampleModel (PatchID "p15") + m0 <- assertRight $ markAsApplied sampleModel (PatchID "p1") + assertEqual sampleModel m0 + m1 <- assertRight $ markAsApplied sampleModel (PatchID "p4") + assertEqual sampleModel m1 + -- p6 + m2 <- assertRight $ markAsApplied sampleModel (PatchID "p11") + assertEqual (sampleModel { + m_closedGroups = + m_closedGroups sampleModel ++ + [ClosedPatchGroup (pgID "pg4") + (Left $ PatchList + (Just (p11 { p_state = APPLIED })) + [p12, p13])] + ,m_openGroups = Map.delete (pgID "pg4") + (m_openGroups sampleModel) + }) + m2 + +test_closePatchGroup = + do assertLeft $ closePatchGroup sampleModel (pgID "foo") + assertThrowsSome $ closePatchGroup invalidModel (pgID "pg1") + m0 <- assertRight $ closePatchGroup sampleModel (pgID "pg1") + assertEqual sampleModel m0 + m1 <- assertRight $ closePatchGroup sampleModel (pgID "pg4") + assertEqual (sampleModel { + m_closedGroups = + m_closedGroups sampleModel ++ + [ClosedPatchGroup (pgID "pg4") + (Right (PatchList (Just p11) [p12,p13]))] + ,m_openGroups = + Map.delete (pgID "pg4") (m_openGroups sampleModel) + }) + m1 + +test_openPatchGroup = + do assertLeft $ openPatchGroup sampleModel (PatchID "foo") + assertThrowsSome $ openPatchGroup invalidModel (PatchID "p11") + assertLeft $ openPatchGroup sampleModel (PatchID "p1") + (m0,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p11") + assertEqual sampleModel m0 + (m0',_) <- assertRight $ openPatchGroup sampleModel (PatchID "p12") + assertEqual sampleModel m0' + (m1,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p6") + assertEqual (sampleModel { + m_closedGroups = + listDeleteAt 2 (m_closedGroups sampleModel) + ,m_openGroups = + Map.insert (pgID "pg2") + (OpenPatchGroup + (PatchList (Just p6) [p7,p8])) + (m_openGroups sampleModel) + }) + m1 + (m2,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p7") + assertEqual m1 m2 + (m3,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p8") + assertEqual m1 m3 + (m4,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p9") + assertEqual (sampleModel { + m_closedGroups = + listDeleteAt 3 (m_closedGroups sampleModel) + ,m_openGroups = + Map.insert (pgID "pg3") + (OpenPatchGroup + (PatchList Nothing [p9,p10])) + (m_openGroups sampleModel) + }) + m4 + (m5,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p10") + assertEqual m4 m5 + (m6,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p17") + assertEqual (sampleModel { + m_closedGroups = + listDeleteAt 4 (m_closedGroups sampleModel) + ,m_openGroups = + Map.insert + (pgID "pg4") + (OpenPatchGroup (PatchList (Just p11) [p17, + p12, + p13])) + (m_openGroups sampleModel) + }) + m6 + (m7,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p18") + assertEqual (sampleModel { + m_closedGroups = + listDeleteAt 5 (m_closedGroups sampleModel) + ,m_openGroups = + Map.insert + (pgID "pg4") + (OpenPatchGroup (PatchList (Just p18) + [p19, + p11 { p_state = + (DISCARDED + ReasonObsolete) }, + p12, + p13])) + (m_openGroups sampleModel) + }) + m7 + +test_getPatches = + do assertThrowsSome $ getPatches invalidModel + let allPGs = [PatchGroup (pgID "pg1") + PatchGroupClosed + [convertPatch p1, convertPatch p2, + convertPatch p3] + True + ,PatchGroup (pgID "pg2") + PatchGroupClosed + [convertPatch p4, convertPatch p5] + True + ,PatchGroup (pgID "pg2") + PatchGroupClosed + [convertPatch p6, convertPatch p7, + convertPatch p8] + True + ,PatchGroup (pgID "pg3") + PatchGroupClosed + [convertPatch p9, convertPatch p10] + True + ,PatchGroup (pgID "pg4") + PatchGroupClosed + [convertPatch p17] + True + ,PatchGroup (pgID "pg4") + PatchGroupClosed + [convertPatch p18, convertPatch p19] + True + ,PatchGroup (pgID "pg4") + PatchGroupOpen + [convertPatch p11, convertPatch p12, + convertPatch p13] + True + ,PatchGroup (pgID "pg5") + PatchGroupOpen + [convertPatch p14, convertPatch p15] + True] + assertEqual allPGs (getPatches sampleModel) + +-- +-- Pretty instances +-- + +instance Pretty PatchGroupState where + pretty PatchGroupClosed = text "closed" + pretty PatchGroupOpen = text "open" + +instance Pretty a => Pretty (PatchGroup a) where + pretty pg = + text "PatchGroup" <+> char '{' <> + nest 0 (text "pg_id" <+> equals <+> pretty (pg_id pg) <> comma $$ + text "pg_state" <+> equals <+> pretty (pg_state pg) <> comma $$ + text "pg_complete" <+> equals <+> + pretty (pg_complete pg) <> comma $$ + text "pg_patches" <+> equals <+> pretty (pg_patches pg)) <> + char '}' + +instance Pretty a => Pretty (Patch a) where + pretty p = + text "Patch" <+> char '{' <> + nest 0 (text "p_id" <=> pretty (p_id p) <> comma $$ + text "p_state" <=> + pretty (p_state p) <> comma $$ + text "p_dependents" <=> pretty (p_dependents p) <> comma $$ + text "p_isReviewed" <=> pretty (p_isReviewed p)) <> + char '}' + +instance Pretty PatchState where + pretty PatchStateUNDECIDED = text "UNDECIDED" + pretty PatchStateAPPLIED = text "APPLIED" + pretty (PatchStateDISCARDED reason) = text "DISCARDED" <> + braces (pretty reason) + +instance Pretty ReasonDiscarded where + pretty ReasonRejected = text "rejected" + pretty ReasonObsolete = text "obsolete" + +instance Pretty PatchGroupID where + pretty pgid = text (unPatchGroupID pgid) + +instance Pretty PatchID where + pretty pid = text (unPatchID pid) diff --git a/src/DPM/Core/PatchBundleParser.hs b/src/DPM/Core/PatchBundleParser.hs new file mode 100644 --- /dev/null +++ b/src/DPM/Core/PatchBundleParser.hs @@ -0,0 +1,233 @@ +-- largely stolen from darcswatch (http://darcs.nomeata.de/darcswatch) + +{- +Copyright (C) 2008 Joachim Breitner + +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 BangPatterns #-} +module DPM.Core.PatchBundleParser + ( PatchBundle + , PatchInfo(..) + , scanBundle + , readDiffFromString + ) where + +import Control.Arrow +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Char8 (ByteString) +import Data.List +import Data.Either + +import DPM.Core.DataTypes ( PatchID(..) ) + +-- | The defining informtion of a Darcs patch. +data PatchInfo = PatchInfo + { piDate :: String + , piName :: String + , piAuthor :: String + , piLog :: [String] + , piInverted :: Bool + } deriving (Eq,Ord,Show) + +-- | A patch bundle (e.g. a mail) +type PatchBundle = [(PatchInfo, ByteString)] + + +readPatchInfos :: ByteString -> [PatchInfo] +readPatchInfos inv | B.null inv = [] +readPatchInfos inv = case breakOn '[' inv of + (_,r) -> case readPatchInfo r of + Just (pinfo,r) -> pinfo : readPatchInfos r + Nothing -> [] + +readPatchInfo :: ByteString -> Maybe (PatchInfo, ByteString) +readPatchInfo s = + if B.null s' || B.head s' /= '[' -- ] + then Nothing + else case breakOn '\n' (B.tail s') of + (!name,s') | B.null s' -> + error $ "Broken file (1) " ++ show (B.unpack s) + | otherwise -> + case breakOn '*' $ B.tail s' of + (!author,s2) | B.null s2 -> error "Broken file (2)" + | otherwise -> + case B.break (\c->c==']'||c=='\n') $ B.drop 2 s2 of + (!ct,!s''') -> + do (!log, !s4) <- + lines_starting_with_ending_with ' ' ']' $ dn s''' + let not_star = B.index s2 1 /= '*' + not_star `seq` return + ( PatchInfo { piDate = B.unpack ct + , piName = B.unpack name + , piAuthor = B.unpack author + , piLog = map B.unpack log + , piInverted = not_star + }, s4) + where dn x = if B.null x || B.head x /= '\n' then x else B.tail x + s' = dropWhite s + +lines_starting_with_ending_with :: Char -> Char -> ByteString + -> Maybe ([ByteString],ByteString) +lines_starting_with_ending_with st en s = lswew s + where + lswew x | B.null x = Nothing + lswew x = + if B.head x == en + then Just ([], B.tail x) + else if B.head x /= st + then Nothing + else case breakOn '\n' $ B.tail x of + (!l,r) -> case lswew $ B.tail r of + Just (!ls,r') -> Just (l:ls,r') + Nothing -> + case breakLast en l of + Just (!l2,_) -> + let rest = B.drop (B.length l2+2) x in + rest `seq` Just ([l2], B.drop (B.length l2+2) x) + Nothing -> Nothing + + +dropWhite = B.dropWhile (`elem` " \n\t\r") +breakOn :: Char -> ByteString -> (ByteString, ByteString) +breakOn c = B.break (==c) + +breakLast c p = case B.elemIndexEnd c p of + Nothing -> Nothing + Just n -> Just (B.take n p, B.drop (n+1) p) + +scanBundle :: ByteString -> Either String PatchBundle +scanBundle ps + | B.null ps = Left "Bad patch bundle!" + | otherwise = + case silly_lex ps of + ("New patches:",rest) -> + case get_patches rest of + (submitted, rest') -> + case silly_lex rest' of + ("Context:", rest'') -> + case get_context rest'' of + (context,maybe_hash) -> -- FIXME verify patch bundle hash + returnResult submitted + (a,r) -> Left $ "Malformed patch bundle: '"++a++"' is not 'Context:'" + ++ "\n" ++ B.unpack r + ("Context:",rest) -> + case get_context rest of + (context, rest') -> + case silly_lex rest' of + ("New patches:", rest'') -> + case get_patches rest'' of + (submitted,_) -> returnResult submitted + (a,_) -> Left $ "Malformed patch bundle: '" ++ a ++ + "' is not 'New patches:'" + ("-----BEGIN PGP SIGNED MESSAGE-----",rest) -> + scanBundle $ filter_gpg_dashes rest + (_,rest) -> scanBundle rest + where + returnResult list = Right list + +get_patches :: ByteString -> ([(PatchInfo,ByteString)], ByteString) +get_patches ps = + case readPatchInfo ps of + Nothing -> ([], ps) + Just (pinfo,ps) -> + case readDiff ps of + Nothing -> ([], ps) + Just (diff, r) -> (pinfo, diff) -:- get_patches r + + +silly_lex :: ByteString -> (String, ByteString) +silly_lex = first B.unpack . B.span (/='\n') . dropWhite + +scan_context :: ByteString -> [PatchInfo] +scan_context = fst . get_context + +get_context :: ByteString -> ([PatchInfo],ByteString) +get_context ps = + case readPatchInfo ps of + Just (pinfo,r') -> pinfo -:- get_context r' + Nothing -> ([],ps) + +filter_gpg_dashes :: ByteString -> ByteString +filter_gpg_dashes ps = + B.unlines $ map drop_dashes $ + takeWhile (/= litEndPGPSignedMessages) $ + dropWhile not_context_or_newpatches $ B.lines ps + where drop_dashes x = if B.length x < 2 then x + else if B.take 2 x == litDashSpace + then B.drop 2 x + else x + not_context_or_newpatches s = (s /= litContext) && + (s /= litNewPatches) + +readDiffFromString :: String -> Maybe (ByteString, ByteString) +readDiffFromString = readDiff . B.pack + +readDiff :: ByteString -> Maybe (ByteString, ByteString) +readDiff s = + if B.null s' then Nothing + else do n <- findSplitPoint s' initMode 0 + return $ B.splitAt n s' + where s' = dropWhite s + initMode = litOpenAngle `B.isPrefixOf` s' + findSplitPoint :: ByteString -> Bool -- whether inside <...> or not + -> Int -> Maybe Int + findSplitPoint s _ _ | B.null s = Nothing + findSplitPoint s True acc = + case drop litNewlineCloseAngle s of + Just (rest, n) -> findSplitPoint rest False (acc + n) + Nothing -> findSplitPoint (B.tail s) True (acc + 1) + findSplitPoint s False acc = + case drop litNewlineOpenAngle s of + Just (rest, n) -> findSplitPoint rest True (acc + n) + Nothing -> + if litNewlineNewlineContext `B.isPrefixOf` s || + litNewlineBracket `B.isPrefixOf` s + then Just acc + else findSplitPoint (B.tail s) False (acc + 1) + drop init s = + if init `B.isPrefixOf` s + then let n = B.length init + in Just (B.drop n s, n) + else Nothing + +(-:-) :: a -> ([a],b) -> ([a],b) +a -:- (as,r) = (a:as,r) + +addSlash filename | last filename == '/' = filename + | otherwise = filename ++ "/" + +-- Packed bytestring literators, to avoid re-packing them constantly (ghc is +-- probably not smart enough to do it by itself + +litHashedDarcs2 = B.pack "hashed\ndarcs-2\n" +litDarcs10 = B.pack "darcs-1.0\n" +litHashed = B.pack "hashed\n" +litStartingWithTag = B.pack "Starting with tag:" +litPristine = B.pack "pristine" +litStartingWithInventory = B.pack "Starting with inventory:" +litEndPGPSignedMessages = B.pack "-----END PGP SIGNED MESSAGE-----" +litDashSpace = B.pack "- " +litContext = B.pack "Context:" +litNewPatches = B.pack "New patches:" +litNewlineNewlineContext = B.pack "\n\nContext:" +litNewlineBracket = B.pack "\n[" +litNewlineOpenAngle = B.pack "\n<" +litOpenAngle = B.pack "<" +litNewlineCloseAngle = B.pack "\n>" +litT = B.pack "t" +litF = B.pack "f" diff --git a/src/DPM/Core/ReverseDependencies.hs b/src/DPM/Core/ReverseDependencies.hs new file mode 100644 --- /dev/null +++ b/src/DPM/Core/ReverseDependencies.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} + +module DPM.Core.ReverseDependencies where + +import qualified Data.Map as Map +import Test.Framework + +import DPM.Core.DataTypes ( PatchID ) + +type Map = Map.Map + +data RevDeps a = RevDeps { rd_map :: Map a [a] } + +type PatchRevDeps = RevDeps PatchID + +getRevDeps :: Ord a => RevDeps a -> a -> [a] +getRevDeps rd key = Map.findWithDefault [] key (rd_map rd) + +getMaxChainLen :: Ord a => RevDeps a -> a -> Int +getMaxChainLen rd key = + case Map.lookup key (rd_map rd) of + Nothing -> 0 + Just l -> 1 + maximum (map (getMaxChainLen rd) l) + +buildRevDeps :: Ord a => [(a, [a])] -> RevDeps a +buildRevDeps list = RevDeps $ foldr add Map.empty list + where + add (x,ys) m0 = + foldr (\y m -> Map.insertWith (++) y [x] m) m0 ys + +prop_hasMapping :: [(Int, [Int])] -> Bool +prop_hasMapping list = + let rd = buildRevDeps list + in all (hasMapping rd) list + where + hasMapping rd (val, keys) = + all (\k -> val `elem` getRevDeps rd k) keys diff --git a/src/DPM/Core/ShortID.hs b/src/DPM/Core/ShortID.hs new file mode 100644 --- /dev/null +++ b/src/DPM/Core/ShortID.hs @@ -0,0 +1,103 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module DPM.Core.ShortID (getShortID, allHTFTests) where + +import qualified Data.List as List +import qualified Data.Set as Set +import Data.Maybe ( isJust ) +import Test.Framework + +import DPM.Core.DataTypes +import DPM.Core.Utils ( retain ) + +getShortID :: [PatchID] -> PatchID -> String +getShortID allIds id = + case susLen (map unPatchID allIds) of + Nothing -> error ("List of patch IDs " ++ show allIds ++ + " contains duplicates!") + Just n -> retain (lowerBounded minLength n) (unPatchID id) + where minLength = 4 + lowerBounded m n | n < m = m + | otherwise = n + +-- sus stands for "shortest unique suffix" +susLen :: Ord a => [[a]] -> Maybe Int +susLen [] = Just 0 +susLen input = + let rev = map List.reverse input + n = minimum (map length input) + allSuffices = [(i, [take i l | l <- rev]) | i <- [1..n]] + in case filter (\(_,l) -> hasUniqueElements l) allSuffices of + [] -> Nothing + ((i,_):_) -> Just i + +prop_susInputNotUnique :: Property +prop_susInputNotUnique = + forAll (listOf (vectorOf 5 arbitrary)) $ \ (l::[[Bool]]) -> + not (hasUniqueElements l) ==> susLen l == Nothing + +-- FIXME: fails sometimes, replay argument "Just (1419540369 504813816,61)" +prop_susUnique1 :: Property +prop_susUnique1 = + forAll uniqueListGen $ \l -> isJust (susLen l) + +prop_susUnique1Replay :: TestableWithQCArgs +prop_susUnique1Replay = + withQCArgs (\a -> a { replay = read "Just (1419540369 504813816,61)"}) + prop_susUnique1 + +prop_susUnique2 :: Property +prop_susUnique2 = + forAll uniqueListGen $ \l -> + let Just n = susLen l + l' = map (retain n) l + in List.nub l' == l' + +prop_susShortest :: Property +prop_susShortest = + forAll uniqueListGen $ \l -> + let Just n = susLen l + l' = map (retain (n-1)) l + in n > 1 ==> List.nub l' /= l' + +uniqueListGen :: Gen [[Int]] +uniqueListGen = + do n <- choose (10, 20) + l <- sequence [elementGen i | i <- [0..n]] + let n = minimum (map length l) + l' = map (reverse . take n . reverse) l + return (removeDups l' l [] []) + where + elementGen :: Int -> Gen [Int] + elementGen i = + do n <- choose (5, 100) + vectorOf n (choose (0,9)) + removeDups [] _ acc1 acc2 = acc2 + removeDups (x:xs) (y:ys) acc1 acc2 + | x `elem` acc1 = removeDups xs ys acc1 acc2 + | otherwise = removeDups xs ys (x:acc1) (y:acc2) + removeDups _ _ _ _ = error ("DPM.Core.ShortID.uniqueListGen.removeDups: " + ++ "invalid arguments") + +prop_uniqueListGenOK :: Property +prop_uniqueListGenOK = + forAll uniqueListGen check + where check l = let n = minimum (map length l) + in hasUniqueElements (map (reverse . take n . reverse) l) + +prop_uniqueListGenOKReplay :: TestableWithQCArgs +prop_uniqueListGenOKReplay = + withQCArgs (\a -> a { replay = read "Just (1419540369 504813816,61)"}) + prop_uniqueListGenOK + +hasUniqueElements :: Ord a => [a] -> Bool +hasUniqueElements l = + walk l Set.empty + where walk [] _ = True + walk (x:xs) set = if Set.member x set then False + else walk xs (Set.insert x set) + +prop_hasUniqueElementsOK :: [[Int]] -> Bool +prop_hasUniqueElementsOK l = + hasUniqueElements l == (List.nub l == l) diff --git a/src/DPM/Core/Storage.hs b/src/DPM/Core/Storage.hs new file mode 100644 --- /dev/null +++ b/src/DPM/Core/Storage.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- NB: clients of this module must perform locking on their own. +module DPM.Core.Storage ( + + Comment, PatchesResult(..), PatchBundleName, + + withLock, setupStorageDir, + + addPatchBundle, addPatch, markAsReviewed, markAsRejected, markAsObsolete, + markAsObsoleteNoCheck, markAsUndecided, markAsApplied, applyPatch, + closePatchGroup, openPatchGroup, getPatches, getPatchFile, allPatchIDs, + allConflicts, addComment + +) where + +import Prelude hiding ( catch ) +import qualified Data.Map as Map +import System.FilePath +import qualified Data.ByteString as B +import qualified Darcs.Lock +import Control.Monad +import Control.Monad.Trans +import System.Directory ( doesFileExist, createDirectoryIfMissing ) +import Control.Exception +import Data.IORef +import Data.Time ( getCurrentTime ) +import Data.Maybe ( mapMaybe ) +import Data.Char ( toLower ) +import qualified Data.List as List +import System.IO +import System.IO.Unsafe +import Data.IORef + +import DPM.Core.DataTypes +import qualified DPM.Core.Model as M +import DPM.Core.Utils +import DPM.Core.DPM_Monad +import DPM.Core.Conflicts +import DPM.Core.ReverseDependencies + +type Patches = Map.Map PatchID (Patch, PatchBundleName) +type Log a = Map.Map a [LogEntry] +type Comment = String + +newtype PatchBundleName = PatchBundleName { unPatchBundleName :: String } + deriving (Show,Read) + +newtype DPMStorageVersion = DPMStorageVersion { unVersion :: Int } + deriving (Show,Read,Eq,Ord) + +ppVersion :: DPMStorageVersion -> String +ppVersion (DPMStorageVersion i) = show i + +currentVersion :: DPMStorageVersion +currentVersion = DPMStorageVersion 1 + +withLock :: DPM a -> DPM a +withLock x = + do fname <- getDPMConfigValue cfg_lockFile + io <- asIO x + liftIO $ + do -- withLock terminates the program, so we have to + -- workaround this fact + ref <- newIORef False + (Darcs.Lock.withLock fname (writeIORef ref True >> io)) + `catch` (\ (e::SomeException) -> + do b <- readIORef ref + if b then throwIO e + else failIO ("Could not obtain lock " + ++ show fname ++ + ", aborting.")) + +setupStorageDir :: DPM () +setupStorageDir = + do cfg <- getDPMConfig + liftIO $ createDirectoryIfMissing False (cfg_dataDir cfg) + liftIO $ createDirectoryIfMissing False (cfg_reviewDir cfg) + writeIfNonExisting (cfg_modelFile cfg) M.emptyModel + writeIfNonExisting (cfg_patchesFile cfg) (Map.empty :: Patches) + writeIfNonExisting (cfg_patchLog cfg) (Map.empty :: Log PatchID) + writeIfNonExisting (cfg_patchGroupLog cfg) (Map.empty :: + Log PatchGroupID) + where + writeIfNonExisting :: Show a => FilePath -> a -> DPM () + writeIfNonExisting fname x = + do exists <- liftIO (doesFileExist fname) + unless exists (writeToFile fname x) + +readFromFile :: Read a => FilePath -> DPM a +readFromFile fname = + do debugDPM ("Storage: reading " ++ fname) + s <- liftIO $ readFile fname + liftIO $ evaluate (length s) -- force the string! + case reads s of + [(version, rest)] -> + if version /= currentVersion + then fail ("Version of storage is " ++ ppVersion version ++ + " but DPM can handle only storage version " ++ + ppVersion currentVersion ++ + ". Migrate your storage if possible.") + else case readM rest of + Nothing -> fail ("Content of " ++ fname ++ " corrupted") + Just m -> return m + _ -> fail ("Content of " ++ fname ++ " corrupted") + +writeToFile :: Show a => FilePath -> a -> DPM () +writeToFile fname x = + do debugDPM ("Storage: writing " ++ fname) + liftIO $ writeFile fname (show currentVersion ++ show x) + +modifyFile :: (Show a, Read a) => FilePath -> (a -> DPM a) -> DPM a +modifyFile fname trans = + do x <- readFromFile fname + y <- trans x + writeToFile fname y + return y + +readModel :: DPM M.Model +readModel = + do fname <- getDPMConfigValue cfg_modelFile + readFromFile fname + +writeModel :: M.Model -> DPM () +writeModel model = + do fname <- getDPMConfigValue cfg_modelFile + writeToFile fname model + +readPatches :: DPM Patches +readPatches = + do fname <- getDPMConfigValue cfg_patchesFile + readFromFile fname + +writePatches :: Patches -> DPM () +writePatches patches = + do fname <- getDPMConfigValue cfg_patchesFile + writeToFile fname patches + +insertPatch :: Patch -> PatchBundleName -> Patches -> Patches +insertPatch p bname ps = Map.insert (p_id p) (p, bname) ps + +lookupPatch :: PatchID -> Patches -> Maybe Patch +lookupPatch pid patches = + do (p,_) <- Map.lookup pid patches + return p + +getPatchFile :: PatchID -> DPM FilePath +getPatchFile pid = + do patches <- readPatches + getPatchFileIntern patches pid + +getPatchFileIntern :: Patches -> PatchID -> DPM FilePath +getPatchFileIntern patches pid = + do case Map.lookup pid patches of + Nothing -> fail ("Internal state inconsistent: patch with ID " ++ + show pid ++ " not found") + Just (_, PatchBundleName name) -> + do dir <- getDPMConfigValue cfg_dataDir + return (dir name) + +withModelAndPatchesLogPG :: (M.Model -> Patches -> (M.Partial M.Model, Patches, + PatchGroupID, String)) + -> DPM Bool +withModelAndPatchesLogPG f = + withModelAndPatchesGeneric cfg_patchGroupLog (\m p -> return (f m p)) + +withModelAndPatches :: (M.Model -> Patches -> (M.Partial M.Model, Patches, + PatchID, String)) + -> DPM Bool +withModelAndPatches f = withModelAndPatchesDPM (\m p -> return (f m p)) + +withModelAndPatchesDPM :: (M.Model -> Patches -> + DPM (M.Partial M.Model, Patches, + PatchID, String)) + -> DPM Bool +withModelAndPatchesDPM = withModelAndPatchesGeneric cfg_patchLog + +withModelAndPatchesGeneric :: (Show a, Read a, Ord a) => + (DPMConfig -> FilePath) + -> (M.Model -> Patches -> + DPM (M.Partial M.Model, Patches, a, String)) + -> DPM Bool +withModelAndPatchesGeneric logFileFun f = + do model <- readModel + patches <- readPatches + res <- f model patches + case res of + (Left err, _, _, _) -> fail err + (Right model', patches', a, logMsg) -> + do writeModel model' + writePatches patches' + t <- liftIO $ getCurrentTime + user <- getDPMConfigValue cfg_currentUser + logFile <- getDPMConfigValue logFileFun + let logEntry = LogEntry t user (model /= model') logMsg + modifyFile logFile + (\ m -> case Map.lookup a m of + Nothing -> return $ Map.insert a [logEntry] m + Just l -> return $ Map.insert a (logEntry:l) m) + return (model /= model') + +addPatchBundle :: B.ByteString -> DPM PatchBundleName +addPatchBundle bs = + do dir <- getDPMConfigValue cfg_dataDir + liftIO $ do (tmpFile, handle) <- openTempFile dir ".dpatch" + B.hPutStr handle bs + hClose handle + return (PatchBundleName (takeFileName tmpFile)) + +addPatch :: Patch -> PatchBundleName -> [PatchID] -> Bool -> DPM Bool +addPatch p bundleName conflicts conflictWithRepo = + withModelAndPatchesDPM $ \model patches -> + case M.addPatch model (p_id p) (p_name p) (p_dependents p) + conflicts conflictWithRepo + of + Left err -> return (Left err, patches, p_id p, "added") + Right model' -> + do return (Right model', + insertPatch p bundleName patches, + p_id p, + "added") + +markAsReviewed :: PatchID -> Comment -> DPM Bool +markAsReviewed pid comment = withModelAndPatches $ + \model patches -> (M.markAsReviewed model pid, patches, + pid, "marked as reviewed: " ++ comment) + +markAsRejected :: PatchID -> Comment -> DPM Bool +markAsRejected pid comment = withModelAndPatches $ + \model patches -> (M.markAsDiscarded model pid ReasonRejected, patches, + pid, "marked as rejected: " ++ comment) + +markAsObsolete :: PatchID -> Comment -> DPM Bool +markAsObsolete pid comment = withModelAndPatches $ + \model patches -> (M.markAsDiscarded model pid ReasonObsolete, patches, + pid, "marked as obsolete: " ++ comment) + +markAsObsoleteNoCheck :: PatchID -> Comment -> DPM Bool +markAsObsoleteNoCheck pid comment = withModelAndPatches $ + \model patches -> (M.markAsDiscarded' False model pid ReasonObsolete, + patches, pid, "marked as obsolete: " ++ comment) + +markAsUndecided :: PatchID -> Comment -> DPM Bool +markAsUndecided pid comment = withModelAndPatches $ + \model patches -> (M.markAsUndecided model pid, patches, + pid, "marked as undecided: " ++ comment) + +markAsApplied :: PatchID -> Comment -> DPM Bool +markAsApplied pid comment = withModelAndPatches $ + \model patches -> (M.markAsApplied model pid, patches, + pid, "marked as applied: " ++ comment) + +addComment :: PatchID -> Comment -> DPM Bool +addComment pid comment = withModelAndPatches $ + \model patches -> (Right model, patches, pid, comment) + +applyPatch :: PatchID + -> (FilePath -> DPM ()) -- Applies the patch stored in the file + -> Maybe Comment + -> DPM Bool +applyPatch pid applyFun comment = withModelAndPatchesDPM $ + \model patches -> + case M.markAsApplied model pid of + Left err -> return (Left err, patches, pid, "applied") + Right model' -> + do when (model' /= model) $ + do patchFile <- getPatchFileIntern patches pid + applyFun patchFile + return (Right model', patches, pid, + case comment of + Nothing -> "applied" + Just s -> "applied (" ++ s ++ ")") + +closePatchGroup :: PatchGroupID -> DPM Bool +closePatchGroup pgid = withModelAndPatchesLogPG $ + \model patches -> (M.closePatchGroup model pgid, patches, + pgid, "closed patch group") + +openPatchGroup :: PatchID -> DPM Bool +openPatchGroup pid = withModelAndPatchesLogPG $ + \model patches -> + case M.openPatchGroup model pid of + Left err -> (Left err, patches, + error "no patch group id", "opened patch group") + Right (model', pgid) -> (Right model', patches, + pgid, "opened patch group") + +data PatchesResult = PatchesResult { pr_groups :: [PatchGroup (Patch, FilePath)] + , pr_revDeps :: PatchRevDeps + , pr_allPatchIDs :: [PatchID] + , pr_allConflicts :: PatchConflicts } + +-- FIXME: test filtering +getPatches :: Query -> DPM PatchesResult +getPatches query = + do model <- readModel + patches <- readPatches + let allPatchIDs = Map.keys patches + patches' = M.getPatches model + revDeps = buildRevDeps (map (\(p,_) -> (p_id p, p_dependents p)) + (Map.elems patches)) + logFile <- getDPMConfigValue cfg_patchLog + logMap <- readFromFile logFile + allGroups <- mapM (convertPG logMap patches) patches' + let matchingGroups = mapMaybe (filterPatchGroups revDeps) allGroups + return $ PatchesResult matchingGroups revDeps + allPatchIDs (M.allConflicts model) + where + -- Conversion of patches and groups (injects additional info etc.) + convertPG :: Log PatchID -> Patches -> PatchGroup (M.Patch PatchState) + -> DPM (PatchGroup (Patch, FilePath)) + convertPG logMap allPatches (PatchGroup id state ps c) = + do ps' <- mapM (retrievePatch logMap allPatches) ps + return $ PatchGroup id state ps' c + retrievePatch :: Log PatchID -> Patches -> M.Patch PatchState + -> DPM (Patch, FilePath) + retrievePatch logMap patches mp = + case lookupPatch (M.p_id mp) patches of + Nothing -> fail ("Internal state inconsistent: patch with ID " ++ + show (M.p_id mp) ++ " not found") + Just p -> + do let log = case Map.lookup (p_id p) logMap of + Nothing -> [] + Just l -> l + patchFile <- getPatchFileIntern patches (p_id p) + return $ + (p { p_state = M.p_state mp + , p_tags = if M.p_isReviewed mp then [TagReviewed] + else [] + , p_log = log } + ,patchFile) + -- Filtering + filterPatchGroups :: PatchRevDeps -> PatchGroup (Patch, FilePath) + -> Maybe (PatchGroup (Patch, FilePath)) + filterPatchGroups revDeps pg = + let patches = pg_patches pg + patches' = filter (matchesPatch revDeps (pg_state pg)) patches + in if null patches' + then Nothing + else Just $ pg { pg_patches = patches' + , pg_complete = (length patches == + length patches') } + matchesPatch :: PatchRevDeps -> PatchGroupState + -> (Patch, FilePath) -> Bool + matchesPatch revDeps pgState (p, _) = + let strings = [prettyDate (p_date p), + unPatchGroupID (p_name p), + p_author p] + trailingStrings = [unPatchID (p_id p)] ++ + (map unPatchID (p_dependents p)) ++ + (map unPatchID (getRevDeps revDeps (p_id p))) + in evalQuery query pgState p + (map (\s -> (s, False)) strings ++ + map (\s -> (s, True)) trailingStrings) + evalQuery :: Query -> PatchGroupState -> Patch + -> [(String, Bool)] -- snd indicates if only trailing part should + -- be matched + -> Bool + evalQuery q pgState patch strings = + eval q + where + eval (QPrim s) = any (matchesString s) strings + eval (QAnd q1 q2) = eval q1 && eval q2 + eval (QOr q1 q2) = eval q1 || eval q2 + eval (QNot q') = not (eval q') + eval (QState pState) = p_state patch == pState + eval (QGroupState pgState') = pgState == pgState' + eval (QPatchID id) = unPatchID (p_id patch) == id + eval QReviewed = isReviewed patch + eval QTrue = True + eval QFalse = False + matchesString queryStr (existingStr, trailingOnly) = + let lowerQueryStr = map toLower queryStr + lowerExistingStr = map toLower existingStr + pred = if trailingOnly then List.isSuffixOf else List.isInfixOf + in lowerQueryStr `pred` lowerExistingStr + +allPatchIDs :: DPM [PatchID] +allPatchIDs = + do patches <- readPatches + return $ Map.keys patches + +allConflicts :: DPM PatchConflicts +allConflicts = + do model <- readModel + return (M.allConflicts model) diff --git a/src/DPM/Core/TestDarcs.hs b/src/DPM/Core/TestDarcs.hs new file mode 100644 --- /dev/null +++ b/src/DPM/Core/TestDarcs.hs @@ -0,0 +1,282 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module DPM.Core.TestDarcs ( allHTFTests ) where + +import Prelude hiding ( catch ) +import Control.Monad ( when ) +import System.Environment ( getArgs ) +import Data.List ( find ) +import System.FilePath +import Control.Exception ( bracket_, catch, SomeException ) +import Prelude hiding ( catch ) +import Data.List ( isPrefixOf ) +import qualified Data.ByteString.Char8 as B +import System.IO +import Text.PrettyPrint + +import HSH +import Test.Framework + +import DPM.Core.DataTypes ( Patch(..), unPatchGroupID, + PatchData(..), unPatchID ) +import DPM.Core.Darcs +import DPM.Core.PatchBundleParser + +repoRoot :: FilePath +repoRoot = "__repo__" + +withRepoRoot :: IO a -> IO a +withRepoRoot = withTempDir repoRoot + +withTempDir :: FilePath -> IO a -> IO a +withTempDir dir action = + bracket_ (do runIO ("rm", ["-rf", dir]) + runIO ("mkdir", [dir])) + (do runIO ("rm", ["-rf", dir]) + `catch` \(e::SomeException) -> return ()) + (bracketCD dir action) + +setupRepos :: IO () +setupRepos = + do runIO "mkdir A B" + bracketCD "A" $ mapM_ runIO ["darcs init" + ,"echo 1 > x" + ,"darcs add x" + ,"darcs record --no-ask-deps -a -m 'Patch 0'"] + bracketCD "B" $ mapM_ runIO ["darcs init" + ,"darcs pull ../A -a" + ,"echo 2 >> x" + ,"echo 3 >> x" + ,"echo 4 >> x" + ,"echo 5 >> x" + ,"echo anchor >> x" + ,"echo anchor >> x" + ,"echo anchor >> x" + ,"echo 6 >> x" + ,"echo 7 >> x" + ,"darcs record --no-ask-deps -a -m 'Patch 1'" + ,"echo 1 > x" + ,"echo 22 >> x" + ,"echo 3 >> x" + ,"echo 4 >> x" + ,"echo 5 >> x" + ,"echo 5 >> x" + ,"echo 5 >> x" + ,"echo 5 >> x" + ,"echo anchor >> x" + ,"echo anchor >> x" + ,"echo anchor >> x" + ,"echo 42 >> x" + ,"echo 7 >> x" + ,"darcs record --no-ask-deps -a -m 'Patch 2'" + ,"echo 4 > y" + ,"darcs add y" + ,"darcs record --no-ask-deps -a -m " ++ + "'INDEPENDENT'" + ,"darcs send -a -o ../bundle"] + +test_ok = withRepoRoot $ + do setupRepos + bundle <- B.readFile "bundle" + eith <- readPatchBundle "A" bundle + content <- assertRight eith + let patches = pbc_patches content + assertEqual 3 (length patches) + let patch1:patch2:patch3:[] = patches + -- check patch 1 + assertEqual "Patch 1" (unPatchGroupID (p_name patch1)) + assertEmpty (p_dependents patch1) + -- check patch 2 + assertEqual "Patch 2" (unPatchGroupID (p_name patch2)) + let deps2 = p_dependents patch2 + assertEqual 1 (length deps2) + assertEqual (p_id patch1) (head deps2) + -- check patch 3 + assertEqual "INDEPENDENT" (unPatchGroupID (p_name patch3)) + assertEmpty (p_dependents patch3) + +-- check what happens if repo A already has all patches of the bundle +test_allPatchesPresent = withRepoRoot $ + do setupRepos + bracketCD "A" $ runIO "darcs pull --all ../B" + bundle <- B.readFile "bundle" + eith <- readPatchBundle "A" bundle + content <- assertRight eith + let patches = pbc_patches content + assertEmpty patches + +-- check what happens if repo A misses a patch in the context +-- of the bundle +test_missingPatch = withRepoRoot $ + do setupRepos + bracketCD "A" $ runIO "darcs unrecord --all" + bundle <- B.readFile "bundle" + eith <- readPatchBundle "A" bundle + s <- assertLeft eith + assertBool ("We cannot process this patch bundle, since we're missing" + `isPrefixOf` s) + +-- check what happens if the patch bundle has a wrong hash +test_wrongBundleHash = withRepoRoot $ + do setupRepos + s <- readFile "bundle" + let l = lines s + hash = head (reverse l) + wrongHash = case hash of + ('1':xs) -> '2':xs + (_:xs) -> '1':xs + l' = reverse (wrongHash : (tail (reverse l))) + s' = unlines l' + writeFile "bundle_wrong_hash" s' + bundle <- B.readFile "bundle_wrong_hash" + eith <- readPatchBundle "A" bundle + s <- assertLeft eith + assertBool ("Patch bundle failed hash" `isPrefixOf` s) + +-- check what happens if the patch bundle has an illegal format +test_illegalBundleFormat = withRepoRoot $ + do setupRepos + eith <- readPatchBundle "A" (B.pack "I AM AN ILLEGAL PATCH BUNDLE") + s <- assertLeft eith + assertBool ("Bad patch bundle" `isPrefixOf` s) + +assertPatches :: [String] -> String -> IO () +assertPatches patchNames changesOut = + let patchNames' = map (drop 4) . + filter (\s -> " * " `isPrefixOf` s) . + lines $ changesOut + in assertEqual patchNames patchNames' + +-- FIXME: test apply +test_apply = withRepoRoot $ + do setupRepos + bundle <- B.readFile "bundle" + eith <- readPatchBundle "A" bundle + content <- assertRight eith + let patches = pbc_patches content + assertEqual 3 (length patches) + let p1:p2:p3:[] = patches + x <- apply "A" (text "Patch 1") (p_id p1) False False "bundle" + assertRight x + out1 <- run "darcs changes --repodir=A" + assertPatches ["Patch 1", "Patch 0"] out1 + y <- apply "A" (text "Patch 2") (p_id p2) False False "bundle" + assertRight y + out2 <- run "darcs changes --repodir=A" + assertPatches ["Patch 2", "Patch 1", "Patch 0"] out2 + z <- apply "A" (text "INDEPENDENT") (p_id p3) False False "bundle" + assertRight z + out3 <- run "darcs changes --repodir=A" + assertPatches ["INDEPENDENT", "Patch 2", "Patch 1", "Patch 0"] out3 + +-- FIXME: test conflicts more seriously + +{- +test_conflicts = withRepoRoot $ + do runIO "mkdir A B C" + bracketCD "A" $ mapM_ runIO ["darcs init" + ,"echo 1 > x" + ,"darcs add x" + ,"darcs record -a -m 'Patch 0'"] + mkRepo "B" + mkRepo "C" + bundleB <- B.readFile "bundleB" + eithB <- readPatchBundle "A" bundleB [] + contentB <- assertRight eithB + let pidB = p_id $ head $ pbc_patches contentB + assertEqual (pbc_conflicts contentB) [(pidB, [])] + bundleC <- B.readFile "bundleC" + eithC <- readPatchBundle "A" bundleC (pbc_data contentB) + contentC <- assertRight eithC + let pidC = p_id $ head $ pbc_patches contentC + assertEqual (pbc_conflicts contentC) [(pidC, [pidB])] + let getBS x = pd_content $ head $ pbc_data x + bsB = getBS contentB + bsC = getBS contentC + repoConflictB <- bundleConflictsWithRepo "A" bsB + assertEqual repoConflictB False + repoConflictC <- bundleConflictsWithRepo "A" bsC + assertEqual repoConflictC False + -- after applying bundleB, C conflicts with the repo + x <- apply "A" "bundleB" + assertRight x + repoConflictC <- bundleConflictsWithRepo "A" bsC + assertEqual repoConflictC True + where mkRepo dir = + do bracketCD dir $ mapM_ runIO ["darcs init" + ,"darcs pull ../A -a" + ,"echo " ++ dir ++ " >> x" + ,"darcs record -a -m 'Patch " ++ + dir ++ "'" + ,"darcs send -a -o " ++ + "../bundle" ++ dir] +-} + +test_patchBundleParser = + do let bundleData = B.pack $ unlines testPatchBundleContent + let eith = scanBundle bundleData + infos <- assertRight eith + assertEqual (length infos) 3 + let (pi1,d1):(pi2,d2):(pi3,d3):[] = infos + assertEqual pi1 (PatchInfo "20091203132005" + "MINOR: Vitalwerte ueber Konfig (de-)aktivieren" + "Dirk Spoeri " + ["Ignore-this: 729a19332b2cfec7c18391234d505998"] + False) + assertEqual d1 (B.pack "{\nhunk11\nhunk12") + assertEqual pi2 (PatchInfo "20100125162933" + "FEATURE: bei Standalone neue Mobil-Mitarbeiter anlegen" + "Dirk Spoeri " + ["Ignore-this: 59a42d4317961478dfd3d731b5a3a95d"] + False) + assertEqual d2 + (B.pack ("<\n" ++ + "[TRIVIAL: 'versorgt durch' durch 'Versorgung durch'\n" ++ + "Johannes Weiss **20071130173047]\n" ++ + "> {\n" ++ + "hunk21\n" ++ + "hunk22")) + assertEqual pi3 (PatchInfo "20091210101000" + "MINOR: Merge-Konflikt Standalone<->Global editieren" + "Dirk Spoeri " + ["Ignore-this: 79ac83a1f24ca4835b9ad467498d5e30"] + False) + assertEqual d3 (B.pack "hunk31\nhunk32") + +testPatchBundleContent = + ["", + "", + "New patches:", + "", + "[MINOR: Vitalwerte ueber Konfig (de-)aktivieren", + "Dirk Spoeri **20091203132005", + " Ignore-this: 729a19332b2cfec7c18391234d505998", + "] {", + "hunk11", + "hunk12", + "[FEATURE: bei Standalone neue Mobil-Mitarbeiter anlegen", + "Dirk Spoeri **20100125162933", + " Ignore-this: 59a42d4317961478dfd3d731b5a3a95d", + "]", + "<", + "[TRIVIAL: 'versorgt durch' durch 'Versorgung durch'", + "Johannes Weiss **20071130173047]", + "> {", + "hunk21", + "hunk22", + "[MINOR: Merge-Konflikt Standalone<->Global editieren", + "Dirk Spoeri **20091210101000", + " Ignore-this: 79ac83a1f24ca4835b9ad467498d5e30", + "] hunk31", + "hunk32", + "", + "Context:", + "", + "[TRIVIAL: Grammatikalischen Fehler gefixt", + "Johannes Weiss **20100125142927", + " Ignore-this: e9dcd96bf556f84979e69c13ab60010b", + "", + " Woerter bestehen aus Buchstaben, Worte bestehen aus Gedanken.", + " vgl. http://www.spiegel.de/kultur/zwiebelfisch/0,1518,307445,00.html", + "]"] diff --git a/src/DPM/Core/Utils.hs b/src/DPM/Core/Utils.hs new file mode 100644 --- /dev/null +++ b/src/DPM/Core/Utils.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} + +module DPM.Core.Utils ( + + listReplaceAt, listDeleteAt, readM, execCommand, findCommand, + escapeRegexChars, escapeRegexChar, unlessM, whenM, + retain, trim, bool, formatTime, formatTimeUTC, + darcsDateFormat, darcsInternDateFormat, prettyDate, + joinStrings, splitOn, + + allHTFTests + +) where + +import Test.Framework +import System.Cmd ( rawSystem ) +import System.Exit +import Control.Monad +import qualified Data.List as List +import Data.Char ( isSpace ) +import System.Directory ( doesFileExist, doesDirectoryExist ) +import System.FilePath +import Text.PrettyPrint +import Data.Time ( UTCTime, TimeZone, getCurrentTimeZone, + utcToLocalTime ) +import qualified Data.Time +import System.Locale ( defaultTimeLocale ) +import System.IO.Unsafe ( unsafePerformIO ) + +listReplaceAt :: Int -> a -> [a] -> [a] +listReplaceAt i x l + | i < 0 = error "listReplaceAt: index too small" + | i == 0 = + case l of + [] -> error "listReplaceAt: index too small" + _:ys -> x : ys + | otherwise = + case l of + [] -> error "DPM.Utils.listReplaceAt: index too large" + y:ys -> y : listReplaceAt (i-1) x ys + +prop_listReplaceAt :: Char -> [Char] -> Property +prop_listReplaceAt new l = + not (null l) ==> + forAll (choose (0, max 0 (length l - 1))) $ \ix -> + let l' = listReplaceAt ix new l + in (l' !! ix == new) && + (and [l!!i == l'!!i | i <- [0..(length l - 1)], i /= ix]) + +listDeleteAt :: Int -> [a] -> [a] +listDeleteAt i [] = error ("DPM.Utils.listDeleteAt: list empty") +listDeleteAt i (x:xs) + | i < 0 = error ("DPM.Utils.listDeleteAt: index too small") + | i == 0 = xs + | otherwise = x : listDeleteAt (i-1) xs + +prop_listDeleteAt :: [Char] -> Property +prop_listDeleteAt l = + not (null l) ==> + forAll (choose (0, max 0 (length l - 1))) $ \ix -> + let l' = listDeleteAt ix l + in (and [l!!i == l'!!i | i <- [0..(ix - 1)]]) && + (and [l!!(i+1) == l'!!i | i <- [ix..(length l -2)]]) + +readM :: (Monad m, Read a) => String -> m a +readM s | [x] <- parse = return x + | otherwise = fail $ "Failed parse: " ++ show s + where + parse = [x | (x,t) <- reads s] + +execCommand :: FilePath -> [String] -> IO (Either String ()) +execCommand cmd args = + do retcode <- rawSystem cmd args + case retcode of + ExitSuccess -> return (Right ()) + ExitFailure i -> + return (Left ("Command " ++ show cmd ++ " with arguments " ++ + show args ++ " failed with exit code " ++ show i)) + +findCommand :: FilePath -> IO (Either String FilePath) +findCommand fname = + if pathSeparator `elem` fname + then return (Right fname) + else do path <- getSearchPath + l <- filterM doesFileExist $ map (\p -> p fname) path + case l of + [] -> return $ Left ("No executable " ++ show fname ++ + " found") + x:_ -> return (Right x) + +escapeRegexChars :: String -> String +escapeRegexChars = concatMap escapeRegexChar + +-- copied from the Real World Haskell book +escapeRegexChar :: Char -> String +escapeRegexChar c | c `elem` regexChars = '\\' : [c] + | otherwise = [c] + where regexChars = "\\+()^$.{}]|" + +unlessM :: Monad m => m Bool -> m () -> m () +unlessM cond act = + do b <- cond + unless b act + +whenM :: Monad m => m Bool -> m () -> m () +whenM cond act = + do b <- cond + when b act + +retain :: Int -> [a] -> [a] +retain i l = + let n = length l + in drop (n - i) l + +prop_retainEmpty :: [Int] -> Bool +prop_retainEmpty l = null $ retain 0 l + +prop_retainFull :: [Int] -> Bool +prop_retainFull l = l == retain (length l) l + +prop_retainLength :: Int -> [Int] -> Bool +prop_retainLength i l = length (retain i l) == max 0 (min i (length l)) + +prop_retainSuffix :: Int -> [Int] -> Bool +prop_retainSuffix i l = List.isSuffixOf (retain i l) l + +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + +bool :: Bool -> Doc +bool True = text "yes" +bool False = text "no" + +timeZone :: TimeZone +timeZone = unsafePerformIO getCurrentTimeZone + +formatTimeUTC :: String -> UTCTime -> String +formatTimeUTC format time = + Data.Time.formatTime defaultTimeLocale format time + +formatTime :: String -> UTCTime -> String +formatTime format time = + let local = utcToLocalTime timeZone time + in Data.Time.formatTime defaultTimeLocale format local + +darcsDateFormat :: String +darcsDateFormat = "%a %b %e %T %Z %Y" + +darcsInternDateFormat :: String +darcsInternDateFormat = "%Y%m%d%H%M%S" + +prettyDate :: UTCTime -> String +prettyDate date = + formatTime darcsDateFormat date + +joinStrings :: [String] -> String +joinStrings = List.intercalate " " + +splitOn :: (a -> Bool) -> [a] -> [[a]] +splitOn _ [] = [] +splitOn f l@(x:xs) + | f x = splitOn f xs + | otherwise = let (h,t) = break f l in h:(splitOn f t) diff --git a/src/DPM/UI/Commandline/ANSIColors.hs b/src/DPM/UI/Commandline/ANSIColors.hs new file mode 100644 --- /dev/null +++ b/src/DPM/UI/Commandline/ANSIColors.hs @@ -0,0 +1,12 @@ +module DPM.UI.Commandline.ANSIColors (Color(..), colored) where + +import Data.Char ( chr ) + +data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White + | Reset + deriving (Eq,Show,Read,Ord,Bounded,Enum) + +colored :: Color -> String +colored Reset = [chr 27, '[', '0', 'm'] +colored c = [chr 27, '[', '1', ';', '3', head (show (fromEnum c)), 'm'] + diff --git a/src/DPM/UI/Commandline/CDPM_Monad.hs b/src/DPM/UI/Commandline/CDPM_Monad.hs new file mode 100644 --- /dev/null +++ b/src/DPM/UI/Commandline/CDPM_Monad.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module DPM.UI.Commandline.CDPM_Monad ( + + Config(..), defaultConfig, CDPM, runCDPM, + liftDPM, bracketCDPM, asDPM, funAsDPM, + + getConfig, getConfigValue, debugCDPM, + + withLock + +) where + +import Control.Monad.Reader + +import DPM.Core.DPM_Monad +import qualified DPM.Core.Storage as S + +import DPM.UI.Commandline.ANSIColors + +data Config = Config { cfg_verbose :: Bool + , cfg_batch :: Bool + , cfg_tests :: Bool + , cfg_force :: Bool + , cfg_color1 :: Color + , cfg_color2 :: Color + , cfg_color3 :: Color + , cfg_colored :: Bool } + +defaultConfig :: Config +defaultConfig = Config { cfg_verbose = False + , cfg_batch = False + , cfg_tests = True + , cfg_force = False + , cfg_color1 = Red + , cfg_color2 = Blue + , cfg_color3 = Green + , cfg_colored = True } + +newtype CDPM a = CDPM { unCDPM :: ReaderT Config DPM a } + deriving (Monad, MonadIO) + +runCDPM :: Config -> CDPM a -> DPM a +runCDPM cfg (CDPM r) = runReaderT r cfg + +liftDPM :: DPM a -> CDPM a +liftDPM dpm = CDPM (lift dpm) + +bracketCDPM :: CDPM a -> (a -> CDPM c) -> (a -> CDPM c) -> CDPM c +bracketCDPM acquire release doWork = + do config <- getConfig + liftDPM $ bracketDPM (run acquire config) + (\x -> run (release x) config) + (\x -> run (doWork x) config) + where run = runReaderT . unCDPM + +asDPM :: CDPM a -> CDPM (DPM a) +asDPM (CDPM x) = + do config <- getConfig + return $ runReaderT x config + +funAsDPM :: (a -> CDPM b) -> CDPM (a -> DPM b) +funAsDPM f = + do cfg <- getConfig + return $ \x -> runReaderT (unCDPM (f x)) cfg + +withLock :: CDPM a -> CDPM a +withLock cdpm = + do dpm <- asDPM cdpm + liftDPM (S.withLock dpm) + + +getConfig :: CDPM Config +getConfig = CDPM ask + +getConfigValue :: (Config -> a) -> CDPM a +getConfigValue f = + do cfg <- getConfig + return (f cfg) + +instance DPMConfigAccess CDPM where + getDPMConfig = liftDPM getDPMConfig + +debugCDPM :: String -> CDPM () +debugCDPM = liftDPM . debugDPM diff --git a/src/DPM/UI/Commandline/Commands.hs b/src/DPM/UI/Commandline/Commands.hs new file mode 100644 --- /dev/null +++ b/src/DPM/UI/Commandline/Commands.hs @@ -0,0 +1,724 @@ +{-# LANGUAGE PatternGuards, ScopedTypeVariables #-} + +module DPM.UI.Commandline.Commands ( + + addPatchBundle, applyPatch, reviewPatch, listPatches, sync, + markAsReviewed, markAsUndecided, markAsObsolete, markAsRejected, + openGroup, closeGroup, + addComment, viewPatch, exportBundle, markAsApplied, markAsUnapplied + +) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Control.Monad +import Control.Monad.Trans +import qualified Data.List as List +import qualified Text.PrettyPrint as PP +import System.Directory +import System.IO +import Text.PrettyPrint +import ByteStringUtils ( gzReadFilePS ) -- from darcs +import Data.Time ( UTCTime, getCurrentTime ) + +import DPM.Core.DataTypes +import DPM.Core.QueryParser +import DPM.Core.DPM_Monad +import DPM.Core.Email +import qualified DPM.Core.PatchBundleParser as PBP +import DPM.Core.Conflicts +import DPM.Core.ReverseDependencies +import qualified DPM.Core.Darcs as Darcs +import qualified DPM.Core.Storage as S +import DPM.Core.Utils +import DPM.Core.ShortID +import DPM.UI.Commandline.Interaction +import DPM.UI.Commandline.CDPM_Monad +import qualified DPM.UI.Commandline.ANSIColors as Colors + +-- +-- Commands +-- + +addPatchBundle :: String -> B.ByteString -> CDPM () +addPatchBundle origin bs = withLock $ + do info ("About to add patches from bundle " ++ show origin) + repoDir <- getDPMConfigValue cfg_repoDir + -- existing <- getAllUnapplied + darcsRes <- liftIO $ Darcs.readPatchBundle repoDir bs -- existing + case darcsRes of + Left err -> darcsFailed err + Right content -> + let patches = Darcs.pbc_patches content + conflicts = Darcs.pbc_conflicts content + in if null patches + then info ("All patches in " ++ origin ++ + " have already been applied.") + else do bname <- liftDPM $ + S.addPatchBundle $ readDarcsEmail bs + mapM_ (\p -> addPatch repoDir p + bname + conflicts) + patches + where + addPatch repoDir p bname conflicts = + do conflictWithRepo <- liftIO $ + Darcs.conflictsBundleWithRepo repoDir bs + let c = lookupConflicts (p_id p) conflicts + liftDPM $ S.addPatch p bname c conflictWithRepo + info ("Added patch\n" ++ show (nest 2 (renderPatchNameShort p))) + getAllUnapplied = + do result <- + liftDPM $ S.getPatches (QNot (QState PatchStateAPPLIED)) + liftIO $ mapM (\(p,fp) -> do s <- B.readFile fp + return $ PatchData (p_id p) s) + (concatMap pg_patches (S.pr_groups result)) + lookupConflicts pid conflicts = + case List.lookup pid conflicts of + Nothing -> [] + Just c -> c + + +data ExtraInfo = ExtraInfo { ei_revDeps :: PatchRevDeps + , ei_conflicts :: PatchConflicts } + +listPatches :: Query -> CDPM () +listPatches query = + do result <- liftDPM $ S.getPatches query + cfg <- getConfig + let sorted = sortPatchGroups + (map (\pg -> pg { pg_patches = + sortPGMembers (pg_patches pg) }) + (S.pr_groups result)) + render sorted (S.pr_allPatchIDs result) + cfg (ExtraInfo (S.pr_revDeps result) (S.pr_allConflicts result)) + where + sortPatchGroups :: [PatchGroup (Patch, FilePath)] + -> [PatchGroup (Patch, FilePath)] + sortPatchGroups pgs = + flip List.sortBy pgs + (\pg1 pg2 -> + case (pg_state pg1, pg_state pg2) of + (PatchGroupOpen, PatchGroupClosed) -> LT + (PatchGroupClosed, PatchGroupOpen) -> GT + _ -> case (pg_patches pg1, pg_patches pg2) of + ((p1,_):_, (p2,_):_) -> + p_date p2 `compare` p_date p1 + _ -> EQ) + sortPGMembers :: [(Patch, FilePath)] -> [(Patch, FilePath)] + sortPGMembers members = + flip List.sortBy members + (\(p1,_) (p2,_) -> + case () of + _| p_state p1 `elem` [PatchStateUNDECIDED, + PatchStateAPPLIED] + -> LT + | p_state p2 `elem` [PatchStateUNDECIDED, + PatchStateAPPLIED] + -> GT + | otherwise -> + -- most recent patch comes first + p_date p2 `compare` p_date p1) + render matching allIDs cfg conflicts = + if null matching + then liftIO $ putStrLn ("(no matches)") + else liftIO $ putStrLn (PP.render (foldr (\g d -> + renderPatchGroup + allIDs cfg conflicts g + $$ d) + empty matching)) + +applyPatch :: Bool -> String -> CDPM () +applyPatch interactive s = + do allPIDs <- liftDPM S.allPatchIDs + applyPatch' allPIDs s + where + applyPatch' allIDs shortPID = + do pid <- resolvePID allIDs shortPID + p <- getPatch pid + case p_state p of + (PatchStateDISCARDED reason) -> + abort ("Patch " ++ shortPID ++ " is in state " ++ + show (prettyReason reason) ++ ".") + PatchStateAPPLIED -> + info ("Patch " ++ shortPID ++ " is in state APPLIED, " ++ + "nothing to do") + PatchStateUNDECIDED -> + do unless (isReviewed p) $ + do b <- query_yN ("Patch " ++ shortPID ++ + " not reviewed. Shall I " ++ + "nevertheless apply it? ") + when (not b) userAbort + mapM_ checkDependency (p_dependents p) + info ("About to apply patch " ++ shortPID) + let patchName = renderPatchName p + f <- liftDPM $ S.getPatchFile pid + -- it would be better to take the lock while + -- performing the darcs apply command. However, + -- this may take a long time, so we do not take + -- the lock here but later + darcsApply patchName pid f + liftDPM $ S.withLock $ S.markAsApplied pid "-" + do info ("Patch " ++ shortPID ++ + " applied successfully") + send <- query_Yn + ("Send notification to author " ++ + p_author p ++ " of patch " ++ + shortPID ++ "? ") + when send $ liftDPM $ sendEmailSimple p "applied" + where + darcsApply patchName patchID fname = + do repoDir <- getDPMConfigValue cfg_repoDir + color3 <- getConfigValue cfg_color3 + runTests <- getConfigValue cfg_tests + runTests' <- + if (not runTests) + then do b <- query_yN "Will not run any tests. Sure? " + return (not b) + else return True + -- info (Colors.colored color3 ++ "[start darcs]") + res <- liftIO $ Darcs.apply repoDir patchName patchID + runTests' interactive fname + -- info ("[end darcs]" ++ Colors.colored Colors.Reset) + case res of + Left err -> darcsFailed err + Right () -> return () + checkDependency pid' = + do p <- getPatch pid' + case p_state p of + PatchStateAPPLIED -> return () + PatchStateUNDECIDED -> + do b <- query_Yn ("Patch " ++ shortPID ++ + " depends on patch " ++ + getShortID allIDs pid' ++ + ". Apply patch " ++ + getShortID allIDs pid' ++ " first? ") + if not b + then userAbort + else applyPatch' allIDs (getShortID allIDs pid') + PatchStateDISCARDED reason -> + do abort ("Patch " ++ shortPID ++ + " depends on patch " ++ + getShortID allIDs pid' ++ + ", which is marked as " ++ + show (prettyReason reason) ++ ".") + +reviewPatch :: String -> CDPM () +reviewPatch shortPID = + do batch <- getConfigValue cfg_batch + force <- getConfigValue cfg_force + info ("Reviewing patch " ++ shortPID) + allPIDs <- liftDPM $ S.allPatchIDs + pid <- resolvePID allPIDs shortPID + doReview force allPIDs pid shortPID + where + doReview force allPIDs pid shortPID = + do p <- getPatch pid + case () of + _| p_state p == PatchStateAPPLIED -> + info "Refusing to offer an already applied patch for review." + | isReviewed p && not force -> + info ("Patch " ++ shortPID ++ + " already reviewed, nothing to do.") + | otherwise -> do + if isDiscarded (p_state p) + then do b <- query_yN ("Really review patch " ++ shortPID ++ + ", which is in state " ++ + show (prettyPatchState (p_state p)) + ++ "? ") + if b then reallyReview force allPIDs pid shortPID p + else return () + else reallyReview force allPIDs pid shortPID p + reviewDependent force allPIDs parentShortPID pid = + do p <- getPatch pid + if isReviewed p || p_state p == PatchStateAPPLIED + then return False + else + do let shortPID = getShortID allPIDs pid + discardedWarning = + if isDiscarded (p_state p) + then (", which is in state " ++ + show (prettyPatchState (p_state p))) + else "" + b <- query_Yn ("Patch " ++ parentShortPID ++ + " depends on patch " ++ shortPID ++ + discardedWarning ++ ". Review patch " ++ + shortPID ++ " first? ") + when b $ reallyReview force allPIDs pid shortPID p + return b + reallyReview force allPIDs pid shortPID p = + do bs <- mapM (reviewDependent force allPIDs shortPID) (p_dependents p) + when (or bs) $ + do wait ("Press ENTER to continue with review of patch " + ++ shortPID ++ ". ") + fname <- liftDPM $ S.getPatchFile pid + bracketCDPM + (do tmpDir <- getDPMConfigValue cfg_reviewDir + user <- getDPMConfigValue cfg_currentUser + liftIO $ do patchData <- gzReadFilePS fname + time <- getCurrentTime + let formattedTime = formatTime "%F" time + (tmpFile, handle) <- + openTempFile tmpDir (formattedTime ++ "_" ++ + shortPID ++ "_" ++ user + ++ "_" ++ ".dpatch") + let infoDoc = (renderPatchName p) $$ + (vcat $ map text (p_darcsLog p)) + hPutStr handle (quote (show infoDoc)) + hPutStrLn handle ">" + cleaned <- cleanupBundle p patchData + B.hPut handle (quoteBS cleaned) + hPutStrLn handle "" + hClose handle + return tmpFile) + (return $ return ()) -- do not remove + (\tmpFile -> do + editorCmd <- liftIO $ getEditorCommand + info ("Starting editor on " ++ tmpFile) + either <- liftIO $ execCommand editorCmd [tmpFile] + case either of + Left err -> abort err + Right _ -> return () + mr <- if not (isReviewed p) + then query_Yn ("Mark patch " ++ shortPID ++ + " as reviewed? ") + else return False + (md, mn) <- + if p_state p == PatchStateUNDECIDED + then do b <- query_yN ("Patch " ++ shortPID ++ + " is in state UNDECIDED, " ++ + "reject this patch? ") + return (b, False) + else do b <- query_yN ("Patch " ++ shortPID ++ + " is " ++ + show (prettyPatchState (p_state p)) + ++ ", move it " + ++ "to the UNDECIDED state? ") + return (False, b) + comment <- + if mr || md || mn || force then query ("Enter a comment: ") "" + else return "" + withLock $ do when mr $ + do liftDPM $ S.markAsReviewed pid comment + info ("Marked patch " ++ shortPID ++ + " as reviewed") + when md $ + do liftDPM $ S.markAsRejected pid + comment + info ("Moved patch " ++ shortPID ++ + " to REJECTED state") + when mn $ + do liftDPM $ S.markAsUndecided pid comment + info ("Moved patch " ++ shortPID ++ + " to UNDECIDED state") + from <- getDPMConfigValue cfg_fromAddress + sentReview <- + do reviewAddr <- getDPMConfigValue cfg_reviewAddress + let to = case reviewAddr of + Just s -> s + Nothing -> p_author p + queryFun = if md then query_Yn else query_yN + send <- queryFun ("Send review to " ++ to ++ "? ") + if not send + then return False + else do body <- liftIO $ readFile tmpFile + liftIO $ sendEmail from to [] + (tagSubject "reviewed" + (Just (p_author p)) + (unPatchGroupID (p_name p))) + body [] + return True + when (not sentReview && (md || mn)) $ + do send <- query_Yn ("Send notification to author " ++ + p_author p ++ " of patch " + ++ shortPID ++ "? ") + let task = if md then "rejected" else "marked-as-undecided" + when send $ liftDPM $ sendEmailSimple p task + return ()) + +quote :: String -> String +quote s = unlines $ map quoteLine $ lines s + where quoteLine l = "> " ++ l + +quoteBS :: B.ByteString -> B.ByteString +quoteBS bs = BC.unlines $ map quoteLine $ BC.lines bs + where quoteLine = BC.append (BC.pack "> ") + +cleanupBundle :: MonadIO m => Patch -> B.ByteString -> m B.ByteString +cleanupBundle p bs = + case PBP.scanBundle bs of + Left err -> + do warn ("Reading patch bundle for patch " ++ show (p_id p) ++ + " failed: " ++ err) + return bs + Right list -> + case List.find (\(pi,_) -> patchMatches pi) list of + Just (_, bs') -> return bs' + Nothing -> + do warn ("Patch " ++ show (p_id p) ++ " not found in bundle") + return bs + where + -- dirty hack to work around missing/wrong IDs in patch bundles + patchMatches pi = + PBP.piName pi == unPatchGroupID (p_name p) + && PBP.piAuthor pi == p_author p + && PBP.piDate pi == formatTimeUTC darcsInternDateFormat (p_date p) + +{- + Synchronzies DPM with the repository. The command changes only + the state of patches and patch groups managed by DPM, it nevers + adds new patches to DPM. +-} +-- FIXME: review and test +-- FIXME: update information about which patches are in conflict with the repo +sync :: CDPM () +sync = + do action <- asDPM doWork + liftDPM $ S.withLock action + where + doWork = + do repoDir <- getDPMConfigValue cfg_repoDir + info "Getting all patches from repo ..." + either <- liftIO $ Darcs.getPatchesInRepo repoDir + patchesInRepo <- + case either of + Left err -> abort err + Right l -> return l + -- (1) + -- Search for patches in the repo that are managed by DPM but which + -- are not in state APPLIED. Then order these patches by dependency + -- and mark them as APPLIED. + info "Marking relevant patches as applied ..." + allPatches <- liftDPM $ S.getPatches QTrue + mapM_ (markAsApplied allPatches) (map sp_id patchesInRepo) + -- (2) + -- Search for patch names in the repo such that DPM manages an + -- open patch group of the same name. Because step (1) did not + -- close the patch group, it could be that the patch group + -- should be closed. If in interactive mode, ask wether to close + -- the patch group. If in batch mode, do not close the patch group + -- but output a warning. + info "Searching for closable groups ..." + (searchResult, allIDs, conflicts) <- liftDPM $ + do res <- S.getPatches (QGroupState PatchGroupOpen) + ids <- S.allPatchIDs + conflicts <- S.allConflicts + return (res, ids, conflicts) + let openGroups = S.pr_groups searchResult + extraInfo = ExtraInfo (S.pr_revDeps searchResult) conflicts + mapM_ (possiblyCloseGroup allIDs extraInfo openGroups) patchesInRepo + info "Done." + getPatch allPatches pid = + let l = concatMap (\g -> map fst $ pg_patches g) + (S.pr_groups allPatches) + in List.find (\p -> p_id p == pid) l + markAsApplied allPatches pid = + do case getPatch allPatches pid of + Nothing -> return () + Just p -> + when (p_state p /= PatchStateAPPLIED) $ + do mapM_ (markAsApplied allPatches) (p_dependents p) + changed <- + liftDPM $ + do when (isDiscarded (p_state p)) + (S.markAsUndecided pid "required by sync" + >> return ()) + S.applyPatch pid (\_ -> return ()) + (Just "required by sync") + when changed $ info ("Patch " ++ unPatchID pid ++ + " is already in the repository, " + ++ "marked it as APPLIED.") + possiblyCloseGroup allIDs extraInfo openGroups repoPatch = + case List.find (\g -> pg_id g == sp_name repoPatch) openGroups of + Nothing -> return () + Just g -> + do cfg <- getConfig + let batch = cfg_batch cfg + cfg' = cfg { cfg_verbose = True } + groupStr = PP.render $ + renderPatchGroup allIDs cfg' extraInfo g + patchStr = PP.render $ + renderSimplePatch repoPatch + prefix = ("Repository contains the following patch:\n\n" + ++ patchStr ++ + "\n\nIn DPM, the following patch group " ++ + "is open:\n\n" ++ groupStr ++ "\n") + if batch + then warn (prefix ++ + "The group should possibly be closed.") + else do info prefix + b <- query_Yn "Shall the group be closed? " + when b (withLock $ do + liftDPM $ S.closePatchGroup + (sp_name repoPatch) + info ("Closed patch group of name " ++ + show (unPatchGroupID + (sp_name repoPatch)))) + +viewPatch :: String -> CDPM () +viewPatch shortPID = + do allPIDs <- liftDPM S.allPatchIDs + pid <- resolvePID allPIDs shortPID + fname <- liftDPM $ S.getPatchFile pid + p <- getPatch pid + liftIO $ do patchData <- gzReadFilePS fname + hPutStrLn handle (show (renderPatchName p)) + hPutStrLn handle "" + cleaned <- cleanupBundle p patchData + B.hPut handle cleaned + hPutStrLn handle "" + where handle = stdout + +exportBundle :: String -> CDPM () +exportBundle shortPID = + do allPIDs <- liftDPM S.allPatchIDs + pid <- resolvePID allPIDs shortPID + fname <- liftDPM $ S.getPatchFile pid + liftIO $ do patchData <- gzReadFilePS fname + B.hPut handle patchData + where handle = stdout + +openGroup :: String -> CDPM () +openGroup name = + do liftDPM $ S.withLock (S.openPatchGroup (PatchID name)) + return () + +closeGroup :: String -> CDPM () +closeGroup name = + do liftDPM $ S.withLock (S.closePatchGroup (PatchGroupID name)) + return () + +markAsReviewed :: String -> S.Comment -> CDPM () +markAsReviewed = genericMark S.markAsReviewed + +markAsUndecided :: String -> S.Comment -> CDPM () +markAsUndecided = genericMark S.markAsUndecided + +markAsRejected :: String -> S.Comment -> CDPM () +markAsRejected = genericMark S.markAsRejected + +markAsObsolete :: String -> S.Comment -> CDPM () +markAsObsolete = genericMark S.markAsObsolete + +markAsUnapplied :: String -> S.Comment -> CDPM () +markAsUnapplied shortPID comment = + do allPIDs <- liftDPM S.allPatchIDs + pid <- resolvePID allPIDs shortPID + p <- getPatch pid + case p_state p of + PatchStateAPPLIED -> + do repo <- liftDPM $ getDPMConfigValue cfg_repoDir + ans <- query_yN ("Are you sure that patch " ++ shortPID ++ + " (" ++ unPatchGroupID (p_name p) ++ + ") has really been " ++ + "unapplied from repository " ++ repo ++ "? ") + when ans $ do genericMark S.markAsObsoleteNoCheck + shortPID + ("mark-as-unapplied: " ++ comment) + genericMark S.markAsUndecided + shortPID + ("mark-as-unapplied: " ++ comment) + _ -> abort ("Patch " ++ shortPID ++ " is not in state APPLIED") + +markAsApplied :: String -> S.Comment -> CDPM () +markAsApplied shortPID comment = + do repo <- liftDPM $ getDPMConfigValue cfg_repoDir + ans <- query_yN ("Are you sure that patch " ++ shortPID ++ + " has really already been applied to repository " ++ + repo ++ "? ") + when ans $ genericMark S.markAsApplied shortPID ("mark-as-applied: " ++ + comment) + +genericMark :: (PatchID -> S.Comment -> DPM Bool) + -> String -> S.Comment -> CDPM () +genericMark fun shortPID comment = + do allIDs <- liftDPM S.allPatchIDs + pid <- resolvePID allIDs shortPID + liftDPM $ S.withLock $ fun pid comment + return () + +addComment :: String -> S.Comment -> CDPM () +addComment shortPID comment = + do allIDs <- liftDPM S.allPatchIDs + pid <- resolvePID allIDs shortPID + liftDPM $ S.withLock $ S.addComment pid comment + return () + +-- +-- Auxiliaries +-- + +moduleName :: String +moduleName = "CPM.UI.Commandline.Commands" + +getPatch :: PatchID -> CDPM Patch +getPatch pid = + do x <- getPatchGen pid + case x of + Left err -> abort err + Right p -> return p + +getPatchGen :: PatchID -> CDPM (Either String Patch) +getPatchGen pid = + do r <- liftDPM $ S.withLock $ + S.getPatches (QPatchID (unPatchID pid)) + let l = S.pr_groups r + case l of + [] -> return $ Left ("No patch with ID " ++ unPatchID pid) + [pg] | [(p,_)] <- pg_patches pg -> return $ Right p + _ -> do bug (moduleName ++ ".getPatchesGen: " ++ + "Unexcepted result returned by getPatches: " ++ show l) + +resolvePID :: [PatchID] -> String -> CDPM PatchID +resolvePID allIDs shortPID = + do let matching = + filter (\pid -> List.isSuffixOf shortPID (unPatchID pid)) allIDs + case matching of + [] -> abort ("No patch whose ID has " ++ show shortPID ++ + " as its suffix") + [pid] -> + do when (shortPID /= unPatchID pid) $ + debug ("Resolved short patch ID " ++ + shortPID ++ " as full patch ID " ++ unPatchID pid) + return pid + l -> abort ("Short patch ID " ++ shortPID ++ + " does not uniquely determine a full patch ID. " ++ + "Possible candidates: " ++ + List.intercalate ", " (map unPatchID l)) + +renderPatchGroup :: [PatchID] -> Config -> ExtraInfo + -> PatchGroup (Patch, FilePath) -> Doc +renderPatchGroup allIDs cfg extraInfo pg = + nest 0 (colored2 cfg (text (unPatchGroupID (pg_id pg))) <+> + brackets (text "State:" <+> renderPGState (pg_state pg)) $$ + (foldr (\p d -> renderPatch allIDs cfg groupIDs extraInfo p $$ d) + (if pg_complete pg then empty + else colored1 cfg (text " ..."))) + (map fst (pg_patches pg))) + where + groupIDs = map (p_id . fst) (pg_patches pg) + +renderPatch :: [PatchID] -> Config -> [PatchID] -> ExtraInfo -> Patch -> Doc +renderPatch allIDs cfg idsInGroup extraInfo p = + let shortID = getShortID allIDs (p_id p) + in nest 2 (colored1 cfg (text shortID) + <+> renderDate (p_date p) <+> + text (p_author p) $$ + nest (length shortID + 1) + (text "State:" <+> renderPatchState (p_state p) + <> comma <+> + text "Reviewed:" <+> bool (isReviewed p) + $$ (if conflictsWithRepo (ei_conflicts extraInfo) (p_id p) + then text "CONFLICT WITH REPOSITORY" + else empty) + $$ renderDependents allIDs (p_dependents p) + $$ renderRevDependents allIDs (p_id p) (ei_revDeps extraInfo) + $$ renderConflicts allIDs (conflictsOf p) + $$ renderShortLog (p_log p) $$ + (if not (cfg_verbose cfg) then empty + else text "Full-ID:" <+> + text (unPatchID (p_id p)) $$ + text "Inverted:" <+> bool (p_inverted p) $$ + renderDarcsLog (p_darcsLog p) $$ + renderLog (p_log p)))) + where + conflictsOf p = + let all = getConflicts (ei_conflicts extraInfo) (p_id p) + in List.nub $ filter (\x -> not (x `elem` idsInGroup)) all + renderShortLog l | cfg_verbose cfg = empty + | otherwise = + case filter (not . isIrrelevantLogEntry) l of + [] -> empty + (entry:_) -> text (log_message entry) + +renderSimplePatch :: SimplePatch -> Doc +renderSimplePatch p = + nest 2 (renderDate (sp_date p) <+> text (sp_author p) $$ + text "Full-ID:" <+> text (unPatchID (sp_id p)) $$ + text "Inverted:" <+> bool (sp_inverted p)) + +renderPGState :: PatchGroupState -> Doc +renderPGState PatchGroupOpen = text "OPEN" +renderPGState PatchGroupClosed = text "CLOSED" + +renderDependents :: [PatchID] -> [PatchID] -> Doc +renderDependents = renderDependentsGen "Requires" empty + +renderRevDependents :: [PatchID] -> PatchID -> PatchRevDeps -> Doc +renderRevDependents allIDs pid revDeps = + let list = getRevDeps revDeps pid + n = getMaxChainLen revDeps pid + hint = if n < 2 then empty + else text "Length of max chain:" <+> int n + in renderDependentsGen "Required by" hint allIDs list + +renderDependentsGen :: String -> Doc -> [PatchID] -> [PatchID] -> Doc +renderDependentsGen _ _ allIDs [] = empty +renderDependentsGen label last allIDs l = + text label <> text ":" <+> + nest 0 (foldr (\pid d -> text (getShortID allIDs pid) <> + (if isEmpty d then empty else comma <+> d)) + last l) + +renderConflicts :: [PatchID] -> [PatchID] -> Doc +renderConflicts allIDs [] = empty +renderConflicts allIDs l = + text "Conflicts with: " <> + nest 0 (foldr (\pid d -> text (getShortID allIDs pid) $$ d) + empty l) + +renderPatchState = text . prettyPatchState + +renderPatchNameShort p = + (text (prettyDate (p_date p)) <+> + text (p_author p) $$ + text " *" <+> + text (unPatchGroupID (p_name p))) + +renderPatchName p = + renderPatchNameShort p $$ + (text ("(Hash: " ++ unPatchID (p_id p) ++ ")")) + +prettyPatchState s = + case s of + PatchStateUNDECIDED -> "UNDECIDED" + PatchStateAPPLIED -> "APPLIED" + (PatchStateDISCARDED r) -> prettyReason r + +prettyReason r = + case r of + ReasonRejected -> "REJECTED" + ReasonObsolete -> "OBSOLETE" + +renderDate = text . prettyDate + +renderLog [] = text "History: -" +renderLog l = + text "History: " $$ nest 0 (foldr (\entry d -> + renderLogEntry entry $$ d) + empty l) + +-- FIXME: this is not the right place to filter out log message +isIrrelevantLogEntry :: LogEntry -> Bool +isIrrelevantLogEntry entry = + not (log_modelChanged entry) && log_message entry == "added" + +renderLogEntry entry = + if isIrrelevantLogEntry entry + then empty + else text "*" <+> + nest 2 (renderDate (log_time entry) <+> text (log_user entry) $$ + (text (log_message entry))) + +renderDarcsLog :: [String] -> Doc +renderDarcsLog list = + text "Long comment:" $$ nest 1 (vcat $ map text list) + +colored :: Config -> Colors.Color -> Doc -> Doc +colored cfg c doc | cfg_colored cfg = text (Colors.colored c) <> doc <> + text (Colors.colored Colors.Reset) + | otherwise = doc + +colored1, colored2 :: Config -> Doc -> Doc +colored1 cfg = colored cfg (cfg_color1 cfg) +colored2 cfg = colored cfg (cfg_color2 cfg) diff --git a/src/DPM/UI/Commandline/Interaction.hs b/src/DPM/UI/Commandline/Interaction.hs new file mode 100644 --- /dev/null +++ b/src/DPM/UI/Commandline/Interaction.hs @@ -0,0 +1,91 @@ +module DPM.UI.Commandline.Interaction ( + + query_yN, query_Yn, query, wait, + + abort, userAbort, warn, info, debug, darcsFailed, bug, bugHeader + +) where + +import qualified Data.List as List +import System.IO +import Control.Monad +import Control.Monad.Trans + +import DPM.Core.DPM_Monad +import DPM.Core.Utils ( trim ) +import DPM.UI.Commandline.CDPM_Monad + +ynAnswers :: [(String, Bool)] +ynAnswers = [("y", True), ("n", False), ("Y", True), ("N", False)] + +query_yN :: String -> CDPM Bool +query_yN msg = + queryString (msg ++ "[y/N] ") (Just False) ynAnswers + +query_Yn :: String -> CDPM Bool +query_Yn msg = + queryString (msg ++ "[Y/n] ") (Just True) ynAnswers + +query_yn :: String -> Bool -> CDPM Bool +query_yn msg defaultForBatch = + queryString (msg ++ "[y/n] ") Nothing ynAnswers + +queryString :: String -> (Maybe a) -> [(String, a)] -> CDPM a +queryString msg def opts = + do liftIO $ putStr msg + liftIO $ hFlush stdout + ms <- liftIO $ do s <- getLine + return (Just (trim s)) + `catch` (\_ -> return Nothing) + case ms of + Just s -> + case List.lookup s opts of + Just x -> return x + Nothing -> returnDef + Nothing -> + returnDef + where + returnDef = + case def of + Just x -> return x + Nothing -> queryString ("Invalid choice, try again: ") def opts + +query :: String -> String -> CDPM String +query msg def = + do batch <- getConfigValue cfg_batch + if batch then return def + else liftIO $ do putStr msg + hFlush stdout + getLine `catch` (\_ -> return "") + +wait :: String -> CDPM () +wait msg = + do query msg "" + return () + +darcsFailed :: String -> CDPM a +darcsFailed msg = fail ("Darcs command failed. Here is the output of darcs:\n" + ++ "---\n" ++ msg ++ "\n---") + +userAbort :: CDPM a +userAbort = fail ("Program aborted on request of the user") + +abort :: String -> CDPM a +abort msg = fail (msg ++ "\nAborting.") + +info :: String -> CDPM () +info = liftIO . putStrLn + +warn :: MonadIO m => String -> m () +warn s = liftIO $ hPutStrLn stderr ("WARNING: " ++ s) + +debug :: String -> CDPM () +debug s = + do b <- getConfigValue cfg_verbose + when b $ liftIO (putStrLn s) + +bugHeader :: String +bugHeader = "BUG in dpm!\n" + +bug :: String -> CDPM a +bug msg = fail (bugHeader ++ msg) diff --git a/src/DPM/UI/Commandline/Main.hs b/src/DPM/UI/Commandline/Main.hs new file mode 100644 --- /dev/null +++ b/src/DPM/UI/Commandline/Main.hs @@ -0,0 +1,440 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} + +module DPM.UI.Commandline.Main (mainWithArgs) where + +import Prelude hiding ( catch ) +import System.Environment +import System.Console.GetOpt +import System.FilePath +import System.Posix.User +import System.Exit +import Control.Exception +import Control.Monad +import System.IO +import qualified Data.List as List +import qualified Data.ByteString as B +import Data.Typeable +import System.Directory ( doesFileExist, doesDirectoryExist ) +import System.FilePath +import Data.List.Split +import System.Posix.IO ( stdOutput) +import System.Posix.Terminal ( queryTerminal ) +import System.Exit ( ExitCode(..), exitWith ) + +import DPM.Core.DPM_Monad +import DPM.Core.Utils ( unlessM, findCommand, joinStrings ) +import DPM.Core.DataTypes ( PatchID(..), Query(..), PatchGroupState(..) ) +import DPM.Core.Storage ( setupStorageDir ) +import DPM.Core.QueryParser +import DPM.UI.Commandline.Commands +import DPM.UI.Commandline.Interaction ( bugHeader ) +import DPM.UI.Commandline.CDPM_Monad + +versionString :: String +versionString = "DPM version 0.1.0" + +data Options = Options { opt_repoDir :: FilePath + , opt_storageDir :: FilePath + , opt_longList :: Bool + , opt_verbose :: Bool + , opt_debug :: Bool + , opt_batch :: Bool + , opt_no_colors :: Bool + , opt_tests :: Bool + , opt_interactive :: Bool + , opt_force :: Bool + , opt_user :: Maybe String + , opt_from :: Maybe String + , opt_reviewAddress :: Maybe String + , opt_help :: Bool + , opt_version :: Bool } + deriving (Show) + +type CommandName = String + +type DPMOptDescr = OptDescr (Options -> Options) + +data OptionMissingException = OptionMissingException { ome_msg :: String } + deriving (Show,Read,Eq,Typeable) + +instance Exception OptionMissingException where + +optionMissing :: String -> a +optionMissing s = throw (OptionMissingException s) + +checkOptions :: Options -> IO () +checkOptions opts = + force `catch` (\ (e::OptionMissingException) -> + abort (ome_msg e) exitCodeArgParseFailed) + where force = -- poor man's trick to force opts + do evaluate (length (show opts)) + return () + +defaultOptions :: Maybe CommandName -> Options +defaultOptions mc = + let def = Options { opt_repoDir = + optionMissing "no repository directory given" + , opt_storageDir = + optionMissing "no storage directory given" + , opt_longList = False + , opt_verbose = False + , opt_debug = False + , opt_batch = False + , opt_no_colors = False + , opt_tests = True + , opt_interactive = False + , opt_force = False + , opt_user = Nothing + , opt_from = Nothing + , opt_reviewAddress = Nothing + , opt_help = False + , opt_version = False } + in def + +fillOptions :: [Options -> Options] -> Options -> Options +fillOptions otrans def = foldl (flip id) def otrans + +globalOptionSpec :: [DPMOptDescr] +globalOptionSpec = + [Option ['r'] ["repo-dir"] + (ReqArg (\d opts -> opts { opt_repoDir = d }) "DIR") + "directory of the darcs repository" + ,Option ['s'] ["storage-dir"] + (ReqArg (\d opts -> opts { opt_storageDir = d }) "DIR") + "directory for storing DPM data" + ,Option ['v'] ["verbose"] + (NoArg (\opts -> opts { opt_verbose = True })) + "be verbose" + ,Option [] ["debug"] + (NoArg (\opts -> opts { opt_debug = True })) + "output debug messages" + ,Option [] ["batch"] + (NoArg (\opts -> opts { opt_batch = True })) + "run in batch mode" + ,Option [] ["no-colors"] + (NoArg (\opts -> opts { opt_no_colors = True })) + "do not use colors when printing text" + ,Option [] ["user"] + (ReqArg (\u opts -> opts { opt_user = Just u }) "USER") + "current user" + ,Option [] ["from"] + (ReqArg (\f opts -> opts { opt_from = Just f }) "EMAIL_ADDRESS") + "from address for emails" + ,Option [] ["review-address"] + (ReqArg (\f opts -> opts { opt_reviewAddress = Just f }) + "EMAIL_ADDRESS") + "email address for sending reviews" + ,Option ['h', '?'] ["help"] + (NoArg (\opts -> opts { opt_help = True })) + "display this help message" + ,Option [] ["version"] + (NoArg (\opts -> opts { opt_version = True })) + "display the version" + ] + +maxArgs :: Int +maxArgs = 1024 + +type CommandRunner = Options -> [String] -> CDPM () + +commands :: [(CommandName, -- name of command + (String, -- description + String, -- argument specifier + [DPMOptDescr], -- options of the command + Int, -- minimal number of arguments + Int, -- maximal number of arguments + CommandRunner))] -- function to run +commands = + [("add", + ("Put the given patch bundles under DPM's control " ++ + "(use '-' to read from stdin).", + "FILE...", + [], 1, maxArgs, + addCmd)) + ,("apply", + ("Apply the patches with the IDs given to the darcs repository.", + "ID...", + [Option [] ["no-tests"] + (NoArg (\opts -> opts { opt_tests = False })) + "do not run tests when applying patches", + Option ['i'] ["interactive"] + (NoArg (\opts -> opts { opt_interactive = True })) + "apply interactively"], + 1, maxArgs, + applyCmd)) + ,("list", + ("List the patches matching the given query.\n\n" ++ + querySyntax ++ "\n" ++ + "If no query is given, DPM lists all open patch groups.\n", + "QUERY ...", + [], + 0, maxArgs, + listCmd)) + ,("review", + ("Review the patches with the IDs given.", + "ID...", + [Option [] ["force"] + (NoArg (\opts -> opts { opt_force = True })) + "force review"], + 1, maxArgs, + reviewCmd)) + ,("sync", + ("Synchronize with the darcs repository.", + "", + [], 0, 0, + syncCmd)) + ,("mark-as-reviewed", + ("Mark the patch given as reviewed.", + "ID COMMENT ...", + [], 2, maxArgs, + markAsReviewedCmd)) + ,("mark-as-undecided", + ("Mark the patch given as undecided.", + "ID COMMENT ...", + [], 2, maxArgs, + markAsUndecidedCmd)) + ,("mark-as-obsolete", + ("Mark the patch given as obsolete.", + "ID COMMENT ...", + [], 2, maxArgs, + markAsObsoleteCmd)) + ,("mark-as-rejected", + ("Mark the patch given as rejected.", + "ID COMMENT ...", + [], 2, maxArgs, + markAsRejectedCmd)) + ,("mark-as-applied", + ("Mark the patch given as applied.", + "ID COMMENT ...", + [], 2, maxArgs, + markAsAppliedCmd)) + ,("mark-as-unapplied", + ("Mark the patch given (in state APPLIED) as UNDECIDED.", + "ID COMMENT ...", + [], 2, maxArgs, + markAsUnappliedCmd)) + ,("close-group", + ("Close the patch group given.", + "NAME", + [], 1, 1, + closeGroupCmd)) + ,("open-group", + ("Open the patch that contains the patch with the ID given.", + "ID", + [], 1, 1, + openGroupCmd)) + ,("add-comment", + ("Add a comment to the patch given.", + "ID COMMENT ...", + [], 2, maxArgs, + addCommentCmd)) + ,("view", + ("View the patch given.", + "ID", + [], 1, 1, + viewCmd)) + ,("export", + ("Export the bundle containing the patch given.", + "ID", + [], 1, 1, + exportCmd)) + ] + +addCmd :: CommandRunner +addCmd _ files = + mapM_ (\f -> do bs <- liftIO (readBundleData f) + addPatchBundle f bs) + files + where + readBundleData "-" = B.getContents + readBundleData f = B.readFile f + +applyCmd :: CommandRunner +applyCmd opts ids = mapM_ (applyPatch (opt_interactive opts)) ids + +listCmd :: CommandRunner +listCmd opts args = + do q <- case args of + [] -> return (QGroupState PatchGroupOpen) + l -> do let q = joinStrings l + debugCDPM ("Query: " ++ q) + case parseQuery q of + Just x -> return x + Nothing -> fail ("Cannot parse query: " ++ q) + listPatches q + +reviewCmd :: CommandRunner +reviewCmd _ ids = mapM_ reviewPatch ids + +syncCmd :: CommandRunner +syncCmd _ _ = sync + +markAsReviewedCmd :: CommandRunner +markAsReviewedCmd _ args = markAsReviewed (args!!0) (joinStrings (tail args)) + +markAsObsoleteCmd :: CommandRunner +markAsObsoleteCmd _ args = markAsObsolete (args!!0) (joinStrings (tail args)) + +markAsRejectedCmd :: CommandRunner +markAsRejectedCmd _ args = markAsRejected (args!!0) (joinStrings (tail args)) + +markAsUndecidedCmd :: CommandRunner +markAsUndecidedCmd _ args = markAsUndecided (args!!0) (joinStrings (tail args)) + +markAsAppliedCmd :: CommandRunner +markAsAppliedCmd _ args = markAsApplied (args!!0) (joinStrings (tail args)) + +markAsUnappliedCmd :: CommandRunner +markAsUnappliedCmd _ args = markAsUnapplied (args!!0) (joinStrings (tail args)) + +closeGroupCmd :: CommandRunner +closeGroupCmd _ args = closeGroup (args!!0) + +openGroupCmd :: CommandRunner +openGroupCmd _ args = openGroup (args!!0) + +addCommentCmd :: CommandRunner +addCommentCmd _ args = addComment (head args) (joinStrings (tail args)) + +viewCmd :: CommandRunner +viewCmd _ args = viewPatch (args!!0) + +exportCmd :: CommandRunner +exportCmd _ args = exportBundle (args!!0) + +getOpts :: [String] -> Either String (Options, CDPM ()) +getOpts argv = + case getOpt' Permute globalOptionSpec argv of + (otrans, nonOptionArgs, extraOptionArgs, []) -> + let options = fillOptions otrans (defaultOptions Nothing) + in case nonOptionArgs of + [] -> + case (opt_help options, opt_version options) of + (True, _) -> Left (helpMessage globalOptionSpec Nothing) + (_, True) -> Left versionString + _ -> Left ("No command given") + (cmd:args) -> + case List.lookup cmd commands of + Nothing -> Left ("Unknown command " ++ show cmd) + Just (_, _, optSpec, lowerBound, upperBound, runner) -> + let options = + fillOptions otrans (defaultOptions (Just cmd)) + in case () of + _| opt_help options -> + Left (helpMessage globalOptionSpec (Just cmd)) + | length args < lowerBound -> + Left ("Not enough arguments for command " ++ + show cmd) + | length args > upperBound -> + Left ("Too many arguments for command " ++ + show cmd) + | otherwise -> + case getOpt Permute optSpec extraOptionArgs of + (otrans', [], []) -> + let options' = fillOptions otrans' + options + in + Right (options', + runner options' args) + (_, _, errs) -> + Left ("Invalid options for command " ++ + show cmd ++ ": " ++ concat errs) + (_, _, _, errs) -> + Left (concat errs) + +helpMessage :: [OptDescr a] -> Maybe String -> String +helpMessage opts Nothing = + usageInfo header opts ++ footer + where header = "Usage: dpm [OPTION]... COMMAND [ARGUMENT]...\n\n" ++ + "Global options:" + footer = "\nAvailable commands:\n" ++ + (unlines (map (\x -> " " ++ fst x) commands)) +helpMessage opts (Just cmd) = + usageInfo header argOpts ++ + usageInfo header' opts + where + Just (descr, argSpec, argOpts, minArgs, maxArgs, _) = + List.lookup cmd commands + header = cmd ++ ": " ++ descr ++ "\nUsage: " ++ cmd ++ " " + ++ optSpec ++ argSpec ++ "\n\nCommand options:" + header' = "\nGlobal options:" + optSpec = if null argOpts then "" + else "[OPTION]... " + +exitCodeArgParseFailed :: Int +exitCodeArgParseFailed = 2 + +exitCodeFailure :: Int +exitCodeFailure = 1 + +abort :: String -> Int -> IO a +abort msg exitCode = + do hPutStrLn stderr msg + exitWith (ExitFailure exitCode) + +mainWithArgs args = + do user <- getEffectiveUserName + case getOpts args of + Left err -> abort err exitCodeArgParseFailed + Right (opts, runner) -> + do checkOptions opts + tty <- isatty + let dpmCfg = DPMConfig { + cfg_modelFile = opt_storageDir opts "model" + , cfg_patchesFile = + opt_storageDir opts "patches" + , cfg_dataDir = opt_storageDir opts "data" + , cfg_currentUser = getOptional (opt_user opts) user + , cfg_fromAddress = getOptional (opt_from opts) user + , cfg_patchLog = opt_storageDir opts "patchLog" + , cfg_patchGroupLog = + opt_storageDir opts "patchGroupLog" + , cfg_lockFile = opt_storageDir opts ".lock" + , cfg_reviewDir = opt_storageDir opts "reviews" + , cfg_repoDir = opt_repoDir opts + , cfg_reviewAddress = opt_reviewAddress opts + , cfg_debug = opt_debug opts + } + cfg = defaultConfig { + cfg_verbose = opt_verbose opts + , cfg_batch = opt_batch opts + , cfg_colored = tty && not (opt_no_colors opts) + , cfg_tests = opt_tests opts + , cfg_force = opt_force opts + } + -- same sanity checks + checkDirExists (opt_storageDir opts) + checkDirExists (opt_repoDir opts) + runDPM dpmCfg $ runCDPM cfg $ liftDPM setupStorageDir >> runner + `catches` + [Handler (\(DPMException err) -> + abort err exitCodeFailure) + ,Handler (\e@(ExitFailure code) -> + exitWith e) + ,Handler (\(e::AsyncException) -> + case e of + UserInterrupt -> + abort "\nUser interrupt!" + exitCodeFailure + _ -> reportBug e) + ,Handler (\(e::SomeException) -> + reportBug e)] + where + getOptional Nothing x = x + getOptional (Just x) _ = x + reportBug :: Show a => a -> IO b + reportBug e = + abort (bugHeader ++ "Unhandled exception: " ++ show e) + exitCodeFailure + checkDirExists d = + unlessM (doesDirectoryExist d) $ + abort ("Directory " ++ show d ++ " does not exist") + exitCodeFailure + checkFileExists f = + unlessM (doesFileExist f) $ + abort ("File " ++ show f ++ " does not exist") + exitCodeFailure + isatty = queryTerminal stdOutput + +mainWithString :: String -> IO () +mainWithString s = mainWithArgs (splitOn " " s)