DPM 0.2.0 → 0.2.1
raw patch · 20 files changed
+4355/−69 lines, 20 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- DPM.cabal +9/−3
- dist/build/dpm/dpm-tmp/DPM/Core/Lexer.hs +108/−65
- dist/build/dpm/dpm-tmp/DPM/Core/QueryParser.hs +1/−1
- src/DPM/Core/Conflicts.hs +43/−0
- src/DPM/Core/DPM_Monad.hs +91/−0
- src/DPM/Core/Darcs.hs +347/−0
- src/DPM/Core/DataTypes.hs +94/−0
- src/DPM/Core/Email.hs +118/−0
- src/DPM/Core/Model.hs +987/−0
- src/DPM/Core/PatchBundleParser.hs +233/−0
- src/DPM/Core/ReverseDependencies.hs +37/−0
- src/DPM/Core/ShortID.hs +103/−0
- src/DPM/Core/Storage.hs +385/−0
- src/DPM/Core/TestDarcs.hs +282/−0
- src/DPM/Core/Utils.hs +165/−0
- src/DPM/UI/Commandline/ANSIColors.hs +12/−0
- src/DPM/UI/Commandline/CDPM_Monad.hs +85/−0
- src/DPM/UI/Commandline/Commands.hs +724/−0
- src/DPM/UI/Commandline/Interaction.hs +91/−0
- src/DPM/UI/Commandline/Main.hs +440/−0
DPM.cabal view
@@ -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
dist/build/dpm/dpm-tmp/DPM/Core/Lexer.hs view
@@ -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 "<built-in>" #-}+{-# LINE 1 "<command line>" #-}+{-# 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 "<built-in>" #-} {-# LINE 1 "<command line>" #-}-{-# 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 "<built-in>" #-}-{-# LINE 1 "<command line>" #-}-{-# 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.-
dist/build/dpm/dpm-tmp/DPM/Core/QueryParser.hs view
@@ -229,7 +229,7 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "<command line>" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp
+ src/DPM/Core/Conflicts.hs view
@@ -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
+ src/DPM/Core/DPM_Monad.hs view
@@ -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)
+ src/DPM/Core/Darcs.hs view
@@ -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
+ src/DPM/Core/DataTypes.hs view
@@ -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
+ src/DPM/Core/Email.hs view
@@ -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:
+ src/DPM/Core/Model.hs view
@@ -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)
+ src/DPM/Core/PatchBundleParser.hs view
@@ -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"
+ src/DPM/Core/ReverseDependencies.hs view
@@ -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
+ src/DPM/Core/ShortID.hs view
@@ -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)
+ src/DPM/Core/Storage.hs view
@@ -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)
+ src/DPM/Core/TestDarcs.hs view
@@ -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 <dspoeri@umidev.de>"+ ["Ignore-this: 729a19332b2cfec7c18391234d505998"]+ False)+ assertEqual d1 (B.pack "{\nhunk11\nhunk12")+ assertEqual pi2 (PatchInfo "20100125162933"+ "FEATURE: bei Standalone neue Mobil-Mitarbeiter anlegen"+ "Dirk Spoeri <dspoeri@umidev.de>"+ ["Ignore-this: 59a42d4317961478dfd3d731b5a3a95d"]+ False)+ assertEqual d2+ (B.pack ("<\n" +++ "[TRIVIAL: 'versorgt durch' durch 'Versorgung durch'\n" +++ "Johannes Weiss <weiss@tux4u.de>**20071130173047]\n" +++ "> {\n" +++ "hunk21\n" +++ "hunk22"))+ assertEqual pi3 (PatchInfo "20091210101000"+ "MINOR: Merge-Konflikt Standalone<->Global editieren"+ "Dirk Spoeri <dspoeri@umidev.de>"+ ["Ignore-this: 79ac83a1f24ca4835b9ad467498d5e30"]+ False)+ assertEqual d3 (B.pack "hunk31\nhunk32")++testPatchBundleContent =+ ["",+ "",+ "New patches:",+ "",+ "[MINOR: Vitalwerte ueber Konfig (de-)aktivieren",+ "Dirk Spoeri <dspoeri@umidev.de>**20091203132005",+ " Ignore-this: 729a19332b2cfec7c18391234d505998",+ "] {",+ "hunk11",+ "hunk12",+ "[FEATURE: bei Standalone neue Mobil-Mitarbeiter anlegen",+ "Dirk Spoeri <dspoeri@umidev.de>**20100125162933",+ " Ignore-this: 59a42d4317961478dfd3d731b5a3a95d",+ "]",+ "<",+ "[TRIVIAL: 'versorgt durch' durch 'Versorgung durch'",+ "Johannes Weiss <weiss@tux4u.de>**20071130173047]",+ "> {",+ "hunk21",+ "hunk22",+ "[MINOR: Merge-Konflikt Standalone<->Global editieren",+ "Dirk Spoeri <dspoeri@umidev.de>**20091210101000",+ " Ignore-this: 79ac83a1f24ca4835b9ad467498d5e30",+ "] hunk31",+ "hunk32",+ "",+ "Context:",+ "",+ "[TRIVIAL: Grammatikalischen Fehler gefixt",+ "Johannes Weiss <weiss@tux4u.de>**20100125142927",+ " Ignore-this: e9dcd96bf556f84979e69c13ab60010b",+ "",+ " Woerter bestehen aus Buchstaben, Worte bestehen aus Gedanken.",+ " vgl. http://www.spiegel.de/kultur/zwiebelfisch/0,1518,307445,00.html",+ "]"]
+ src/DPM/Core/Utils.hs view
@@ -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)
+ src/DPM/UI/Commandline/ANSIColors.hs view
@@ -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'] +
+ src/DPM/UI/Commandline/CDPM_Monad.hs view
@@ -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
+ src/DPM/UI/Commandline/Commands.hs view
@@ -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)
+ src/DPM/UI/Commandline/Interaction.hs view
@@ -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)
+ src/DPM/UI/Commandline/Main.hs view
@@ -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)