diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + 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 of the License, 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; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/Distribution/ShellHarness.hs b/Distribution/ShellHarness.hs new file mode 100644 --- /dev/null +++ b/Distribution/ShellHarness.hs @@ -0,0 +1,174 @@ +{-# OPTIONS_GHC -cpp #-} +module Distribution.ShellHarness ( runTests ) where + +import Prelude hiding( catch ) +import System.Directory ( getCurrentDirectory, setPermissions, + Permissions(..), getDirectoryContents, + findExecutable, createDirectoryIfMissing ) +import System.Environment ( getEnv, getEnvironment ) +import System.Exit ( ExitCode (..) ) +import System.FilePath +import System.IO +import System.Process ( ProcessHandle, + runInteractiveProcess, waitForProcess, + getProcessExitCode ) +import Data.Maybe +import Data.List ( isInfixOf, isPrefixOf, (\\), nubBy ) +import Control.Concurrent +#if __GLASGOW_HASKELL__ >= 610 +import Control.OldException +#else +import Control.Exception +#endif +import Control.Monad + +runTests :: Maybe FilePath -> String -> [String] -> IO Bool +runTests darcs_path cwd tests = do + fails <- run darcs_path tests + if "bugs" `isInfixOf` cwd + then if (length tests /= length fails) + then do putStrLn $ "Some bug tests passed:" + mapM_ putStrLn (tests \\ fails) + return False + else do putStrLn "All bug tests OK" + return True + else if fails /= [] + then do putStrLn "Some tests failed:" + mapM_ putStrLn fails + return False + else do putStrLn "All tests OK" + return True + +run :: Maybe FilePath -> [String] -> IO [String] +run set_darcs_path tests= do + cwd <- getCurrentDirectory + path <- getEnv "PATH" + env <- getEnvironment + darcs_path <- case set_darcs_path of + Nothing -> get_darcs_path + Just x -> return x + let myenv = [("HOME",cwd) + ,("APPDATA",cwd) -- the Windows analogue of $HOME. + ,("TESTS_WD",cwd) + ,("EMAIL","tester") + ,("DARCSEMAIL","tester") + ,("PATH",(darcs_path++":"++path)) + ,("DARCS_DONT_COLOR","1") + ,("DARCS_DONT_ESCAPE_ANYTHING","1")] + bash <- find_bash + let shell = takeWhile (/= '\n') bash + putStrLn $ "Using bash shell in '"++shell++"'" + set_prefs + run_helper shell tests [] (set_env myenv env) + where get_darcs_path = do + env <- getEnvironment + cwd <- getCurrentDirectory + case lookup "DARCS" env of + Nothing -> return (cwd ++ "/..") + Just d -> return $ takeDirectory d + set_prefs = do + finally (catch (appendFile ".darcs/defaults" "\nALL --ignore-times\n") + (\e -> fail $ "Unable to set preferences: " + ++ show e)) + (createDirectoryIfMissing False ".darcs") +run_helper :: String -> [String] -> [String] -> + [(String,String)] -> IO [String] +run_helper _ [] fails _ = return fails +run_helper shell (test:ts) fails env = do + putStr $ "Running " ++ test ++ " ..." ++ (replicate (36 - (length test)) ' ') + (output,success) <- backtick shell test env + if success then do putStrLn " passed." + cleanup_dirs + run_helper shell ts fails env + else do putStrLn " failed." + putStrLn $ "Probable reason :" ++ output + cleanup_dirs + run_helper shell ts (fails++[test]) env + where cleanup_dirs :: IO () + cleanup_dirs = + do dirfiles <- getDirectoryContents (fromJust $ lookup "TESTS_WD" env) + let tempfiles = (filter ("temp" `isPrefixOf`) dirfiles) ++ + (filter ("tmp" `isPrefixOf`) dirfiles) + mapM_ (\x-> + setPermissions x (Permissions + {readable = True + ,writable = True + ,executable = False + ,searchable = True} + ) + ) tempfiles + +backtick :: String -> String -> [(String, String)]-> IO (String,Bool) +backtick cmd args env = do + (exitcode,res) <- backtick_helper cmd args env + case exitcode of + ExitSuccess -> return (res, True) + ExitFailure _ -> return (res, False) + +backtick_helper :: String -> String -> [(String,String)] -> + IO (ExitCode, String) +backtick_helper cmd args env = process_wrapper (runInteractiveProcess + cmd [args] Nothing + (Just env) + ) "" + +find_bash :: IO FilePath +find_bash = + do sh <- findExecutable "bash" + case sh of + Just p -> return p + Nothing -> error "Could not find bash in PATH" + +-- | Run a process with a list of arguments and return anything from +-- /stderr/ or /stdout/ +process_wrapper :: IO (Handle, Handle, Handle, ProcessHandle) -> + String -> IO (ExitCode, String) +process_wrapper f _ = do + (_,o,e,pid) <- f + hSetBuffering o LineBuffering + hSetBuffering e LineBuffering + ch <- newChan + -- WARNING: beware of hokeyness ahead! + let readWrite i = do x <- hGetLine i + writeChan ch $ Just x + readWrite i + `catch` \_ -> writeChan ch Nothing + readEO = do x <- readChan ch + case x of + Just l -> do y <- readEO + return $ l:y + Nothing -> readEO' + readEO' = do x <- readChan ch + case x of + Just l -> do y <- readEO' + return $ l:y + Nothing -> return [] + forkIO $ readWrite o + forkIO $ readWrite e + outerr <- readEO + ec <- waitForProcessNonBlocking pid + threadDelay 1000 + case ec of + ExitFailure 127 -> fail $ "timeout running command\n\n" + ++unlines outerr + _ -> return (ec, unlines outerr) + +-- +-- waitForProcess uses a very hokey heuristic to try to avoid burning too +-- much CPU time in a busy wait, while also not adding too much extra +-- latency. + +waitForProcessNonBlocking :: ProcessHandle -> IO ExitCode +waitForProcessNonBlocking = if rtsSupportsBoundThreads + then waitForProcess + else wfp 0 + where wfp n pid = do mec <- getProcessExitCode pid + case mec of + Just ec -> return ec + Nothing -> do threadDelay n + wfp (min 100000 (n+1+n`div`4)) pid + + + +set_env :: [(String,String)] -> [(String,String)] -> [(String, String)] +set_env es env = nubBy (\(x,_) (y,_) -> x == y) (es ++ env) diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,90 @@ +Darcs +===== +This is the source tree for darcs, a distributed version control system +written in Haskell. + +For more information, visit the darcs web site: + + http://www.darcs.net + + +Compilation and Installation +============================ + +Darcs currently supports two build systems: a traditional autotools- +based system, and an experimental cabal-based system. Currently +AUTOTOOLS IS RECOMMENDED; in later releases it will be deprecated and +eventually removed (in favour of cabal). + +If a "configure" file is present, autotools is supported. If a +"Setup.lhs" file is present, cabal is supported. Currently there is a +separate source tarball for each build system; either can be used in +unstable checkouts. + + +Using Autotools +--------------- + +If you have the normal, autotools-based tarball, this sequence should work +for you (if you are in doubt, this is likely the case): + + $ ./configure + $ make + # make install + +You first need to run `autoconf` if you obtained the source tree from the +darcs repository (but this is not needed for release tarballs). + +For more information, please see the manual: + + * http://www.darcs.net/manual + * doc/manual/darcs.ps + + +Using Cabal +----------- + +This method requires the cabal package, version 1.6 or higher. The +cabal-install package is also recommended. + +If you have the "cabal-install" package on your system (that is, there +is a "cabal" executable in your path), you can use the following +commands to create an executable in ~/.cabal/bin/darcs. + + $ cabal configure + $ cabal build + $ cabal install + +Otherwise, if you have the "cabal" package but not the "cabal-install" +package, run the following: + + $ runghc Setup configure + $ runghc Setup build + $ sudo runghc Setup install + +You may also omit the last step and copy the darcs executable (found in +dist/build/darcs/darcs) to a location of your choosing. + +More detailed instructions can be found at + +including instructions on obtaining a copy of cabal-install. + +Please also note that the cabal-based build by default requires the cURL +library (and development headers). If, for some reason, you cannot provide +cURL, please pass "-f-curl" to the configure step above. + +Hacking +======= +For more information about darcs hacking and best practices please check +the darcs wiki at http://wiki.darcs.net/DarcsWiki + +Of particular interest are the following documents: + * http://wiki.darcs.net/index.html/DeveloperFAQ + * http://wiki.darcs.net/index.html/DeveloperTips + +Testing +======= +For more information about the test suite, including how to run specific +tests please read tests/README.test_maintainers.txt. + +Happy hacking! diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,389 @@ +\begin{code} +{-# OPTIONS_GHC -cpp #-} +-- copyright (c) 2008 Duncan Coutts +-- portions copyright (c) 2008 David Roundy + +import Distribution.Simple + ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) +import Distribution.PackageDescription + ( PackageDescription(executables), Executable(buildInfo, exeName) + , BuildInfo(customFieldsBI), emptyBuildInfo + , updatePackageDescription, cppOptions, ccOptions ) +import Distribution.Package + ( packageVersion ) +import Distribution.Version + ( Version(versionBranch) ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), absoluteInstallDirs ) +import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest)) +import Distribution.Simple.Setup + (buildVerbosity, copyDest, copyVerbosity, fromFlag, + haddockVerbosity, installVerbosity, sDistVerbosity) +import Distribution.Simple.BuildPaths + ( autogenModulesDir ) +import Distribution.System + ( OS(Windows), buildOS ) +import Distribution.Simple.Utils + (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout, + rewriteFile) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Text + ( display ) +import Distribution.Package (Package) + +import Control.Monad ( zipWithM_, when, unless, filterM ) +import Control.Exception ( bracket ) +import System.Directory + (copyFile, createDirectory, createDirectoryIfMissing, + doesDirectoryExist, doesFileExist, + getCurrentDirectory, getDirectoryContents, + removeDirectoryRecursive, removeFile, setCurrentDirectory) +import System.IO (openFile, IOMode (..)) +import System.Process (runProcess) +import System.IO.Error ( isDoesNotExistError ) +import Data.List( isSuffixOf, sort, partition ) + +import System.FilePath ( (), splitDirectories, isAbsolute ) +import Foreign.Marshal.Utils ( with ) +import Foreign.Storable ( peek ) +import Foreign.Ptr ( castPtr ) +import Data.Word ( Word8, Word32 ) + +import qualified Distribution.ShellHarness as Harness ( runTests ) + +#if __GLASGOW_HASKELL__ >= 610 +import qualified Control.OldException as Exception +#else +import qualified Control.Exception as Exception +#endif + +main :: IO () +main = defaultMainWithHooks simpleUserHooks { + + buildHook = \ pkg lbi hooks flags -> + let verb = fromFlag $ buildVerbosity flags + in commonBuildHook buildHook pkg lbi hooks verb >>= ($ flags), + + haddockHook = \ pkg lbi hooks flags -> + let verb = fromFlag $ haddockVerbosity flags + in commonBuildHook haddockHook pkg lbi hooks verb >>= ($ flags) , + + postBuild = \ _ _ _ lbi -> buildManpage lbi, + postCopy = \ _ flags pkg lbi -> + installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags), + postInst = \ _ flags pkg lbi -> + installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest, + + runTests = \ args _ _ lbi -> do + cwd <- getCurrentDirectory + let isabs = isAbsolute $ buildDir lbi + path = (if isabs then id else (cwd )) + (buildDir lbi "darcs") + what = if null args then ["tests"] else args + (series, tests) = partition + (`elem` ["bugs", "network", "tests"]) what + sequence_ [ case w of + "bugs" -> allTests path Bug [] + "network" -> execTests path Network "" [] + "tests" -> allTests path Test [] + _ -> return () {- impossible, silence -Wall -} + | w <- series ] + when (not $ null tests) $ individualTests path tests, + + -- Remove the temporary directories created by "cabal test". + postClean = \ _ _ _ _ -> mapM_ rmRf + ["tests-darcs-2.dir", + "tests-hashed.dir", + "tests-old-fashioned-inventory.dir", + "bugs-darcs-2.dir", + "bugs-hashed.dir", + "bugs-old-fashioned-inventory.dir", + "tests_network-.dir"], + + sDistHook = \ pkg lbi hooks flags -> do + let pkgVer = packageVersion pkg + verb = fromFlag $ sDistVerbosity flags + x <- versionPatches verb pkgVer + y <- context verb pkgVer + rewriteFile "release/distributed-version" $ show x + rewriteFile "release/distributed-context" $ show y + + sDistHook simpleUserHooks pkg lbi hooks flags +} + +-- | For @./Setup build@ and @./Setup haddock@, do some unusual +-- things, then invoke the base behaviour ("simple hook"). +commonBuildHook :: (UserHooks -> PackageDescription -> LocalBuildInfo -> t -> a) + -> PackageDescription -> LocalBuildInfo -> t -> Verbosity -> IO a +commonBuildHook runHook pkg lbi hooks verbosity = do + -- Autoconf may have generated a context file. Remove it before + -- building, as its existence inexplicably breaks Cabal. + removeFile "src/Context.hs" + `catch` (\e -> unless (isDoesNotExistError e) (ioError e)) + + -- Create our own context file. + writeGeneratedModules verbosity pkg lbi + + -- Add custom -DFOO[=BAR] flags to the cpp (for .hs) and cc (for .c) + -- invocations, doing a dance to make the base hook aware of them. + (version, state) <- determineVersion verbosity pkg + littleEndian <- testEndianness + let args = ("-DPACKAGE_VERSION=" ++ show' version) : + ("-DPACKAGE_VERSION_STATE=" ++ show' state) : + [arg | (arg, True) <- -- include fst iff snd. + [("-DHAVE_HTTP", "x-have-http" `elem` customFields), + ("-DUSE_COLOR", "x-use-color" `elem` customFields), + -- We have MAPI iff building on/for Windows. + ("-DHAVE_MAPI", buildOS == Windows), + ("-DBIGENDIAN", not littleEndian)]] + bi = emptyBuildInfo { cppOptions = args, ccOptions = args } + hbi = (Just bi, [(exeName exe, bi) | exe <- executables pkg]) + pkg' = updatePackageDescription hbi pkg + lbi' = lbi { localPkgDescr = pkg' } + return $ runHook simpleUserHooks pkg' lbi' hooks + + where + customFields = map fst . customFieldsBI . buildInfo $ darcsExe + darcsExe = head [e | e <- executables pkg, exeName e == "darcs"] + show' :: String -> String -- Petr was worried that we might + show' = show -- allow non-String arguments. + testEndianness :: IO Bool + testEndianness = with (1 :: Word32) $ \p -> do o <- peek $ castPtr p + return $ o == (1 :: Word8) + +buildManpage :: LocalBuildInfo -> IO () +buildManpage lbi = do + let darcs = buildDir lbi "darcs/darcs" + manpage = buildDir lbi "darcs/darcs.1" + manpageHandle <- openFile manpage WriteMode + runProcess darcs ["help","manpage"] + Nothing Nothing Nothing (Just manpageHandle) Nothing + return () + +installManpage :: PackageDescription -> LocalBuildInfo + -> Verbosity -> CopyDest -> IO () +installManpage pkg lbi verbosity copy = + copyFiles verbosity + (mandir (absoluteInstallDirs pkg lbi copy) "man1") + [(buildDir lbi "darcs", "darcs.1")] + +writeGeneratedModules :: Verbosity + -> PackageDescription -> LocalBuildInfo -> IO () +writeGeneratedModules verbosity pkg lbi = do + createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi) + + let contextModulePath = autogenModulesDir lbi "Context.hs" + generateContextModule verbosity contextModulePath pkg + +determineVersion :: Verbosity -> PackageDescription -> IO (String, String) +determineVersion verbosity pkg = do + let darcsVersion = packageVersion pkg + numPatches <- versionPatches verbosity darcsVersion + return (display darcsVersion, versionStateString numPatches darcsVersion) + + where + versionStateString :: Maybe Int -> Version -> String + versionStateString Nothing _ = "unknown" + versionStateString (Just 0) v = case versionBranch v of + x | 97 `elem` x -> "alpha " ++ show (after 97 x) + | 98 `elem` x -> "beta " ++ show (after 98 x) + | 99 `elem` x -> + "release candidate " ++ show (after 99 x) + _ -> "release" + versionStateString (Just 1) _ = "+ 1 patch" + versionStateString (Just n) _ = "+ " ++ show n ++ " patches" + after w (x:r) | w == x = head r + | otherwise = after w r + after _ [] = undefined + +versionPatches :: Verbosity -> Version -> IO (Maybe Int) +versionPatches verbosity darcsVersion = do + numPatchesDarcs <- do + out <- rawSystemStdout verbosity "darcs" + ["changes", "--from-tag", display darcsVersion, "--count"] + case reads (out) of + ((n,_):_) -> return $ Just ((n :: Int) - 1) + _ -> return Nothing + `Exception.catch` \_ -> return Nothing + + numPatchesDist <- parseFile versionFile + return $ case (numPatchesDarcs, numPatchesDist) of + (Just x, _) -> Just x + (Nothing, Just x) -> Just x + (Nothing, Nothing) -> Nothing + + where + versionFile = "release/distributed-version" + +generateContextModule :: (Package pkg) => Verbosity -> FilePath -> pkg -> IO () +generateContextModule verbosity targetFile pkg = do + ctx <- context verbosity (packageVersion pkg) + rewriteFile targetFile $ unlines + ["module Context where" + ,"context :: String" + ,"context = " ++ case ctx of + Just x -> show x + Nothing -> show "context not available" + ] + +context :: Verbosity -> Version -> IO (Maybe String) +context verbosity version = do + contextDarcs <- do + -- FIXME currently we run changes --from-tag to at least assert that the + -- requested version is tagged in this repository... it is a weak check, + -- but otherwise, my ~/_darcs context tends to gets used when running + -- from an unpacked distribution + rawSystemStdout verbosity "darcs" + ["changes", "--from-tag", display version ] + out <- rawSystemStdout verbosity "darcs" ["changes", "--context"] + return $ Just out + `Exception.catch` \_ -> return Nothing + + contextDist <- parseFile contextFile + return $ case (contextDarcs, contextDist) of + (Just x, _) -> Just x + (Nothing, Just x) -> Just x + (Nothing, Nothing) -> Nothing + where contextFile = "release/distributed-context" + +parseFile :: (Read a) => String -> IO (Maybe a) +parseFile f = do + exist <- doesFileExist f + if exist then do + content <- readFile f -- ^ ratify readFile: we don't care here. + case reads content of + ((s,_):_) -> return s + _ -> return Nothing + else return Nothing + +------------------------------------- +-- Running the testsuite +-- + +data TestKind = Bug | Test | Network deriving Eq + +instance Show TestKind where + show Bug = "bugs" + show Test = "tests" + show Network = "tests/network" + +flat :: (Show a) => a -> String +flat a = [ if x == '/' then '_' else x | x <- show a ] + +isTest :: FilePath -> Bool +isTest = (".sh" `isSuffixOf`) + +execTests :: FilePath -> TestKind -> String -> [String] -> IO () +execTests darcs_path k fmt tests = do + let dir = (flat k) ++ "-" ++ fmt ++ ".dir" + rmRf dir + cloneTree (show k) dir + withCurrentDirectory dir $ do + createDirectory ".darcs" + when (not $ null fmt) $ appendFile ".darcs/defaults" $ "ALL " ++ fmt ++ "\n" + putStrLn $ "Running tests for format: " ++ fmt + exec + where exec = do + fs <- case tests of + [] -> sort `fmap` getDirectoryContents "." + x -> return x + cwd <- getCurrentDirectory + let run = filter isTest fs + res <- Harness.runTests (Just darcs_path) cwd run + when ((not res) && (k /= Bug)) $ fail "Tests failed" + return () + +individualTests :: FilePath -> [String] -> IO () +individualTests darcs_path tests = do + run <- concat `fmap` mapM find tests + sequence_ [ do exec kind [test | (kind', test) <- run, kind' == kind] + | kind <- [Test, Bug, Network] ] + where tryin w t' = [w t', w (t' ++ ".sh")] + exec _ [] = return () + exec kind to_run = allTests darcs_path kind to_run + find t = do + let c = [t, t ++ ".sh"] ++ tryin "tests" t ++ tryin "bugs" t + ++ tryin "network" t + run <- map kindify `fmap` filterM doesFileExist c + return $ take 1 run + kindify test = case splitDirectories test of + [p, y] -> (parse_kind p, y) + _ -> error $ "Bad format in " ++ test ++ + ": expected type/test" + parse_kind "tests" = Test + parse_kind "bugs" = Bug + parse_kind "network" = Network + parse_kind x = error $ "Test prefix must be one of " ++ + "[tests, bugs, network] in " ++ x + + +allTests :: FilePath -> TestKind -> [String] -> IO () +allTests darcs_path k s = + do test `mapM` repotypes + return () + where repotypes = ["darcs-2", "hashed", "old-fashioned-inventory"] + test x = execTests darcs_path k x s + +------------------------------------------------------- +-- Utility functions (FIXME) +-- copy & paste & edit: darcs wants to share these +-- + +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory name m = + bracket + (do cwd <- getCurrentDirectory + when (name /= "") (setCurrentDirectory name) + return cwd) + (\oldwd -> setCurrentDirectory oldwd `catch` (\_ -> return ())) + (const m) + +cloneTree :: FilePath -> FilePath -> IO () +cloneTree = cloneTreeExcept [] + +cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO () +cloneTreeExcept except source dest = + do isdir <- doesDirectoryExist source + if isdir then do + createDirectoryIfMissing True dest + fps <- getDirectoryContents source + let fps' = filter (`notElem` (".":"..":except)) fps + mk_source fp = source ++ "/" ++ fp + mk_dest fp = dest ++ "/" ++ fp + zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') + else fail ("cloneTreeExcept: Bad source " ++ source) + `catch` fail ("cloneTreeExcept: Bad source " ++ source) + +cloneSubTree :: FilePath -> FilePath -> IO () +cloneSubTree source dest = + do isdir <- doesDirectoryExist source + isfile <- doesFileExist source + if isdir then do + createDirectory dest + fps <- getDirectoryContents source + let fps' = filter (`notElem` [".", ".."]) fps + mk_source fp = source ++ "/" ++ fp + mk_dest fp = dest ++ "/" ++ fp + zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') + else if isfile then do + cloneFile source dest + else fail ("cloneSubTree: Bad source "++ source) + `catch` (\e -> if isDoesNotExistError e + then return () + else ioError e) + +cloneFile :: FilePath -> FilePath -> IO () +cloneFile = copyFile + +rmRf :: FilePath -> IO () +rmRf path = do + isdir <- doesDirectoryExist path + isf <- doesFileExist path + when isdir $ removeDirectoryRecursive path + when isf $ removeFile path + return () + +-- (END FIXME) + +\end{code} diff --git a/bugs/add_permissions.sh b/bugs/add_permissions.sh new file mode 100644 --- /dev/null +++ b/bugs/add_permissions.sh @@ -0,0 +1,36 @@ +#!/usr/bin/env bash +## Darcs should refuse to add an unreadable file, because unreadable +## files aren't recordable. +## +## Copyright (C) 2005 Mark Stosberg +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +abort_windows # does not work on Windows. +rm -rf temp1 # Another script may have left a mess. +darcs initialize --repodir temp1 +touch temp1/unreadable +chmod a-r temp1/unreadable # Make the file unreadable. +not darcs add --repodir temp1 no_perms.txt 2>temp1/log +fgrep -i 'permission denied' temp1/log +rm -rf temp1 diff --git a/bugs/dist-v.sh b/bugs/dist-v.sh new file mode 100644 --- /dev/null +++ b/bugs/dist-v.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash +set -ev + +# tests for "darcs dist" + +not () { "$@" && exit 1 || :; } + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +# needs fixed on FreeBSD +darcs dist -v 2> log +not grep error log +cd .. + +rm -rf temp1 + diff --git a/bugs/emailformat.sh b/bugs/emailformat.sh new file mode 100644 --- /dev/null +++ b/bugs/emailformat.sh @@ -0,0 +1,46 @@ +#!/usr/bin/env bash + +# This appears to hang on Windows + +set -ev +# TODO: is this really enough to make all commands interpret the given strings +# as latin1? +export LANG="en_US.ISO-8859-1" + +rm -rf temp1 +rm -rf temp2 +mkdir temp1 +mkdir temp2 +cd temp1 + +seventysevenaddy="" + +darcs init + +echo "Have you seen the smørrebrød of René Çavésant?" > non_ascii_file +darcs add non_ascii_file +darcs record -am "non-ascii file add" -A test + +cd ../temp2 +darcs init +cd ../temp1 + +# long email adress: check that email adresses of <= 77 chars don't get split up +darcs send --from="Kjålt Überström $seventysevenaddy" \ + --subject "Un patch pour le répositoire" \ + --to="Un garçon français " \ + --sendmail-command='cp /dev/stdin mail_as_file %<' \ + -a ../temp2 + +cat mail_as_file +# The long mail address should be in there as a whole +grep $seventysevenaddy mail_as_file + +# Check that there are no non-ASCII characters in the mail +ghc -e 'getContents >>= return . not . any (> Data.Char.chr 127)' < mail_as_file | grep '^True$' + + +cd .. +rm -rf temp1 +rm -rf temp2 + diff --git a/bugs/issue1013_either_dependency.sh b/bugs/issue1013_either_dependency.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1013_either_dependency.sh @@ -0,0 +1,53 @@ +#!/usr/bin/env bash +set -ev +export DARCS_EMAIL=test +rm -rf tmp_d1 tmp_d2 tmp_d +# Preparations: +# Set up two repos, each with a patch (d1 and d2 respectively) with both +# an individual change and a change that is identical in both repos, +# and thus auto-merge, i.e., they don't conflict in darcs2. Pull them +# together and record a patch (problem) on top of the auto-merged change, +# so that it depends on EITHER of two patches. + +mkdir tmp_d1; cd tmp_d1 +darcs init --darcs-2 +echo a > a +echo b > b +echo c > c +darcs rec -alm init +echo a-independent > a +echo c-common > c +darcs rec -am d1 +cd .. +darcs get --to-patch init tmp_d1 tmp_d2 +cd tmp_d2 +echo b-independent > b +echo c-common > c +darcs rec -am d2 +darcs pull -a ../tmp_d1 +# no conflicts -- c-common is identical +echo c-problem > c +darcs rec -am problem +cd .. + +# I want to pull the 'problem' patch, but expect darcs to get confused +# because it doesn't know how to select one of the two dependent patches. + +darcs get --to-patch init tmp_d2 tmp_d +cd tmp_d +echo n/n/y |tr / \\012 |darcs pull ../tmp_d2 +darcs cha + +# This is weird, we got d2 though we said No. I would have expected +# darcs to skip the 'problem' patch in this case. + +# Try to pull d1 and unpull d2. + +darcs pull -a ../tmp_d1 +exit 1 # darcs hangs here (2.0.2+77)! +echo n/y/d |tr / \\012 |darcs obl -p d2 + +# The obliterate fails with: patches to commute_to_end does not commutex (1) + +cd .. +rm -rf tmp_d1 tmp_d2 tmp_d diff --git a/bugs/issue1014_identical_patches.sh b/bugs/issue1014_identical_patches.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1014_identical_patches.sh @@ -0,0 +1,60 @@ +#!/usr/bin/env bash +set -ev + +# Set up a base repo. Our experiment will start from this point +mkdir base +cd base +darcs init --darcs-2 +printf "Line1\nLine2\nLine3\n" > foo +darcs rec -alm Base +cd .. + +# Now we want to record patch A, which will turn "Line2" into "Hello" +darcs get base a +cd a +printf "Line1\nHello\nLine3\n" > foo +darcs rec --ignore-times -am A +cd .. + +# Make B the same as A +darcs get base b +cd b +printf "Line1\nHello\nLine3\n" > foo +darcs rec --ignore-times -am B +cd .. + +# Now we make a patch C that depends on A +darcs get a ac +cd ac +printf "Line1\nWorld\nLine3\n" > foo +darcs rec --ignore-times -am C +cd .. + +# Merge A and B +darcs get a ab +cd ab +darcs pull -a ../b +darcs revert -a +cd .. + +# And merge in C too +darcs get ab abc +cd abc +darcs pull -a ../ac +darcs revert -a +cd .. + +# Now we can pull just B and C into base +darcs get base bc +cd bc +darcs pull ../abc -ap 'B|C' +cd .. + +# Now we have base, B and C in a repository. At this point we're correct. + +# Let's try merging AC with BC now, here we discover a bug. + +darcs get ac abc2 +cd abc2 +darcs pull -a ../bc + diff --git a/bugs/issue1190_unmarked_hunk_replace_conflict.sh b/bugs/issue1190_unmarked_hunk_replace_conflict.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1190_unmarked_hunk_replace_conflict.sh @@ -0,0 +1,43 @@ +#!/usr/bin/env bash +## Test for issue1190 - conflicts between HUNK and REPLACE are not +## marked by --mark-conflicts. +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +rm -rf d e # Another script may have left a mess. +darcs init --repo d/ +printf %s\\n foo bar baz >d/f +darcs record --repo d/ -lam f1 +darcs get d/ e/ +darcs replace --repo e/ --force bar baz f +darcs record --repo e/ -lam replacement +printf %s\\n foo bar quux >d/f # replace baz with quux +darcs record --repo d/ -am f2 + +## There ought to be a conflict here, and there is. +darcs pull --repo e/ d/ -a --mark-conflicts +## The file ought to now have conflict markers in it. +grep 'v v v' e/f +rm -rf d/ e/ # Clean up after ourselves. diff --git a/bugs/issue1196_whatsnew_falsely_lists_all_changes.sh b/bugs/issue1196_whatsnew_falsely_lists_all_changes.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1196_whatsnew_falsely_lists_all_changes.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash +set -ev + +not () { "$@" && exit 1 || :; } + +rm -rf temp1 +mkdir temp1 +cd temp1 + +darcs init +touch aargh +darcs add aargh +echo utrecht > aargh + +darcs wh foo foo/../foo/. > out +cat out +not grep utrecht out + +cd .. +rm -rf temp1 + diff --git a/bugs/issue1266_init_inside_a_repo.sh b/bugs/issue1266_init_inside_a_repo.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1266_init_inside_a_repo.sh @@ -0,0 +1,33 @@ +#!/usr/bin/env bash +## Test for issue1266 - attempting to initialize a repository inside +## another repository should cause a warning, because while perfectly +## legitimate, it is likely to be accidental. +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +rm -rf temp1 out # Another script may have left a mess. +darcs init --repodir temp1 +darcs init --repodir temp1/temp2 2>&1 | tee out +grep -i WARNING out # A warning should be printed. diff --git a/bugs/issue1327.sh b/bugs/issue1327.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1327.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash +set -ev + +# See issue1327. +# results in the error: +# patches to commute_to_end does not commutex (1) at src/Darcs/Patch/Depends.hs:452 + + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +echo fileA version 1 > fileA +echo fileB version 1 > fileB +darcs add fileA fileB +darcs record --author foo@bar --ignore-times --all -m "Add fileA and fileB" +echo fileA version 2 > fileA +darcs record --author foo@bar --ignore-times --all -m "Modify fileA" +cd .. +darcs get temp1 temp2 +cd temp2 +darcs obliterate -p "Modify fileA" --all +darcs unrecord -p "Add fileA and fileB" --all +darcs record --author foo@bar --ignore-times --all fileA -m "Add just fileA" +cd ../temp1 +darcs pull --all ../temp2 +echo y | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB" diff --git a/bugs/issue1337_darcs_changes_false_positives.sh b/bugs/issue1337_darcs_changes_false_positives.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1337_darcs_changes_false_positives.sh @@ -0,0 +1,37 @@ +#!/usr/bin/env bash +## Test for issue1337 - darcs changes shows unrelated patches +## Asking "darcs changes" about an unrecorded file d/f will list the +## patch that creates the parent directory d/ (instead of no patches). +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +rm -rf temp1 +darcs init --repodir temp1 +cd temp1 +mkdir d +darcs record -lam d d +# We use --match 'touch d/f' instead of simply d/f because the latter +# prints "Changes to d/f:\n" before the count. +test 0 -eq "$(darcs changes --count --match 'touch d/f')" diff --git a/bugs/issue1396_changepref-conflict.sh b/bugs/issue1396_changepref-conflict.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1396_changepref-conflict.sh @@ -0,0 +1,32 @@ +#!/usr/bin/env bash +set -ev + +. ../tests/lib + +rm -rf temp1 temp1a temp1b + +mkdir temp1 +cd temp1 +darcs init +darcs setpref test 'echo nothing' +darcs record -am 'null pref' +cd .. + +darcs get temp1 temp1a +cd temp1a +darcs setpref test 'echo a' +darcs record -am 'pref a' +cd .. + +darcs get temp1 temp1b +cd temp1b +darcs setpref test 'echo b' +darcs record -am 'pref b' +cd .. + +cd temp1 +darcs pull -a ../temp1a --dont-allow-conflicts +not darcs pull -a ../temp1b --dont-allow-conflicts +cd .. + +rm -rf temp1 temp1a temp1b diff --git a/bugs/issue1401_bug_in_get_extra.sh b/bugs/issue1401_bug_in_get_extra.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1401_bug_in_get_extra.sh @@ -0,0 +1,44 @@ +#!/usr/bin/env bash +## Test for issue1401 - when two repos share a HUNK patch, but that +## patch's ADDFILE dependency is met by different patches in each +## repo, it becomes impossible to pull between the two repos. +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +## This bug only affects darcs-2 repositories. +fgrep darcs-2 ~/.darcs/defaults &>/dev/null || exit 0 + +rm -rf d e # Another script may have left a mess. +darcs initialize --repodir d/ +darcs initialize --repodir e/ +touch d/f d/g e/f +darcs record --repodir d/ -lam 'Add f and g' +darcs record --repodir e/ -lam 'Add f' +echo >d/f +darcs record --repodir d/ -am 'Change f' +darcs pull --repodir e/ -a d/ +darcs obliterate --repodir e/ -ap 'Add f and g' +darcs pull --repodir e/ -a d/ +rm -rf d/ e/ # Clean up after ourselves. diff --git a/bugs/issue1406.sh b/bugs/issue1406.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1406.sh @@ -0,0 +1,19 @@ +#!/bin/sh +rm -rf temp1 +darcs init --repodir temp1 + +cd temp1 + +echo "test exit 1" > _darcs/prefs/prefs +echo "name" > _darcs/prefs/author +echo "a" > a +darcs record --look-for-adds --no-test --all --patch-name=p1 +echo "b" >> a +echo "y" | darcs amend-record --all --patch=p1 + +# There should be one patch in the repo +test 1 -eq `darcs changes --count` || exit 1 + +# Another check: there should be nothing new after a is restored +echo "a" > a +darcs whatsnew -l && exit 1 || exit 0 diff --git a/bugs/issue1442_encoding_round-trip.sh b/bugs/issue1442_encoding_round-trip.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1442_encoding_round-trip.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +## -*- coding: utf-8 -*- +## Test for issue1442 - if we disable Darcs escaping and don't change +## our encoding, the bytes in a filename should be the same bytes that +## "darcs changes -v" prints to the right of "addfile" and "hunk". +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib + +rm -rf R # Another script may have left a mess. + +## Use the first UTF-8 locale we can find. +export LC_ALL=$(locale -a | egrep 'utf8|UTF-8' | head -1) +export DARCS_DONT_ESCAPE_ANYTHING=True + +## If LC_ALL is the empty string, this system doesn't support UTF-8. +if test -z "$LC_ALL" +then exit 1 +fi + +darcs init --repo R +echo '首頁 = א₀' >R/'首頁 = א₀' +darcs record --repo R -lam '首頁 = א₀' '首頁 = א₀' +darcs changes --repo R -v '首頁 = א₀' >R/log +#cat R/log # Show the humans what the output was. +grep -c '首頁 = א₀' R/log >R/count +echo 5 >R/expected-count +cmp R/count R/expected-count # Both count files should contain "5\n". +rm -rf R # Clean up after ourselves. diff --git a/bugs/issue1461_case_folding.sh b/bugs/issue1461_case_folding.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1461_case_folding.sh @@ -0,0 +1,83 @@ +#!/usr/bin/env bash +## Test for issue1461 - patches to files whose names only differ by +## case can be wrongly applied to the same file in the working directory. +## +## Copyright (C) 2009 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf lower upper joint # Another script may have left a mess. +mkdir lower upper + +cd lower +darcs init +cat > a << EOF +1 +2 +3 +EOF +darcs add a +darcs record -am 'lower init a' +cd .. + +cd upper +darcs init +cat > A << EOF +1 +2 +3 +EOF +darcs add A +darcs record -am 'upper init A' +cd .. + +darcs get lower joint +cd joint +darcs pull -a ../upper +cd .. + +cd lower +cat > a << EOF +one lower +2 +3 +EOF +darcs record -am 'lower modify' +cd .. + +cd upper +cat > A << EOF +1 +2 +three upper +EOF +darcs record -am 'upper modify' +cd .. + +cd joint +darcs pull ../lower -a +darcs pull ../upper -a +grep one a && not grep three a +grep three A && not grep one A +cd .. +# clean up after ourselves +rm -rf lower upper joint diff --git a/bugs/issue1473_annotate_repodir.sh b/bugs/issue1473_annotate_repodir.sh new file mode 100644 --- /dev/null +++ b/bugs/issue1473_annotate_repodir.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash +set -ev + +. ../tests/lib +rm -rf temp +mkdir temp +cd temp +darcs init +mkdir a b +touch a/a b/b +darcs add --rec . +darcs record -a -m ab -A test +darcs annotate a/a +# annotate --repodir=something '.' should work +cd .. +darcs annotate --repodir temp '.' +cd temp + +cd .. +rm -rf temp + diff --git a/bugs/issue27.sh b/bugs/issue27.sh new file mode 100644 --- /dev/null +++ b/bugs/issue27.sh @@ -0,0 +1,43 @@ +#!/bin/sh + +set -ev + +rm -rf temp1 temp2 +mkdir temp1 temp2 +cd temp1 +darcs init +echo first > a +darcs add a +darcs record --pipe --all --patch-name=first < b +darcs add b +darcs record --pipe --all --patch-name=first <> a +darcs record --pipe --all --patch-name=second <> b +darcs record --pipe --all --patch-name=second < file1 +date > file2 +darcs add file* +darcs record -am "test" + +strace darcs whatsnew file1 &> out +# we should be accessing file1 +grep file1 out +# but shouldn't be accessing file2 +if grep file2 out +then + echo A whatsnew for file1 should not involve a 'stat' call to file2 + exit 1 +else + echo Yay. We pass. +fi + +rm -rf temp diff --git a/bugs/issue558_broken_pipe.sh b/bugs/issue558_broken_pipe.sh new file mode 100644 --- /dev/null +++ b/bugs/issue558_broken_pipe.sh @@ -0,0 +1,29 @@ +#!/usr/bin/env bash + +# For issue588, "amend-record --look-for-adds end up with two "addfile" entries" + +set -ev +rm -rf temp1 +darcs init --repodir temp1 + +export EMAIL=me + +cd temp1 + +date > f +darcs add f +darcs rec -am p1 +for (( i=0 ; i < 500; i=i+1 )); do + echo $i >> f; + darcs rec -am p$i +done + +darcs changes 2> err | head + +touch correcterr + +diff correcterr err + +cd .. + +rm -rf temp1 diff --git a/bugs/issue944_partial_inventory.sh b/bugs/issue944_partial_inventory.sh new file mode 100644 --- /dev/null +++ b/bugs/issue944_partial_inventory.sh @@ -0,0 +1,46 @@ +#!/usr/bin/env bash + +set -ev + +test $DARCS || DARCS=$PWD/../darcs +ACTUAL_DARCS=`which $DARCS` +DARCSPATH=`dirname $ACTUAL_DARCS` +PATH="$DARCSPATH:$PATH" +export PATH + +# create base repository +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init + +echo first > a +darcs add a +darcs record -am first +darcs tag --checkpoint 'Tag 1' + +echo second > b +darcs add b +darcs record -am second +darcs tag --checkpoint 'Tag 2' + +echo third > c +darcs add c +darcs record -am third +darcs tag --checkpoint 'Tag 3' + +# create a partial copy of the base repository and modify it +cd .. +rm -rf temp2 +darcs get --partial temp1 temp2 +cd temp2 + +# instead of the following three commands one could also use darcs optimize +echo mistake > a +darcs record -am mistake +darcs unrecord -ap mistake + +# now check the repository +darcs check +# => darcs: failed to read patch: ... + diff --git a/bugs/merging_newlines.sh b/bugs/merging_newlines.sh new file mode 100644 --- /dev/null +++ b/bugs/merging_newlines.sh @@ -0,0 +1,47 @@ +#!/usr/bin/env bash +set -ev + +# Note that this is fixed, the lines marked # BUG HERE +# should be moved back into merging_newlines.sh + +# trick: requiring something to fail +not () { "$@" && exit 1 || :; } + +rm -rf temp1 temp2 + +# set up the repository +mkdir temp1 +cd temp1 +darcs init +cd .. + +cd temp1 +echo "apply allow-conflicts" > _darcs/prefs/defaults +# note: to make this pass, change echo to echo -n +# is that right? +echo "from temp1" > one.txt +darcs add one.txt +darcs record -A bar -am "add one.txt" +echo >> one.txt +darcs wh -u +cd .. + +darcs get temp1 temp2 +cd temp2 +# reality check +darcs show files | grep one.txt +echo "in tmp2" >> one.txt +darcs whatsnew -s | grep M +darcs record -A bar -am "add extra line" +darcs annotate -p . -u +darcs push -av > log +cat log +not grep -i conflicts log +# BUG HERE +# after a conflict, darcs resolve should report a conflict +darcs mark-conflicts > log 2>&1 +cat log +not grep -i 'no conflicts' log +cd .. + +rm -rf temp1 temp2 diff --git a/bugs/newlines.sh b/bugs/newlines.sh new file mode 100644 --- /dev/null +++ b/bugs/newlines.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 + +# set up the repository +mkdir temp1 +cd temp1 +darcs init +cd .. + +cd temp1 +echo -n "from temp1" > one.txt +darcs add one.txt +darcs record -A bar -am "add one.txt" +echo >> one.txt +cd .. + +darcs get temp1 temp2 +cd temp2 +echo "in tmp2" >> one.txt +darcs record -A bar -am "add extra line" +lines_added=`darcs changes -v --last=1 | grep '\+' | wc -l` +echo $lines_added +test $lines_added -eq 1 +cd .. + +rm -rf temp1 temp2 diff --git a/bugs/nfs-failure.sh b/bugs/nfs-failure.sh new file mode 100644 --- /dev/null +++ b/bugs/nfs-failure.sh @@ -0,0 +1,35 @@ +#!/bin/sh + +set -ev + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +echo first > a +darcs add a +darcs record --pipe --all --patch-name=first < b +darcs add b +darcs record --pipe --all --patch-name=first < foobar +darcs add foobar +sleep 2 # so the time stamps won't accidentally be identical +darcs record -am 'add foobar' + +HASHVAL=0000000025-4cbbfd8ce543076b132b13b60ae06d0189ee80b4d5908abb5e060d331d25eb5c + +if test -d _darcs/pristine.hashed; +then + ls _darcs/pristine.hashed + test -f _darcs/pristine.hashed/$HASHVAL + # verify that the modification time of the file in the pristine cache + # is identical to the modification time of the file in the working + # directory. + not test foobar -ot _darcs/pristine.hashed/$HASHVAL + not test foobar -nt _darcs/pristine.hashed/$HASHVAL +else + not test foobar -ot _darcs/pristine/foobar + not test foobar -nt _darcs/pristine/foobar +fi + +# Now let's verify that the test actually works... + +sleep 1 +touch foobar + +if test -d _darcs/pristine.hashed; +then + not test foobar -ot _darcs/pristine.hashed/$HASHVAL + test foobar -nt _darcs/pristine.hashed/$HASHVAL +else + not test foobar -ot _darcs/pristine/foobar + test foobar -nt _darcs/pristine/foobar +fi + + +cd .. + +rm -rf temp diff --git a/contrib/_darcs.zsh b/contrib/_darcs.zsh new file mode 100644 --- /dev/null +++ b/contrib/_darcs.zsh @@ -0,0 +1,36 @@ +#compdef darcs +## Darcs completion snippet for zsh. +## +## Copyright (C) 2009 Nicolas Pouillard +## +## 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 of the License, 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. + +if (($CURRENT == 2)); then + # We're completing the first word after "darcs" -- the command. + _wanted command expl 'darcs command' \ + compadd -- $( darcs --commands ) +else + case "${words[$CURRENT]}"; in + # If it looks like an URL... + ht*|ft*) + _arguments '*:URL:_urls' + ;; + # If it looks like an explicit path... + /*|./*|\~*|../*) + _arguments '*:file:_files' + ;; + # Otherwise, let's ask darcs for all possible options + *) + _wanted args expl 'arg for darcs command' \ + compadd -- $( darcs ${words[2]} --list-option ) + ;; + esac +fi diff --git a/contrib/cgi/README.in b/contrib/cgi/README.in new file mode 100644 --- /dev/null +++ b/contrib/cgi/README.in @@ -0,0 +1,42 @@ +darcs.cgi is the darcs repository viewer. It provides a web interface +for viewing darcs repositories, using XSLT to transform darcs' XML +output into XHTML. It is written in perl and is more featureful than +the older haskell cgi program darcs_cgi.lhs (seen in URLs as "darcs"). + +dependencies + + darcs.cgi requires with the following tools and has been tested with + the version mentioned: + + darcs-1.0.1 http://www.darcs.net + libxslt-1.1.6 http://xmlsoft.org/XSLT/ + perl-5.8.0 http://www.perl.com + +installation + + 1) copy darcs.cgi to your webserver's cgi directory, eg + /usr/lib/cgi-bin. A symlink probably won't do. Make + sure it's executable. + 2) copy cgi.conf to @sysconfdir@/darcs/cgi.conf and edit appropriately. + You can overwrite the cgi.conf used by the old darcs cgi script. + You probably don't need to change anything here. + 3) copy the xslt directory to @datadir@/darcs/xslt + 4) copy xslt/styles.css to @sysconfdir@/darcs/styles.css + + Test by browsing "http:///cgi-bin/darcs.cgi/". + +troubleshooting + + if the configuration is incorrect error messages will be printed to + the webserver's error log, for example "/var/log/apache/error.log". + + you can also double check the configuration by running darcs.cgi + from the command line and supplying a --check argument: + + $ ./darcs.cgi --check + +character encodings + + if your repositories contain files with characters encoded in + something other than ASCII or UTF-8, change the 'xml_encoding' + setting in cgi.conf to the appropriate encoding. diff --git a/contrib/cgi/cgi.conf.in b/contrib/cgi/cgi.conf.in new file mode 100644 --- /dev/null +++ b/contrib/cgi/cgi.conf.in @@ -0,0 +1,31 @@ +# This is an example for cgi.conf + +# reposdir is the directory containing the repositories + +reposdir = /var/www/repos + +# cachedir is a directory writable by www-data (or whatever user your cgi +# scripts run as) which is used to cache the web pages. + +cachedir = /var/cache/darcs + +# The following are used by darcs.cgi (not darcs_cgi) +PATH = /bin:/usr/bin:/usr/local/bin + +# paths to executables, or just the executables if they are in 'PATH' +#darcs = darcs +#xsltproc = xsltproc + +# Path to XSLT templates (default is /usr/local/share/darcs/xslt) +xslt_dir = @datadir@/darcs/xslt + +# HTTP request path of the style sheet, the default will magically read +# @sysconfdir@/darcs/styles.css +#stylesheet = /cgi-bin/darcs.cgi/styles.css + +css_styles = @sysconfdir@/darcs/styles.css + +# encoding to include in XML declaration. Set this to the encoding used +# by the files in your repositories. + +xml_encoding = UTF-8 diff --git a/contrib/cgi/darcs.cgi.in b/contrib/cgi/darcs.cgi.in new file mode 100644 --- /dev/null +++ b/contrib/cgi/darcs.cgi.in @@ -0,0 +1,491 @@ +#!/usr/bin/perl -T +# +# darcs.cgi - the darcs repository viewer +# +# Copyright (c) 2004 Will Glozer +# +# Permission is hereby granted, free of charge, to any person obtaining +# a copy of this software and associated documentation files (the +# "Software"), to deal in the Software without restriction, including +# without limitation the rights to use, copy, modify, merge, publish, +# distribute, sublicense, and/or sell copies of the Software, and to +# permit persons to whom the Software is furnished to do so, subject to +# the following conditions +# +# The above copyright notice and this permission notice shall be +# included in all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +# LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +# OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +# WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +# +# This program calls darcs (or its own subroutines) to generate XML +# which is rendered into HTML by XSLT. It is capable of displaying +# the files in a repository, various patch histories, annotations, etc. +# + +use strict; + +use CGI qw( :standard ); +use CGI::Util; +use File::Basename; +use File::stat; +use IO::File; +use POSIX; + +## the following variables can be customized to reflect your system +## configuration by defining them appropriately in the file +## "@sysconfdir@/darcs/cgi.conf". The syntax accepts equals signs or simply +## blanks separating values from assignments. + +$ENV{'PATH'} = read_conf('PATH', $ENV{'PATH'}); + +# path to executables, or just the executable if they are in $ENV{'PATH'} +my $darcs_program = read_conf("darcs", "darcs"); +my $xslt_program = read_conf("xsltproc", "xsltproc"); + +# directory containing repositories +my $repository_root = read_conf("reposdir", "/var/www"); + +# XSLT template locations +my $template_root = read_conf("xslt_dir", '@datadir@/darcs/xslt'); + +my $xslt_annotate = "$template_root/annotate.xslt"; +my $xslt_browse = "$template_root/browse.xslt"; +my $xslt_patches = "$template_root/patches.xslt"; +my $xslt_repos = "$template_root/repos.xslt"; +my $xslt_rss = "$template_root/rss.xslt"; + +my $xslt_errors = "$template_root/errors.xslt"; + +# CSS stylesheet that XSLT templates refer to. This is a HTTP request +# path, not a local file system path. The default will cause darcs.cgi +# to serve the stylesheet rather than the web server. +my $stylesheet = read_conf("stylesheet", "/cgi-bin/darcs.cgi/styles.css"); + +# location of the CSS stylesheet that darcs.cgi will serve if it +# receives a request for '/styles.css' +my $css_styles = read_conf("css_styles", '@sysconfdir@/darcs/styles.css'); + +# location of the favicon that darcs.cgi will serve if it +# receives a request for '/[\w\-]+/favicon.ico' +my $favicon = read_conf("favicon", "/cgi-bin/favicon.ico"); + +# XML source for the error pages +my $xml_errors = "$template_root/errors.xml"; + +# encoding to include in XML declaration +my $xml_encoding = read_conf("xml_encoding", "UTF-8"); + +## end customization + +# ---------------------------------------------------------------------- + +# read a value from the cgi.conf file. +{ + my(%conf); + + sub read_conf { + my ($flag, $val) = @_; + $val = "" if !defined($val); + + if (!%conf && open(CGI_CONF, '@sysconfdir@/darcs/cgi.conf')) { + while () { + chomp; + next if /^\s*(?:\#.*)?$/; # Skip blank lines and comment lines + if (/^\s*(\S+)\s*(?:\=\s*)?(\S+)\s*$/) { + $conf{$1} = $2; + # print "read_conf: $1 = $2\n"; + } else { + warn "read_conf: $_\n"; + } + } + close(CGI_CONF); + } + + $val = $conf{$flag} if exists($conf{$flag}); + + return $val; + } +} + +# open xsltproc to transform and output `xml' with stylesheet file `xslt' +sub transform { + my ($xslt, $args, $content_type) = @_; + + $| = 1; + printf "Content-type: %s\r\n\r\n", $content_type || "text/html"; + my $pipe = new IO::File "| $xslt_program $args $xslt -"; + $pipe->autoflush(0); + return $pipe; +} + +sub pristine_dir { + my ($repo) = @_; + my $pristine = "current"; + if (! -d "${repository_root}/${repo}/_darcs/$pristine") { + $pristine = "pristine"; + } + return "${repository_root}/${repo}/_darcs/$pristine"; +} + +# begin an XML document with a root element and the repository path +sub make_xml { + my ($fh, $repo, $dir, $file) = @_; + my ($full_path, $path) = '/'; + + printf $fh qq(\n); + + printf $fh qq(\n), + $repo, ($dir ? "$dir/" : ''), ($file ? "$file" : ''); + + print $fh qq(\n); + foreach $path (split('/', "$repo/$dir")) { + $full_path .= "$path/"; + print $fh qq($path\n); + } + if ($file) { + print $fh qq($file\n) if $file; + } + print $fh qq(\n\n); +} + +# finish XML output +sub finish_xml { + my ($fh) = @_; + print $fh "\n\n"; + $fh->flush; +} + +# run darcs and wrap the output in an XML document +sub darcs_xml { + my ($fh, $repo, $cmd, $args, $dir, $file) = @_; + + make_xml($fh, $repo, $dir, $file); + + push(@$args, '--xml-output'); + darcs($fh, $repo, $cmd, $args, $dir, $file); + + finish_xml($fh); +} + +# run darcs with output redirected to the specified file handle +sub darcs { + my ($fh, $repo, $cmd, $args, $dir, $file) = @_; + my (@darcs_argv) = ($darcs_program, $cmd, @$args); + + # push target only if there is one, otherwise darcs will get an empty param + if ($dir || $file) { + push(@darcs_argv, sprintf("%s%s%s", $dir, ($dir ? '/' : ''), $file)); + } + + my($pid) = fork; + if ($pid) { + # in the parent process + my($status) = waitpid($pid, 0); + die "$darcs_program exited with status $?\n" if $?; + } elsif(defined($pid)) { + # in the child process + open(STDIN, '/dev/null'); + if (defined($fh)) { + open(STDOUT, '>&', $fh) + || die "can't dup to stdout: $!\n"; + } + chdir "$repository_root/$repo" + || die "chdir: $repository_root/$repo: $!\n"; + exec @darcs_argv; + die "can't exec ".$darcs_argv[0].": $!\n"; + } else { + # fork failed + die "can't fork: $!\n"; + } +} + +# get a directory listing as XML output +sub dir_listing { + my ($fh, $repo, $dir) = @_; + make_xml($fh, $repo, $dir, ''); + + print $fh "\n"; + my $dir_ = pristine_dir ($repo) . "/$dir"; + opendir(DH, $dir_); + while( defined (my $file_ = readdir(DH)) ) { + next if $file_ =~ /^\.\.?$/; + my $file = "$dir_/$file_"; + my $secs = stat($file)->mtime; + my $mtime = localtime($secs); + my $ts = POSIX::strftime("%Y%m%d%H%M%S", gmtime $secs); + + my ($name, $type); + + if (-d $file) { + ($name, $type) = (basename($file) . '/', 'directory'); + } else { + ($name, $type) = (basename($file), 'file'); + } + print $fh qq( <$type name="$name" modified="$mtime" ts="$ts" />\n); + } + closedir(DH); + print $fh "\n"; + + finish_xml($fh); +} + +# get a repository listing as XML output +sub repo_listing { + my($fh) = @_; + + make_xml($fh, "", "", ""); + + print $fh "\n"; + opendir(DH, $repository_root); + while( defined (my $name = readdir(DH)) ) { + next if $name =~ /^\.\.?$/; + if (-d "$repository_root/$name/_darcs") { + print $fh qq( \n); + } + } + closedir(DH); + print $fh "\n"; + + finish_xml($fh); + return $fh; +} + +# show an error page +sub show_error { + my ($type, $code, $message) = @_; + my $xml; + + # set the xslt processing arguments + my $xslt_args = qq { + --stringparam error-type '$type' + --stringparam stylesheet '$stylesheet' + }; + $xslt_args =~ s/\s+/ /gm; + + print "Status: $code $message\r\n\r\n"; + system("$xslt_program $xslt_args $xslt_errors $xml_errors"); +} + +# check if the requested resource has been modified since the client last +# saw it. If not send HTTP status code 304, otherwise set the Last-modified +# and Cache-control headers. +sub is_cached { + my ($path) = @_; + my ($stat) = stat($path); + + # stat may fail because the path was renamed or deleted but still referred + # to by older darcs patches + if ($stat) { + my $last_modified = CGI::expires($stat->mtime); + + if (http('If-Modified-Since') eq $last_modified) { + print("Status: 304 Not Modified\r\n\r\n"); + return 1; + } + + print("Cache-control: max-age=0, must-revalidate\r\n"); + print("Last-modified: $last_modified\r\n"); + } + return 0; +} + +# safely extract a parameter from the http request. This applies a regexp +# to the parameter which should group only the appropriate parameter value +sub safe_param { + my ($param, $regex, $default) = @_; + my $value = CGI::Util::unescape(param($param)); + return ($value =~ $regex) ? $1 : $default; +} + +# common regular expressions for validating passed parameters +my $hash_regex = qr/^([\w\-.]+)$/; +my $path_regex = qr@^([^\\!\$\^&*()\[\]{}<>`|';"?\r\n]+)$@; + +# respond to a CGI request +sub respond { + # untaint the full URL to this CGI + my $cgi_url = CGI::Util::unescape(url()); + $cgi_url =~ $path_regex or die qq(bad url "$cgi_url"); + $cgi_url = $1; + + # untaint script_name, reasonable to expect only \w, -, /, and . in the name + my $script_name = CGI::Util::unescape(script_name()); + $script_name =~ qr~^([\w/.\-\~]+)$~ or die qq(bad script_name "$script_name"); + $script_name = $1; + + # untaint simple parameters, which can only have chars matching \w+ + my $cmd = safe_param('c', '^(\w+)$', 'browse'); + my $sort = safe_param('s', '^(\w+)$', ''); + + # set the xslt processing arguments + my $xslt_args = qq { + --stringparam cgi-program '$script_name' + --stringparam cgi-url '$cgi_url' + --stringparam sort-by '$sort' + --stringparam stylesheet '$stylesheet' + }; + $xslt_args =~ s/\s+/ /gm; + + my ($path) = CGI::Util::unescape(path_info()); + # don't allow ./ or ../ in paths + $path =~ s|[.]+/||g; + + # check whether we're asking for styles.css + if ($path eq '/styles.css') { + return if is_cached($css_styles); + + open (STYLES_CSS, $css_styles) or die qq(couldn't open "${css_styles}"); + my $size = stat($css_styles)->size; + + print "Content-length: $size\r\n"; + print "Content-type: text/css\r\n\r\n"; + + while () { + print $_; + } + close (STYLES_CSS); + return; + } + + # check whether we're asking for favicon.ico + if ($path =~ '/[\w\-]+/favicon.ico') { + return if is_cached($favicon); + + open (FAVICON, $favicon) or die qq(couldn't open "${favicon}"); + my $size = stat($favicon)->size; + + print "Content-length: $size\r\n"; + print "Content-type: image/x-icon\r\n\r\n"; + + while () { + print $_; + } + close (FAVICON); + return; + } + + # when no repository is requested display available repositories + if (length($path) < 2) { + my $fh = transform($xslt_repos, $xslt_args); + repo_listing($fh); + return; + } + + # don't allow any shell meta characters in paths + $path =~ $path_regex or die qq(bad path_info "$path"); + my @path = split('/', substr($1, 1)); + + # split the path into a repository, directory, and file + my ($repo, $dir, $file, @bits) = ('', '', ''); + while (@path > 0) { + $repo = join('/', @path); + # check if remaining path elements refer to a repo + if (-d "${repository_root}/${repo}/_darcs") { + if (@bits > 1) { + $dir = join('/', @bits[0..$#bits - 1]); + } + $file = $bits[$#bits]; + # check if last element of path, stored in $file, is really a dir + if (-d (pristine_dir ($repo) . "/${dir}/${file}")) { + $dir = ($dir ? "$dir/$file" : $file); + $file = ''; + } + last; + } else { + $repo = ''; + unshift(@bits, pop @path); + } + } + + # make sure the repository exists + unless ($repo) { + show_error('invalid-repository', '404', 'Invalid repository'); + return; + } + + # don't generate output unless the requested path has been + # modified since the client last saw it. + return if is_cached(pristine_dir ($repo) . "/$dir/$file"); + + # untaint patches and tags. Tags can have arbitrary values, so + # never pass these unquoted, on pain of pain! + my $patch = safe_param('p', $hash_regex); + my $tag = safe_param('t', '^(.+)$'); + + my @darcs_args; + push(@darcs_args, '--match', "hash $patch") if $patch; + push(@darcs_args, '-t', $tag) if $tag; + + # process the requested command + if ($cmd eq 'browse') { + my $fh = transform($xslt_browse, $xslt_args); + dir_listing($fh, $repo, $dir); + } elsif ($cmd eq 'patches') { + # patches as an option is used to support "--patches" + if (my $patches = safe_param('patches','^(.+)$')) { + push @darcs_args, '--patches', $patches; + } + + my $fh = transform($xslt_patches, $xslt_args); + darcs_xml($fh, $repo, "changes", \@darcs_args, $dir, $file); + } elsif ($cmd eq 'annotate') { + push(@darcs_args, '--summary'); + + my $creator_hash = safe_param('ch', $hash_regex); + my $original_path = safe_param('o', $path_regex); + my $fh = transform($xslt_annotate, $xslt_args); + + # use the creator hash and original file name when available so + # annotations can span renames + if ($creator_hash ne '' && $original_path ne '') { + push(@darcs_args, '--creator-hash', $creator_hash); + darcs_xml($fh, $repo, "annotate", \@darcs_args, '', $original_path); + } else { + darcs_xml($fh, $repo, "annotate", \@darcs_args, $dir, $file); + } + } elsif ($cmd eq 'diff') { + push(@darcs_args, '-u'); + print "Content-type: text/plain\r\n\r\n"; + darcs(undef, $repo, "diff", \@darcs_args, $dir, $file); + } elsif ($cmd eq 'rss') { + push(@darcs_args, '--last', '25'); + + my $fh = transform($xslt_rss, $xslt_args, "application/rss+xml"); + darcs_xml($fh, $repo, "changes", \@darcs_args, $dir, $file); + } else { + show_error('invalid-command', '400', 'Invalid command'); + } +} + +# run a self-test when the --check argument is supplied +if ($ARGV[0] eq '--check') { + (read_conf("css_styles", "abc") ne "abc") || + die "cannot read config file: $!\n"; + + (`$darcs_program`) || + die "cannot execute darcs as '$darcs_program': $!\n"; + (`$xslt_program`) || + die "cannot execute xstlproc as '$xslt_program': $!\n"; + + (-d $repository_root && -r $repository_root) || + die "cannot read repository root directory '$repository_root': $!\n"; + (-d $template_root && -r $template_root) || + die "cannot read template root directory '$template_root': $!\n"; + (-f $css_styles) || + die "cannot read css stylesheet '$css_styles': $!\n"; + (-f $xml_errors) || + die "cannot read error messages '$xml_errors': $!\n"; + + exit 0; +} + +# handle the CGI request +respond(); + diff --git a/contrib/cgi/xslt/annotate.xslt b/contrib/cgi/xslt/annotate.xslt new file mode 100644 --- /dev/null +++ b/contrib/cgi/xslt/annotate.xslt @@ -0,0 +1,390 @@ + + + + + + + + + +

+ annotations for projects / +

+ + + + + + + + + + + + + + + + + + + + + + + + +
filechange
+ +
+

+ + +

+
+ + + + + + + + + + + + +/ + + - + + lines + + + annotate + patches + + + + + + + + + + added file + annotate + patches + + + + + + + + + + + moved from + annotate + patches + + + + + + + + + + removed file + annotate + patches + + + + + + + + + + added directory + annotate + patches + + + + + + + + + + removed directory + annotate + patches + + + + + + + + + + + + + + + + + + +
filechange
+ + + + + + + + + + + + + + / + + + + + + + + added directory + moved directory + removed directory + + + + annotate + + patches + + + + + + + + + + + + + added file + moved file + removed file + + + annotate + patches + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
filechange
+ + added file + moved file + removed file + + annotatepatches
+ + + + 

+      
+
+ + + + + + + + + + + + + +
+ + + + + + + + + + + + + + + +
+ + + + + + + + + + + + + + + + + + +
+ + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + +

+ patch " + + + + " +

+ + + +

+ comment " + + " +

+ + + + +

+ by + + + + + on + + + +

+ + + + + + + + + + + + ?c=annotate&p=&ch=&o= + + + + + + + + diff --git a/contrib/cgi/xslt/browse.xslt b/contrib/cgi/xslt/browse.xslt new file mode 100644 --- /dev/null +++ b/contrib/cgi/xslt/browse.xslt @@ -0,0 +1,110 @@ + + + + + + + +

+ files in projects / +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ name + (rev) + + modified + (rev) +
+ + + + + + + + + + + + + annotate + + + patches + + + + + + + + + + + + + annotate + patches + + + + + diff --git a/contrib/cgi/xslt/common.xslt b/contrib/cgi/xslt/common.xslt new file mode 100644 --- /dev/null +++ b/contrib/cgi/xslt/common.xslt @@ -0,0 +1,66 @@ + + + + / + + + + + + + + darcs repository + + + + + + + +
+

+ + + rss + + + darcs.cgi + v1.0 + +

+
+ + + + + + + + + + / + + + + + + + diff --git a/contrib/cgi/xslt/errors.xml b/contrib/cgi/xslt/errors.xml new file mode 100644 --- /dev/null +++ b/contrib/cgi/xslt/errors.xml @@ -0,0 +1,22 @@ + + + +

Invalid command

+ +

+ The requested command is invalid. +

+ + + +

Invalid repository

+ +

+ The requested repository does not exist on this server. +

+ + diff --git a/contrib/cgi/xslt/errors.xslt b/contrib/cgi/xslt/errors.xslt new file mode 100644 --- /dev/null +++ b/contrib/cgi/xslt/errors.xslt @@ -0,0 +1,36 @@ + + + + + + + + + <xsl:value-of select="@title"/> + + + + + + + + + + + + + diff --git a/contrib/cgi/xslt/patches.xslt b/contrib/cgi/xslt/patches.xslt new file mode 100644 --- /dev/null +++ b/contrib/cgi/xslt/patches.xslt @@ -0,0 +1,125 @@ + + + + + + + + +

+ patches applied to projects / +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ name + (rev) + + date + (rev) + + author + (rev) + +
+ + + + + + + + + + + + + + ?c=annotate&p= + + &ch= + &o= + + + + + + + + + + detail + + + + + + + + + + diff --git a/contrib/cgi/xslt/repos.xslt b/contrib/cgi/xslt/repos.xslt new file mode 100644 --- /dev/null +++ b/contrib/cgi/xslt/repos.xslt @@ -0,0 +1,59 @@ + + + + + + / + + + + + + darcs repository viewer + + + + +

Available Repositories

+ + + +
+ + + + + + + + + + + + + + + + + + + + + + + diff --git a/contrib/cgi/xslt/rss.xslt b/contrib/cgi/xslt/rss.xslt new file mode 100644 --- /dev/null +++ b/contrib/cgi/xslt/rss.xslt @@ -0,0 +1,92 @@ + + + + + + + + + / + + + + + + changes to <xsl:value-of select="$repo"/> + + + Recent patches applied to the darcs repository named + "". + + + + + + + + + + + + + + + + + + ?c=annotate&p= + + &ch= + &o= + + + + + + + 0 + + + + + + + + + + + + + <xsl:value-of select="name"/> + + + + + + + + + + + + + diff --git a/contrib/cgi/xslt/styles.css b/contrib/cgi/xslt/styles.css new file mode 100644 --- /dev/null +++ b/contrib/cgi/xslt/styles.css @@ -0,0 +1,91 @@ +/** + stylesheet for darcs repository browser +**/ + +a:link, a:visited { + color: blue; + text-decoration: none; +} + +a:hover { text-decoration: underline; } +a.sort { color: black; } +a.revsort { + color: black; + font-size: 75%; +} +a.home { color: #9292C9; } + +body { margin: 10px 10px 10px 10px; } + +h1.target { + font-size: 150%; + font-weight: bold; +} + +h2.patch { + font-size: 125%; + font-weight: bold; + margin-top: -10px; + padding-left: 10px; +} + +h2.author { + font-size: smaller; + margin-top: -10px; + font-weight: bold; + padding-left: 30px; +} + +input.patches { margin-right: 20px; } +label.tag { margin-right: 5px; } + +span.path, span.path > a { color: #2A2A6B; } + +span.version { + color: #9292C9; + margin-left: 75px; +} + +span.comment { + color: #2A2A6B; + white-space: pre; +} + +th,td { + text-align: left; + padding: 5px 10px 5px 10px; +} + +tr.annotate { background-color: #FFAAAA; } +tr.browse { background-color: #FFFF99; } +tr.patches { background-color: #AAFFAA; } +tr.directory { background-color: #CFCFCF; } +tr.file, tr.patch, tr.modified-file { background-color: #DCDCDA; } +tr.modified-file, tr.add-remove-file { background-color: #DCDCDA; } + +pre { + margin: 0 0 0 0; +} + +a.added-line { + color: #00AA00; + float: left; +} + +a.normal-line { + color: #000000; + float: left; +} + +a.removed-line { + color: #CC0000; + float: left; + text-decoration: line-through; +} + +a.removed-by { + clear: right; + color: #CC0000; + float: right; + font-size: 125%; +} diff --git a/contrib/cygwin-wrapper.bash b/contrib/cygwin-wrapper.bash new file mode 100644 --- /dev/null +++ b/contrib/cygwin-wrapper.bash @@ -0,0 +1,263 @@ +#! /bin/bash + +DIRNAME=`dirname "${0}"` +if [ "${DIRNAME:0:1}" = "/" ] ; then + DARCSPACKAGEDIR="${DIRNAME}" +else + DARCSPACKAGEDIR="${PWD}/${DIRNAME}" +fi + +# If the DARCSPACKAGEDIR assignment above doesn't work for some funny reason, +# you could set these variables by hand. Or fix the script to work +# automatically and submit a patch. + +# Should be set to the full Cygwin path to the directory containing the +# putty executables. +putty_binary_dir="${DARCSPACKAGEDIR}" +# Should be set to the full Cygwin path to the directory containing the +# Windows binary "darcs.exe". +darcs_binary_dir="$putty_binary_dir" +# Should be set to the full Cygwin path to the Windows binary +# "darcs.exe". +darcs_binary="${darcs_binary_dir}/realdarcs.exe" + +#--------------------------------------------------------------------- +# Darcs Wrapper for Cygwin +# +# A Bash script that allows Cywin paths on the command line when using +# a version of Darcs compiled for Windows. Darcs will still use still +# Windows paths internally. +# +#--------------------------------------------------------------------- +# Usage +# +# Edit this file and set the variables above. Then, rename this +# script to "darcs" and put it in your PATH somewhere before the +# original binary. +# +# Darcs needs to launch itself for some operations and so the original +# binary needs to be in your Windows PATH. Do not rename it. +# +#--------------------------------------------------------------------- +# Known Issues +# +# This script is just a stopgap measure. Things don't work perfectly. +# We really need a Cygwin build of Darcs. +# +# No path conversion is performed on: +# - Any preferences set with "setpref" +# - The "COMMAND" argument to "darcs trackdown" +# +# When Darcs launches external programs, it uses a Windows system call +# to do so. This means you may not be able to run "hash bang" scripts +# directly. For example, to run the Bash script "myscript", you'll +# have to tell Darcs to run "bash myscript". +# +# -------------------------------------------------------------------- + + +PATH="$putty_binary_dir:$darcs_binary_dir:${PATH}" + +debug=false + +cmd="$1" + +# Print each argument to stderr on a separate line. Then exit. +function die() { + local line + for line in "$@"; do + echo "$line" > /dev/stderr + done + exit 2 +} + +# Make sure 'darcs_binary_dir' is set. +if [ ! -d "$darcs_binary_dir" ]; then + die "Please edit this script and set the 'darcs_binary_dir' variable" \ + "to refer to a valid directory." \ + " script path = '$0'" \ + " darcs_binary_dir = '$darcs_binary_dir'" +fi + +# Special case for when the first argument is an option. +if expr match "$cmd" '-' > /dev/null; then + if $debug; then + # echo "SIMPLE CASE:" + for arg in "$@"; do + echo " arg = '$arg'" + done + else + # echo about to exec -a darcs "$darcs_binary" "$@" + exec -a darcs "$darcs_binary" "$@" + fi +fi + +# Shift off the darcs command name +shift + +function is_opaque_opt() { + local opt + for opt in "${opaque_binary_opts[@]}"; do + if [ "$opt" == "$1" ]; then + return 0 + fi + done + return 1 +} + +function is_file_opt() { + local opt + for opt in "${file_binary_opts[@]}"; do + if [ "$opt" == "$1" ]; then + return 0 + fi + done + return 1 +} + +# Options are not dealt with in a command-specific way. AFAIK, Darcs +# doesn't use the same option in two different ways, so we should be +# fine. + +# List of "opaque" binary options. These are options where we don't +# treat the option argument like a file. +declare -a opaque_binary_opts=( \ + '--repo-name' \ + '--to-match' '--to-patch' '--to-tag' \ + '--from-match' '--from-patch' '--from-tag' \ + '-t' '--tag' '--tags' '--tag-name' \ + '-p' '--patch' '--patches' \ + '-m' '--patch-name' \ + '--matches' '--match' \ + '--token-chars' \ + '-A' '--author' '--from' '--to' '--cc' \ + '--sign-as' '--creator-hash' \ + '--last' '--diff-opts' \ + '-d' '--dist-name' \ + '--log-file' \ + '--apply-as' \ + ) + +# List of binary options that take file arguments that need to be converted. +declare -a file_binary_opts=( \ + '--repodir' '--repo' '--sibling' \ + '--context' \ + '--logfile' '-o' '--output' \ + '--external-merge' \ + '--sign-ssl' '--verify' '--verify-ssl' \ + ) + +# -------------------------------------------------------------------- +# The three command categories. We only use the first one, but the +# others are listed to make sure we've covered everything. Luckily, +# there aren't any commands that have some args that need to be +# converted and some that don't. + +# Commands whose arguments are file paths that need to be translated. +cmds_convert_nonoption_args='|get|put|pull|push|send|apply' + +# Commands who's arguments should be left alone. File paths that +# refer to files in the repo should NOT be converted because they +# are relative paths, which Darcs will handle just fine. Cygwin +# sometimes makes them absolute paths, which confuses Darcs. +#cmds_no_convert_nonoption_paths='|add|remove|mv|replace|record|whatsnew|changes|setpref|trackdown|amend-record|revert|diff|annotate' + +# Commands that don't accept non-option arguments +#cmds_no_nonoption_args='|initialize|tag|check|optimize|rollback|unrecord|unpull|resolve|dist|repair' + +# See if we need to convert the non-option args for the current +# command. This matches some prefix of one of the commands in the +# list. The match may not be unambiguous, we can rely on Darcs to +# deal with that correctly. +if expr match "$cmds_convert_nonoption_args" ".*|$cmd" > /dev/null; then + convert_nonoption_args=true +else + convert_nonoption_args=false +fi + +function convert_path() { + # echo "converting path ${*} ..." >> /tmp/log + if expr match "$1" '[-@._A-Za-z0-9]*:' > /dev/null; then + # Some sort of URL or remote ssh pathname ("xxx:/") + echo "$1" + # echo "converting path ${*} ... to ${1}" >> /tmp/log + elif [ "$1" == '.' ]; then + # Compensate for stupid 'cygpath' behavior. + echo '.' + # echo "converting path ${*} ... to ." >> /tmp/log + else + cygpath -wl -- "$1" + # echo "converting path ${*} ... to `cygpath -wl -- ${1}`" >> /tmp/log + fi +} + +declare -a params=("$cmd") + +num_nonoption_args=0 + +while [ $# -gt 0 ]; do + arg=$1 + shift + if expr match "$arg" '-' > /dev/null; then + # It's an option. Check to see if it's an opaque binary option. + + if expr match "$arg" '.*=' > /dev/null; then + # The option has an '=' in it. + opt=`expr match "$arg" '\([^=]*\)'` + opt_arg=`expr match "$arg" '[^=]*=\(.*\)'` + if is_opaque_opt "$opt"; then + true; + elif is_file_opt "$opt"; then + opt_arg=`convert_path "$opt_arg"` + else + die "darcs-wrapper: I don't think '$opt' accepts an argument." \ + "[ If it does, then there is a bug in the wrapper script. ]" + fi + params[${#params[*]}]="$opt=$opt_arg" + + else + # The option doesn't have an '=' + opt="$arg" + if is_opaque_opt "$opt"; then + if [ $# -eq 0 ]; then + die "darcs-wrapper: I think '$arg' requires an argument." \ + "[ If it doesn't, then there is a bug in the wrapper script. ]" + fi + opt_arg="$1" + shift + params[${#params[*]}]="$opt" + params[${#params[*]}]="$opt_arg" + elif is_file_opt "$opt"; then + if [ $# -eq 0 ]; then + die "darcs-wrapper: I think '$arg' requires an argument." \ + "[ If it doesn't, then there is a bug in the wrapper script. ]" + fi + opt_arg=`convert_path "$1"` + shift + params[${#params[*]}]="$opt" + params[${#params[*]}]="$opt_arg" + else + params[${#params[*]}]="$opt" + fi + fi + + else + if $convert_nonoption_args; then + arg=`convert_path "$arg"` + fi + params[${#params[*]}]="$arg" + (( num_nonoption_args += 1 )) + fi +done + +# DEBUG +if $debug; then + echo "ARGS:" + for arg in "${params[@]}"; do + echo " arg = '$arg'" + done +else + # echo about to exec -a darcs "$darcs_binary" "${params[@]}" + exec -a darcs "$darcs_binary" "${params[@]}" +fi + diff --git a/contrib/darcs_completion b/contrib/darcs_completion new file mode 100644 --- /dev/null +++ b/contrib/darcs_completion @@ -0,0 +1,52 @@ +#-*- mode: shell-script;-*- + +# darcs command line completion. +# Copyright 2002 "David Roundy" +# +have darcs && +_darcs() +{ + local cur + cur=${COMP_WORDS[COMP_CWORD]} + + COMPREPLY=() + + if (($COMP_CWORD == 1)); then + COMPREPLY=( $( darcs --commands | grep "^$cur" ) ) + return 0 + fi + + local IFS=$'\n' # So that the following "command-output to array" operation splits only at newlines, not at each space, tab or newline. + COMPREPLY=( $( darcs ${COMP_WORDS[1]} --list-option | grep "^${cur//./\\.}") ) + + # Then, we adapt the resulting strings to be reusable by bash. If we don't + # do this, in the case where we have two repositories named + # ~/space in there-0.1 and ~/space in there-0.2, the first completion will + # give us: + # bash> darcs push ~/space in there-0. + # ~/space in there-0.1 ~/space in there-0.2 + # and we have introduced two spaces in the command line (if we try to + # recomplete that, it won't find anything, as it doesn't know anything + # starting with "there-0."). + # printf %q will gracefully add the necessary backslashes. + # + # Bash also interprets colon as a separator. If we didn't handle it + # specially, completing http://example.org/repo from http://e would + # give us: + # bash> darcs pull http:http://example.org/repo + # An option would be to require the user to escape : as \: and we + # would do the same here. Instead, we return only the part after + # the last colon that is already there, and thus fool bash. The + # downside is that bash only shows this part to the user. + local i=${#COMPREPLY[*]} + local colonprefixes=${cur%"${cur##*:}"} + while [ $((--i)) -ge 0 ]; do + COMPREPLY[$i]=`printf %q "${COMPREPLY[$i]}"` + + COMPREPLY[$i]=${COMPREPLY[$i]#"$colonprefixes"} + done + return 0 + +} +[ "$have" ] && complete -F _darcs -o default darcs + diff --git a/contrib/update_roundup.pl b/contrib/update_roundup.pl new file mode 100644 --- /dev/null +++ b/contrib/update_roundup.pl @@ -0,0 +1,78 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +# A script to update the status of an issue in a Roundup bug tracker +# based on the format of a darcs patch name. +# It is intended to be run from a darcs posthook. + +# The format we look for is: +# resolved issue123 +# in the first line of the patch. + +use Getopt::Long; + +use MIME::Lite; +use XML::Simple; + +unless ($ENV{DARCS_PATCHES_XML}) { + die "DARCS_PATCHES_XML was expected to be set in the environment, but was not found. + Are you running this from a Darcs 2.0 or newer posthook?" +} + +my $xml = eval { XMLin($ENV{DARCS_PATCHES_XML}); }; +die "hmmm.. we couldn't parse your XML. The error was: $@" if $@; + +# $xml structure returned looks like this: +# 'patch' => { +# 'resolved issue123: adding t.t' => { +# 'hash' => '20080215033723-20bb4-54f935f89817985a3e98f3de8e8ac9dad5e8e0e5.gz', +# 'inverted' => 'False', +# 'date' => '20080215033723', +# 'author' => 'Mark Stosberg ', +# 'local_date' => 'Thu Feb 14 22:37:23 EST 2008' +# }, +# 'some other patch' => { ... }, + +for my $patch_name (keys %{ $xml->{patch} }) { + my $issue_re = qr/resolved? \s+ (issue\d+)/msxi; + + next unless ($patch_name =~ $issue_re); + my $issue = $1; + my $patch = $xml->{patch}{$patch_name}; + + # Using the Command Line would be a simpler alternative. + # my $out = `roundup-admin -i /var/lib/roundup/trackers/darcs set $issue status=resolved`; + # warn "unexpected output: $out" if $out; + + my $author = $patch->{author}; + # If the Author name contains an @ sign, we take it to be an e-mail address. + # Otherwise, we default to darcs-devel as the sender. + my $email = ($author =~ m/\@/) ? $author : 'darcs-devel@darcs.net'; + + my $comment = $patch->{comment} ? "\n$patch->{comment}" : ''; + + my $patch_name_minus_status = $patch_name; + $patch_name_minus_status =~ s/$issue_re(:?\s?)//; + + # Each patches can potentially update the status of a different issue, so generates a different e-mail + my $msg = MIME::Lite->new( + From => $email, + To =>'bugs@darcs.net', + #To =>'mark@stosberg.com', + Subject =>"[$issue] [status=resolved]", + Type =>'text/plain', + Data => qq!The following patch updated the status of $issue to be resolved: + +* $patch_name $comment + +! + ); + $msg->send; + # An alternative to actually sending, for debugging. + # use File::Slurp; + # write_file("msg-$patch->{hash}.out",$msg->as_string); +} + + diff --git a/contrib/upload.cgi b/contrib/upload.cgi new file mode 100644 --- /dev/null +++ b/contrib/upload.cgi @@ -0,0 +1,126 @@ +#!/usr/bin/perl + +use strict; +use File::Temp qw/ tempdir tempfile /; + +# this is a sample cgi script to accept darcs patches via POST +# it simply takes patches and sends them using sendmail or +# places them in a Maildir style mailbox. + +my $tmp_dir; # temporary directory, when placing patches to maildir + # files are linked from $tmp_dir to $maildir +$tmp_dir = "/tmp"; + +# target email addresses--leave blank to use To: header in patch contents. +my $target_email; + +# target repository for patch testing. Leave blank to use DarcsURL header +# in patch contents. +my $target_repo; + +my $sendmail_cmd; # command to send patches with +$sendmail_cmd = "/usr/sbin/sendmail -i -t $target_email"; + +my $maildir; # maildir to put patches to, replace sendmail +#$maildir = "/tmp/maildir"; + +my $patch_test_cmd; # command to test patches with +$patch_test_cmd = "darcs apply --dry-run --repodir 'TARGETREPO' 'TARGETPATCH'"; + +my $repo_get_cmd; # command to get testing repo + # used only when $target_repo is blank +$repo_get_cmd = "darcs get --lazy --repodir 'TARGETDIR' 'TARGETREPO'"; + + +sub error_page { + my ($m) = @_; + print "Status: 500 Error accepting patch\n"; + print "Content-Type: text/plain\n\n"; + print($m || "There was an error processing your request"); + print "\n"; + exit 0; +} + +sub success_page { + print "Content-Type: text/plain\n\n"; + print "Thank you for your contribution!\n"; + exit 0; +} + + +if ($ENV{CONTENT_TYPE} eq 'message/rfc822') { + my $m = start_message() or error_page("could not create temporary file"); + my $fh = $m->{fh}; + my ($totalbytes, $bytesread, $buffer); + do { + $bytesread = read(STDIN, $buffer, 1024); + print $fh $buffer; + $totalbytes += $bytesread; + } while ($bytesread); + my $r = end_message($m); + $r ? error_page($r) : success_page(); +} elsif ($ENV{CONTENT_TYPE}) { + error_page("invalid content type, I expect something of message/rfc822"); +} else { + error_page("This url is for accepting darcs patches."); +} + + + +sub maildir_file { + my ($tmp_file) = @_; + my $base_name = sprintf("patch-%d-%d-0000", $$, time()); + my $count = 0; + until (link("$tmp_file", "$maildir/$base_name")) { + $base_name =~ s/-(\d+)$/"-" . (1 + $1)/e; + return undef if $count++ > 100; + } + return "$maildir/$base_name"; +} + +sub start_message { + my ($fh, $fname) = tempfile("$tmp_dir/dpatch".'X'x8, UNLINK => 1) or + return undef; + return { fh => $fh, filename => $fname }; +} + +sub end_message { + my ($m) = @_; + close $m->{fh} or return "$!: $m->{filename} - Could not close filehandle"; + + unless ($target_repo) { + # Look for DarcsURL header + my $darcsurl; + open(MF,$m->{filename}) or return "$!: $m->{filename} - Could not open file"; + while () { + if (/^DarcsURL: (.+)$/) { + $darcsurl = $1; + last; + } + } + close(MF); + return "Could not find DarcsURL header" unless $darcsurl; + + my $test_dir = tempdir(CLEANUP => 1).'/repo' or + return "$!: Could not create test directory"; + $repo_get_cmd =~ s/TARGETDIR/$test_dir/; + $repo_get_cmd =~ s/TARGETREPO/$darcsurl/; + system("$repo_get_cmd >/dev/null 2>/dev/null") == 0 or + return "Could not get target repo: '$repo_get_cmd' failed"; + $target_repo = $test_dir; + } + $patch_test_cmd =~ s/TARGETREPO/$target_repo/; + $patch_test_cmd =~ s/TARGETPATCH/$m->{filename}/; + system("$patch_test_cmd >/dev/null 2>/dev/null") == 0 or + return "Patch is not valid: '$patch_test_cmd' failed"; + + if ($maildir) { + maildir_file("$m->{filename}") or + return "$!: Could not create a new file in maildir"; + } else { + system("$sendmail_cmd < '$m->{filename}'") == 0 or + return "$!: Could not send mail"; + } + + return 0; +} diff --git a/darcs-beta.cabal b/darcs-beta.cabal new file mode 100644 --- /dev/null +++ b/darcs-beta.cabal @@ -0,0 +1,648 @@ +Name: darcs-beta +version: 2.2.98.1 +License: GPL +License-file: COPYING +Author: David Roundy , +Maintainer: + +Stability: Experimental +Category: Development +Synopsis: a distributed, interactive, smart revision control system +Description: Darcs is a free, open source revision control + system. It is: + . + * Distributed: Every user has access to the full + command set, removing boundaries between server and + client or committer and non-committers. + . + * Interactive: Darcs is easy to learn and efficient to + use because it asks you questions in response to + simple commands, giving you choices in your work + flow. You can choose to record one change in a file, + while ignoring another. As you update from upstream, + you can review each patch name, even the full "diff" + for interesting patches. + . + * Smart: Originally developed by physicist David + Roundy, darcs is based on a unique algebra of + patches. + . + This smartness lets you respond to changing demands + in ways that would otherwise not be possible. Learn + more about spontaneous branches with darcs. +Homepage: http://darcs.net/ + +Build-Type: Custom +Cabal-Version: >= 1.6 +Tested-with: GHC==6.8.2 + +extra-source-files: + -- C headers + src/*.h src/Crypt/sha2.h + src/win32/send_email.h src/win32/sys/mman.h + + -- TODO: factor out these standalone executables to other sections + src/preproc.hs, src/unit.lhs, + + -- The contrib directory would make a sensible 'darcs-contrib' package + contrib/_darcs.zsh, contrib/darcs_completion, + contrib/cygwin-wrapper.bash, contrib/update_roundup.pl, contrib/upload.cgi, + contrib/cgi/darcs.cgi.in, contrib/cgi/cgi.conf.in, contrib/cgi/README.in + contrib/cgi/xslt/*.xslt, contrib/cgi/xslt/*.xml, contrib/cgi/xslt/*.css, + + -- documentation files + src/best_practices.tex, src/building_darcs.tex, src/configuring_darcs.tex, + src/features.tex, src/gpl.tex, src/switching.tex, + contrib/cgi/README.in + + README + + -- release data + release/distributed-version, release/distributed-context + + -- testsuite + Distribution/ShellHarness.hs + tests/repos/*.tgz tests/repos/README + tests/*.sh + tests/network/*.sh + tests/lib + tests/example_binary.png + bugs/*.sh + +source-repository head + type: darcs + location: http://darcs.net/ + +flag curl + description: Use libcurl for HTTP support. + +flag curl-pipelining + description: Use libcurl's HTTP pipelining. + default: False + --TODO: needs Cabal ticket #342 to allow default True + -- and decide on this automatically + +flag http + description: Use the pure Haskell HTTP package for HTTP support. + +-- SUNSET: this should be mandatory after the 2009-07 release is out +flag bytestring + description: Use the external bytestring package. + +flag zlib + description: Use the external zlib binding package. + default: True + +-- SUNSET: this should be mandatory after the 2009-07 release is out +flag utf8-string + description: Use the external utf8-string binding package. + +flag terminfo + description: Use the terminfo package for enhanced console support. + +flag type-witnesses + description: Use GADT type witnesses. + default: False + +flag color + description: Use ansi color escapes. + +flag mmap + description: Compile with mmap support. + +flag base3 + +flag test + description: Compile unit tests (requires QuickCheck >= 2.1.0.0). + default: False + +Executable witnesses + main-is: witnesses.hs + hs-source-dirs: src + include-dirs: src + cpp-options: -DGADT_WITNESSES=1 + -- FIXME... + c-sources: src/atomic_create.c + src/fpstring.c + src/c_compat.c + src/maybe_relink.c + src/umask.c + src/Crypt/sha2.c + if !flag(type-witnesses) + buildable: False + + if !flag(zlib) + extra-libraries: z + + if os(windows) + hs-source-dirs: src/win32 + include-dirs: src/win32 + other-modules: CtrlC + System.Posix + System.Posix.Files + System.Posix.IO + cpp-options: -DWIN32 + c-sources: src/win32/send_email.c + +-- ---------------------------------------------------------------------- +-- darcs library +-- ---------------------------------------------------------------------- + +Library + hs-source-dirs: src + include-dirs: src + + exposed-modules: CommandLine + Crypt.SHA256 + Darcs.ArgumentDefaults + Darcs.Arguments + Darcs.Bug + Darcs.CheckFileSystem + Darcs.ColorPrinter + Darcs.Commands + Darcs.Commands.Add + Darcs.Commands.AmendRecord + Darcs.Commands.Annotate + Darcs.Commands.Apply + Darcs.CommandsAux + Darcs.Commands.Changes + Darcs.Commands.Check + Darcs.Commands.Convert + Darcs.Commands.Diff + Darcs.Commands.Dist + Darcs.Commands.Get + Darcs.Commands.GZCRCs + Darcs.Commands.Help + Darcs.Commands.Init + Darcs.Commands.MarkConflicts + Darcs.Commands.Move + Darcs.Commands.Optimize + Darcs.Commands.Pull + Darcs.Commands.Push + Darcs.Commands.Put + Darcs.Commands.Record + Darcs.Commands.Remove + Darcs.Commands.Repair + Darcs.Commands.Replace + Darcs.Commands.Revert + Darcs.Commands.Rollback + Darcs.Commands.Send + Darcs.Commands.SetPref + Darcs.Commands.Show + Darcs.Commands.ShowAuthors + Darcs.Commands.ShowBug + Darcs.Commands.ShowContents + Darcs.Commands.ShowFiles + Darcs.Commands.ShowIndex + Darcs.Commands.ShowRepo + Darcs.Commands.ShowTags + Darcs.Commands.Tag + Darcs.Commands.TrackDown + Darcs.Commands.TransferMode + Darcs.Commands.Unrecord + Darcs.Commands.Unrevert + Darcs.Commands.WhatsNew + Darcs.Compat + Darcs.Diff + Darcs.Email + Darcs.External + Darcs.FilePathMonad + Darcs.Flags + Darcs.Global + Darcs.Gorsvet + Darcs.Hopefully + Darcs.IO + Darcs.Lock + Darcs.Match + Darcs.Ordered + Darcs.Patch + Darcs.Patch.Apply + Darcs.Patch.Bundle + Darcs.Patch.Check + Darcs.Patch.Choices + Darcs.Patch.Commute + Darcs.Patch.Core + Darcs.Patch.Depends + Darcs.Patch.FileName + Darcs.Patch.Info + Darcs.Patch.Match + Darcs.Patch.MatchData + Darcs.Patch.Non + Darcs.Patch.Patchy + Darcs.Patch.Permutations + Darcs.Patch.Prim + Darcs.Patch.Properties + Darcs.Patch.Read + Darcs.Patch.ReadMonads + Darcs.Patch.Real + Darcs.Patch.Set + Darcs.Patch.Show + Darcs.Patch.TouchesFiles + Darcs.Patch.Viewing + Darcs.Population + Darcs.PopulationData + Darcs.PrintPatch + Darcs.ProgressPatches + Darcs.RemoteApply + Darcs.RepoPath + Darcs.Repository + Darcs.Repository.ApplyPatches + Darcs.Repository.Cache + Darcs.Repository.Checkpoint + Darcs.Repository.DarcsRepo + Darcs.Repository.Format + Darcs.Repository.HashedIO + Darcs.Repository.HashedRepo + Darcs.Repository.Internal + Darcs.Repository.InternalTypes + Darcs.Repository.Motd + Darcs.Repository.Prefs + Darcs.Repository.Pristine + Darcs.Repository.Repair + Darcs.Resolution + Darcs.RunCommand + Darcs.Sealed + Darcs.SelectChanges + Darcs.Show + Darcs.SignalHandler + Darcs.SlurpDirectory + Darcs.SlurpDirectory.Internal + Darcs.Test + Darcs.TheCommands + Darcs.URL + Darcs.Utils + DateMatcher + English + Exec + ByteStringUtils + HTTP + IsoDate + Lcs + OldDate + Printer + Progress + RegChars + SHA1 + Ssh + URL + UTF8 + Workaround + + other-modules: ThisVersion + + c-sources: src/atomic_create.c + src/fpstring.c + src/c_compat.c + src/maybe_relink.c + src/umask.c + src/Crypt/sha2.c + cc-options: -D_REENTRANT + + if os(windows) + hs-source-dirs: src/win32 + include-dirs: src/win32 + other-modules: CtrlC + System.Posix + System.Posix.Files + System.Posix.IO + cpp-options: -DWIN32 + + if os(solaris) + cc-options: -DHAVE_SIGINFO_H + + build-depends: base < 4, + regex-compat >= 0.71 && < 0.94, + mtl >= 1.0 && < 1.2, + parsec >= 2.0 && < 3.1, + html == 1.0.*, + filepath == 1.1.*, + haskeline >= 0.6.1 && < 0.7, + hashed-storage >= 0.3.3.1 && < 0.4 + + if !os(windows) + build-depends: unix >= 1.0 && < 2.4 + + if flag(base3) + build-depends: base >= 3, + old-time == 1.0.*, + directory == 1.0.*, + process == 1.0.*, + containers >= 0.1 && < 0.3, + array >= 0.1 && < 0.3, + random == 1.0.* + else + build-depends: base < 3 + + -- We need optimizations, regardless of what Hackage says + ghc-options: -Wall -O2 -funbox-strict-fields + ghc-prof-options: -prof -auto-all + + if flag(curl) + extra-libraries: curl + includes: curl/curl.h + cpp-options: -DHAVE_CURL + c-sources: src/hscurl.c + cc-options: -DHAVE_CURL + + if flag(curl-pipelining) + -- curl 7.19.1 has bug-free pipelining + if !os(windows) + pkgconfig-depends: libcurl >= 7.19.1 + cpp-options: -DCURL_PIPELINING -DCURL_PIPELINING_DEFAULT + + if flag(http) + build-depends: network == 2.2.*, + HTTP >= 3000.0 && < 3001.2 + cpp-options: -DHAVE_HTTP + x-have-http: + + if !flag(curl) && !flag(http) + buildable: False + + if flag(mmap) && !os(windows) + build-depends: mmap >= 0.2 + cpp-options: -DHAVE_MMAP + + if flag(bytestring) + build-depends: bytestring >= 0.9.0 && < 0.10 + cpp-options: -DHAVE_BYTESTRING + + if flag(zlib) + build-depends: zlib >= 0.5.1.0 && < 0.6.0.0 + cpp-options: -DHAVE_HASKELL_ZLIB + else + extra-libraries: z + + if flag(utf8-string) + build-depends: utf8-string == 0.3.* + cpp-options: -DHAVE_UTF8STRING + + -- The terminfo package cannot be built on Windows. + if flag(terminfo) && !os(windows) + build-depends: terminfo == 0.3.* + cpp-options: -DHAVE_TERMINFO + + if flag(color) + x-use-color: + + extensions: + CPP, + ForeignFunctionInterface, + BangPatterns, + PatternGuards, + MagicHash, + UndecidableInstances, + DeriveDataTypeable, + GADTs, + TypeOperators, + ExistentialQuantification, + FlexibleContexts, + FlexibleInstances, + ScopedTypeVariables, + KindSignatures, + TypeSynonymInstances, + Rank2Types, + RankNTypes, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses + +-- ---------------------------------------------------------------------- +-- darcs itself +-- ---------------------------------------------------------------------- + +Executable darcs + main-is: darcs.hs + hs-source-dirs: src + include-dirs: src + c-sources: src/atomic_create.c + src/fpstring.c + src/c_compat.c + src/maybe_relink.c + src/umask.c + src/Crypt/sha2.c + + -- We need optimizations, regardless of what Hackage says + ghc-options: -Wall -O2 -funbox-strict-fields -threaded + ghc-prof-options: -prof -auto-all + + if !flag(zlib) + extra-libraries: z + + cc-options: -D_REENTRANT + + if os(windows) + hs-source-dirs: src/win32 + include-dirs: src/win32 + other-modules: CtrlC + System.Posix + System.Posix.Files + System.Posix.IO + cpp-options: -DWIN32 + c-sources: src/win32/send_email.c + + if os(solaris) + cc-options: -DHAVE_SIGINFO_H + + build-depends: base < 4, + regex-compat >= 0.71 && < 0.94, + mtl >= 1.0 && < 1.2, + parsec >= 2.0 && < 3.1, + html == 1.0.*, + filepath == 1.1.*, + haskeline >= 0.6.1 && < 0.7, + hashed-storage >= 0.3.3.1 && < 0.4 + + if !os(windows) + build-depends: unix >= 1.0 && < 2.4 + + if flag(base3) + build-depends: base >= 3, + old-time == 1.0.*, + directory == 1.0.*, + process == 1.0.*, + containers >= 0.1 && < 0.3, + array >= 0.1 && < 0.3, + random == 1.0.* + else + build-depends: base < 3 + + if flag(curl) + extra-libraries: curl + includes: curl/curl.h + cpp-options: -DHAVE_CURL + c-sources: src/hscurl.c + cc-options: -DHAVE_CURL + + if flag(curl-pipelining) + -- curl 7.19.1 has bug-free pipelining + if !os(windows) + pkgconfig-depends: libcurl >= 7.19.1 + cpp-options: -DCURL_PIPELINING -DCURL_PIPELINING_DEFAULT + + if flag(http) + build-depends: network == 2.2.*, + HTTP >= 3000.0 && < 3001.2 + cpp-options: -DHAVE_HTTP + x-have-http: + + if !flag(curl) && !flag(http) + buildable: False + + if flag(mmap) && !os(windows) + build-depends: mmap >= 0.2 + cpp-options: -DHAVE_MMAP + + if flag(bytestring) + build-depends: bytestring >= 0.9.0 && < 0.10 + cpp-options: -DHAVE_BYTESTRING + + if flag(zlib) + build-depends: zlib >= 0.5.1.0 && < 0.6.0.0 + cpp-options: -DHAVE_HASKELL_ZLIB + else + extra-libraries: z + + if flag(utf8-string) + build-depends: utf8-string == 0.3.* + cpp-options: -DHAVE_UTF8STRING + + -- The terminfo package cannot be built on Windows. + if flag(terminfo) && !os(windows) + build-depends: terminfo == 0.3.* + cpp-options: -DHAVE_TERMINFO + + if flag(color) + x-use-color: + + extensions: + CPP, + ForeignFunctionInterface, + BangPatterns, + PatternGuards, + MagicHash, + UndecidableInstances, + DeriveDataTypeable, + GADTs, + TypeOperators, + ExistentialQuantification, + FlexibleContexts, + FlexibleInstances, + ScopedTypeVariables, + KindSignatures, + TypeSynonymInstances, + Rank2Types, + RankNTypes, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses + +-- ---------------------------------------------------------------------- +-- unit test driver +-- ---------------------------------------------------------------------- + +Executable unit + main-is: unit.lhs + hs-source-dirs: src + include-dirs: src + c-sources: src/atomic_create.c + src/fpstring.c + src/c_compat.c + src/maybe_relink.c + src/umask.c + src/Crypt/sha2.c + + -- We need optimizations, regardless of what Hackage says + ghc-options: -Wall -O2 -funbox-strict-fields -threaded + ghc-prof-options: -prof -auto-all + + if !flag(test) + buildable: False + else + buildable: True + build-depends: base < 4, + regex-compat >= 0.71 && < 0.94, + mtl >= 1.0 && < 1.2, + parsec >= 2.0 && < 3.1, + html == 1.0.*, + filepath == 1.1.*, + QuickCheck >= 2.1.0.0, + HUnit >= 1.0, + test-framework >= 0.2.2, + test-framework-hunit >= 0.2.2, + test-framework-quickcheck2 >= 0.2.2 + + + if !flag(zlib) + extra-libraries: z + + cc-options: -D_REENTRANT + + if os(windows) + hs-source-dirs: src/win32 + include-dirs: src/win32 + other-modules: CtrlC + System.Posix + System.Posix.Files + System.Posix.IO + cpp-options: -DWIN32 + c-sources: src/win32/send_email.c + + if os(solaris) + cc-options: -DHAVE_SIGINFO_H + + if !os(windows) + build-depends: unix >= 1.0 && < 2.4 + + if flag(base3) + build-depends: base >= 3, + old-time == 1.0.*, + directory == 1.0.*, + process == 1.0.*, + containers >= 0.1 && < 0.3, + array >= 0.1 && < 0.3, + random == 1.0.* + else + build-depends: base < 3 + + if flag(mmap) && !os(windows) + build-depends: mmap >= 0.2 + cpp-options: -DHAVE_MMAP + + if flag(bytestring) + build-depends: bytestring >= 0.9.0 && < 0.10 + cpp-options: -DHAVE_BYTESTRING + + if flag(zlib) + build-depends: zlib >= 0.5.1.0 && < 0.6.0.0 + cpp-options: -DHAVE_HASKELL_ZLIB + else + extra-libraries: z + + -- The terminfo package cannot be built on Windows. + if flag(terminfo) && !os(windows) + build-depends: terminfo == 0.3.* + cpp-options: -DHAVE_TERMINFO + + if flag(color) + x-use-color: + + extensions: + CPP, + ForeignFunctionInterface, + BangPatterns, + PatternGuards, + MagicHash, + UndecidableInstances, + DeriveDataTypeable, + GADTs, + TypeOperators, + ExistentialQuantification, + FlexibleContexts, + FlexibleInstances, + ScopedTypeVariables, + KindSignatures, + TypeSynonymInstances, + Rank2Types, + RankNTypes, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses + OverlappingInstances diff --git a/release/distributed-context b/release/distributed-context new file mode 100644 --- /dev/null +++ b/release/distributed-context @@ -0,0 +1,1 @@ +Just "\nContext:\n\n[TAG 2.2.98.1\nPetr Rockai **20090623155657\n Ignore-this: b388b0221526b2609dec75bb733bfc4c\n] \n" diff --git a/release/distributed-version b/release/distributed-version new file mode 100644 --- /dev/null +++ b/release/distributed-version @@ -0,0 +1,1 @@ +Just 0 diff --git a/src/ByteStringUtils.hs b/src/ByteStringUtils.hs new file mode 100644 --- /dev/null +++ b/src/ByteStringUtils.hs @@ -0,0 +1,575 @@ +{-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP, ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : ByteStringUtils +-- Copyright : (c) The University of Glasgow 2001, +-- David Roundy 2003-2005 +-- License : GPL (I'm happy to also license this file BSD style but don't +-- want to bother distributing two license files with darcs. +-- +-- Maintainer : droundy@abridgegame.org +-- Stability : experimental +-- Portability : portable +-- +-- GZIp and MMap IO for ByteStrings, and miscellaneous functions for Data.ByteString +-- + +module ByteStringUtils ( + + unsafeWithInternals, + unpackPSfromUTF8, + + -- IO with mmap or gzip + gzReadFilePS, + mmapFilePS, + gzWriteFilePS, + gzWriteFilePSs, + + -- gzip handling + isGZFile, +#ifdef HAVE_HASKELL_ZLIB + gzDecompress, +#endif + + -- list utilities + ifHeadThenTail, + dropSpace, + breakSpace, + linesPS, + unlinesPS, + hashPS, + breakFirstPS, + breakLastPS, + substrPS, + readIntPS, + is_funky, + fromHex2PS, + fromPS2Hex, + betweenLinesPS, + break_after_nth_newline, + break_before_nth_newline, + intercalate + ) where + +import Prelude hiding ( catch ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Internal as BI +import Data.ByteString (intercalate, uncons) +import Data.ByteString.Internal (fromForeignPtr) + +#if defined (HAVE_MMAP) || ! defined (HAVE_HASKELL_ZLIB) +import Control.Exception ( catch ) +#endif +import System.IO +import System.IO.Unsafe ( unsafePerformIO ) + +import Foreign.Storable ( peekElemOff, peek ) +import Foreign.Marshal.Alloc ( free ) +import Foreign.Marshal.Array ( mallocArray, peekArray, advancePtr ) +import Foreign.C.Types ( CInt ) + +import Data.Bits ( rotateL ) +import Data.Char ( chr, ord, isSpace ) +import Data.Word ( Word8 ) +import Data.Int ( Int32 ) +import Control.Monad ( when ) + +#ifndef HAVE_HASKELL_ZLIB +import Foreign.Ptr ( nullPtr ) +import Foreign.ForeignPtr ( ForeignPtr ) +#endif +import Foreign.Ptr ( plusPtr, Ptr ) +import Foreign.ForeignPtr ( withForeignPtr ) + +#ifdef DEBUG_PS +import Foreign.ForeignPtr ( addForeignPtrFinalizer ) +import Foreign.Ptr ( FunPtr ) +#endif + +#if HAVE_HASKELL_ZLIB +import qualified Data.ByteString.Lazy as BL +import qualified Codec.Compression.GZip as GZ +import qualified Codec.Compression.Zlib.Internal as ZI +import Darcs.Global ( addCRCWarning ) +#else +import Foreign.C.String ( CString, withCString ) +#endif + +#ifdef HAVE_MMAP +import System.IO.MMap( mmapFileByteString ) +import System.Mem( performGC ) +import System.Posix.Files( fileSize, getSymbolicLinkStatus ) +#endif + +-- ----------------------------------------------------------------------------- +-- obsolete debugging code + +# ifndef HAVE_HASKELL_ZLIB +debugForeignPtr :: ForeignPtr a -> String -> IO () +#ifdef DEBUG_PS +foreign import ccall unsafe "static fpstring.h debug_alloc" debug_alloc + :: Ptr a -> CString -> IO () +foreign import ccall unsafe "static fpstring.h & debug_free" debug_free + :: FunPtr (Ptr a -> IO ()) +debugForeignPtr fp n = + withCString n $ \cname-> withForeignPtr fp $ \p-> + do debug_alloc p cname + addForeignPtrFinalizer debug_free fp +#else +debugForeignPtr _ _ = return () +#endif +#endif + +-- ----------------------------------------------------------------------------- +-- unsafeWithInternals + +-- | Do something with the internals of a PackedString. Beware of +-- altering the contents! +unsafeWithInternals :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a +unsafeWithInternals ps f + = case BI.toForeignPtr ps of + (fp,s,l) -> withForeignPtr fp $ \p -> f (p `plusPtr` s) l + +-- | readIntPS skips any whitespace at the beginning of its argument, and +-- reads an Int from the beginning of the PackedString. If there is no +-- integer at the beginning of the string, it returns Nothing, otherwise it +-- just returns the int read, along with a B.ByteString containing the +-- remainder of its input. + +readIntPS :: B.ByteString -> Maybe (Int, B.ByteString) +readIntPS = BC.readInt . BC.dropWhile isSpace + +-- ----------------------------------------------------------------------------- +-- Destructor functions (taking PackedStrings apart) + +unpackPSfromUTF8 :: B.ByteString -> String +unpackPSfromUTF8 ps = + case BI.toForeignPtr ps of + (_,_, 0) -> "" + (x,s,l) -> + unsafePerformIO $ withForeignPtr x $ \p-> + do outbuf <- mallocArray l + lout <- fromIntegral `fmap` + utf8_to_ints outbuf (p `plusPtr` s) (fromIntegral l) + when (lout < 0) $ error "Bad UTF8!" + str <- (map (chr . fromIntegral)) `fmap` peekArray lout outbuf + free outbuf + return str + +foreign import ccall unsafe "static fpstring.h utf8_to_ints" utf8_to_ints + :: Ptr Int -> Ptr Word8 -> CInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- List-mimicking functions for PackedStrings + +{-# INLINE ifHeadThenTail #-} +ifHeadThenTail :: Word8 -> B.ByteString -> Maybe B.ByteString +ifHeadThenTail c s = case uncons s of + Just (w, t) | w == c -> Just t + _ -> Nothing + +------------------------------------------------------------------------ +-- A reimplementation of Data.ByteString.Char8.dropSpace, but +-- specialised to darcs' need for a 4 way isspace. +-- +-- TODO: if it is safe to use the expanded definition of isSpaceWord8 +-- provided by Data.ByteString.Char8, then all this can go. + +-- A locale-independent isspace(3) so patches are interpreted the same everywhere. +-- ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) == '\r') +isSpaceWord8 :: Word8 -> Bool +isSpaceWord8 w = + w == 0x20 || -- ' ' + w == 0x09 || -- '\t' + w == 0x0A || -- '\n' + w == 0x0D -- '\r' +{-# INLINE isSpaceWord8 #-} + +firstnonspace :: Ptr Word8 -> Int -> Int -> IO Int +firstnonspace !ptr !n !m + | n >= m = return n + | otherwise = do w <- peekElemOff ptr n + if isSpaceWord8 w then firstnonspace ptr (n+1) m else return n + +firstspace :: Ptr Word8 -> Int -> Int -> IO Int +firstspace !ptr !n !m + | n >= m = return n + | otherwise = do w <- peekElemOff ptr n + if (not . isSpaceWord8) w then firstspace ptr (n+1) m else return n + +-- | 'dropSpace' efficiently returns the 'ByteString' argument with +-- white space Chars removed from the front. It is more efficient than +-- calling dropWhile for removing whitespace. I.e. +-- +-- > dropWhile isSpace == dropSpace +-- +dropSpace :: B.ByteString -> B.ByteString +dropSpace (BI.PS x s l) = BI.inlinePerformIO $ withForeignPtr x $ \p -> do + i <- firstnonspace (p `plusPtr` s) 0 l + return $! if i == l then B.empty else BI.PS x (s+i) (l-i) +{-# INLINE dropSpace #-} + +-- | 'breakSpace' returns the pair of ByteStrings when the argument is +-- broken at the first whitespace byte. I.e. +-- +-- > break isSpace == breakSpace +-- +breakSpace :: B.ByteString -> (B.ByteString,B.ByteString) +breakSpace (BI.PS x s l) = BI.inlinePerformIO $ withForeignPtr x $ \p -> do + i <- firstspace (p `plusPtr` s) 0 l + return $! case () of {_ + | i == 0 -> (B.empty, BI.PS x s l) + | i == l -> (BI.PS x s l, B.empty) + | otherwise -> (BI.PS x s i, BI.PS x (s+i) (l-i)) + } +{-# INLINE breakSpace #-} + +------------------------------------------------------------------------ + +{-# INLINE is_funky #-} +is_funky :: B.ByteString -> Bool +is_funky ps = case BI.toForeignPtr ps of + (x,s,l) -> + unsafePerformIO $ withForeignPtr x $ \p-> + (/=0) `fmap` has_funky_char (p `plusPtr` s) (fromIntegral l) + +foreign import ccall unsafe "fpstring.h has_funky_char" has_funky_char + :: Ptr Word8 -> CInt -> IO CInt + +------------------------------------------------------------------------ + +-- ByteString rewrites break (=='x') to breakByte 'x' +-- break ((==) x) = breakChar x +-- break (==x) = breakChar x +-- + +{- +{-# INLINE breakOnPS #-} +breakOnPS :: Char -> B.ByteString -> (B.ByteString, B.ByteString) +breakOnPS c p = case BC.elemIndex c p of + Nothing -> (p, BC.empty) + Just n -> (B.take n p, B.drop n p) +-} + +{-# INLINE hashPS #-} +hashPS :: B.ByteString -> Int32 +hashPS ps = + case BI.toForeignPtr ps of + (x,s,l) -> + unsafePerformIO $ withForeignPtr x $ \p-> + do hash (p `plusPtr` s) l + +hash :: Ptr Word8 -> Int -> IO Int32 +hash ptr len = f (0 :: Int32) ptr len + where f h _ 0 = return h + f h p n = do x <- peek p + let !h' = (fromIntegral x) + (rotateL h 8) + f h' (p `advancePtr` 1) (n-1) + +{-# INLINE substrPS #-} +substrPS :: B.ByteString -> B.ByteString -> Maybe Int +substrPS tok str + | B.null tok = Just 0 + | B.length tok > B.length str = Nothing + | otherwise = do n <- BC.elemIndex (BC.head tok) str + let ttok = B.tail tok + reststr = B.drop (n+1) str + if ttok == B.take (B.length ttok) reststr + then Just n + else ((n+1)+) `fmap` substrPS tok reststr + +------------------------------------------------------------------------ + +-- TODO: replace breakFirstPS and breakLastPS with definitions based on +-- ByteString's break/breakEnd +{-# INLINE breakFirstPS #-} +breakFirstPS :: Char -> B.ByteString -> Maybe (B.ByteString,B.ByteString) +breakFirstPS c p = case BC.elemIndex c p of + Nothing -> Nothing + Just n -> Just (B.take n p, B.drop (n+1) p) + +{-# INLINE breakLastPS #-} +breakLastPS :: Char -> B.ByteString -> Maybe (B.ByteString,B.ByteString) +breakLastPS c p = case BC.elemIndexEnd c p of + Nothing -> Nothing + Just n -> Just (B.take n p, B.drop (n+1) p) + +-- TODO: rename +{-# INLINE linesPS #-} +linesPS :: B.ByteString -> [B.ByteString] +linesPS ps + | B.null ps = [B.empty] + | otherwise = BC.split '\n' ps + +{- QuickCheck property: + +import Test.QuickCheck +import qualified Data.ByteString.Char8 as BC +import Data.Char +instance Arbitrary BC.ByteString where + arbitrary = fmap BC.pack arbitrary +instance Arbitrary Char where + arbitrary = chr `fmap` choose (32,127) +deepCheck = check (defaultConfig { configMaxTest = 10000}) +testLines = deepCheck (\x -> (linesPS x == linesPSOld x)) +linesPSOld ps = case BC.elemIndex '\n' ps of + Nothing -> [ps] + Just n -> B.take n ps : linesPS (B.drop (n+1) ps) -} + +{-| This function acts exactly like the "Prelude" unlines function, or like +"Data.ByteString.Char8" 'unlines', but with one important difference: it will +produce a string which may not end with a newline! That is: + +> unlinesPS ["foo", "bar"] + +evaluates to \"foo\\nbar\", not \"foo\\nbar\\n\"! This point should hold true for +'linesPS' as well. + +TODO: rename this function. -} +unlinesPS :: [B.ByteString] -> B.ByteString +unlinesPS [] = BC.empty +unlinesPS x = BC.init $ BC.unlines x +{-# INLINE unlinesPS #-} +{- QuickCheck property: + +testUnlines = deepCheck (\x -> (unlinesPS x == unlinesPSOld x)) +unlinesPSOld ss = BC.concat $ intersperse_newlines ss + where intersperse_newlines (a:b:s) = a : newline : intersperse_newlines (b:s) + intersperse_newlines s = s + newline = BC.pack "\n" -} + +-- ----------------------------------------------------------------------------- +-- gzReadFilePS + +#ifdef HAVE_HASKELL_ZLIB + +gzDecompress :: forall m . (Functor m, Monad m) => m () -> Maybe Int -> BL.ByteString -> m [B.ByteString] +gzDecompress reportBadCRC mbufsize = + -- This is what the code would be without the bad CRC recovery logic: + -- return . BL.toChunks . GZ.decompressWith decompressParams + toListWarn . ZI.decompressWithErrors ZI.GZip decompressParams + where + decompressParams = case mbufsize of + Just bufsize -> GZ.defaultDecompressParams { GZ.decompressBufferSize = bufsize } + Nothing -> GZ.defaultDecompressParams + + toListWarn :: ZI.DecompressStream -> m [B.ByteString] + toListWarn ZI.StreamEnd = return [] + toListWarn (ZI.StreamChunk x xs) = fmap (x:) (toListWarn xs) + -- For a while a bug in darcs caused gzip files with good data but bad CRCs to be + -- produced. Trap bad CRC messages, run the specified action to report that it happened, + -- but continue on the assumption that the data is valid. + toListWarn (ZI.StreamError ZI.DataError "incorrect data check") = reportBadCRC >> return [] + toListWarn (ZI.StreamError _ msg) = fail msg + +#else + +foreign import ccall unsafe "static zlib.h gzopen" c_gzopen + :: CString -> CString -> IO (Ptr ()) +foreign import ccall unsafe "static zlib.h gzclose" c_gzclose + :: Ptr () -> IO () +foreign import ccall unsafe "static zlib.h gzread" c_gzread + :: Ptr () -> Ptr Word8 -> CInt -> IO CInt +foreign import ccall unsafe "static zlib.h gzwrite" c_gzwrite + :: Ptr () -> Ptr Word8 -> CInt -> IO CInt + +#endif + +isGZFile :: FilePath -> IO (Maybe Int) +isGZFile f = do + h <- openBinaryFile f ReadMode + header <- B.hGet h 2 + if header /= BC.pack "\31\139" + then do hClose h + return Nothing + else do hSeek h SeekFromEnd (-4) + len <- hGetLittleEndInt h + hClose h + return (Just len) + +-- | Read an entire file, which may or may not be gzip compressed, directly +-- into a 'B.ByteString'. +gzReadFilePS :: FilePath -> IO B.ByteString +gzReadFilePS f = do + mlen <- isGZFile f + case mlen of + Nothing -> mmapFilePS f + Just len -> +#ifdef HAVE_HASKELL_ZLIB + -- Passing the length to gzDecompress means that it produces produces one chunk, + -- which in turn means that B.concat won't need to copy data. + -- If the length is wrong this will just affect efficiency, not correctness + fmap B.concat . (gzDecompress (addCRCWarning f) (Just len) =<<) $ +#ifdef HAVE_OLD_BYTESTRING + -- bytestring < 0.9.1 had a bug where it did not know to close handles upon EOF + -- performance would be better with a newer bytestring and lazy + -- readFile below -- ratify readFile: comment + fmap (BL.fromChunks . (:[])) $ + B.readFile f -- ratify readFile: immediately consumed +#else + BL.readFile f -- ratify readFile: immediately consumed by the conversion to a strict bytestring +#endif +#else + withCString f $ \fstr-> withCString "rb" $ \rb-> do + gzf <- c_gzopen fstr rb + when (gzf == nullPtr) $ fail $ "problem opening file "++f + fp <- BI.mallocByteString len + debugForeignPtr fp $ "gzReadFilePS "++f + lread <- withForeignPtr fp $ \p -> + c_gzread gzf p (fromIntegral len) + c_gzclose gzf + when (fromIntegral lread /= len) $ + fail $ "problem gzreading file "++f + return $ fromForeignPtr fp 0 len +#endif + +hGetLittleEndInt :: Handle -> IO Int +hGetLittleEndInt h = do + b1 <- ord `fmap` hGetChar h + b2 <- ord `fmap` hGetChar h + b3 <- ord `fmap` hGetChar h + b4 <- ord `fmap` hGetChar h + return $ b1 + 256*b2 + 65536*b3 + 16777216*b4 + +gzWriteFilePS :: FilePath -> B.ByteString -> IO () +gzWriteFilePS f ps = gzWriteFilePSs f [ps] + +gzWriteFilePSs :: FilePath -> [B.ByteString] -> IO () +gzWriteFilePSs f pss = +#ifdef HAVE_HASKELL_ZLIB + BL.writeFile f $ GZ.compress $ BL.fromChunks pss +#else + withCString f $ \fstr -> withCString "wb" $ \wb -> do + gzf <- c_gzopen fstr wb + when (gzf == nullPtr) $ fail $ "problem gzopening file for write: "++f + mapM_ (gzWriteToGzf gzf) pss `catch` + \_ -> fail $ "problem gzwriting file: "++f + c_gzclose gzf + +gzWriteToGzf :: Ptr () -> B.ByteString -> IO () +gzWriteToGzf gzf ps = case BI.toForeignPtr ps of + (_,_,0) -> return () -- avoid calling gzwrite with 0 length this would + -- trouble on some versions of zlib, and is always + -- unnecessary. + (x,s,l) -> do + lw <- withForeignPtr x $ \p -> c_gzwrite gzf (p `plusPtr` s) + (fromIntegral l) + when (fromIntegral lw /= l) $ fail $ "problem in gzWriteToGzf" +#endif + +-- ----------------------------------------------------------------------------- +-- mmapFilePS + +-- | Like readFilePS, this reads an entire file directly into a +-- 'B.ByteString', but it is even more efficient. It involves directly +-- mapping the file to memory. This has the advantage that the contents of +-- the file never need to be copied. Also, under memory pressure the page +-- may simply be discarded, wile in the case of readFilePS it would need to +-- be written to swap. If you read many small files, mmapFilePS will be +-- less memory-efficient than readFilePS, since each mmapFilePS takes up a +-- separate page of memory. Also, you can run into bus errors if the file +-- is modified. NOTE: as with 'readFilePS', the string representation in +-- the file is assumed to be ISO-8859-1. + +mmapFilePS :: FilePath -> IO B.ByteString +#ifdef HAVE_MMAP +mmapFilePS f = do + x <- mmapFileByteString f Nothing + `catch` (\_ -> do + size <- fileSize `fmap` getSymbolicLinkStatus f + if size == 0 + then return B.empty + else performGC >> mmapFileByteString f Nothing) + return x +#else +mmapFilePS = B.readFile +#endif + +-- ------------------------------------------------------------------------- +-- fromPS2Hex + +foreign import ccall unsafe "static fpstring.h conv_to_hex" conv_to_hex + :: Ptr Word8 -> Ptr Word8 -> CInt -> IO () + +fromPS2Hex :: B.ByteString -> B.ByteString +fromPS2Hex ps = case BI.toForeignPtr ps of + (x,s,l) -> + BI.unsafeCreate (2*l) $ \p -> withForeignPtr x $ \f -> + conv_to_hex p (f `plusPtr` s) $ fromIntegral l + +-- ------------------------------------------------------------------------- +-- fromHex2PS + +foreign import ccall unsafe "static fpstring.h conv_from_hex" conv_from_hex + :: Ptr Word8 -> Ptr Word8 -> CInt -> IO () + +fromHex2PS :: B.ByteString -> B.ByteString +fromHex2PS ps = case BI.toForeignPtr ps of + (x,s,l) -> + BI.unsafeCreate (l `div` 2) $ \p -> withForeignPtr x $ \f -> + conv_from_hex p (f `plusPtr` s) (fromIntegral $ l `div` 2) + +-- ------------------------------------------------------------------------- +-- betweenLinesPS + +-- | betweenLinesPS returns the B.ByteString between the two lines given, +-- or Nothing if they do not appear. + +betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString + -> Maybe (B.ByteString) +betweenLinesPS start end ps + = case break (start ==) (linesPS ps) of + (_, _:rest@(bs1:_)) -> + case BI.toForeignPtr bs1 of + (ps1,s1,_) -> + case break (end ==) rest of + (_, bs2:_) -> case BI.toForeignPtr bs2 of (_,s2,_) -> Just $ fromForeignPtr ps1 s1 (s2 - s1) + _ -> Nothing + _ -> Nothing + +-- ------------------------------------------------------------------------- +-- break_after_nth_newline + +break_after_nth_newline :: Int -> B.ByteString + -> Maybe (B.ByteString, B.ByteString) +break_after_nth_newline 0 the_ps | B.null the_ps = Just (B.empty, B.empty) +break_after_nth_newline n the_ps = + case BI.toForeignPtr the_ps of + (fp,the_s,l) -> + unsafePerformIO $ withForeignPtr fp $ \p -> + do let findit 0 s | s == end = return $ Just (the_ps, B.empty) + findit _ s | s == end = return Nothing + findit 0 s = let left_l = s - the_s + in return $ Just (fromForeignPtr fp the_s left_l, + fromForeignPtr fp s (l - left_l)) + findit i s = do w <- peekElemOff p s + if w == nl then findit (i-1) (s+1) + else findit i (s+1) + nl = BI.c2w '\n' + end = the_s + l + findit n the_s + +-- ------------------------------------------------------------------------- +-- break_before_nth_newline + +break_before_nth_newline :: Int -> B.ByteString -> (B.ByteString, B.ByteString) +break_before_nth_newline 0 the_ps + | B.null the_ps = (B.empty, B.empty) +break_before_nth_newline n the_ps = + case BI.toForeignPtr the_ps of + (fp,the_s,l) -> + unsafePerformIO $ withForeignPtr fp $ \p -> + do let findit _ s | s == end = return (the_ps, B.empty) + findit i s = do w <- peekElemOff p s + if w == nl + then if i == 0 + then let left_l = s - the_s + in return (fromForeignPtr fp the_s left_l, + fromForeignPtr fp s (l - left_l)) + else findit (i-1) (s+1) + else findit i (s+1) + nl = BI.c2w '\n' + end = the_s + l + findit n the_s diff --git a/src/CommandLine.hs b/src/CommandLine.hs new file mode 100644 --- /dev/null +++ b/src/CommandLine.hs @@ -0,0 +1,122 @@ +-- Copyright (C) 2005 Benedikt Schmidt +-- +-- 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. + +-- |A parser for commandlines, returns an arg list and expands +-- format strings given in a translation table. Additionally +-- the commandline can end with "%<" specifying that the command +-- expects input on stdin. +-- +-- Some tests for the parser. +-- +-- > formatTable = [('s',""), +-- > ('a',"")] +-- > +-- > testParser :: (Show a, Eq a) => Parser a -> String -> a -> a +-- > testParser p s ok = case parse p "" s of +-- > Left e -> error $ "Parser failed with: " ++ (show e) +-- > Right res -> if res == ok +-- > then res +-- > else error $ "Parser failed: got " +-- > ++ (show res) ++ ", expected " +-- > ++ (show ok) +-- > +-- > testCases = [("a b",(["a","b"], False)), +-- > ("a b %<",(["a","b"], True)), +-- > ("a b %< ",(["a","b"], True)), +-- > ("\"arg0 contains spaces \\\"quotes\\\"\" b", +-- > (["arg0 contains spaces \"quotes\"","b"],False)), +-- > ("a %s %<",(["a",""], True))] +-- > +-- > runTests = map (uncurry $ testParser (commandline formatTable)) testCases +module CommandLine ( parseCmd, addUrlencoded ) where +import Text.ParserCombinators.Parsec +import Data.Char ( ord, intToDigit, toUpper ) +import Data.List ( find ) + +-- | assoc list mapping characters to strings +-- eg (c,s) means that %c is replaced by s +type FTable = [(Char,String)] +commandline :: FTable -> Parser ([String], Bool) +commandline ftable = consumeAll (do l <- sepEndBy1 (arg ftable) + (try separator) + redir <- formatRedir + spaces + return (l,redir)) + +escape:: Parser String +arg, format, quotedArg, unquotedArg, quoteContent :: FTable -> Parser String +arg ftable = (quotedArg ftable <|> unquotedArg ftable) + +unquotedArg ftable = do (try $ format ftable) + <|> (many1 $ noneOf [' ', '\t', '"', '%']) + +quotedArg ftable = between (char '"') (char '"') $ quoteContent ftable + +quoteContent ftable = do s1 <- escape + <|> (try $ format ftable) + <|> (many1 (noneOf ['"', '\\', '%'])) + s2 <- quoteContent ftable + return $ s1 ++ s2 + <|> return "" + +formatRedir :: Parser Bool +formatRedir = do string "%<" + return True + <|> return False + +format ftable = do char '%' + c <- oneOf (map fst ftable) + return $ expandFormat ftable c + +escape = do char '\\' + c <- anyChar + return [c] + +consumeAll :: Parser a -> Parser a +consumeAll p = do r <- p + eof + return r + +separator :: Parser () +separator = do skipMany1 space + +expandFormat :: FTable -> Char -> String +expandFormat ftable c = case find ((==c) . fst) ftable of + Just (_,s) -> s + Nothing -> error "impossible" + +-- | parse a commandline returning a list of strings +-- (intended to be used as argv) and a bool value which +-- specifies if the command expects input on stdin +-- format specifiers with a mapping in ftable are accepted +-- and replaced by the given strings. E.g. if the ftable is +-- [('s',"Some subject")], then "%s" is replaced by "Some subject" +parseCmd :: FTable -> String -> Either ParseError ([String],Bool) +parseCmd ftable s = parse (commandline ftable) "" s + +urlEncode :: String -> String +urlEncode s = concat $ map escapeC s + where escapeC x = if allowed x then [x] else '%':(intToHex $ ord x) + intToHex i = map intToDigit [i `div` 16, i `mod` 16] + allowed x = x `elem` ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] + ++ "!'()*-.~" + +-- | for every mapping (c,s), add a mapping with uppercase c +-- and the urlencoded string s +addUrlencoded :: FTable -> FTable +addUrlencoded ftable = + ftable ++(map (\ (c,x) -> (toUpper c, urlEncode x)) ftable) diff --git a/src/Crypt/SHA256.hs b/src/Crypt/SHA256.hs new file mode 100644 --- /dev/null +++ b/src/Crypt/SHA256.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +-- | +-- Module: Data.Digest.SHA256 +-- Copyright: Zooko O'Whielacronx +-- License: GPL +-- +-- Stability: experimental + +-- ByteString-based, zero-copying binding to Crypto++'s sha interface + +-- thanks to Don Stewart , Matthew Sackman +-- , Brian O'Sullivan, lispy, Adam Langley + +module Crypt.SHA256 ( sha256sum ) where + +import Foreign +import Foreign.C.Types +import Numeric (showHex) +import Foreign.C.String ( withCString ) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import qualified Data.ByteString as B + +sha256sum :: B.ByteString -> String +sha256sum p = unsafePerformIO $ + withCString (take 64 $ repeat 'x') $ \digestCString -> + unsafeUseAsCStringLen p $ \(ptr,n) -> + do let digest = castPtr digestCString :: Ptr Word8 + c_sha256 ptr (fromIntegral n) digest + go digest 0 [] + where -- print it in 0-padded hex format + go :: Ptr Word8 -> Int -> [String] -> IO String + go q n acc | seq q n >= 32 = return $ concat (reverse acc) + | otherwise = do w <- peekElemOff q n + go q (n+1) (draw w : acc) + draw w = case showHex w [] of + [x] -> ['0', x] + x -> x + +-- void sha256sum(const unsigned char *d, size_t n, unsigned char *md); +-- +foreign import ccall unsafe "sha2.h sha256" c_sha256 + :: Ptr CChar -> CSize -> Ptr Word8 -> IO () + diff --git a/src/Crypt/sha2.c b/src/Crypt/sha2.c new file mode 100644 --- /dev/null +++ b/src/Crypt/sha2.c @@ -0,0 +1,950 @@ +/* + * FIPS 180-2 SHA-224/256/384/512 implementation + * Last update: 02/02/2007 + * Issue date: 04/30/2005 + * + * Copyright (C) 2005, 2007 Olivier Gay + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. Neither the name of the project nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#if 0 +#define UNROLL_LOOPS /* Enable loops unrolling */ +#endif + +#include + +#include "sha2.h" + +#define SHFR(x, n) (x >> n) +#define ROTR(x, n) ((x >> n) | (x << ((sizeof(x) << 3) - n))) +#define ROTL(x, n) ((x << n) | (x >> ((sizeof(x) << 3) - n))) +#define CH(x, y, z) ((x & y) ^ (~x & z)) +#define MAJ(x, y, z) ((x & y) ^ (x & z) ^ (y & z)) + +#define SHA256_F1(x) (ROTR(x, 2) ^ ROTR(x, 13) ^ ROTR(x, 22)) +#define SHA256_F2(x) (ROTR(x, 6) ^ ROTR(x, 11) ^ ROTR(x, 25)) +#define SHA256_F3(x) (ROTR(x, 7) ^ ROTR(x, 18) ^ SHFR(x, 3)) +#define SHA256_F4(x) (ROTR(x, 17) ^ ROTR(x, 19) ^ SHFR(x, 10)) + +#define SHA512_F1(x) (ROTR(x, 28) ^ ROTR(x, 34) ^ ROTR(x, 39)) +#define SHA512_F2(x) (ROTR(x, 14) ^ ROTR(x, 18) ^ ROTR(x, 41)) +#define SHA512_F3(x) (ROTR(x, 1) ^ ROTR(x, 8) ^ SHFR(x, 7)) +#define SHA512_F4(x) (ROTR(x, 19) ^ ROTR(x, 61) ^ SHFR(x, 6)) + +#define UNPACK32(x, str) \ +{ \ + *((str) + 3) = (uint8) ((x) ); \ + *((str) + 2) = (uint8) ((x) >> 8); \ + *((str) + 1) = (uint8) ((x) >> 16); \ + *((str) + 0) = (uint8) ((x) >> 24); \ +} + +#define PACK32(str, x) \ +{ \ + *(x) = ((uint32) *((str) + 3) ) \ + | ((uint32) *((str) + 2) << 8) \ + | ((uint32) *((str) + 1) << 16) \ + | ((uint32) *((str) + 0) << 24); \ +} + +#define UNPACK64(x, str) \ +{ \ + *((str) + 7) = (uint8) ((x) ); \ + *((str) + 6) = (uint8) ((x) >> 8); \ + *((str) + 5) = (uint8) ((x) >> 16); \ + *((str) + 4) = (uint8) ((x) >> 24); \ + *((str) + 3) = (uint8) ((x) >> 32); \ + *((str) + 2) = (uint8) ((x) >> 40); \ + *((str) + 1) = (uint8) ((x) >> 48); \ + *((str) + 0) = (uint8) ((x) >> 56); \ +} + +#define PACK64(str, x) \ +{ \ + *(x) = ((uint64) *((str) + 7) ) \ + | ((uint64) *((str) + 6) << 8) \ + | ((uint64) *((str) + 5) << 16) \ + | ((uint64) *((str) + 4) << 24) \ + | ((uint64) *((str) + 3) << 32) \ + | ((uint64) *((str) + 2) << 40) \ + | ((uint64) *((str) + 1) << 48) \ + | ((uint64) *((str) + 0) << 56); \ +} + +/* Macros used for loops unrolling */ + +#define SHA256_SCR(i) \ +{ \ + w[i] = SHA256_F4(w[i - 2]) + w[i - 7] \ + + SHA256_F3(w[i - 15]) + w[i - 16]; \ +} + +#define SHA512_SCR(i) \ +{ \ + w[i] = SHA512_F4(w[i - 2]) + w[i - 7] \ + + SHA512_F3(w[i - 15]) + w[i - 16]; \ +} + +#define SHA256_EXP(a, b, c, d, e, f, g, h, j) \ +{ \ + t1 = wv[h] + SHA256_F2(wv[e]) + CH(wv[e], wv[f], wv[g]) \ + + sha256_k[j] + w[j]; \ + t2 = SHA256_F1(wv[a]) + MAJ(wv[a], wv[b], wv[c]); \ + wv[d] += t1; \ + wv[h] = t1 + t2; \ +} + +#define SHA512_EXP(a, b, c, d, e, f, g ,h, j) \ +{ \ + t1 = wv[h] + SHA512_F2(wv[e]) + CH(wv[e], wv[f], wv[g]) \ + + sha512_k[j] + w[j]; \ + t2 = SHA512_F1(wv[a]) + MAJ(wv[a], wv[b], wv[c]); \ + wv[d] += t1; \ + wv[h] = t1 + t2; \ +} + +uint32 sha224_h0[8] = + {0xc1059ed8, 0x367cd507, 0x3070dd17, 0xf70e5939, + 0xffc00b31, 0x68581511, 0x64f98fa7, 0xbefa4fa4}; + +uint32 sha256_h0[8] = + {0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a, + 0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19}; + +uint64 sha384_h0[8] = + {0xcbbb9d5dc1059ed8ULL, 0x629a292a367cd507ULL, + 0x9159015a3070dd17ULL, 0x152fecd8f70e5939ULL, + 0x67332667ffc00b31ULL, 0x8eb44a8768581511ULL, + 0xdb0c2e0d64f98fa7ULL, 0x47b5481dbefa4fa4ULL}; + +uint64 sha512_h0[8] = + {0x6a09e667f3bcc908ULL, 0xbb67ae8584caa73bULL, + 0x3c6ef372fe94f82bULL, 0xa54ff53a5f1d36f1ULL, + 0x510e527fade682d1ULL, 0x9b05688c2b3e6c1fULL, + 0x1f83d9abfb41bd6bULL, 0x5be0cd19137e2179ULL}; + +uint32 sha256_k[64] = + {0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5, + 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5, + 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3, + 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174, + 0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc, + 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da, + 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7, + 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967, + 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13, + 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85, + 0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3, + 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070, + 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5, + 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3, + 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208, + 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2}; + +uint64 sha512_k[80] = + {0x428a2f98d728ae22ULL, 0x7137449123ef65cdULL, + 0xb5c0fbcfec4d3b2fULL, 0xe9b5dba58189dbbcULL, + 0x3956c25bf348b538ULL, 0x59f111f1b605d019ULL, + 0x923f82a4af194f9bULL, 0xab1c5ed5da6d8118ULL, + 0xd807aa98a3030242ULL, 0x12835b0145706fbeULL, + 0x243185be4ee4b28cULL, 0x550c7dc3d5ffb4e2ULL, + 0x72be5d74f27b896fULL, 0x80deb1fe3b1696b1ULL, + 0x9bdc06a725c71235ULL, 0xc19bf174cf692694ULL, + 0xe49b69c19ef14ad2ULL, 0xefbe4786384f25e3ULL, + 0x0fc19dc68b8cd5b5ULL, 0x240ca1cc77ac9c65ULL, + 0x2de92c6f592b0275ULL, 0x4a7484aa6ea6e483ULL, + 0x5cb0a9dcbd41fbd4ULL, 0x76f988da831153b5ULL, + 0x983e5152ee66dfabULL, 0xa831c66d2db43210ULL, + 0xb00327c898fb213fULL, 0xbf597fc7beef0ee4ULL, + 0xc6e00bf33da88fc2ULL, 0xd5a79147930aa725ULL, + 0x06ca6351e003826fULL, 0x142929670a0e6e70ULL, + 0x27b70a8546d22ffcULL, 0x2e1b21385c26c926ULL, + 0x4d2c6dfc5ac42aedULL, 0x53380d139d95b3dfULL, + 0x650a73548baf63deULL, 0x766a0abb3c77b2a8ULL, + 0x81c2c92e47edaee6ULL, 0x92722c851482353bULL, + 0xa2bfe8a14cf10364ULL, 0xa81a664bbc423001ULL, + 0xc24b8b70d0f89791ULL, 0xc76c51a30654be30ULL, + 0xd192e819d6ef5218ULL, 0xd69906245565a910ULL, + 0xf40e35855771202aULL, 0x106aa07032bbd1b8ULL, + 0x19a4c116b8d2d0c8ULL, 0x1e376c085141ab53ULL, + 0x2748774cdf8eeb99ULL, 0x34b0bcb5e19b48a8ULL, + 0x391c0cb3c5c95a63ULL, 0x4ed8aa4ae3418acbULL, + 0x5b9cca4f7763e373ULL, 0x682e6ff3d6b2b8a3ULL, + 0x748f82ee5defb2fcULL, 0x78a5636f43172f60ULL, + 0x84c87814a1f0ab72ULL, 0x8cc702081a6439ecULL, + 0x90befffa23631e28ULL, 0xa4506cebde82bde9ULL, + 0xbef9a3f7b2c67915ULL, 0xc67178f2e372532bULL, + 0xca273eceea26619cULL, 0xd186b8c721c0c207ULL, + 0xeada7dd6cde0eb1eULL, 0xf57d4f7fee6ed178ULL, + 0x06f067aa72176fbaULL, 0x0a637dc5a2c898a6ULL, + 0x113f9804bef90daeULL, 0x1b710b35131c471bULL, + 0x28db77f523047d84ULL, 0x32caab7b40c72493ULL, + 0x3c9ebe0a15c9bebcULL, 0x431d67c49c100d4cULL, + 0x4cc5d4becb3e42b6ULL, 0x597f299cfc657e2aULL, + 0x5fcb6fab3ad6faecULL, 0x6c44198c4a475817ULL}; + +/* SHA-256 functions */ + +void sha256_transf(sha256_ctx *ctx, const unsigned char *message, + unsigned int block_nb) +{ + uint32 w[64]; + uint32 wv[8]; + uint32 t1, t2; + const unsigned char *sub_block; + int i; + +#ifndef UNROLL_LOOPS + int j; +#endif + + for (i = 0; i < (int) block_nb; i++) { + sub_block = message + (i << 6); + +#ifndef UNROLL_LOOPS + for (j = 0; j < 16; j++) { + PACK32(&sub_block[j << 2], &w[j]); + } + + for (j = 16; j < 64; j++) { + SHA256_SCR(j); + } + + for (j = 0; j < 8; j++) { + wv[j] = ctx->h[j]; + } + + for (j = 0; j < 64; j++) { + t1 = wv[7] + SHA256_F2(wv[4]) + CH(wv[4], wv[5], wv[6]) + + sha256_k[j] + w[j]; + t2 = SHA256_F1(wv[0]) + MAJ(wv[0], wv[1], wv[2]); + wv[7] = wv[6]; + wv[6] = wv[5]; + wv[5] = wv[4]; + wv[4] = wv[3] + t1; + wv[3] = wv[2]; + wv[2] = wv[1]; + wv[1] = wv[0]; + wv[0] = t1 + t2; + } + + for (j = 0; j < 8; j++) { + ctx->h[j] += wv[j]; + } +#else + PACK32(&sub_block[ 0], &w[ 0]); PACK32(&sub_block[ 4], &w[ 1]); + PACK32(&sub_block[ 8], &w[ 2]); PACK32(&sub_block[12], &w[ 3]); + PACK32(&sub_block[16], &w[ 4]); PACK32(&sub_block[20], &w[ 5]); + PACK32(&sub_block[24], &w[ 6]); PACK32(&sub_block[28], &w[ 7]); + PACK32(&sub_block[32], &w[ 8]); PACK32(&sub_block[36], &w[ 9]); + PACK32(&sub_block[40], &w[10]); PACK32(&sub_block[44], &w[11]); + PACK32(&sub_block[48], &w[12]); PACK32(&sub_block[52], &w[13]); + PACK32(&sub_block[56], &w[14]); PACK32(&sub_block[60], &w[15]); + + SHA256_SCR(16); SHA256_SCR(17); SHA256_SCR(18); SHA256_SCR(19); + SHA256_SCR(20); SHA256_SCR(21); SHA256_SCR(22); SHA256_SCR(23); + SHA256_SCR(24); SHA256_SCR(25); SHA256_SCR(26); SHA256_SCR(27); + SHA256_SCR(28); SHA256_SCR(29); SHA256_SCR(30); SHA256_SCR(31); + SHA256_SCR(32); SHA256_SCR(33); SHA256_SCR(34); SHA256_SCR(35); + SHA256_SCR(36); SHA256_SCR(37); SHA256_SCR(38); SHA256_SCR(39); + SHA256_SCR(40); SHA256_SCR(41); SHA256_SCR(42); SHA256_SCR(43); + SHA256_SCR(44); SHA256_SCR(45); SHA256_SCR(46); SHA256_SCR(47); + SHA256_SCR(48); SHA256_SCR(49); SHA256_SCR(50); SHA256_SCR(51); + SHA256_SCR(52); SHA256_SCR(53); SHA256_SCR(54); SHA256_SCR(55); + SHA256_SCR(56); SHA256_SCR(57); SHA256_SCR(58); SHA256_SCR(59); + SHA256_SCR(60); SHA256_SCR(61); SHA256_SCR(62); SHA256_SCR(63); + + wv[0] = ctx->h[0]; wv[1] = ctx->h[1]; + wv[2] = ctx->h[2]; wv[3] = ctx->h[3]; + wv[4] = ctx->h[4]; wv[5] = ctx->h[5]; + wv[6] = ctx->h[6]; wv[7] = ctx->h[7]; + + SHA256_EXP(0,1,2,3,4,5,6,7, 0); SHA256_EXP(7,0,1,2,3,4,5,6, 1); + SHA256_EXP(6,7,0,1,2,3,4,5, 2); SHA256_EXP(5,6,7,0,1,2,3,4, 3); + SHA256_EXP(4,5,6,7,0,1,2,3, 4); SHA256_EXP(3,4,5,6,7,0,1,2, 5); + SHA256_EXP(2,3,4,5,6,7,0,1, 6); SHA256_EXP(1,2,3,4,5,6,7,0, 7); + SHA256_EXP(0,1,2,3,4,5,6,7, 8); SHA256_EXP(7,0,1,2,3,4,5,6, 9); + SHA256_EXP(6,7,0,1,2,3,4,5,10); SHA256_EXP(5,6,7,0,1,2,3,4,11); + SHA256_EXP(4,5,6,7,0,1,2,3,12); SHA256_EXP(3,4,5,6,7,0,1,2,13); + SHA256_EXP(2,3,4,5,6,7,0,1,14); SHA256_EXP(1,2,3,4,5,6,7,0,15); + SHA256_EXP(0,1,2,3,4,5,6,7,16); SHA256_EXP(7,0,1,2,3,4,5,6,17); + SHA256_EXP(6,7,0,1,2,3,4,5,18); SHA256_EXP(5,6,7,0,1,2,3,4,19); + SHA256_EXP(4,5,6,7,0,1,2,3,20); SHA256_EXP(3,4,5,6,7,0,1,2,21); + SHA256_EXP(2,3,4,5,6,7,0,1,22); SHA256_EXP(1,2,3,4,5,6,7,0,23); + SHA256_EXP(0,1,2,3,4,5,6,7,24); SHA256_EXP(7,0,1,2,3,4,5,6,25); + SHA256_EXP(6,7,0,1,2,3,4,5,26); SHA256_EXP(5,6,7,0,1,2,3,4,27); + SHA256_EXP(4,5,6,7,0,1,2,3,28); SHA256_EXP(3,4,5,6,7,0,1,2,29); + SHA256_EXP(2,3,4,5,6,7,0,1,30); SHA256_EXP(1,2,3,4,5,6,7,0,31); + SHA256_EXP(0,1,2,3,4,5,6,7,32); SHA256_EXP(7,0,1,2,3,4,5,6,33); + SHA256_EXP(6,7,0,1,2,3,4,5,34); SHA256_EXP(5,6,7,0,1,2,3,4,35); + SHA256_EXP(4,5,6,7,0,1,2,3,36); SHA256_EXP(3,4,5,6,7,0,1,2,37); + SHA256_EXP(2,3,4,5,6,7,0,1,38); SHA256_EXP(1,2,3,4,5,6,7,0,39); + SHA256_EXP(0,1,2,3,4,5,6,7,40); SHA256_EXP(7,0,1,2,3,4,5,6,41); + SHA256_EXP(6,7,0,1,2,3,4,5,42); SHA256_EXP(5,6,7,0,1,2,3,4,43); + SHA256_EXP(4,5,6,7,0,1,2,3,44); SHA256_EXP(3,4,5,6,7,0,1,2,45); + SHA256_EXP(2,3,4,5,6,7,0,1,46); SHA256_EXP(1,2,3,4,5,6,7,0,47); + SHA256_EXP(0,1,2,3,4,5,6,7,48); SHA256_EXP(7,0,1,2,3,4,5,6,49); + SHA256_EXP(6,7,0,1,2,3,4,5,50); SHA256_EXP(5,6,7,0,1,2,3,4,51); + SHA256_EXP(4,5,6,7,0,1,2,3,52); SHA256_EXP(3,4,5,6,7,0,1,2,53); + SHA256_EXP(2,3,4,5,6,7,0,1,54); SHA256_EXP(1,2,3,4,5,6,7,0,55); + SHA256_EXP(0,1,2,3,4,5,6,7,56); SHA256_EXP(7,0,1,2,3,4,5,6,57); + SHA256_EXP(6,7,0,1,2,3,4,5,58); SHA256_EXP(5,6,7,0,1,2,3,4,59); + SHA256_EXP(4,5,6,7,0,1,2,3,60); SHA256_EXP(3,4,5,6,7,0,1,2,61); + SHA256_EXP(2,3,4,5,6,7,0,1,62); SHA256_EXP(1,2,3,4,5,6,7,0,63); + + ctx->h[0] += wv[0]; ctx->h[1] += wv[1]; + ctx->h[2] += wv[2]; ctx->h[3] += wv[3]; + ctx->h[4] += wv[4]; ctx->h[5] += wv[5]; + ctx->h[6] += wv[6]; ctx->h[7] += wv[7]; +#endif /* !UNROLL_LOOPS */ + } +} + +void sha256(const unsigned char *message, unsigned int len, unsigned char *digest) +{ + sha256_ctx ctx; + + sha256_init(&ctx); + sha256_update(&ctx, message, len); + sha256_final(&ctx, digest); +} + +void sha256_init(sha256_ctx *ctx) +{ +#ifndef UNROLL_LOOPS + int i; + for (i = 0; i < 8; i++) { + ctx->h[i] = sha256_h0[i]; + } +#else + ctx->h[0] = sha256_h0[0]; ctx->h[1] = sha256_h0[1]; + ctx->h[2] = sha256_h0[2]; ctx->h[3] = sha256_h0[3]; + ctx->h[4] = sha256_h0[4]; ctx->h[5] = sha256_h0[5]; + ctx->h[6] = sha256_h0[6]; ctx->h[7] = sha256_h0[7]; +#endif /* !UNROLL_LOOPS */ + + ctx->len = 0; + ctx->tot_len = 0; +} + +void sha256_update(sha256_ctx *ctx, const unsigned char *message, + unsigned int len) +{ + unsigned int block_nb; + unsigned int new_len, rem_len, tmp_len; + const unsigned char *shifted_message; + + tmp_len = SHA256_BLOCK_SIZE - ctx->len; + rem_len = len < tmp_len ? len : tmp_len; + + memcpy(&ctx->block[ctx->len], message, rem_len); + + if (ctx->len + len < SHA256_BLOCK_SIZE) { + ctx->len += len; + return; + } + + new_len = len - rem_len; + block_nb = new_len / SHA256_BLOCK_SIZE; + + shifted_message = message + rem_len; + + sha256_transf(ctx, ctx->block, 1); + sha256_transf(ctx, shifted_message, block_nb); + + rem_len = new_len % SHA256_BLOCK_SIZE; + + memcpy(ctx->block, &shifted_message[block_nb << 6], + rem_len); + + ctx->len = rem_len; + ctx->tot_len += (block_nb + 1) << 6; +} + +void sha256_final(sha256_ctx *ctx, unsigned char *digest) +{ + unsigned int block_nb; + unsigned int pm_len; + unsigned int len_b; + +#ifndef UNROLL_LOOPS + int i; +#endif + + block_nb = (1 + ((SHA256_BLOCK_SIZE - 9) + < (ctx->len % SHA256_BLOCK_SIZE))); + + len_b = (ctx->tot_len + ctx->len) << 3; + pm_len = block_nb << 6; + + memset(ctx->block + ctx->len, 0, pm_len - ctx->len); + ctx->block[ctx->len] = 0x80; + UNPACK32(len_b, ctx->block + pm_len - 4); + + sha256_transf(ctx, ctx->block, block_nb); + +#ifndef UNROLL_LOOPS + for (i = 0 ; i < 8; i++) { + UNPACK32(ctx->h[i], &digest[i << 2]); + } +#else + UNPACK32(ctx->h[0], &digest[ 0]); + UNPACK32(ctx->h[1], &digest[ 4]); + UNPACK32(ctx->h[2], &digest[ 8]); + UNPACK32(ctx->h[3], &digest[12]); + UNPACK32(ctx->h[4], &digest[16]); + UNPACK32(ctx->h[5], &digest[20]); + UNPACK32(ctx->h[6], &digest[24]); + UNPACK32(ctx->h[7], &digest[28]); +#endif /* !UNROLL_LOOPS */ +} + +/* SHA-512 functions */ + +void sha512_transf(sha512_ctx *ctx, const unsigned char *message, + unsigned int block_nb) +{ + uint64 w[80]; + uint64 wv[8]; + uint64 t1, t2; + const unsigned char *sub_block; + int i, j; + + for (i = 0; i < (int) block_nb; i++) { + sub_block = message + (i << 7); + +#ifndef UNROLL_LOOPS + for (j = 0; j < 16; j++) { + PACK64(&sub_block[j << 3], &w[j]); + } + + for (j = 16; j < 80; j++) { + SHA512_SCR(j); + } + + for (j = 0; j < 8; j++) { + wv[j] = ctx->h[j]; + } + + for (j = 0; j < 80; j++) { + t1 = wv[7] + SHA512_F2(wv[4]) + CH(wv[4], wv[5], wv[6]) + + sha512_k[j] + w[j]; + t2 = SHA512_F1(wv[0]) + MAJ(wv[0], wv[1], wv[2]); + wv[7] = wv[6]; + wv[6] = wv[5]; + wv[5] = wv[4]; + wv[4] = wv[3] + t1; + wv[3] = wv[2]; + wv[2] = wv[1]; + wv[1] = wv[0]; + wv[0] = t1 + t2; + } + + for (j = 0; j < 8; j++) { + ctx->h[j] += wv[j]; + } +#else + PACK64(&sub_block[ 0], &w[ 0]); PACK64(&sub_block[ 8], &w[ 1]); + PACK64(&sub_block[ 16], &w[ 2]); PACK64(&sub_block[ 24], &w[ 3]); + PACK64(&sub_block[ 32], &w[ 4]); PACK64(&sub_block[ 40], &w[ 5]); + PACK64(&sub_block[ 48], &w[ 6]); PACK64(&sub_block[ 56], &w[ 7]); + PACK64(&sub_block[ 64], &w[ 8]); PACK64(&sub_block[ 72], &w[ 9]); + PACK64(&sub_block[ 80], &w[10]); PACK64(&sub_block[ 88], &w[11]); + PACK64(&sub_block[ 96], &w[12]); PACK64(&sub_block[104], &w[13]); + PACK64(&sub_block[112], &w[14]); PACK64(&sub_block[120], &w[15]); + + SHA512_SCR(16); SHA512_SCR(17); SHA512_SCR(18); SHA512_SCR(19); + SHA512_SCR(20); SHA512_SCR(21); SHA512_SCR(22); SHA512_SCR(23); + SHA512_SCR(24); SHA512_SCR(25); SHA512_SCR(26); SHA512_SCR(27); + SHA512_SCR(28); SHA512_SCR(29); SHA512_SCR(30); SHA512_SCR(31); + SHA512_SCR(32); SHA512_SCR(33); SHA512_SCR(34); SHA512_SCR(35); + SHA512_SCR(36); SHA512_SCR(37); SHA512_SCR(38); SHA512_SCR(39); + SHA512_SCR(40); SHA512_SCR(41); SHA512_SCR(42); SHA512_SCR(43); + SHA512_SCR(44); SHA512_SCR(45); SHA512_SCR(46); SHA512_SCR(47); + SHA512_SCR(48); SHA512_SCR(49); SHA512_SCR(50); SHA512_SCR(51); + SHA512_SCR(52); SHA512_SCR(53); SHA512_SCR(54); SHA512_SCR(55); + SHA512_SCR(56); SHA512_SCR(57); SHA512_SCR(58); SHA512_SCR(59); + SHA512_SCR(60); SHA512_SCR(61); SHA512_SCR(62); SHA512_SCR(63); + SHA512_SCR(64); SHA512_SCR(65); SHA512_SCR(66); SHA512_SCR(67); + SHA512_SCR(68); SHA512_SCR(69); SHA512_SCR(70); SHA512_SCR(71); + SHA512_SCR(72); SHA512_SCR(73); SHA512_SCR(74); SHA512_SCR(75); + SHA512_SCR(76); SHA512_SCR(77); SHA512_SCR(78); SHA512_SCR(79); + + wv[0] = ctx->h[0]; wv[1] = ctx->h[1]; + wv[2] = ctx->h[2]; wv[3] = ctx->h[3]; + wv[4] = ctx->h[4]; wv[5] = ctx->h[5]; + wv[6] = ctx->h[6]; wv[7] = ctx->h[7]; + + j = 0; + + do { + SHA512_EXP(0,1,2,3,4,5,6,7,j); j++; + SHA512_EXP(7,0,1,2,3,4,5,6,j); j++; + SHA512_EXP(6,7,0,1,2,3,4,5,j); j++; + SHA512_EXP(5,6,7,0,1,2,3,4,j); j++; + SHA512_EXP(4,5,6,7,0,1,2,3,j); j++; + SHA512_EXP(3,4,5,6,7,0,1,2,j); j++; + SHA512_EXP(2,3,4,5,6,7,0,1,j); j++; + SHA512_EXP(1,2,3,4,5,6,7,0,j); j++; + } while (j < 80); + + ctx->h[0] += wv[0]; ctx->h[1] += wv[1]; + ctx->h[2] += wv[2]; ctx->h[3] += wv[3]; + ctx->h[4] += wv[4]; ctx->h[5] += wv[5]; + ctx->h[6] += wv[6]; ctx->h[7] += wv[7]; +#endif /* !UNROLL_LOOPS */ + } +} + +void sha512(const unsigned char *message, unsigned int len, + unsigned char *digest) +{ + sha512_ctx ctx; + + sha512_init(&ctx); + sha512_update(&ctx, message, len); + sha512_final(&ctx, digest); +} + +void sha512_init(sha512_ctx *ctx) +{ +#ifndef UNROLL_LOOPS + int i; + for (i = 0; i < 8; i++) { + ctx->h[i] = sha512_h0[i]; + } +#else + ctx->h[0] = sha512_h0[0]; ctx->h[1] = sha512_h0[1]; + ctx->h[2] = sha512_h0[2]; ctx->h[3] = sha512_h0[3]; + ctx->h[4] = sha512_h0[4]; ctx->h[5] = sha512_h0[5]; + ctx->h[6] = sha512_h0[6]; ctx->h[7] = sha512_h0[7]; +#endif /* !UNROLL_LOOPS */ + + ctx->len = 0; + ctx->tot_len = 0; +} + +void sha512_update(sha512_ctx *ctx, const unsigned char *message, + unsigned int len) +{ + unsigned int block_nb; + unsigned int new_len, rem_len, tmp_len; + const unsigned char *shifted_message; + + tmp_len = SHA512_BLOCK_SIZE - ctx->len; + rem_len = len < tmp_len ? len : tmp_len; + + memcpy(&ctx->block[ctx->len], message, rem_len); + + if (ctx->len + len < SHA512_BLOCK_SIZE) { + ctx->len += len; + return; + } + + new_len = len - rem_len; + block_nb = new_len / SHA512_BLOCK_SIZE; + + shifted_message = message + rem_len; + + sha512_transf(ctx, ctx->block, 1); + sha512_transf(ctx, shifted_message, block_nb); + + rem_len = new_len % SHA512_BLOCK_SIZE; + + memcpy(ctx->block, &shifted_message[block_nb << 7], + rem_len); + + ctx->len = rem_len; + ctx->tot_len += (block_nb + 1) << 7; +} + +void sha512_final(sha512_ctx *ctx, unsigned char *digest) +{ + unsigned int block_nb; + unsigned int pm_len; + unsigned int len_b; + +#ifndef UNROLL_LOOPS + int i; +#endif + + block_nb = 1 + ((SHA512_BLOCK_SIZE - 17) + < (ctx->len % SHA512_BLOCK_SIZE)); + + len_b = (ctx->tot_len + ctx->len) << 3; + pm_len = block_nb << 7; + + memset(ctx->block + ctx->len, 0, pm_len - ctx->len); + ctx->block[ctx->len] = 0x80; + UNPACK32(len_b, ctx->block + pm_len - 4); + + sha512_transf(ctx, ctx->block, block_nb); + +#ifndef UNROLL_LOOPS + for (i = 0 ; i < 8; i++) { + UNPACK64(ctx->h[i], &digest[i << 3]); + } +#else + UNPACK64(ctx->h[0], &digest[ 0]); + UNPACK64(ctx->h[1], &digest[ 8]); + UNPACK64(ctx->h[2], &digest[16]); + UNPACK64(ctx->h[3], &digest[24]); + UNPACK64(ctx->h[4], &digest[32]); + UNPACK64(ctx->h[5], &digest[40]); + UNPACK64(ctx->h[6], &digest[48]); + UNPACK64(ctx->h[7], &digest[56]); +#endif /* !UNROLL_LOOPS */ +} + +/* SHA-384 functions */ + +void sha384(const unsigned char *message, unsigned int len, + unsigned char *digest) +{ + sha384_ctx ctx; + + sha384_init(&ctx); + sha384_update(&ctx, message, len); + sha384_final(&ctx, digest); +} + +void sha384_init(sha384_ctx *ctx) +{ +#ifndef UNROLL_LOOPS + int i; + for (i = 0; i < 8; i++) { + ctx->h[i] = sha384_h0[i]; + } +#else + ctx->h[0] = sha384_h0[0]; ctx->h[1] = sha384_h0[1]; + ctx->h[2] = sha384_h0[2]; ctx->h[3] = sha384_h0[3]; + ctx->h[4] = sha384_h0[4]; ctx->h[5] = sha384_h0[5]; + ctx->h[6] = sha384_h0[6]; ctx->h[7] = sha384_h0[7]; +#endif /* !UNROLL_LOOPS */ + + ctx->len = 0; + ctx->tot_len = 0; +} + +void sha384_update(sha384_ctx *ctx, const unsigned char *message, + unsigned int len) +{ + unsigned int block_nb; + unsigned int new_len, rem_len, tmp_len; + const unsigned char *shifted_message; + + tmp_len = SHA384_BLOCK_SIZE - ctx->len; + rem_len = len < tmp_len ? len : tmp_len; + + memcpy(&ctx->block[ctx->len], message, rem_len); + + if (ctx->len + len < SHA384_BLOCK_SIZE) { + ctx->len += len; + return; + } + + new_len = len - rem_len; + block_nb = new_len / SHA384_BLOCK_SIZE; + + shifted_message = message + rem_len; + + sha512_transf(ctx, ctx->block, 1); + sha512_transf(ctx, shifted_message, block_nb); + + rem_len = new_len % SHA384_BLOCK_SIZE; + + memcpy(ctx->block, &shifted_message[block_nb << 7], + rem_len); + + ctx->len = rem_len; + ctx->tot_len += (block_nb + 1) << 7; +} + +void sha384_final(sha384_ctx *ctx, unsigned char *digest) +{ + unsigned int block_nb; + unsigned int pm_len; + unsigned int len_b; + +#ifndef UNROLL_LOOPS + int i; +#endif + + block_nb = (1 + ((SHA384_BLOCK_SIZE - 17) + < (ctx->len % SHA384_BLOCK_SIZE))); + + len_b = (ctx->tot_len + ctx->len) << 3; + pm_len = block_nb << 7; + + memset(ctx->block + ctx->len, 0, pm_len - ctx->len); + ctx->block[ctx->len] = 0x80; + UNPACK32(len_b, ctx->block + pm_len - 4); + + sha512_transf(ctx, ctx->block, block_nb); + +#ifndef UNROLL_LOOPS + for (i = 0 ; i < 6; i++) { + UNPACK64(ctx->h[i], &digest[i << 3]); + } +#else + UNPACK64(ctx->h[0], &digest[ 0]); + UNPACK64(ctx->h[1], &digest[ 8]); + UNPACK64(ctx->h[2], &digest[16]); + UNPACK64(ctx->h[3], &digest[24]); + UNPACK64(ctx->h[4], &digest[32]); + UNPACK64(ctx->h[5], &digest[40]); +#endif /* !UNROLL_LOOPS */ +} + +/* SHA-224 functions */ + +void sha224(const unsigned char *message, unsigned int len, + unsigned char *digest) +{ + sha224_ctx ctx; + + sha224_init(&ctx); + sha224_update(&ctx, message, len); + sha224_final(&ctx, digest); +} + +void sha224_init(sha224_ctx *ctx) +{ +#ifndef UNROLL_LOOPS + int i; + for (i = 0; i < 8; i++) { + ctx->h[i] = sha224_h0[i]; + } +#else + ctx->h[0] = sha224_h0[0]; ctx->h[1] = sha224_h0[1]; + ctx->h[2] = sha224_h0[2]; ctx->h[3] = sha224_h0[3]; + ctx->h[4] = sha224_h0[4]; ctx->h[5] = sha224_h0[5]; + ctx->h[6] = sha224_h0[6]; ctx->h[7] = sha224_h0[7]; +#endif /* !UNROLL_LOOPS */ + + ctx->len = 0; + ctx->tot_len = 0; +} + +void sha224_update(sha224_ctx *ctx, const unsigned char *message, + unsigned int len) +{ + unsigned int block_nb; + unsigned int new_len, rem_len, tmp_len; + const unsigned char *shifted_message; + + tmp_len = SHA224_BLOCK_SIZE - ctx->len; + rem_len = len < tmp_len ? len : tmp_len; + + memcpy(&ctx->block[ctx->len], message, rem_len); + + if (ctx->len + len < SHA224_BLOCK_SIZE) { + ctx->len += len; + return; + } + + new_len = len - rem_len; + block_nb = new_len / SHA224_BLOCK_SIZE; + + shifted_message = message + rem_len; + + sha256_transf(ctx, ctx->block, 1); + sha256_transf(ctx, shifted_message, block_nb); + + rem_len = new_len % SHA224_BLOCK_SIZE; + + memcpy(ctx->block, &shifted_message[block_nb << 6], + rem_len); + + ctx->len = rem_len; + ctx->tot_len += (block_nb + 1) << 6; +} + +void sha224_final(sha224_ctx *ctx, unsigned char *digest) +{ + unsigned int block_nb; + unsigned int pm_len; + unsigned int len_b; + +#ifndef UNROLL_LOOPS + int i; +#endif + + block_nb = (1 + ((SHA224_BLOCK_SIZE - 9) + < (ctx->len % SHA224_BLOCK_SIZE))); + + len_b = (ctx->tot_len + ctx->len) << 3; + pm_len = block_nb << 6; + + memset(ctx->block + ctx->len, 0, pm_len - ctx->len); + ctx->block[ctx->len] = 0x80; + UNPACK32(len_b, ctx->block + pm_len - 4); + + sha256_transf(ctx, ctx->block, block_nb); + +#ifndef UNROLL_LOOPS + for (i = 0 ; i < 7; i++) { + UNPACK32(ctx->h[i], &digest[i << 2]); + } +#else + UNPACK32(ctx->h[0], &digest[ 0]); + UNPACK32(ctx->h[1], &digest[ 4]); + UNPACK32(ctx->h[2], &digest[ 8]); + UNPACK32(ctx->h[3], &digest[12]); + UNPACK32(ctx->h[4], &digest[16]); + UNPACK32(ctx->h[5], &digest[20]); + UNPACK32(ctx->h[6], &digest[24]); +#endif /* !UNROLL_LOOPS */ +} + +#ifdef TEST_VECTORS + +/* FIPS 180-2 Validation tests */ + +#include +#include + +void test(const unsigned char *vector, unsigned char *digest, + unsigned int digest_size) +{ + unsigned char output[2 * SHA512_DIGEST_SIZE + 1]; + int i; + + output[2 * digest_size] = '\0'; + + for (i = 0; i < (int) digest_size ; i++) { + sprintf((char *) output + 2 * i, "%02x", digest[i]); + } + + printf("H: %s\n", output); + if (strcmp((char *) vector, (char *) output)) { + fprintf(stderr, "Test failed.\n"); + exit(EXIT_FAILURE); + } +} + +int main() +{ + static const unsigned char *vectors[4][3] = + { /* SHA-224 */ + { + "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7", + "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525", + "20794655980c91d8bbb4c1ea97618a4bf03f42581948b2ee4ee7ad67", + }, + /* SHA-256 */ + { + "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad", + "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1", + "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0", + }, + /* SHA-384 */ + { + "cb00753f45a35e8bb5a03d699ac65007272c32ab0eded1631a8b605a43ff5bed" + "8086072ba1e7cc2358baeca134c825a7", + "09330c33f71147e83d192fc782cd1b4753111b173b3b05d22fa08086e3b0f712" + "fcc7c71a557e2db966c3e9fa91746039", + "9d0e1809716474cb086e834e310a4a1ced149e9c00f248527972cec5704c2a5b" + "07b8b3dc38ecc4ebae97ddd87f3d8985", + }, + /* SHA-512 */ + { + "ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a" + "2192992a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f", + "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018" + "501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909", + "e718483d0ce769644e2e42c7bc15b4638e1f98b13b2044285632a803afa973eb" + "de0ff244877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b" + } + }; + + static const unsigned char message1[] = "abc"; + static const unsigned char message2a[] = "abcdbcdecdefdefgefghfghighijhi" + "jkijkljklmklmnlmnomnopnopq"; + static const unsigned char message2b[] = + "abcdefghbcdefghicdefghijdefghijkefghij" + "klfghijklmghijklmnhijklmnoijklmnopjklm" + "nopqklmnopqrlmnopqrsmnopqrstnopqrstu"; + unsigned char *message3; + unsigned int message3_len = 1000000; + unsigned char digest[SHA512_DIGEST_SIZE]; + + message3 = malloc(message3_len); + if (message3 == NULL) { + fprintf(stderr, "Can't allocate memory\n"); + return -1; + } + memset(message3, 'a', message3_len); + + printf("SHA-2 FIPS 180-2 Validation tests\n\n"); + printf("SHA-224 Test vectors\n"); + + sha224(message1, strlen((char *) message1), digest); + test(vectors[0][0], digest, SHA224_DIGEST_SIZE); + sha224(message2a, strlen((char *) message2a), digest); + test(vectors[0][1], digest, SHA224_DIGEST_SIZE); + sha224(message3, message3_len, digest); + test(vectors[0][2], digest, SHA224_DIGEST_SIZE); + printf("\n"); + + printf("SHA-256 Test vectors\n"); + + sha256(message1, strlen((char *) message1), digest); + test(vectors[1][0], digest, SHA256_DIGEST_SIZE); + sha256(message2a, strlen((char *) message2a), digest); + test(vectors[1][1], digest, SHA256_DIGEST_SIZE); + sha256(message3, message3_len, digest); + test(vectors[1][2], digest, SHA256_DIGEST_SIZE); + printf("\n"); + + printf("SHA-384 Test vectors\n"); + + sha384(message1, strlen((char *) message1), digest); + test(vectors[2][0], digest, SHA384_DIGEST_SIZE); + sha384(message2b, strlen((char *) message2b), digest); + test(vectors[2][1], digest, SHA384_DIGEST_SIZE); + sha384(message3, message3_len, digest); + test(vectors[2][2], digest, SHA384_DIGEST_SIZE); + printf("\n"); + + printf("SHA-512 Test vectors\n"); + + sha512(message1, strlen((char *) message1), digest); + test(vectors[3][0], digest, SHA512_DIGEST_SIZE); + sha512(message2b, strlen((char *) message2b), digest); + test(vectors[3][1], digest, SHA512_DIGEST_SIZE); + sha512(message3, message3_len, digest); + test(vectors[3][2], digest, SHA512_DIGEST_SIZE); + printf("\n"); + + printf("All tests passed.\n"); + + return 0; +} + +#endif /* TEST_VECTORS */ + diff --git a/src/Crypt/sha2.h b/src/Crypt/sha2.h new file mode 100644 --- /dev/null +++ b/src/Crypt/sha2.h @@ -0,0 +1,108 @@ +/* + * FIPS 180-2 SHA-224/256/384/512 implementation + * Last update: 02/02/2007 + * Issue date: 04/30/2005 + * + * Copyright (C) 2005, 2007 Olivier Gay + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. Neither the name of the project nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#ifndef SHA2_H +#define SHA2_H + +#define SHA224_DIGEST_SIZE ( 224 / 8) +#define SHA256_DIGEST_SIZE ( 256 / 8) +#define SHA384_DIGEST_SIZE ( 384 / 8) +#define SHA512_DIGEST_SIZE ( 512 / 8) + +#define SHA256_BLOCK_SIZE ( 512 / 8) +#define SHA512_BLOCK_SIZE (1024 / 8) +#define SHA384_BLOCK_SIZE SHA512_BLOCK_SIZE +#define SHA224_BLOCK_SIZE SHA256_BLOCK_SIZE + +#ifndef SHA2_TYPES +#define SHA2_TYPES +typedef unsigned char uint8; +typedef unsigned int uint32; +typedef unsigned long long uint64; +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +typedef struct { + unsigned int tot_len; + unsigned int len; + unsigned char block[2 * SHA256_BLOCK_SIZE]; + uint32 h[8]; +} sha256_ctx; + +typedef struct { + unsigned int tot_len; + unsigned int len; + unsigned char block[2 * SHA512_BLOCK_SIZE]; + uint64 h[8]; +} sha512_ctx; + +typedef sha512_ctx sha384_ctx; +typedef sha256_ctx sha224_ctx; + +void sha224_init(sha224_ctx *ctx); +void sha224_update(sha224_ctx *ctx, const unsigned char *message, + unsigned int len); +void sha224_final(sha224_ctx *ctx, unsigned char *digest); +void sha224(const unsigned char *message, unsigned int len, + unsigned char *digest); + +void sha256_init(sha256_ctx * ctx); +void sha256_update(sha256_ctx *ctx, const unsigned char *message, + unsigned int len); +void sha256_final(sha256_ctx *ctx, unsigned char *digest); +void sha256(const unsigned char *message, unsigned int len, + unsigned char *digest); + +void sha384_init(sha384_ctx *ctx); +void sha384_update(sha384_ctx *ctx, const unsigned char *message, + unsigned int len); +void sha384_final(sha384_ctx *ctx, unsigned char *digest); +void sha384(const unsigned char *message, unsigned int len, + unsigned char *digest); + +void sha512_init(sha512_ctx *ctx); +void sha512_update(sha512_ctx *ctx, const unsigned char *message, + unsigned int len); +void sha512_final(sha512_ctx *ctx, unsigned char *digest); +void sha512(const unsigned char *message, unsigned int len, + unsigned char *digest); + +#ifdef __cplusplus +} +#endif + +#endif /* !SHA2_H */ + diff --git a/src/Darcs/ArgumentDefaults.lhs b/src/Darcs/ArgumentDefaults.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/ArgumentDefaults.lhs @@ -0,0 +1,172 @@ +% Copyright (C) 2003 David Roundy +% +% 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. + +\begin{code} +module Darcs.ArgumentDefaults ( get_default_flags ) where +import Data.Maybe ( catMaybes, listToMaybe, mapMaybe ) + +import Darcs.Arguments ( DarcsFlag, + DarcsOption( DarcsArgOption, DarcsNoArgOption, DarcsMultipleChoiceOption ), + arein, isin ) +import Darcs.Commands ( CommandControl( Command_data ), + command_alloptions ) +import Darcs.Commands.Help ( command_control_list ) +import Darcs.Repository.Prefs ( get_global, get_preflist ) +\end{code} + +\paragraph{defaults}\label{defaults} + +Default values for darcs commands can be configured on a per-repository +basis by editing (and possibly creating) the \verb!_darcs/prefs/defaults! +file. Each line of this file has the following form: +\begin{verbatim} +COMMAND FLAG VALUE +\end{verbatim} +where \verb!COMMAND! is either the name of the command to which the default +applies, or \verb!ALL! to indicate that the default applies to all commands +accepting that flag. The \verb!FLAG! term is the name of the long argument +option without the ``\verb!--!'', i.e.\ \verb!verbose! rather than +\verb!--verbose!. Finally, the \verb!VALUE! option can be omitted if the +flag is one such as \verb!verbose! that doesn't involve a value. +If the value has spaces in it, use single quotes, not double quotes, to surround it. +Each line only takes one flag. To set multiple defaults for the same +command (or for \verb!ALL! commands), use multiple lines. + +Note that the use of \verb|ALL| easily can have unpredicted consequences, +especially if commands in newer versions of darcs accepts flags that they +didn't in previous versions. A command like \verb|obliterate| could be +devastating with the ``wrong'' flags (for example --all). Only use safe +flags with \verb|ALL|. + +\begin{tabular}{ll} +{\tt \verb!~/.darcs/defaults!} & provides defaults for this user account, on MS Windows~\ref{ms_win} \\ +{\tt \verb!repo/_darcs/prefs/defaults!} & provides defaults for one project,\\ + & overrules changes per user \\ +\end{tabular} + +For example, if your system clock is bizarre, you could instruct darcs to +always ignore the file modification times by adding the following line to +your \verb!_darcs/prefs/defaults! file. (Note that this would have to be +done for each repository!) +\begin{verbatim} +ALL ignore-times +\end{verbatim} + +If you never want to run a test when recording to a particular repository +(but still want to do so when running +\verb'check' on that repository), and like to name +all your patches ``Stupid patch'', you could use the following: +\begin{verbatim} +record no-test +record patch-name Stupid patch +\end{verbatim} + +If you would like a command to be run every time patches are recorded +in a particular repository (for example if you have one central +repository, that all developers contribute to), then you can set apply +to always run a command when apply is successful. For example, if you +need to make sure that the files in the repository have the correct +access rights you might use the following. There are two things +to note about using darcs this way: +\begin{itemize} +\item Without the second line you will get errors, because the sub + process that runs apply cannot prompt interactively. +\item Whatever script is run by the post apply command should not be + added to the repository with \verb!darcs add!; doing so would + allow people to modify that file and then run arbitrary scripts on + your main repository, possibly damaging or violating security. +\end{itemize} +\begin{verbatim} +apply posthook chmod -R a+r * +apply run-posthook +\end{verbatim} + +Similarly, if you need a command to run automatically before darcs +performs an action you can use a prehook. Using prehooks it could be +possible to canonicalize line endings before recording patches. + +There are some options which are meant specifically for use in +\verb!_darcs/prefs/defaults!. One of them is \verb!--disable!. As the name +suggests, this option will disable every command that got it as argument. So, +if you are afraid that you could damage your repositories by inadvertent use of +a command like amend-record, add the following line to +\verb!_darcs/prefs/defaults!: +\begin{verbatim} +amend-record disable +\end{verbatim} + +Also, a global preferences file can be created with the name +\verb!.darcs/defaults! in your home directory, on MS Windows~\ref{ms_win}. +Options present there will be added to the repository-specific preferences. +If they conflict with repository-specific options, the repository-specific +ones will take precedence. + +\begin{code} +get_default_flags :: String -> [DarcsOption] -> [DarcsFlag] -> IO [DarcsFlag] +get_default_flags com com_opts already = do + repo_defs <- default_content $ get_preflist "defaults" + global_defs <- default_content $ get_global "defaults" + let repo_flags = get_flags_from com com_opts already repo_defs + global_flags = get_flags_from com com_opts + (already++repo_flags) global_defs + return $ repo_flags ++ global_flags + +get_flags_from :: String -> [DarcsOption] -> [DarcsFlag] -> [(String,String,String)] -> [DarcsFlag] +get_flags_from com com_opts already defs = + options_for com_defs com_opts com_opts ++ + options_for all_defs com_opts all_opts + where com_defs = filter (\ (c,_,_) -> c == com) defs + all_defs = filter (\ (c,_,_) -> c == "ALL") defs + options_for d o ao = concatMap (find_option o ao already) d + all_opts = concatMap get_opts command_control_list + get_opts (Command_data c) = let (o1, o2) = command_alloptions c + in o1 ++ o2 + get_opts _ = [] + +find_option :: [DarcsOption] -> [DarcsOption] -> [DarcsFlag] -> (String,String,String) -> [DarcsFlag] +find_option opts all_opts already (c, f, d) = + if null $ mapMaybe choose_option all_opts + then error $ "Bad default option: command '"++c++"' has no option '"++f++"'." + else concat $ mapMaybe choose_option opts + where choose_option (DarcsNoArgOption _ fls o _) + | o `elem` already = Just [] + | f `elem` fls = if null d + then Just [o] + else error $ "Bad default option: '"++f + ++"' takes no argument, but '"++d + ++"' argument given." + choose_option (DarcsArgOption _ fls o _ _) + | o `isin` already = Just [] + | f `elem` fls = if null d + then error $ "Bad default option: '"++f + ++"' requires an argument, but no " + ++"argument given." + else Just [o d] + choose_option (DarcsMultipleChoiceOption os) + | os `arein` already = Just [] + | otherwise = listToMaybe $ mapMaybe choose_option os + choose_option _ = Nothing + +default_content :: IO [String] -> IO [(String,String,String)] +default_content = fmap (catMaybes . map (doline.words)) + where doline (c:a:r) = Just (c, drop_dashdash a, unwords r) + doline _ = Nothing + drop_dashdash ('-':'-':a) = a + drop_dashdash a = a + +\end{code} + diff --git a/src/Darcs/Arguments.lhs b/src/Darcs/Arguments.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Arguments.lhs @@ -0,0 +1,1618 @@ +% Copyright (C) 2002-2004 David Roundy +% +% 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. + +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Arguments ( DarcsFlag( .. ), flagToString, + maxCount, + isin, arein, + definePatches, defineChanges, + fixFilePathOrStd, fixUrl, + fixSubPaths, areFileArgs, + DarcsOption( .. ), option_from_darcsoption, + help, list_options, list_files, + any_verbosity, disable, restrict_paths, + notest, test, working_repo_dir, + testByDefault, + remote_repo, + leave_test_dir, + possibly_remote_repo_dir, get_repourl, + list_registered_files, list_unregistered_files, + author, get_author, get_easy_author, get_sendmail_cmd, + patchname_option, distname_option, + logfile, rmlogfile, from_opt, subject, get_subject, + in_reply_to, get_in_reply_to, + target, cc, get_cc, output, output_auto_name, + recursive, inventory_choices, get_inventory_choices, + askdeps, ignoretimes, lookforadds, + ask_long_comment, sendmail_cmd, + environmentHelpSendmail, + sign, verify, edit_description, + reponame, tagname, creatorhash, + apply_conflict_options, reply, + pull_conflict_options, use_external_merge, + deps_sel, nocompress, + uncompress_nocompress, repo_combinator, + options_latex, reorder_patches, + noskip_boring, allow_problematic_filenames, + applyas, human_readable, + changes_reverse, only_to_files, + changes_format, match_one_context, match_one_nontag, + match_maxcount, + send_to_context, + get_context, + pipe_interactive, all_interactive, + all_pipe_interactive, + summary, unified, tokens, + checkpoint, partial, partial_check, + diff_cmd_flag, diffflags, unidiff, xmloutput, + force_replace, dry_run, dry_run_noxml, + print_dry_run_message_and_exit, showFriendly, + match_one, match_several, match_range, + match_several_or_range, happy_forwarding, + match_several_or_last, + set_default, + fancy_move_add, + set_scripts_executable, + sibling, flagsToSiblings, relink, relink_pristine, nolinks, + files, directories, pending, + posthook_cmd, posthook_prompt, + get_posthook_cmd, + prehook_cmd, prehook_prompt, + get_prehook_cmd, nullFlag, + umask_option, + store_in_memory, + patch_select_flag, + network_options, no_cache, + allow_unrelated_repos, + check_or_repair + ) where +import System.Console.GetOpt +import System.Directory ( doesDirectoryExist ) +import Data.List ( (\\), nub ) +import Data.Maybe ( fromMaybe, listToMaybe ) +import System.Exit ( ExitCode(ExitSuccess), exitWith ) +import Data.Maybe ( catMaybes ) +import Control.Monad ( when, unless ) +import Data.Char ( isDigit ) +#ifndef WIN32 +import Printer ( renderString ) +import System.Posix.Env ( setEnv ) +import Darcs.Patch ( list_touched_files ) +import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) +#endif + +import Darcs.Hopefully ( PatchInfoAnd, info, hopefullyM ) +import Darcs.Patch ( RepoPatch, Patchy, showNicely, description, xml_summary ) +import Darcs.Patch.Info ( to_xml ) +import Darcs.Ordered ( FL, mapFL ) +import qualified Darcs.Patch ( summary ) +import Darcs.Utils ( askUser, maybeGetEnv, firstNotBlank, firstJustIO, + withCurrentDirectory ) +import Darcs.Repository.Prefs ( boring_file_filter, get_preflist, get_global ) +import Darcs.URL ( is_file ) +import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd, SubPath, toFilePath, + makeSubPathOf, simpleSubPath, + ioAbsolute, ioAbsoluteOrStd, + makeAbsolute, makeAbsoluteOrStd, rootDirectory ) +import Darcs.Patch.MatchData ( patch_match ) +import Darcs.Flags ( DarcsFlag(..), maxCount ) +import Darcs.Repository ( slurp_pending, withRepository, ($-) ) +import Darcs.Repository.HashedRepo ( slurp_all_but_darcs ) +import Darcs.SlurpDirectory ( list_slurpy ) +import Darcs.Global ( darcsdir ) +import Printer ( Doc, putDocLn, text, vsep, ($$), vcat, insert_before_lastline, + prefix ) +import URL ( pipeliningEnabledByDefault ) +#include "impossible.h" + +data FlagContent = NoContent | AbsoluteContent AbsolutePath | AbsoluteOrStdContent AbsolutePathOrStd | StringContent String + deriving (Eq, Show, Ord) + +-- getContent is very tedious to write, but this is the only way (that +-- I know of) to guarantee that it works for all flags (which then +-- guarantees that isAnAbsolute, isa, flagToString, etc also work +-- properly) + +-- | 'get_content' returns the content of a flag, if any. +-- For instance, the content of @Author \"Louis Aragon\"@ is @StringContent +-- \"Louis Aragon\"@, while the content of @Pipe@ is @NoContent@ +getContent :: DarcsFlag -> FlagContent +getContent (PatchName s) = StringContent s +getContent (Output s) = AbsoluteOrStdContent s +getContent Verbose = NoContent +getContent Help = NoContent +getContent ListOptions = NoContent +getContent Test = NoContent +getContent NoTest = NoContent +getContent OnlyChangesToFiles = NoContent +getContent LeaveTestDir = NoContent +getContent NoLeaveTestDir = NoContent +getContent Timings = NoContent +getContent Debug = NoContent +getContent DebugVerbose = NoContent +getContent DebugHTTP = NoContent +getContent NormalVerbosity = NoContent +getContent Quiet = NoContent +getContent (Target s) = StringContent s +getContent (Cc s) = StringContent s +getContent (Subject s) = StringContent s +getContent (InReplyTo s) = StringContent s +getContent (SendmailCmd s) = StringContent s +getContent (Author s) = StringContent s +getContent (OnePatch s) = StringContent s +getContent (SeveralPatch s) = StringContent s +getContent (AfterPatch s) = StringContent s +getContent (UpToPatch s) = StringContent s +getContent (TagName s) = StringContent s +getContent (LastN s) = StringContent (show s) +getContent (MaxCount s) = StringContent (show s) +getContent (OneTag s) = StringContent s +getContent (AfterTag s) = StringContent s +getContent (UpToTag s) = StringContent s +getContent (Context s) = AbsoluteContent s +getContent (LogFile s) = AbsoluteContent s +getContent (OutputAutoName s) = AbsoluteContent s +getContent NumberPatches = NoContent +getContent (PatchIndexRange _ _) = NoContent -- FIXME this doesn't fit into a neat category +getContent Count = NoContent +getContent All = NoContent +getContent Recursive = NoContent +getContent NoRecursive = NoContent +getContent Reorder = NoContent +getContent RestrictPaths = NoContent +getContent DontRestrictPaths = NoContent +getContent AskDeps = NoContent +getContent NoAskDeps = NoContent +getContent RmLogFile = NoContent +getContent (DistName s) = StringContent s +getContent (CreatorHash s) = StringContent s +getContent (SignAs s) = StringContent s +getContent (SignSSL s) = StringContent s +getContent (Verify s) = AbsoluteContent s +getContent (VerifySSL s) = AbsoluteContent s +getContent IgnoreTimes = NoContent +getContent LookForAdds = NoContent +getContent NoLookForAdds = NoContent +getContent AnyOrder = NoContent +getContent Intersection = NoContent +getContent Unified = NoContent +getContent Union = NoContent +getContent Complement = NoContent +getContent Sign = NoContent +getContent NoSign = NoContent +getContent HappyForwarding = NoContent +getContent SSHControlMaster = NoContent +getContent NoSSHControlMaster = NoContent +getContent (Toks s) = StringContent s +getContent (WorkRepoDir s) = StringContent s +getContent (WorkRepoUrl s) = StringContent s +getContent (RemoteRepo s) = StringContent s +getContent (NewRepo s) = StringContent s +getContent (Reply s) = StringContent s +getContent EditDescription = NoContent +getContent NoEditDescription = NoContent +getContent EditLongComment = NoContent +getContent NoEditLongComment = NoContent +getContent PromptLongComment = NoContent +getContent AllowConflicts = NoContent +getContent MarkConflicts = NoContent +getContent NoAllowConflicts = NoContent +getContent Boring = NoContent +getContent AllowCaseOnly = NoContent +getContent AllowWindowsReserved = NoContent +getContent DontGrabDeps = NoContent +getContent DontPromptForDependencies = NoContent +getContent PromptForDependencies = NoContent +getContent Compress = NoContent +getContent NoCompress = NoContent +getContent UnCompress = NoContent +getContent MachineReadable = NoContent +getContent HumanReadable = NoContent +getContent Pipe = NoContent +getContent Interactive = NoContent +getContent Summary = NoContent +getContent NoSummary = NoContent +getContent (ApplyAs s) = StringContent s +getContent (DiffCmd s) = StringContent s +getContent (ExternalMerge s) = StringContent s +getContent (DiffFlags s) = StringContent s +getContent (OnePattern _) = NoContent -- FIXME!!! +getContent (SeveralPattern _) = NoContent -- FIXME!!! +getContent (UpToPattern _) = NoContent -- FIXME!!! +getContent (AfterPattern _) = NoContent -- FIXME!!! +getContent Reverse = NoContent +getContent CheckPoint = NoContent +getContent Partial = NoContent +getContent Complete = NoContent +getContent Lazy = NoContent +getContent Ephemeral = NoContent +getContent (FixFilePath _ _) = NoContent -- FIXME!!! +getContent XMLOutput = NoContent +getContent ForceReplace = NoContent +getContent NonApply = NoContent +getContent NonVerify = NoContent +getContent NonForce = NoContent +getContent DryRun = NoContent +getContent SetDefault = NoContent +getContent NoSetDefault = NoContent +getContent FancyMoveAdd = NoContent +getContent NoFancyMoveAdd = NoContent +getContent Disable = NoContent +getContent SetScriptsExecutable = NoContent +getContent DontSetScriptsExecutable = NoContent +getContent UseHashedInventory = NoContent +getContent UseOldFashionedInventory = NoContent +getContent UseFormat2 = NoContent +getContent PristinePlain = NoContent +getContent PristineNone = NoContent +getContent NoUpdateWorking = NoContent +getContent Relink = NoContent +getContent RelinkPristine = NoContent +getContent NoLinks = NoContent +getContent Files = NoContent +getContent NoFiles = NoContent +getContent Directories = NoContent +getContent NoDirectories = NoContent +getContent Pending = NoContent +getContent NoPending = NoContent +getContent NoPosthook = NoContent +getContent AskPosthook = NoContent +getContent (Sibling s) = AbsoluteContent s +getContent (PosthookCmd s) = StringContent s +getContent RunPosthook = NoContent +getContent NoPrehook = NoContent +getContent RunPrehook = NoContent +getContent AskPrehook = NoContent +getContent StoreInMemory = NoContent +getContent HTTPPipelining = NoContent +getContent NoHTTPPipelining = NoContent +getContent NoCache = NoContent +getContent NullFlag = NoContent +getContent (PrehookCmd s) = StringContent s +getContent (UMask s) = StringContent s +getContent AllowUnrelatedRepos = NoContent +getContent Check = NoContent +getContent Repair = NoContent + +get_content :: DarcsFlag -> Maybe String +get_content f = do StringContent s <- Just $ getContent f + return s + +-- | @a `'isa'` b@ tests whether @a@ is flag @b@ with a string argument. +-- @b@ typically is a Flag constructor expecting a string +-- For example, @(Author \"Ted Hughes\") `isa` Author@ returns true. +isa :: DarcsFlag -> (String -> DarcsFlag) -> Bool +a `isa` b = case get_content a of + Nothing -> False + Just s -> a == b s + +-- | @a `'isAnAbsolute'` b@ tests whether @a@ is flag @b@ with an absolute path argument. +-- @b@ typically is a Flag constructor expecting an absolute path argument +-- For example, @(Context contextfile) `isAnAbsolute` Context@ returns true. +isAnAbsolute :: DarcsFlag -> (AbsolutePath -> DarcsFlag) -> Bool +isAnAbsolute f x = case getContent f of + AbsoluteContent s -> f == x s + _ -> False + +-- | @a `'isAnAbsoluteOrStd'` b@ tests whether @a@ is flag @b@ with a path argument. +-- @b@ typically is a Flag constructor expecting a path argument +-- For example, @(Output o) `isAnAbsoluteOrStd` @ returns true. +isAnAbsoluteOrStd :: DarcsFlag -> (AbsolutePathOrStd -> DarcsFlag) -> Bool +isAnAbsoluteOrStd f x = case getContent f of + AbsoluteOrStdContent s -> f == x s + _ -> False + +isin :: (String->DarcsFlag) -> [DarcsFlag] -> Bool +f `isin` fs = any (`isa` f) fs + +arein :: [DarcsOption] -> [DarcsFlag] -> Bool +(DarcsNoArgOption _ _ f _ : dos') `arein` fs + = f `elem` fs || dos' `arein` fs +(DarcsArgOption _ _ f _ _ : dos') `arein` fs + = f `isin` fs || dos' `arein` fs +(DarcsAbsPathOption _ _ f _ _ : dos') `arein` fs + = any (`isAnAbsolute` f) fs || dos' `arein` fs +(DarcsAbsPathOrStdOption _ _ f _ _ : dos') `arein` fs + = any (`isAnAbsoluteOrStd` f) fs || dos' `arein` fs +(DarcsOptAbsPathOption _ _ _ f _ _ : dos') `arein` fs + = any (`isAnAbsolute` f) fs || dos' `arein` fs +(DarcsMultipleChoiceOption os: dos') `arein` fs + = os `arein` fs || dos' `arein` fs +[] `arein` _ = False + +-- | A type for darcs' options. The value contains the command line +-- switch(es) for the option, a help string, and a function to build a +-- @DarcsFlag@ from the command line arguments. for each constructor, +-- 'shortSwitches' represents the list of short command line switches +-- which invoke the option, longSwitches the list of long command line +-- switches, optDescr the description of the option, and argDescr the description +-- of its argument, if any. mkFlag is a function which makes a @DarcsFlag@ from +-- the arguments of the option. +data DarcsOption + = DarcsArgOption [Char] [String] (String->DarcsFlag) String String + -- ^ @DarcsArgOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@ + -- The constructor for options with a string argument, such as + -- @--tag@ + + | DarcsAbsPathOption [Char] [String] (AbsolutePath -> DarcsFlag) String String + -- ^ @DarcsAbsPathOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@ + -- The constructor for options with an absolute path argument, such as + -- @--sibling@ + + | DarcsAbsPathOrStdOption [Char] [String] (AbsolutePathOrStd -> DarcsFlag) String String + -- ^ @DarcsAbsPathOrStdOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@ + -- The constructor for options with a path argument, such as @-o@ + + | DarcsOptAbsPathOption [Char] [String] String (AbsolutePath -> DarcsFlag) String String + -- ^ @DarcsOptAbsPathOrStdOption shortSwitches longSwitches defaultPath + -- mkFlag ArgDescr OptDescr@ where defaultPath is a default value + -- for the Path, as a string to be parsed as if it had been given + -- on the command line. + -- The constructor for options with an optional path argument, such as @-O@ + + | DarcsNoArgOption [Char] [String] DarcsFlag String + -- ^ @DarcsNoArgOption shortSwitches longSwitches mkFlag optDescr@ + -- The constructon fon options with no arguments. + + | DarcsMultipleChoiceOption [DarcsOption] + -- ^ A constructor for grouping related options together, such as + -- @--hashed@, @--darcs-2@ and @--old-fashioned-inventory@. + +option_from_darcsoption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag] +option_from_darcsoption _ (DarcsNoArgOption a b c h) = [Option a b (NoArg c) h] +option_from_darcsoption _ (DarcsArgOption a b c n h) = [Option a b (ReqArg c n) h] +option_from_darcsoption wd (DarcsMultipleChoiceOption os) = concatMap (option_from_darcsoption wd) os +option_from_darcsoption wd (DarcsAbsPathOrStdOption a b c n h) = [Option a b (ReqArg (c . makeAbsoluteOrStd wd) n) h] +option_from_darcsoption wd (DarcsAbsPathOption a b c n h) = [Option a b (ReqArg (c . makeAbsolute wd) n) h] +option_from_darcsoption wd (DarcsOptAbsPathOption a b d c n h) = [Option a b (OptArg (c . makeAbsolute wd . fromMaybe d) n) h] + +-- | 'concat_option' creates a DarcsMultipleChoiceOption from a list of +-- option, flattening any DarcsMultipleChoiceOption in the list. +concat_options :: [DarcsOption] -> DarcsOption +concat_options os = DarcsMultipleChoiceOption $ concatMap from_option os + where + from_option (DarcsMultipleChoiceOption xs) = xs + from_option x = [x] + +extract_fix_path :: [DarcsFlag] -> Maybe (AbsolutePath, AbsolutePath) +extract_fix_path [] = Nothing +extract_fix_path ((FixFilePath repo orig):_) = Just (repo, orig) +extract_fix_path (_:fs) = extract_fix_path fs + +fixFilePath :: [DarcsFlag] -> FilePath -> IO AbsolutePath +fixFilePath opts f = case extract_fix_path opts of + Nothing -> bug "Can't fix path in fixFilePath" + Just (_,o) -> withCurrentDirectory o $ ioAbsolute f + +fixFilePathOrStd :: [DarcsFlag] -> FilePath -> IO AbsolutePathOrStd +fixFilePathOrStd opts f = + case extract_fix_path opts of + Nothing -> bug "Can't fix path in fixFilePathOrStd" + Just (_,o) -> withCurrentDirectory o $ ioAbsoluteOrStd f + +fixUrl :: [DarcsFlag] -> String -> IO String +fixUrl opts f = if is_file f + then toFilePath `fmap` fixFilePath opts f + else return f + +fixSubPaths :: [DarcsFlag] -> [FilePath] -> IO [SubPath] +fixSubPaths flags fs = + withCurrentDirectory o $ + do fixedfs <- mapM fixit $ filter (not.null) fs + let (good, bad) = partitionEither fixedfs + unless (null bad) $ + putStrLn $ "Ignoring non-repository paths: " ++ unwords bad + return $ nub good + where + (r,o) = case extract_fix_path flags of + Just xxx -> xxx + Nothing -> bug "Can't fix path in fixSubPaths" + fixit p = do ap <- ioAbsolute p + case makeSubPathOf r ap of + Just sp -> return $ Right sp + Nothing -> return $ maybe (Left p) Right $ simpleSubPath p + +partitionEither :: [Either a b] -> ([b],[a]) +partitionEither es = ( [b | Right b <- es] + , [a | Left a <- es] ) + +-- as opposed to just '.' +areFileArgs :: [SubPath] -> Bool +areFileArgs rps = concatMap toFilePath rps /= "" + +-- | 'list_option' is an option which lists the command's arguments +list_options :: DarcsOption +list_options = DarcsNoArgOption [] ["list-options"] ListOptions + "simply list the command's arguments" + +flagToString :: [DarcsOption] -> DarcsFlag -> Maybe String +flagToString x f = maybeHead $ catMaybes $ map f2o x + where f2o (DarcsArgOption _ (s:_) c _ _) = do arg <- get_content f + if c arg == f + then return $ unwords [('-':'-':s), arg] + else Nothing + f2o (DarcsNoArgOption _ (s:_) f' _) | f == f' = Just ('-':'-':s) + f2o (DarcsMultipleChoiceOption xs) = maybeHead $ catMaybes $ map f2o xs + f2o _ = Nothing + maybeHead (a:_) = Just a + maybeHead [] = Nothing + +reponame :: DarcsOption +tagname :: DarcsOption +deps_sel :: DarcsOption +checkpoint :: DarcsOption +partial :: DarcsOption +partial_check :: DarcsOption +tokens :: DarcsOption +working_repo_dir :: DarcsOption +possibly_remote_repo_dir :: DarcsOption +disable :: DarcsOption +restrict_paths :: DarcsOption + +pipe_interactive, all_pipe_interactive, all_interactive, all_patches, interactive, pipe, + human_readable, diffflags, allow_problematic_filenames, noskip_boring, + ask_long_comment, match_one_nontag, changes_reverse, creatorhash, + changes_format, match_one_context, happy_forwarding, send_to_context, + diff_cmd_flag, store_in_memory, use_external_merge, + pull_conflict_options, target, cc, apply_conflict_options, reply, xmloutput, + distname_option, patchname_option, edit_description, + output, output_auto_name, unidiff, repo_combinator, + unified, summary, uncompress_nocompress, subject, in_reply_to, + nocompress, match_several_or_range, match_several_or_last, + author, askdeps, lookforadds, ignoretimes, test, notest, help, force_replace, + allow_unrelated_repos, + match_one, match_range, match_several, fancy_move_add, sendmail_cmd, + logfile, rmlogfile, leave_test_dir, from_opt, set_default + + :: DarcsOption + +recursive :: String -> DarcsOption + +sign, applyas, verify :: DarcsOption +\end{code} + +\section{Common options to darcs commands} + +\begin{options} +--help +\end{options} +Every \verb|COMMAND| accepts \verb!--help! as an argument, which tells it to +provide a bit of help. Among other things, this help always provides an +accurate listing of the options available with that command, and is +guaranteed never to be out of sync with the version of darcs you actually +have installed (unlike this manual, which could be for an entirely +different version of darcs). +\begin{verbatim} +% darcs COMMAND --help +\end{verbatim} +\begin{code} +help = DarcsNoArgOption ['h'] ["help"] Help + "shows brief description of command and its arguments" +\end{code} + +\begin{options} +--disable +\end{options} +Every {\tt COMMAND} accepts the \verb!--disable! option, which can be used in +\verb!_darcs/prefs/defaults! to disable some commands in the repository. This +can be helpful if you want to protect the repository from accidental use of +advanced commands like obliterate, unpull, unrecord or amend-record. +\begin{code} +disable = DarcsNoArgOption [] ["disable"] Disable + "disable this command" +\end{code} + +\begin{options} +--verbose, --quiet, --normal-verbosity +\end{options} +Most commands also accept the \verb!--verbose! option, which tells darcs to +provide additional output. The amount of verbosity varies from command to +command. Commands that accept \verb!--verbose\verb! also accept \verb!--quiet\verb!, +which surpresses non-error output, and \verb!--normal-verbosity\verb! which can be +used to restore the default verbosity if \verb!--verbose! or \verb!--quiet! is in +the defaults file. + +\begin{options} +--debug, --debug-http +\end{options} +Many commands also accept the \verb!--debug! option, which causes darcs to generate +additional output that may be useful for debugging its behavior, but which otherwise +would not be interesting. Option \verb!--debug-http! makes darcs output debugging +info for libcurl. +\begin{code} +any_verbosity :: [DarcsOption] +any_verbosity =[DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["debug"] Debug + "give only debug output", + DarcsNoArgOption [] ["debug-verbose"] DebugVerbose + "give debug and verbose output", + DarcsNoArgOption [] ["debug-http"] DebugHTTP + "give debug output for libcurl", + DarcsNoArgOption ['v'] ["verbose"] Verbose + "give verbose output", + DarcsNoArgOption ['q'] ["quiet"] Quiet + "suppress informational output", + DarcsNoArgOption [] ["standard-verbosity"] NormalVerbosity + "neither verbose nor quiet output"], + DarcsNoArgOption [] ["timings"] Timings "provide debugging timings information"] +\end{code} + +\begin{options} +--repodir +\end{options} +Another common option is the \verb!--repodir! option, which allows you to +specify the directory of the repository in which to perform the command. +This option is used with commands, such as whatsnew, that ordinarily would +be performed within a repository directory, and allows you to use those +commands without actually being in the repository directory when calling the +command. This is useful when running darcs in a pipe, as might be the case +when running \verb'apply' from a mailer. + +\begin{code} +working_repo_dir = DarcsArgOption [] ["repodir"] WorkRepoDir "DIRECTORY" + "specify the repository directory in which to run" +possibly_remote_repo_dir = DarcsArgOption [] ["repo"] WorkRepoUrl "URL" + "specify the repository URL" + +-- | 'get_repourl' takes a list of flags and returns the url of the +-- repository specified by @Repodir \"directory\"@ in that list of flags, if any. +-- This flag is present if darcs was invoked with @--repodir=DIRECTORY@ +get_repourl :: [DarcsFlag] -> Maybe String +get_repourl [] = Nothing +get_repourl (WorkRepoUrl d:_) | not (is_file d) = Just d +get_repourl (_:fs) = get_repourl fs +\end{code} + +\begin{options} +--remote-repo +\end{options} + +Some commands, such as \verb'pull' require a remote repository to be specified, +either from the command line or as a default. The \verb!--remote-repo! +provides an alternative way to supply this remote repository path. This flag +can be seen as temporarily ``replacing'' the default repository. Setting it +causes the command to ignore the default repository (it also does not affect, +i.e. overwrite the default repository). On the other hand, if any other +repositories are supplied as command line arguments, this flag will be ignored +(and the default repository may be overwritten). + +\begin{code} +-- | 'remote_repo' is the option used to specify the URL of the remote +-- repository to work with +remote_repo :: DarcsOption +remote_repo = DarcsArgOption [] ["remote-repo"] RemoteRepo "URL" + "specify the remote repository URL to work with" +\end{code} + +\input{Darcs/Match.lhs} +\input{Darcs/Patch/Match.lhs} + +\begin{code} +patchname_option = DarcsArgOption ['m'] ["patch-name"] PatchName "PATCHNAME" + "name of patch" + +send_to_context = DarcsAbsPathOption [] ["context"] Context "FILENAME" + "send to context stored in FILENAME" + +match_one_context = + DarcsMultipleChoiceOption + [DarcsArgOption [] ["to-match"] mp "PATTERN" + "select changes up to a patch matching PATTERN", + DarcsArgOption [] ["to-patch"] OnePatch "REGEXP" + "select changes up to a patch matching REGEXP", + __tag, + DarcsAbsPathOption [] ["context"] Context "FILENAME" + "version specified by the context in FILENAME" + ] + where mp s = OnePattern (patch_match s) + +match_one = concat_options [__match, __patch, __tag, __index] +match_one_nontag = concat_options [__match, __patch, __index] +match_several = concat_options [__matches, __patches, __tags] +match_range = concat_options [match_to, match_from, __match, __patch, __last, __indexes] +match_several_or_range = concat_options [match_to, match_from, __last, __indexes, + __matches, __patches, __tags] +match_several_or_last = concat_options [match_from, __last, __matches, __patches, __tags] + +match_to, match_from :: DarcsOption +match_to = DarcsMultipleChoiceOption + [DarcsArgOption [] ["to-match"] uptop "PATTERN" + "select changes up to a patch matching PATTERN", + DarcsArgOption [] ["to-patch"] UpToPatch "REGEXP" + "select changes up to a patch matching REGEXP", + DarcsArgOption [] ["to-tag"] UpToTag "REGEXP" + "select changes up to a tag matching REGEXP"] + where uptop s = UpToPattern (patch_match s) +match_from = DarcsMultipleChoiceOption + [DarcsArgOption [] ["from-match"] fromp "PATTERN" + "select changes starting with a patch matching PATTERN", + DarcsArgOption [] ["from-patch"] AfterPatch "REGEXP" + "select changes starting with a patch matching REGEXP", + DarcsArgOption [] ["from-tag"] AfterTag "REGEXP" + "select changes starting with a tag matching REGEXP"] + where fromp s = AfterPattern (patch_match s) + +__tag, __tags, __patch, __patches, __match, __matches, __last, __index, __indexes :: DarcsOption + +__tag = DarcsArgOption ['t'] ["tag"] OneTag "REGEXP" + "select tag matching REGEXP" +__tags = DarcsArgOption ['t'] ["tags"] OneTag "REGEXP" + "select tags matching REGEXP" + +__patch = DarcsArgOption ['p'] ["patch"] OnePatch "REGEXP" + "select a single patch matching REGEXP" +__patches = DarcsArgOption ['p'] ["patches"] SeveralPatch "REGEXP" + "select patches matching REGEXP" + +__match = DarcsArgOption [] ["match"] mp "PATTERN" + "select a single patch matching PATTERN" + where mp s = OnePattern (patch_match s) +__matches = DarcsArgOption [] ["matches"] mp "PATTERN" + "select patches matching PATTERN" + where mp s = SeveralPattern (patch_match s) + +__last = DarcsArgOption [] ["last"] lastn "NUMBER" + "select the last NUMBER patches" + where lastn = LastN . number_string + +__index = DarcsArgOption ['n'] ["index"] indexrange "N" "select one patch" + where indexrange s = if all isDigit s + then PatchIndexRange (read s) (read s) + else PatchIndexRange 0 0 + +__indexes = DarcsArgOption ['n'] ["index"] indexrange "N-M" "select a range of patches" + where indexrange s = if all isokay s + then if '-' `elem` s + then let x1 = takeWhile (/= '-') s + x2 = reverse $ takeWhile (/= '-') $ reverse s + in PatchIndexRange (read x1) (read x2) + else PatchIndexRange (read s) (read s) + else PatchIndexRange 0 0 + isokay c = isDigit c || c == '-' + +match_maxcount :: DarcsOption +match_maxcount = DarcsArgOption [] ["max-count"] mc "NUMBER" + "return only NUMBER results" + where mc = MaxCount . number_string + + +-- | 'get_context' takes a list of flags and returns the context +-- specified by @Context c@ in that list of flags, if any. +-- This flag is present if darcs was invoked with @--context=FILE@ +get_context :: [DarcsFlag] -> Maybe AbsolutePath +get_context xs = listToMaybe [ c | Context c <- xs ] + +notest = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script", + DarcsNoArgOption [] ["test"] Test "run the test script"] +test = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["test"] Test "run the test script", + DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script"] +leave_test_dir = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["leave-test-directory"] + LeaveTestDir "don't remove the test directory", + DarcsNoArgOption [] ["remove-test-directory"] + NoLeaveTestDir "remove the test directory"] + +testByDefault :: [DarcsFlag] -> [DarcsFlag] +testByDefault o = if NoTest `elem` o then o else Test:o +\end{code} + +\begin{options} +--ignore-times +\end{options} +Darcs optimizes its operations by keeping track of the modification times +of your files. This dramatically speeds up commands such as +\verb!whatsnew! and \verb!record! which would otherwise require reading +every file in the repository and comparing it with a reference version. However, +there are times when this can cause problems, such as when running a series +of darcs commands from a script, in which case often a file will be +modified twice in the same second, which can lead to the second +modification going unnoticed. The solution to such predicaments is the +\verb!--ignore-times! option, which instructs darcs not to trust the file +modification times, but instead to check each file's contents explicitly. +\begin{code} +ignoretimes = DarcsNoArgOption [] ["ignore-times"] IgnoreTimes + "don't trust the file modification times" +lookforadds = + DarcsMultipleChoiceOption + [DarcsNoArgOption ['l'] ["look-for-adds"] LookForAdds + "look for (non-boring) files that could be added", + DarcsNoArgOption [] ["dont-look-for-adds"] NoLookForAdds + "don't look for any files that could be added [DEFAULT]"] + +fancy_move_add = + DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["date-trick"] FancyMoveAdd + "add files with date appended to avoid conflict [EXPERIMENTAL] ", + DarcsNoArgOption [] ["no-date-trick"] NoFancyMoveAdd + "don't use experimental date appending trick [DEFAULT]"] + +askdeps = + DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["ask-deps"] AskDeps + "ask for extra dependencies", + DarcsNoArgOption [] ["no-ask-deps"] NoAskDeps + "don't ask for extra dependencies"] + +ask_long_comment = + DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["edit-long-comment"] EditLongComment + "edit the long comment by default", + DarcsNoArgOption [] ["skip-long-comment"] NoEditLongComment + "don't give a long comment", + DarcsNoArgOption [] ["prompt-long-comment"] PromptLongComment + "prompt for whether to edit the long comment"] +\end{code} + +\begin{options} +--author +\end{options} +\label{env:DARCS_EMAIL} +Several commands need to be able to identify you. Conventionally, you +provide an email address for this purpose, which can include comments, +e.g.\ \verb!David Roundy !. The easiest way to do +this is +to define an environment variable \verb!EMAIL! or \verb!DARCS_EMAIL! (with +the latter overriding the former). You can also override this using the +\verb!--author! flag to any command. Alternatively, you could set your +email address on a per-repository basis using the ``defaults'' mechanism +for ``ALL'' commands, as described in Appendix~\ref{repository_format}. +Or, you could specify the author on a per-repository basis using the +\verb!_darcs/prefs/author! file as described in section~\ref{author_prefs}. + +Also, a global author file can be created in your home directory with the name +\verb!.darcs/author!, on MS Windows~\ref{ms_win}. This file overrides the +contents of the environment variables, but a repository-specific author +file overrides the global author file. + +\begin{code} +logfile = DarcsAbsPathOption [] ["logfile"] LogFile "FILE" + "give patch name and comment in file" + +rmlogfile = DarcsNoArgOption [] ["delete-logfile"] RmLogFile + "delete the logfile when done" + +author = DarcsArgOption ['A'] ["author"] Author "EMAIL" "specify author id" +from_opt = DarcsArgOption [] ["from"] Author "EMAIL" "specify email address" + +-- | 'get_author' takes a list of flags and returns the author of the +-- change specified by @Author \"Leo Tolstoy\"@ in that list of flags, if any. +-- Otherwise, if @Pipe@ is present, asks the user who is the author and +-- returns the answer. If neither are present, try to guess the author, +-- from @_darcs/prefs@, and if it's not possible, ask the user. +get_author :: [DarcsFlag] -> IO String +get_author (Author a:_) = return a +get_author (Pipe:_) = do askUser "Who is the author? " +get_author (_:flags) = get_author flags +get_author [] = do + easy_author <- get_easy_author + case easy_author of + Just a -> return a + Nothing -> do + aminrepo <- doesDirectoryExist (darcsdir++"/prefs") + if aminrepo then do + putDocLn $ + text "Each patch is attributed to its author, usually by email address (for" $$ + text "example, `Fred Bloggs '). Darcs could not determine" $$ + text "your email address, so you will be prompted for it." $$ + text "" $$ + text ("Your address will be stored in " ++ darcsdir ++ "/prefs/author.") $$ + text "It will be used for all patches recorded in this repository." $$ + text "If you move that file to ~/.darcs/author, it will be used for patches" $$ + text "you record in ALL repositories." + add <- askUser "What is your email address? " + writeFile (darcsdir++"/prefs/author") add + return add + else askUser "What is your email address (e.g. Fred Bloggs )? " + +-- | 'get_easy_author' tries to get the author name first from the repository preferences, +-- then from global preferences, then from environment variables. Returns 'Nothing' if it +-- could not get it. +get_easy_author :: IO (Maybe String) +get_easy_author = firstJustIO [ firstNotBlank `fmap` get_preflist "author", + firstNotBlank `fmap` get_global "author", + maybeGetEnv "DARCS_EMAIL", + maybeGetEnv "EMAIL" ] +\end{code} + +\begin{options} +--dont-compress, --compress +\end{options} +By default, darcs commands that write patches to disk will compress the +patch files. If you don't want this, you can choose the +\verb!--dont-compress! option, which causes darcs not to compress the patch +file. + +\begin{code} +nocompress = concat_options [__compress, __dont_compress] +uncompress_nocompress = concat_options [__compress, __dont_compress, __uncompress] + +__compress, __dont_compress, __uncompress :: DarcsOption +__compress = DarcsNoArgOption [] ["compress"] Compress + "create compressed patches" +__dont_compress = DarcsNoArgOption [] ["dont-compress"] NoCompress + "don't create compressed patches" +__uncompress = DarcsNoArgOption [] ["uncompress"] UnCompress + "uncompress patches" + +summary = DarcsMultipleChoiceOption + [DarcsNoArgOption ['s'] ["summary"] Summary "summarize changes", + DarcsNoArgOption [] ["no-summary"] NoSummary "don't summarize changes"] +unified = DarcsNoArgOption ['u'] ["unified"] Unified + "output patch in a darcs-specific format similar to diff -u" +unidiff = DarcsNoArgOption ['u'] ["unified"] Unified + "pass -u option to diff" +diff_cmd_flag = DarcsArgOption [] ["diff-command"] + DiffCmd "COMMAND" "specify diff command (ignores --diff-opts)" +store_in_memory = DarcsNoArgOption [] ["store-in-memory"] StoreInMemory + "do patch application in memory rather than on disk" + +target = DarcsArgOption [] ["to"] Target "EMAIL" "specify destination email" +cc = DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s). Requires --reply" + +-- |'get_cc' takes a list of flags and returns the addresses to send a copy of +-- the patch bundle to when using @darcs send@. +-- looks for a cc address specified by @Cc \"address\"@ in that list of flags. +-- Returns the addresses as a comma separated string. +get_cc :: [DarcsFlag] -> String +get_cc fs = lt $ catMaybes $ map whatcc fs + where whatcc (Cc t) = Just t + whatcc _ = Nothing + lt [t] = t + lt [t,""] = t + lt (t:ts) = t++" , "++lt ts + lt [] = "" + +subject = DarcsArgOption [] ["subject"] Subject "SUBJECT" "specify mail subject" + +-- |'get_subject' takes a list of flags and returns the subject of the mail +-- to be sent by @darcs send@. Looks for a subject specified by +-- @Subject \"subject\"@ in that list of flags, if any. +-- This flag is present if darcs was invoked with @--subject=SUBJECT@ +get_subject :: [DarcsFlag] -> Maybe String +get_subject (Subject s:_) = Just s +get_subject (_:fs) = get_subject fs +get_subject [] = Nothing + +in_reply_to = DarcsArgOption [] ["in-reply-to"] InReplyTo "EMAIL" "specify in-reply-to header" +get_in_reply_to :: [DarcsFlag] -> Maybe String +get_in_reply_to (InReplyTo s:_) = Just s +get_in_reply_to (_:fs) = get_in_reply_to fs +get_in_reply_to [] = Nothing + +output = DarcsAbsPathOrStdOption ['o'] ["output"] Output "FILE" + "specify output filename" + +output_auto_name = DarcsOptAbsPathOption ['O'] ["output-auto-name"] "." OutputAutoName "DIRECTORY" + "output to automatically named file in DIRECTORY, default: current directory" + +edit_description = + DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["edit-description"] EditDescription + "edit the patch bundle description", + DarcsNoArgOption [] ["dont-edit-description"] NoEditDescription + "don't edit the patch bundle description"] + +distname_option = DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME" + "name of version" + +recursive h + = DarcsMultipleChoiceOption + [DarcsNoArgOption ['r'] ["recursive"] Recursive h, + DarcsNoArgOption [] ["not-recursive"] NoRecursive ("don't "++h)] + +inventory_choices :: DarcsOption +inventory_choices = + DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["hashed"] UseHashedInventory + "Some new features. Compatible with older repos", + DarcsNoArgOption [] ["darcs-2"] UseFormat2 + "All features. Related repos must use same format [DEFAULT]", + DarcsNoArgOption [] ["old-fashioned-inventory"] UseOldFashionedInventory + "Minimal features. What older repos use."] + +get_inventory_choices :: DarcsOption +get_inventory_choices = + DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["hashed"] UseHashedInventory + "Convert darcs-1 format to hashed format", + DarcsNoArgOption [] ["old-fashioned-inventory"] UseOldFashionedInventory + "Convert from hashed to darcs-1 format"] + +xmloutput = DarcsNoArgOption [] ["xml-output"] XMLOutput + "generate XML formatted output" + +creatorhash = DarcsArgOption [] ["creator-hash"] CreatorHash "HASH" + "specify hash of creator patch (see docs)" + +sign = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["sign"] Sign + "sign the patch with your gpg key", + DarcsArgOption [] ["sign-as"] SignAs "KEYID" + "sign the patch with a given keyid", + DarcsArgOption [] ["sign-ssl"] SignSSL "IDFILE" + "sign the patch using openssl with a given private key", + DarcsNoArgOption [] ["dont-sign"] NoSign + "don't sign the patch"] +applyas = DarcsMultipleChoiceOption + [DarcsArgOption [] ["apply-as"] ApplyAs "USERNAME" + "apply patch as another user using sudo", + DarcsNoArgOption [] ["apply-as-myself"] NonApply + "don't use sudo to apply as another user [DEFAULT]"] +happy_forwarding = DarcsNoArgOption [] ["happy-forwarding"] HappyForwarding + "forward unsigned messages without extra header" +set_default = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["set-default"] SetDefault + "set default repository [DEFAULT]", + DarcsNoArgOption [] ["no-set-default"] NoSetDefault + "don't set default repository"] + +verify = DarcsMultipleChoiceOption + [DarcsAbsPathOption [] ["verify"] Verify "PUBRING" + "verify that the patch was signed by a key in PUBRING", + DarcsAbsPathOption [] ["verify-ssl"] VerifySSL "KEYS" + "verify using openSSL with authorized keys from file KEYS", + DarcsNoArgOption [] ["no-verify"] NonVerify + "don't verify patch signature"] + +reponame = DarcsArgOption [] ["repo-name","repodir"] NewRepo "DIRECTORY" + "path of output directory" --repodir is there for compatibility + --should be removed eventually +tagname = DarcsArgOption ['t'] ["tag"] TagName "TAGNAME" + "name of version to checkpoint" +deps_sel = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["no-deps"] DontGrabDeps + "don't automatically fulfill dependencies", + DarcsNoArgOption [] ["dont-prompt-for-dependencies"] DontPromptForDependencies + "don't ask about patches that are depended on by matched patches (with --match or --patch)", + DarcsNoArgOption [] ["prompt-for-dependencies"] PromptForDependencies + "prompt about patches that are depended on by matched patches [DEFAULT]"] +checkpoint = DarcsNoArgOption [] ["checkpoint"] CheckPoint + "create a checkpoint file (see get --partial)" +tokens = DarcsArgOption [] ["token-chars"] Toks "\"[CHARS]\"" + "define token to contain these characters" + +partial = concat_options [__partial, __lazy, __ephemeral, __complete] +partial_check = concat_options [__complete, __partial] + +__partial, __lazy, __ephemeral, __complete :: DarcsOption +__partial = DarcsNoArgOption [] ["partial"] Partial + "get partial repository using checkpoint (old-fashioned format only)" +__lazy = DarcsNoArgOption [] ["lazy"] Lazy + "get patch files only as needed" +__ephemeral = DarcsNoArgOption [] ["ephemeral"] Ephemeral + "don't save patch files in the repository" +__complete = DarcsNoArgOption [] ["complete"] Complete + "get a complete copy of the repository" + +force_replace = DarcsMultipleChoiceOption + [DarcsNoArgOption ['f'] ["force"] ForceReplace + "proceed with replace even if 'new' token already exists", + DarcsNoArgOption [] ["no-force"] + NonForce "don't force the replace if it looks scary"] + +reply = DarcsArgOption [] ["reply"] Reply "FROM" "reply to email-based patch using FROM address" +apply_conflict_options + = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["mark-conflicts"] + MarkConflicts "mark conflicts", + DarcsNoArgOption [] ["allow-conflicts"] + AllowConflicts "allow conflicts, but don't mark them", + DarcsNoArgOption [] ["no-resolve-conflicts"] NoAllowConflicts + "equivalent to --dont-allow-conflicts, for backwards compatibility", + DarcsNoArgOption [] ["dont-allow-conflicts"] + NoAllowConflicts "fail on patches that create conflicts [DEFAULT]"] +pull_conflict_options + = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["mark-conflicts"] + MarkConflicts "mark conflicts [DEFAULT]", + DarcsNoArgOption [] ["allow-conflicts"] + AllowConflicts "allow conflicts, but don't mark them", + DarcsNoArgOption [] ["dont-allow-conflicts"] + NoAllowConflicts "fail on patches that create conflicts"] +use_external_merge = DarcsArgOption [] ["external-merge"] + ExternalMerge "COMMAND" "use external tool to merge conflicts" +\end{code} + +\begin{options} +--dry-run +\end{options} +The \verb!--dry-run! option will cause darcs not to actually take the specified +action, but only print what would have happened. Not all commands accept +\verb!--dry-run!, but those that do should accept the \verb!--summary! option. + +\begin{options} +--summary, --no-summary +\end{options} +The \verb!--summary! option shows a summary of the patches that would have been +pulled/pushed/whatever. The format is similar to the output format of +\verb!cvs update! and looks like this: + +\begin{verbatim} +A ./added_but_not_recorded.c +A! ./added_but_not_recorded_conflicts.c +a ./would_be_added_if_look_for_adds_option_was_used.h + +M ./modified.t -1 +1 +M! ./modified_conflicts.t -1 +1 + +R ./removed_but_not_recorded.c +R! ./removed_but_not_recorded_conflicts.c + +\end{verbatim} + +You can probably guess what the flags mean from the clever file names. +\begin{description} +\item{\texttt{A}} is for files that have been added but not recorded yet. +\item{\texttt{a}} is for files found using the \verb!--look-for-adds! option available for +\verb!whatsnew! and \verb!record!. They have not been added yet, but would be +added automatically if \verb!--look-for-adds! were used with the next +\verb!record! command. + +\item{\texttt{M}} is for files that have been modified in the working directory but not +recorded yet. The number of added and subtracted lines is also shown. + +\item{\texttt{R}} is for files that have been removed, but the removal is not +recorded yet. +\end{description} +An exclamation mark appears next to any option that has a conflict. + +\begin{code} +-- NOTE: I'd rather work to have no uses of dry_run_noxml, so that any time +-- --dry-run is a possibility, automated users can examine the results more +-- easily with --xml. +dry_run_noxml :: DarcsOption +dry_run_noxml = DarcsNoArgOption [] ["dry-run"] DryRun + "don't actually take the action" + +dry_run :: [DarcsOption] +dry_run = [dry_run_noxml, xmloutput] + +-- | @'showFriendly' flags patch@ returns a 'Doc' representing the right +-- way to show @patch@ given the list @flags@ of flags darcs was invoked with. +showFriendly :: Patchy p => [DarcsFlag] -> p C(x y) -> Doc +showFriendly opts p | Verbose `elem` opts = showNicely p + | Summary `elem` opts = Darcs.Patch.summary p + | otherwise = description p + +-- | @'print_dry_run_message_and_exit' action opts patches@ prints a string +-- representing the action that would be taken if the @--dry-run@ option +-- had not been passed to darcs. Then darcs exits successfully. +-- @action@ is the name of the action being taken, like @\"push\"@ +-- @opts@ is the list of flags which were sent to darcs +-- @patches@ is the sequence of patches which would be touched by @action@. +print_dry_run_message_and_exit :: RepoPatch p => String -> [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO () +print_dry_run_message_and_exit action opts patches = + do when (DryRun `elem` opts) $ do + putInfo $ text $ "Would " ++ action ++ " the following changes:" + putDocLn $ put_mode + putInfo $ text $ "" + putInfo $ text $ "Making no changes: this is a dry run." + exitWith ExitSuccess + when (All `elem` opts && Summary `elem` opts) $ do + putInfo $ text $ "Will " ++ action ++ " the following changes:" + putDocLn $ put_mode + where put_mode = if XMLOutput `elem` opts + then (text "" $$ + vcat (mapFL (indent . xml_info) patches) $$ + text "") + else (vsep $ mapFL (showFriendly opts) patches) + putInfo = if XMLOutput `elem` opts then \_ -> return () else putDocLn + xml_info pl + | Summary `elem` opts = xml_with_summary pl + | otherwise = (to_xml . info) pl + + xml_with_summary hp + | Just p <- hopefullyM hp = insert_before_lastline + (to_xml $ info hp) (indent $ xml_summary p) + xml_with_summary hp = to_xml (info hp) + indent = prefix " " + + +\end{code} + +\input{Darcs/Resolution.lhs} + +\begin{code} +noskip_boring = DarcsNoArgOption [] ["boring"] + Boring "don't skip boring files" +allow_problematic_filenames = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["case-ok"] AllowCaseOnly + "don't refuse to add files differing only in case" + ,DarcsNoArgOption [] ["reserved-ok"] AllowWindowsReserved + "don't refuse to add files with Windows-reserved names" + ] +diffflags = DarcsArgOption [] ["diff-opts"] + DiffFlags "OPTIONS" "options to pass to diff" + +changes_format = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["context"] + (Context rootDirectory) "give output suitable for get --context", + xmloutput, + human_readable, + DarcsNoArgOption [] ["number"] NumberPatches "number the changes", + DarcsNoArgOption [] ["count"] Count "output count of changes" + ] +changes_reverse = DarcsNoArgOption [] ["reverse"] Reverse + "show changes in reverse order" + +only_to_files :: DarcsOption +only_to_files = DarcsNoArgOption [] ["only-to-files"] OnlyChangesToFiles + "show only changes to specified files" + +human_readable = DarcsNoArgOption [] ["human-readable"] + HumanReadable "give human-readable output" +pipe = DarcsNoArgOption [] ["pipe"] Pipe "ask user interactively for the patch metadata" + +interactive = + DarcsNoArgOption ['i'] ["interactive"] Interactive + "prompt user interactively" +all_patches = DarcsNoArgOption ['a'] ["all"] All "answer yes to all patches" + +all_interactive = DarcsMultipleChoiceOption [all_patches, interactive] + +all_pipe_interactive + = DarcsMultipleChoiceOption [all_patches,pipe,interactive] + +pipe_interactive = + DarcsMultipleChoiceOption [pipe, interactive] + +repo_combinator = + DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["intersection"] Intersection + "take intersection of all repositories", + DarcsNoArgOption [] ["union"] Union + "take union of all repositories [DEFAULT]", + DarcsNoArgOption [] ["complement"] Complement + "take complement of repositories (in order listed)"] + +-- | 'list_files' returns the list of all non-boring files in the repository +list_files :: IO [String] +list_files = do s <- slurp_all_but_darcs "." + skip_boring <- boring_file_filter + return (map drop_dotslash $ skip_boring $ list_slurpy s) + +drop_dotslash :: String -> String +drop_dotslash ('.':'/':x) = drop_dotslash x +drop_dotslash x = x + +-- | 'list_unregistered_files' returns the list of all non-boring unregistered +-- files in the repository. +list_unregistered_files :: IO [String] +list_unregistered_files = withRepository [] $- \repository -> + do s <- slurp_all_but_darcs "." + skip_boring <- boring_file_filter + regs <- slurp_pending repository + return $ map drop_dotslash $ (skip_boring $ list_slurpy s) \\ (list_slurpy regs) + +-- | 'list_registered_files' returns the list of all registered files in the repository. +list_registered_files :: IO [String] +list_registered_files = + (map drop_dotslash . list_slurpy) `fmap` (withRepository [] slurp_pending) + +options_latex :: [DarcsOption] -> String +options_latex opts = "\\begin{tabular}{lll}\n"++ + unlines (map option_latex opts)++ + "\\end{tabular}\n" + +latex_help :: String -> String +latex_help h + = "\\begin{minipage}{7cm}\n\\raggedright\n" ++ h ++ "\\end{minipage}\n" + +option_latex :: DarcsOption -> String +option_latex (DarcsNoArgOption a b _ h) = + show_short_options a ++ show_long_options b ++ latex_help h ++ "\\\\" +option_latex (DarcsArgOption a b _ arg h) = + show_short_options a ++ + show_long_options (map (++(" "++arg)) b) ++ latex_help h ++ "\\\\" +option_latex (DarcsAbsPathOrStdOption a b _ arg h) = + show_short_options a ++ + show_long_options (map (++(" "++arg)) b) ++ latex_help h ++ "\\\\" +option_latex (DarcsAbsPathOption a b _ arg h) = + show_short_options a ++ + show_long_options (map (++(" "++arg)) b) ++ latex_help h ++ "\\\\" +option_latex (DarcsOptAbsPathOption a b _ _ arg h) = + show_short_options a ++ + show_long_options (map (++("[="++arg++"]")) b) ++ latex_help h ++ "\\\\" +option_latex (DarcsMultipleChoiceOption os) = + unlines (map option_latex os) + +show_short_options :: [Char] -> String +show_short_options [] = "&" +show_short_options [c] = "\\verb!-"++[c]++"! &" +show_short_options (c:cs) = "\\verb!-"++[c]++"!,"++show_short_options cs + +show_long_options :: [String] -> String +show_long_options [] = " &" +show_long_options [s] = "\\verb!--" ++ s ++ "! &" +show_long_options (s:ss) + = "\\verb!--" ++ s ++ "!,"++ show_long_options ss + +set_scripts_executable :: DarcsOption +set_scripts_executable = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["set-scripts-executable"] SetScriptsExecutable + "make scripts executable", + DarcsNoArgOption [] ["dont-set-scripts-executable"] DontSetScriptsExecutable + "don't make scripts executable"] + +relink, relink_pristine, sibling :: DarcsOption +relink = DarcsNoArgOption [] ["relink"] Relink + "relink random internal data to a sibling" + +relink_pristine = DarcsNoArgOption [] ["relink-pristine"] RelinkPristine + "relink pristine tree (not recommended)" + +sibling = DarcsAbsPathOption [] ["sibling"] Sibling "URL" + "specify a sibling directory" + +-- | 'flagsToSiblings' collects the contents of all @Sibling@ flags in a list of flags. +flagsToSiblings :: [DarcsFlag] -> [AbsolutePath] +flagsToSiblings ((Sibling s) : l) = s : (flagsToSiblings l) +flagsToSiblings (_ : l) = flagsToSiblings l +flagsToSiblings [] = [] + +nolinks :: DarcsOption +nolinks = DarcsNoArgOption [] ["nolinks"] NoLinks + "do not link repository or pristine to sibling" + +reorder_patches :: DarcsOption +reorder_patches = DarcsNoArgOption [] ["reorder-patches"] Reorder + "reorder the patches in the repository" +\end{code} +\begin{options} +--sendmail-command +\end{options} +\darcsEnv{SENDMAIL} + +\begin{code} +sendmail_cmd = DarcsArgOption [] ["sendmail-command"] SendmailCmd "COMMAND" "specify sendmail command" + +environmentHelpSendmail :: ([String], [String]) +environmentHelpSendmail = (["SENDMAIL"], [ + "On Unix, the `darcs send' command relies on sendmail(8). The", + "`--sendmail-command' or $SENDMAIL environment variable can be used to", + "provide an explicit path to this program; otherwise the standard", + "locations /usr/sbin/sendmail and /usr/lib/sendmail will be tried."]) +-- FIXME: mention the following also: +-- * sendmail(8) is not sendmail-specific; +-- * nowadays, desktops often have no MTA or an unconfigured MTA -- +-- which is awful, because it accepts mail but doesn't relay it; +-- * in this case, can be a sendmail(8)-emulating wrapper on top of an +-- MUA that sends mail directly to a smarthost; and +-- * on a multi-user system without an MTA and on which you haven't +-- got root, can be msmtp. + +-- |'get_sendmail_cmd' takes a list of flags and returns the sendmail command +-- to be used by @darcs send@. Looks for a command specified by +-- @SendmailCmd \"command\"@ in that list of flags, if any. +-- This flag is present if darcs was invoked with @--sendmail-command=COMMAND@ +-- Alternatively the user can set @$S@@ENDMAIL@ which will be used as a fallback if present. +get_sendmail_cmd :: [DarcsFlag] -> IO String +get_sendmail_cmd (SendmailCmd a:_) = return a +get_sendmail_cmd (_:flags) = get_sendmail_cmd flags +get_sendmail_cmd [] = do easy_sendmail <- firstJustIO [ maybeGetEnv "SENDMAIL" ] + case easy_sendmail of + Just a -> return a + Nothing -> return "" + +files :: DarcsOption +files = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["files"] Files + "include files in output [DEFAULT]", + DarcsNoArgOption [] ["no-files"] NoFiles + "don't include files in output"] + +directories :: DarcsOption +directories = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["directories"] Directories + "include directories in output [DEFAULT]", + DarcsNoArgOption [] ["no-directories"] NoDirectories + "don't include directories in output"] + +pending :: DarcsOption +pending = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["pending"] Pending + "reflect pending patches in output [DEFAULT]", + DarcsNoArgOption [] ["no-pending"] NoPending + "only included recorded patches in output"] + +nullFlag :: DarcsOption -- "null" is already taken +nullFlag = DarcsNoArgOption ['0'] ["null"] NullFlag + "separate file names by NUL characters" +\end{code} +\begin{options} +--posthook=COMMAND, --no-posthook +\end{options} +To provide a command that should be run whenever a darcs command completes +successfully, use \verb!--posthook! to specify the command. This is useful +for people who want to have a command run whenever a patch is applied. Using +\verb!--no-posthook! will disable running the command. +\begin{options} +--run-posthook, --prompt-posthook +\end{options} +These options control prompting before running the posthook. Use +\verb!--prompt-posthook! to have darcs prompt before running the +posthook command. You may use --run-posthook to reenable the default +behavior of running user-specified posthooks. + +Some darcs commands export to the posthook command information about the +changes being made. In particular, three environment variables are defined. +\verb!DARCS_PATCHES! contains a human-readable summary of the patches being +acted upon. The format is the same as "darcs changes". \verb!DARCS_PATCHES_XML! +Contains the same details, in the same XML format as "darcs changes". Finally, +\verb!DARCS_FILES! contains a list of the files affected, one file per line. +If your repository has filenames including newlines, you'll just have to +cope. Note, however, that \emph{none} of these environment variables are +defined when running under windows. Note also that we refuse to pass +environment variables greater in size than 10k, in order to avoid triggering +\verb!E2BIG! errors. + +\begin{code} +definePatches :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> IO () +#ifndef WIN32 +definePatches ps = do let k = "Defining environment variables" + beginTedious k + tediousSize k 3 + finishedOneIO k "DARCS_PATCHES" + setEnvCautiously "DARCS_PATCHES" (renderString $ Darcs.Patch.summary ps) + finishedOneIO k "DARCS_PATCHES_XML" + setEnvCautiously "DARCS_PATCHES_XML" + (renderString $ text "" $$ + vcat (mapFL (to_xml . info) ps) $$ + text "") + finishedOneIO k "DARCS_FILES" + setEnvCautiously "DARCS_FILES" (unlines$ list_touched_files ps) + endTedious k + +setEnvCautiously :: String -> String -> IO () +setEnvCautiously e v | toobig (10*1024) v = return () + | otherwise = setEnv e v True + where toobig :: Int -> [a] -> Bool + toobig 0 _ = True + toobig _ [] = False + toobig n (_:xs) = toobig (n-1) xs +#else +definePatches _ = return () +#endif + +defineChanges :: Patchy p => p C(x y) -> IO () +#ifndef WIN32 +defineChanges ps = setEnvCautiously "DARCS_FILES" (unlines $ list_touched_files ps) +#else +defineChanges _ = return () +#endif + +posthook_cmd :: DarcsOption +posthook_cmd = DarcsMultipleChoiceOption + [DarcsArgOption [] ["posthook"] PosthookCmd + "COMMAND" "specify command to run after this darcs command", + DarcsNoArgOption [] ["no-posthook"] NoPosthook + "don't run posthook command"] + +posthook_prompt :: DarcsOption +posthook_prompt = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["prompt-posthook"] AskPosthook + "prompt before running posthook [DEFAULT]", + DarcsNoArgOption [] ["run-posthook"] RunPosthook + "run posthook command without prompting"] + +-- | 'get_posthook_cmd' takes a list of flags and returns the posthook command +-- specified by @PosthookCmd a@ in that list of flags, if any. +get_posthook_cmd :: [DarcsFlag] -> Maybe String +get_posthook_cmd (PosthookCmd a:_) = Just a +get_posthook_cmd (_:flags) = get_posthook_cmd flags +get_posthook_cmd [] = Nothing +\end{code} +\begin{options} +--prehook=COMMAND, --no-prehook +\end{options} +To provide a command that should be run before a darcs command is executed, + use \verb!--prehook! to specify the command. An example use is +for people who want to have a command run whenever a patch is to be recorded, such as +translating line endings before recording patches. Using +\verb!--no-prehook! will disable running the command. +\begin{options} +--run-prehook, --prompt-prehook +\end{options} +These options control prompting before running the prehook. See the +posthook documentation above for details. +\begin{code} +prehook_cmd :: DarcsOption +prehook_cmd = DarcsMultipleChoiceOption + [DarcsArgOption [] ["prehook"] PrehookCmd + "COMMAND" "specify command to run before this darcs command", + DarcsNoArgOption [] ["no-prehook"] NoPrehook + "don't run prehook command"] + +prehook_prompt :: DarcsOption +prehook_prompt = DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["prompt-prehook"] AskPrehook + "prompt before running prehook [DEFAULT]", + DarcsNoArgOption [] ["run-prehook"] RunPrehook + "run prehook command without prompting"] + +-- | 'get_prehook_cmd' takes a list of flags and returns the prehook command +-- specified by @PrehookCmd a@ in that list of flags, if any. +get_prehook_cmd :: [DarcsFlag] -> Maybe String +get_prehook_cmd (PrehookCmd a:_) = Just a +get_prehook_cmd (_:flags) = get_prehook_cmd flags +get_prehook_cmd [] = Nothing +\end{code} + +\begin{options} +--ssh-cm, --no-ssh-cm +\end{options} + +For commands which invoke ssh, darcs will normally multiplex ssh +sessions over a single connection as long as your version of ssh has +the ControlMaster feature from OpenSSH versions 3.9 and above. This +option will avoid darcs trying to use this feature even if your ssh +supports it. + +\begin{options} +--http-pipelining, --no-http-pipelining +\end{options} + +When compiled with libcurl (version 7.18.0 and above), darcs can +use HTTP pipelining. It is enabled by default for libcurl +(version 7.19.1 and above). This option will make darcs enable or +disable HTTP pipelining, overwriting default. Note that if HTTP +pipelining is really used depends on the server. + +\begin{options} +--no-cache +\end{options} + +Do not use patch caches. +\begin{code} +network_options :: [DarcsOption] +network_options = + [DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["ssh-cm"] SSHControlMaster + "use SSH ControlMaster feature", + DarcsNoArgOption [] ["no-ssh-cm"] NoSSHControlMaster + "don't use SSH ControlMaster feature [DEFAULT]"], + DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["http-pipelining"] HTTPPipelining + pipelining_description, + DarcsNoArgOption [] ["no-http-pipelining"] NoHTTPPipelining + no_pipelining_description], + no_cache + ] + where pipelining_description = + "enable HTTP pipelining"++ + (if pipeliningEnabledByDefault then " [DEFAULT]" else "") + no_pipelining_description = + "disable HTTP pipelining"++ + (if pipeliningEnabledByDefault then "" else " [DEFAULT]") + +no_cache :: DarcsOption +no_cache = DarcsNoArgOption [] ["no-cache"] NoCache + "don't use patch caches" +\end{code} +\begin{options} +--umask +\end{options} +By default, Darcs will use your current umask. The option +\verb|--umask| will cause Darcs to switch to a different umask before +writing to the repository. + +\begin{code} +umask_option :: DarcsOption +umask_option = + DarcsArgOption [] ["umask"] UMask "UMASK" + "specify umask to use when writing" +\end{code} + +\begin{options} +--dont-restrict-paths, --restrict-paths +\end{options} +By default darcs is only allowed to manage and modify files and directories +contained inside the current repository and not being part of any darcs +repository's meta data (including the current one). This is mainly for +security, to protect you from spoofed patches modifying arbitrary files +with sensitive data---say, in your home directory---or tampering with any +repository's meta data to switch off this safety guard. + +But sometimes you may want to manage a group of ``sub'' repositories' +preference files with a global repository, or use darcs in some other +advanced way. The best way is probably to put +\verb!ALL dont-restrict-paths! in \verb!_darcs/prefs/defaults!. This turns +off all sanity checking for file paths in patches. + +Path checking can be temporarily turned on with \verb!--restrict-paths! on +the command line, when pulling or applying unknown patches. + +\begin{code} +restrict_paths = + DarcsMultipleChoiceOption + [DarcsNoArgOption [] ["restrict-paths"] RestrictPaths + "don't allow darcs to touch external files or repo metadata", + DarcsNoArgOption [] ["dont-restrict-paths"] DontRestrictPaths + "allow darcs to modify any file or directory (unsafe)"] +\end{code} + +\begin{options} +--allow-unrelated-repos +\end{options} +By default darcs checks and warns user if repositories are unrelated when +doing pull, push and send. This option makes darcs skip this check. + +\begin{code} +allow_unrelated_repos = + DarcsNoArgOption [] ["ignore-unrelated-repos"] AllowUnrelatedRepos + "do not check if repositories are unrelated" +\end{code} + +\begin{code} +check, repair, check_or_repair :: DarcsOption +\end{code} + +\begin{options} +--check +\end{options} +This option specifies checking mode. + +\begin{code} +check = + DarcsNoArgOption [] ["check"] Check + "Specify checking mode" +\end{code} + +\begin{options} +--repair +\end{options} +This option specifies repair mode. + +\begin{code} +repair = + DarcsNoArgOption [] ["repair"] Repair + "Specify repair mode" + +check_or_repair = concat_options [check, repair] + +-- | @'patch_select_flag' f@ holds whenever @f@ is a way of selecting +-- patches such as @PatchName n@. +patch_select_flag :: DarcsFlag -> Bool +patch_select_flag All = True +patch_select_flag (PatchName _) = True +patch_select_flag (OnePatch _) = True +patch_select_flag (SeveralPatch _) = True +patch_select_flag (AfterPatch _) = True +patch_select_flag (UpToPatch _) = True +patch_select_flag (TagName _) = True +patch_select_flag (LastN _) = True +patch_select_flag (OneTag _) = True +patch_select_flag (AfterTag _) = True +patch_select_flag (UpToTag _) = True +patch_select_flag (OnePattern _) = True +patch_select_flag (SeveralPattern _) = True +patch_select_flag (AfterPattern _) = True +patch_select_flag (UpToPattern _) = True +patch_select_flag _ = False + +-- | The integer corresponding to a string, if it's only composed of digits. +-- Otherwise, -1. +number_string :: String -> Int +number_string s = if and (map isDigit s) then read s else (-1) +\end{code} diff --git a/src/Darcs/Bug.hs b/src/Darcs/Bug.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Bug.hs @@ -0,0 +1,27 @@ +-- Reporting bugs in darcs. See also impossible.h. +module Darcs.Bug ( _bug, _bugDoc, _impossible, _fromJust + ) where + +import Printer ( Doc, errorDoc, text, ($$) ) + +type BugStuff = (String, Int, String, String) + +_bug :: BugStuff -> String -> a +_bug bs s = _bugDoc bs (text s) + +_bugDoc :: BugStuff -> Doc -> a +_bugDoc bs s = errorDoc $ + text ("bug at " ++ _bugLoc bs) $$ s $$ + text ("See http://wiki.darcs.net/index.html/BugTrackerHowto " ++ + "for help on bug reporting.") + +_bugLoc :: BugStuff -> String +_bugLoc (file, line, date, time) = file++":"++show line++" compiled "++time++" "++date + +_impossible :: BugStuff -> a +_impossible bs = _bug bs $ "Impossible case at "++_bugLoc bs + +_fromJust :: BugStuff -> Maybe a -> a +_fromJust bs mx = + case mx of Nothing -> _bug bs $ "fromJust error at "++_bugLoc bs + Just x -> x diff --git a/src/Darcs/CheckFileSystem.hs b/src/Darcs/CheckFileSystem.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/CheckFileSystem.hs @@ -0,0 +1,59 @@ +-- Copyright (C) 2004 David Roundy +-- +-- 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. + +module Darcs.CheckFileSystem ( can_I_use_mmap ) where + +import System.Directory ( removeFile, removeDirectory, setCurrentDirectory, + createDirectory, + ) +import Control.Exception ( block ) + +import Darcs.Utils ( withCurrentDirectory ) +import Darcs.Lock ( withOpenTemp ) + +-- Beware that the below test will return true in any directory where we +-- don't have write permission. This is risky, but means we'll do the +-- right thing in the common case where we're dealing with posix +-- filesystems and directories in which we don't have permission to write. + +can_I_remove_open_files :: IO Bool +can_I_remove_open_files = block $ + (withOpenTemp $ \ (_,f) -> + (do { removeFile f; return True}) `catch` \_ -> return False) + `catch` \_ -> return True + +can_I_remove_directories_holding_open_files :: IO Bool +can_I_remove_directories_holding_open_files = block $ + (do createDirectory "darcs_testing_for_nfs" + okay <- (withCurrentDirectory "darcs_testing_for_nfs" $ + do withOpenTemp $ \ (_,f) -> + (do removeFile f + setCurrentDirectory ".." + removeDirectory "darcs_testing_for_nfs" + return True + ) `catch` \_ -> return False + ) `catch` \_ -> return True + removeDirectory "darcs_testing_for_nfs" `catch` \_ -> return () + return okay + ) `catch` \_ -> return True + +can_I_use_mmap :: IO Bool +can_I_use_mmap = do a <- can_I_remove_open_files + if a then can_I_remove_directories_holding_open_files + else return False + + diff --git a/src/Darcs/ColorPrinter.hs b/src/Darcs/ColorPrinter.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/ColorPrinter.hs @@ -0,0 +1,281 @@ +{-# OPTIONS -fno-warn-orphans #-} +module Darcs.ColorPrinter ( errorDoc, traceDoc, assertDoc, fancyPrinters ) where + +import Debug.Trace ( trace ) +import System.IO ( stderr ) +import Darcs.External (getTermNColors) +import Printer (Printer, Printers, Printers'(..), Printable(..), Color(..), + invisiblePrinter, (<>), (), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat, + unsafeText, unsafeChar, space, unsafePackedString, + renderStringWith, prefix ) +import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr, intToDigit ) +import Data.Bits ( bit, xor ) +import System.Environment ( getEnv ) +import qualified Data.ByteString.Char8 as BC (unpack, any, last, spanEnd) +import qualified Data.ByteString as B (null, init) +import System.IO.Unsafe ( unsafePerformIO ) +import System.IO ( hIsTerminalDevice, Handle ) + +dollar, cr :: Doc +dollar = unsafeBothText "$" +cr = unsafeBothText "\r" + +errorDoc :: Doc -> a +errorDoc = error . show + +traceDoc :: Doc -> a -> a +traceDoc d = trace (show d) + +assertDoc :: Maybe Doc -> a -> a +assertDoc Nothing x = x +assertDoc (Just e) _ = errorDoc e + +instance Show Doc where + show = renderStringWith (fancyPrinters stderr) + +-- policy +-- | the 'Policy' type is a record containing the variables which control +-- how 'Doc's will be rendered on some output. +data Policy = Policy { poColor :: Bool -- ^ overall use of color + , poEscape :: Bool -- ^ overall use of escaping + , poLineColor :: Bool -- ^ overall use of colored lines (only hunks for now) + , poAltColor :: Bool -- ^ alternative to color (bold, inverse) + , poIsprint :: Bool -- ^ don't escape isprints + , po8bit :: Bool -- ^ don't escape 8-bit chars + , poNoEscX :: String -- ^ extra chars to never escape + , poEscX :: String -- ^ extra chars to always escape + , poTrailing :: Bool -- ^ escape trailing spaces + , poCR :: Bool -- ^ ignore \r at end of lines + , poSpace :: Bool -- ^ escape spaces (used with poTrailing) + } + +{-# NOINLINE getPolicy #-} +-- | 'getPolicy' returns a suitable policy for a given handle. +-- The policy is chosen according to environment variables, and to the +-- type of terminal which the handle represents +getPolicy :: Handle -> Policy +getPolicy handle = unsafePerformIO $ + do isTerminal <- hIsTerminalDevice handle + nColors <- if isTerminal then getTermNColors else return 0 + + envDontEscapeAnything <- getEnvBool "DARCS_DONT_ESCAPE_ANYTHING" + envDontEscapeIsprint <- getEnvBool "DARCS_DONT_ESCAPE_ISPRINT" + envUseIsprint <- getEnvBool "DARCS_USE_ISPRINT" -- for backwards-compatibility + envDontEscape8bit <- getEnvBool "DARCS_DONT_ESCAPE_8BIT" + + envDontEscapeExtra <- getEnvString "DARCS_DONT_ESCAPE_EXTRA" + envEscapeExtra <- getEnvString "DARCS_ESCAPE_EXTRA" + + envDontEscapeTrailingSpace <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_SPACES" + envDontEscapeTrailingCR <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_CR" + + envDontColor <- getEnvBool "DARCS_DONT_COLOR" + envAlwaysColor <- getEnvBool "DARCS_ALWAYS_COLOR" + envAlternativeColor <- getEnvBool "DARCS_ALTERNATIVE_COLOR" + envDoColorLines <- getEnvBool "DARCS_DO_COLOR_LINES" + + let haveColor = envAlwaysColor || (isTerminal && (nColors > 4)) + doColor = not envDontColor && haveColor + + return Policy { poColor = doColor, + poEscape = not envDontEscapeAnything, + poLineColor= doColor && envDoColorLines, + poIsprint = envDontEscapeIsprint || envUseIsprint, + po8bit = envDontEscape8bit, + poNoEscX = envDontEscapeExtra, + poEscX = envEscapeExtra, + poTrailing = not envDontEscapeTrailingSpace, + poCR = envDontEscapeTrailingCR, + poAltColor = haveColor && envAlternativeColor, + + poSpace = False + } + where + getEnvBool s = safeGetEnv s >>= return.(/= "0") + safeGetEnv s = getEnv s `catch` \_ -> return "0" + getEnvString s = getEnv s `catch` \_ -> return "" + + +-- printers + +-- | @'fancyPrinters' h@ returns a set of printers suitable for outputting +-- to @h@ +fancyPrinters :: Printers +fancyPrinters h = let policy = getPolicy h in + Printers { colorP = colorPrinter policy, + invisibleP = invisiblePrinter, + hiddenP = colorPrinter policy Green, + userchunkP = userchunkPrinter policy, + defP = escapePrinter policy, + lineColorT = lineColorTrans policy, + lineColorS = lineColorSuffix policy + } + +-- | @'lineColorTrans' policy@ tries to color a Doc, according to policy po. +-- That is, if @policy@ has @poLineColor@ set, then colors the line, otherwise +-- does nothing. +lineColorTrans :: Policy -> Color -> Doc -> Doc +lineColorTrans po | poLineColor po = \c d -> prefix (set_color c) d unsafeBothText reset_color + | otherwise = const id + +lineColorSuffix :: Policy -> [Printable] -> [Printable] +lineColorSuffix po | poLineColor po = \d -> S reset_color : d + | otherwise = id + +colorPrinter :: Policy -> Color -> Printer +colorPrinter po | poColor po = \c -> unDoc . color po c . Doc . escapePrinter po{poColor=False} + | otherwise = const $ escapePrinter po + +userchunkPrinter :: Policy -> Printer +userchunkPrinter po p + | not (poEscape po) = simplePrinter p + | not (poTrailing po) = escapePrinter po p + | otherwise = unDoc $ pr p + where + pr (S s) = prString s + pr (Both _ ps) = prPS ps + pr (PS ps) = prPS ps + + prPS ps = let (leadPS, trailPS) = BC.spanEnd isSpace ps + in if B.null trailPS + then Doc $ escapePrinter po p + else Doc (escapePrinter po (PS leadPS)) + <> Doc (escapePrinter po{poSpace=True} (PS trailPS)) + <> mark_escape po dollar + + prString s = let (trail',lead') = span isSpace (reverse s) + lead = reverse lead' + trail = reverse trail' + in if (not.null) trail + then Doc (escapePrinter po (S lead)) + <> Doc (escapePrinter po{poSpace=True} (S trail)) + <> mark_escape po dollar + else Doc (escapePrinter po p) + +escapePrinter :: Policy -> Printer +escapePrinter po + | (not.poEscape) po = simplePrinter + | otherwise = unDoc . crepr + where + crepr p | poCR po && isEndCR p = epr (initPR p) <> cr + | otherwise = epr p + + epr (S s) = escape po s + epr (PS ps) = if BC.any (not.no_escape po) ps + then escape po (BC.unpack ps) + else unsafePackedString ps + epr (Both s _) = escape po s + + isEndCR (S s) = not (null s) && last s == '\r' + isEndCR (PS ps) = not (B.null ps) && BC.last ps == '\r' + isEndCR (Both _ ps) = not (B.null ps) && BC.last ps == '\r' + + initPR (S s) = S $ init s + initPR (PS ps) = PS $ B.init ps + initPR (Both s ps) = Both (init s) (B.init ps) + + +-- escape assumes the input is in ['\0'..'\255'] + +-- | @'escape' policy string@ escapes @string@ according to the rules +-- defined in 'policy', turning it into a 'Doc'. +escape :: Policy -> String -> Doc +escape _ "" = unsafeText "" +escape po s = hcat (map escapeChar s) + where + escapeChar c | no_escape po c = unsafeChar c + escapeChar ' ' = space + escapeChar c = (emph.unsafeText.quoteChar) c + emph = mark_escape po + +-- | @'no_escape' policy c@ tells wether @c@ will be left as-is +-- when escaping according to @policy@ +no_escape :: Policy -> Char -> Bool +no_escape po c | poSpace po && isSpace c = False +no_escape po c | c `elem` poEscX po = False +no_escape po c | c `elem` poNoEscX po = True +no_escape _ '\t' = True -- tabs will likely be converted to spaces +no_escape _ '\n' = True +no_escape po c = if (poIsprint po) then isPrint c + else isPrintableAscii c + || c >= '\x80' && po8bit po + +-- | 'isPrintableAscii' tells wether a character is a printable character +-- of the ascii range. +isPrintableAscii :: Char -> Bool +isPrintableAscii c = isAscii c && isPrint c + + +-- | 'quoteChar' represents a special character as a string. +-- * @quoteChar '^c'@ (where @^c@ is a control character) is @"^c"@ +-- * Otherwise, @quoteChar@ returns "\hex", where 'hex' is the +-- hexadecimal number of the character. +quoteChar :: Char -> String +quoteChar c + | isControl c && isPrintableAscii cHat = ['^', cHat] + | otherwise = sHex + where + cHat = chr $ (bit 6 `xor`) $ ord c + sHex = let (q, r) = quotRem (ord c) 16 + in ['\\', intToDigit q, intToDigit r] + + +-- make colors and highlightings + +-- | @'mark_escape' policy doc@ marks @doc@ with the appropriate +-- marking for escaped characters according to @policy@ +mark_escape :: Policy -> Doc -> Doc +mark_escape po | poAltColor po = make_invert + | poColor po = make_color Red + | otherwise = make_asciiart + +-- | @'color' policy color doc@ colors @doc@ with color @color@ if +-- @policy@ is not set to use an alternative to color. In that case, +-- it makes the text bold instead. +color :: Policy -> Color -> Doc -> Doc +color po | poAltColor po = \_ -> make_bold + | otherwise = make_color + +make_color, make_color' :: Color -> Doc -> Doc + +make_color' = with_color . set_color + +-- memoized version of make_color' +make_color Blue = make_color' Blue +make_color Red = make_color' Red +make_color Green = make_color' Green +make_color Cyan = make_color' Cyan +make_color Magenta = make_color' Magenta + +set_color :: Color -> String +set_color Blue = "\x1B[01;34m" -- bold blue +set_color Red = "\x1B[01;31m" -- bold red +set_color Green = "\x1B[01;32m" -- bold green +set_color Cyan = "\x1B[36m" -- light cyan +set_color Magenta = "\x1B[35m" -- light magenta + +-- | @'make_asciiart' doc@ tries to make @doc@ (usually a +-- single escaped char) stand out with the help of only plain +-- ascii, i.e., no color or font style. +make_asciiart :: Doc -> Doc +make_asciiart x = unsafeBothText "[_" <> x <> unsafeBothText "_]" + +-- | the string to reset the terminal's color. +reset_color :: String +reset_color = "\x1B[00m" + +-- | @'with_color' color doc@ returns a colorized version of @doc@. +-- @color@ is a string that represents a color, given by 'set_color' +with_color :: String -> Doc -> Doc +with_color c = + let c' = unsafeBothText c + r' = unsafeBothText reset_color + in \x -> c' <> x <> r' + + +-- | 'make_bold' boldens a doc. +make_bold :: Doc -> Doc +-- | 'make_invert' returns an invert video version of a doc. +make_invert :: Doc -> Doc +make_bold = with_color "\x1B[01m" +make_invert = with_color "\x1B[07m" diff --git a/src/Darcs/Commands.lhs b/src/Darcs/Commands.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands.lhs @@ -0,0 +1,294 @@ +% Copyright (C) 2002,2003,2005 David Roundy +% +% 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. + +\begin{code} +module Darcs.Commands ( CommandControl( Command_data, Hidden_command, Group_name ), + DarcsCommand( DarcsCommand, command_name, + command_help, command_description, + command_basic_options, command_advanced_options, + command_command, + command_prereq, + command_extra_arg_help, + command_extra_args, + command_argdefaults, + command_get_arg_possibilities, + SuperCommand, + command_sub_commands ), + command_alias, command_stub, + command_options, command_alloptions, + disambiguate_commands, CommandArgs(..), + get_command_help, get_command_mini_help, + get_subcommands, + usage, subusage, chomp_newline, + extract_commands, + super_name, + nodefaults, + loggers, + ) where + +import System.Console.GetOpt( OptDescr, usageInfo ) + +import Data.List ( sort, isPrefixOf ) +import Darcs.Arguments ( DarcsFlag, DarcsOption, disable, help, + any_verbosity, posthook_cmd, posthook_prompt, + prehook_cmd, prehook_prompt, option_from_darcsoption ) +import Darcs.RepoPath ( AbsolutePath, rootDirectory ) +import Darcs.Utils ( putStrLnError ) +import Printer ( Doc, putDocLn ) +\end{code} + +The general format of a darcs command is +\begin{verbatim} +% darcs COMMAND OPTIONS ARGUMENTS ... +\end{verbatim} +Here \verb|COMMAND| is a command such as \verb|add| or \verb|record|, which of +course may have one or more arguments. Options have the form +\verb!--option! or \verb!-o!, while arguments vary from command to +command. There are many options which are common to a number of different +commands, which will be summarized here. + +If you wish, you may use any unambiguous beginning of a command name as a +shortcut: for \verb!darcs record!, you could type \verb!darcs recor! or +\verb!darcs rec!, but not \verb!darcs re! since that could be confused with +\verb!darcs replace!, \verb!darcs revert! and \verb!darcs remove!. + +In some cases, \verb|COMMAND| actually consists of two words, a +super-command and a subcommand. For example, the ``display the +manifest'' command has the form \verb|darcs query manifest|. + +\paragraph{Command overview} + +Not all commands modify the ``patches'' of your repository (that +is, the named patches which other users can pull); some commands only +affect the copy of the source tree you're working on (your ``working +directory''), and some affect both. This table summarizes what you should +expect from each one and will hopefully serve as guide when you're having +doubts about which command to use. + +\begin{center} +\footnotetext[1]{But it affects the repository and working directory targeted + by the push} +\footnotetext[2]{As for the other end, see apply} +\begin{tabular}{|c|c|c|} +\hline +affects & patches & working directory\\ +\hline +record & yes & no\\ +\hline +unrecord & yes & no\\ +\hline +rollback & yes & yes\\ +\hline +revert & no & yes\\ +\hline +unrevert & no & yes\\ +\hline +pull & yes & yes\\ +\hline +obliterate & yes & yes\\ +\hline +apply & yes & yes\\ +\hline +push\footnote{But it affects the repository and working directory targeted by +the push} & no & no\\ +\hline +send\footnote{As for the other end, see apply} & no & no\\ +\hline +put\footnote{Creates a new repository} & no & no\\ +\hline +\end{tabular} +\end{center} + +\begin{code} +extract_commands, extract_hidden_commands :: [CommandControl] -> [DarcsCommand] +extract_commands cs = concatMap (\x -> case x of { Command_data cmd_d -> [cmd_d]; _ -> []}) cs +extract_hidden_commands cs = concatMap (\x -> case x of { Hidden_command cmd_d -> [cmd_d]; _ -> []}) cs +\end{code} + +\input{Darcs/Arguments.lhs} + +\begin{code} +data CommandControl = Command_data DarcsCommand + | Hidden_command DarcsCommand + | Group_name String + +data DarcsCommand = + DarcsCommand {command_name, command_help, command_description :: String, + command_extra_args :: Int, + command_extra_arg_help :: [String], + command_command :: [DarcsFlag] -> [String] -> IO (), + command_prereq :: [DarcsFlag] -> IO (Either String ()), + command_get_arg_possibilities :: IO [String], + command_argdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String], + command_basic_options :: [DarcsOption], + command_advanced_options :: [DarcsOption]} + | SuperCommand {command_name, command_help, command_description :: String, + command_prereq :: [DarcsFlag] -> IO (Either String ()), + command_sub_commands :: [CommandControl]} + +command_alloptions :: DarcsCommand -> ([DarcsOption], [DarcsOption]) +command_alloptions DarcsCommand { command_basic_options = opts1 + , command_advanced_options = opts2 } + = (opts1 ++ [disable, help], + any_verbosity ++ opts2 ++ + [posthook_cmd, posthook_prompt + ,prehook_cmd, prehook_prompt]) + +-- Supercommands cannot be disabled. +command_alloptions SuperCommand { } = ([help],[]) + +-- Obtain options suitable as input to +-- System.Console.Getopt, including the --disable option (which is +-- not listed explicitly in the DarcsCommand definitions). +command_options :: AbsolutePath -> DarcsCommand -> ([OptDescr DarcsFlag], [OptDescr DarcsFlag]) +command_options cwd c = (convert basic, convert advanced) + where (basic, advanced) = command_alloptions c + convert = concatMap (option_from_darcsoption cwd) + +nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] +nodefaults _ _ xs = return xs + +get_subcommands :: DarcsCommand -> [CommandControl] +get_subcommands c@(SuperCommand {}) = command_sub_commands c +get_subcommands _ = [] + +command_alias :: String -> DarcsCommand -> DarcsCommand +command_alias n c = + c { command_name = n + , command_description = "Alias for `darcs " ++ command_name c ++ "'." + , command_help = "The `darcs " ++ n ++ "' command is an alias for " ++ + "`darcs " ++ command_name c ++ "'.\n" ++ + command_help c + } + +command_stub :: String -> String -> String -> DarcsCommand -> DarcsCommand +command_stub n h d c = + c { command_name = n + , command_help = h + , command_description = d + , command_command = \_ _ -> putStr h + } + +usage :: [CommandControl] -> String +usage cs = "Usage: darcs COMMAND ...\n\nCommands:\n" ++ + usage_helper cs ++ "\n" ++ + "Use 'darcs COMMAND --help' for help on a single command.\n" ++ + "Use 'darcs --version' to see the darcs version number.\n" ++ + "Use 'darcs --exact-version' to get the exact version of this darcs instance.\n" ++ + "Use 'darcs help patterns' for help on patch matching.\n" ++ + "Use 'darcs help environment' for help on environment variables.\n" ++ + "\n" ++ + "Check bug reports at http://bugs.darcs.net/\n" + +subusage :: DarcsCommand -> String +subusage super = + (usageInfo + ("Usage: darcs "++command_name super++" SUBCOMMAND ... " ++ + "\n\n"++ command_description super++ + "\n\nSubcommands:\n" ++ usage_helper (get_subcommands super) ++ "\nOptions:") + (option_from_darcsoption rootDirectory help)) + ++ "\n" ++ command_help super + +usage_helper :: [CommandControl] -> String +usage_helper [] = "" +usage_helper (Hidden_command _:cs) = usage_helper cs +usage_helper ((Command_data c):cs) = " "++pad_spaces (command_name c) 15 ++ + chomp_newline (command_description c)++"\n"++usage_helper cs +usage_helper ((Group_name n):cs) = "\n" ++ n ++ "\n" ++ usage_helper cs + +chomp_newline :: String -> String +chomp_newline "" = "" +chomp_newline s = if last s == '\n' then init s else s + +pad_spaces :: String -> Int -> String +pad_spaces s n = s ++ replicate (n - length s) ' ' + +super_name :: Maybe DarcsCommand -> String +super_name Nothing = "" +super_name (Just x) = command_name x ++ " " + +get_command_mini_help :: Maybe DarcsCommand -> DarcsCommand -> String +get_command_mini_help msuper cmd = + get_command_help_core msuper cmd ++ + "\n\nSee darcs help " + ++ (maybe "" (\c -> command_name c ++ " ") msuper) + ++ command_name cmd ++ " for details." + +get_command_help :: Maybe DarcsCommand -> DarcsCommand -> String +get_command_help msuper cmd = + unlines (reverse basicR) + ++ (if null advanced then "" + else "\nAdvanced options:\n" ++ unlines (reverse advancedR)) + ++ "\n" ++ command_help cmd + where -- we could just call usageInfo twice, but then the advanced + -- options might not line up with the basic ones (no short flags) + (advancedR, basicR) = + splitAt (length advanced) $ reverse $ lines combinedUsage + combinedUsage = usageInfo + (get_command_help_core msuper cmd ++ subcommands ++ "\n\nOptions:") + (basic ++ advanced) + (basic, advanced) = command_options rootDirectory cmd + subcommands = + case msuper of + Nothing -> case get_subcommands cmd of + [] -> [] + s -> "\n\nSubcommands:\n" ++ (usage_helper s) + -- we don't want to list subcommands if we're already specifying them + Just _ -> "" + +get_command_help_core :: Maybe DarcsCommand -> DarcsCommand -> String +get_command_help_core msuper cmd = + "Usage: darcs "++super_name msuper++command_name cmd++ + " [OPTION]... " ++ unwords args_help ++ + "\n"++ command_description cmd + where args_help = case cmd of + (DarcsCommand _ _ _ _ _ _ _ _ _ _ _) -> + command_extra_arg_help cmd + _ -> [] + +data CommandArgs = CommandOnly DarcsCommand + | SuperCommandOnly DarcsCommand + | SuperCommandSub DarcsCommand DarcsCommand + +-- Parses a darcs command line with potentially abbreviated commands +disambiguate_commands :: [CommandControl] -> String -> [String] + -> Either String (CommandArgs, [String]) +disambiguate_commands allcs cmd args = + do c <- extract cmd allcs + case (get_subcommands c, args) of + ([], _) -> return (CommandOnly c, args) + (_ ,[]) -> return (SuperCommandOnly c, args) + (subcs, (a:as)) -> case extract a subcs of + Left _ -> return (SuperCommandOnly c, args) + Right sc -> return (SuperCommandSub c sc, as) + +extract :: String -> [CommandControl] -> Either String DarcsCommand +extract cmd cs = + case [ c | c <- extract_commands cs, cmd `isPrefixOf` command_name c ] ++ + [ h | h <- extract_hidden_commands cs, cmd == command_name h ] of + [] -> Left $ "No such command '" ++ cmd ++ "'\n" + [c] -> Right c + cs' -> Left $ "Ambiguous command...\n\n" ++ + "The command '"++cmd++"' could mean one of:\n" ++ + unwords (sort $ map command_name cs') + +-- | Output functions equivalent to (putStrLn, hPutStrLn stderr, putDocLn) +loggers :: [DarcsFlag] -> ( String -> IO () + , String -> IO () + , Doc -> IO ()) +loggers _ = (putStrLn, putStrLnError, putDocLn) +\end{code} diff --git a/src/Darcs/Commands/Add.lhs b/src/Darcs/Commands/Add.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Add.lhs @@ -0,0 +1,278 @@ +% Copyright (C) 2002-2004 David Roundy +% +% 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. + +\darcsCommand{add} +\begin{code} +module Darcs.Commands.Add ( add ) where + +import Data.List ( (\\), nub) + +import Darcs.Commands +import Darcs.Arguments (noskip_boring, allow_problematic_filenames, + fancy_move_add, + recursive, working_repo_dir, dry_run_noxml, umask_option, + list_files, list_unregistered_files, + DarcsFlag (AllowCaseOnly, AllowWindowsReserved, Boring, Recursive, + Verbose, Quiet, FancyMoveAdd, DryRun), + fixSubPaths, + ) +import Darcs.Utils ( withCurrentDirectory, nubsort ) +import IsoDate ( getIsoDateTime ) +import Darcs.Repository ( amInRepository, withRepoLock, ($-), + slurp_pending, add_to_pending ) +import Darcs.Patch ( Prim, apply_to_slurpy, addfile, adddir, move ) +import Darcs.Ordered ( FL(..), unsafeFL, concatFL, nullFL ) +import Darcs.SlurpDirectory ( Slurpy, slurp_has_anycase, slurp_has, + isFileReallySymlink, doesDirectoryReallyExist, + doesFileReallyExist, slurp_hasdir, + ) +import Darcs.Patch.FileName ( fp2fn ) +import Darcs.RepoPath ( toFilePath ) +import Control.Monad ( when, unless ) +import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter ) +import Data.Maybe ( maybeToList ) +import System.FilePath.Posix ( takeDirectory, () ) +import System.IO ( hPutStrLn, stderr ) +import qualified System.FilePath.Windows as WindowsFilePath +import Darcs.Gorsvet( invalidateIndex ) + +add_description :: String +add_description = "Add one or more new files or directories." + +add_help :: String +add_help = + "Generally a repository contains both files that should be version\n" ++ + "controlled (such as source code) and files that Darcs should ignore\n" ++ + "(such as executables compiled from the source code). The `darcs add'\n" ++ + "command is used to tell Darcs which files to version control.\n" ++ + "\n" ++ + "When an existing project is first imported into a Darcs repository, it\n" ++ + "is common to run `darcs add -r *' or `darcs record -l' to add all\n" ++ + "initial source files into darcs.\n"++ + "\n" ++ + "Adding symbolic links (symlinks) is not supported.\n\n" + +add :: DarcsCommand +add = DarcsCommand {command_name = "add", + command_help = add_help ++ add_help' ++ add_help'', + command_description = add_description, + command_extra_args = -1, + command_extra_arg_help = [" ..."], + command_command = add_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = list_unregistered_files, + command_argdefaults = nodefaults, + command_advanced_options = [umask_option], + command_basic_options = + [noskip_boring, allow_problematic_filenames, + recursive "add contents of subdirectories", + fancy_move_add, + working_repo_dir, dry_run_noxml]} + +add_help' :: String +add_help' = + "Darcs will ignore all files and folders that look `boring'. The\n" ++ + "--boring option overrides this behaviour.\n" ++ + "\n" ++ + "Darcs will not add file if another file in the same folder has the\n" ++ + "same name, except for case. The --case-ok option overrides this\n" ++ + "behaviour. Windows and OS X usually use filesystems that do not allow\n" ++ + "files a folder to have the same name except for case (for example,\n" ++ + "`ReadMe' and `README'). If --case-ok is used, the repository might be\n" ++ + "unusable on those systems!\n\n" + +add_cmd :: [DarcsFlag] -> [String] -> IO () +add_cmd opts args = withRepoLock opts $- \repository -> + do cur <- slurp_pending repository + origfiles <- map toFilePath `fmap` fixSubPaths opts args + when (null origfiles) $ + putStrLn "Nothing specified, nothing added." >> + putStrLn "Maybe you wanted to say `darcs add --recursive .'?" + parlist <- get_parents cur origfiles + flist' <- if Recursive `elem` opts + then expand_dirs origfiles + else return origfiles + let flist = nubsort (parlist ++ flist') + -- refuse to add boring files recursively: + nboring <- if Boring `elem` opts + then return darcsdir_filter + else boring_file_filter + let putInfoLn = if Quiet `elem` opts then \_ -> return () else putStrLn + mapM_ (putInfoLn . ((msg_skipping msgs ++ " boring file ")++)) $ + flist \\ nboring flist + date <- getIsoDateTime + invalidateIndex repository + ps <- addp msgs opts date cur $ nboring flist + when (nullFL ps && not (null args)) $ + fail "No files were added" + unless gotDryRun $ add_to_pending repository ps + where + gotDryRun = DryRun `elem` opts + msgs | gotDryRun = dryRunMessages + | otherwise = normalMessages + +addp :: AddMessages -> [DarcsFlag] -> String -> Slurpy -> [FilePath] -> IO (FL Prim) +addp msgs opts date cur0 files = do + (ps, dups) <- + foldr + (\f rest cur accPS accDups -> do + (cur', mp, mdup) <- addp' cur f + rest cur' (maybeToList mp ++ accPS) (maybeToList mdup ++ accDups)) + (\_ ps dups -> return (reverse ps, dups)) + files + cur0 [] [] + let uniq_dups = nub dups + caseMsg = + if gotAllowCaseOnly then ":" + else ";\nnote that to ensure portability we don't allow\n" ++ + "files that differ only in case. Use --case-ok to override this:" + unless (null dups) $ do + dupMsg <- + case uniq_dups of + [f] -> + do + isDir <- doesDirectoryReallyExist f + if isDir + then return $ + "The following directory "++msg_is msgs++" already in the repository" + else return $ + "The following file "++msg_is msgs++" already in the repository" + fs -> + do + areDirs <- mapM doesDirectoryReallyExist fs + if and areDirs + then return $ + "The following directories "++msg_are msgs++" already in the repository" + else + (if or areDirs + then return $ + "The following files and directories " ++ + msg_are msgs ++ " already in the repository" + else return $ + "The following files " ++ msg_are msgs ++ " already in the repository") + putInfo $ dupMsg ++ caseMsg + mapM_ putInfo uniq_dups + return $ concatFL $ unsafeFL ps + where + addp' :: Slurpy -> FilePath -> IO (Slurpy, Maybe (FL Prim), Maybe FilePath) + addp' cur f = + if already_has + then return (cur, Nothing, Just f) + else + if is_badfilename + then do putInfo $ "The filename " ++ f ++ " is invalid under Windows.\nUse --reserved-ok to allow it." + return add_failure + else do + isdir <- doesDirectoryReallyExist f + if isdir + then trypatch $ myadddir f + else do isfile <- doesFileReallyExist f + if isfile + then trypatch $ myaddfile f + else do islink <- isFileReallySymlink f + if islink then + putInfo $ "Sorry, file " ++ f ++ " is a symbolic link, which is unsupported by darcs." + else putInfo $ "File "++ f ++" does not exist!" + return add_failure + where already_has = if gotAllowCaseOnly + then slurp_has f cur + else slurp_has_anycase f cur + is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f) + add_failure = (cur, Nothing, Nothing) + trypatch p = + case apply_to_slurpy p cur of + Nothing -> do putInfo $ msg_skipping msgs ++ " '" ++ f ++ "' ... " ++ parent_error + return (cur, Nothing, Nothing) + Just s' -> do putVerbose $ msg_adding msgs++" '"++f++"'" + return (s', Just p, Nothing) + parentdir = takeDirectory f + have_parentdir = slurp_hasdir (fp2fn parentdir) cur + parent_error = if have_parentdir + then "" + else "couldn't add parent directory '"++parentdir++ + "' to repository." + myadddir d = if gotFancyMoveAdd + then adddir (d++"-"++date) :>: + move (d++"-"++date) d :>: NilFL + else adddir d :>: NilFL + myaddfile d = if gotFancyMoveAdd + then addfile (d++"-"++date) :>: + move (d++"-"++date) d :>: NilFL + else addfile d :>: NilFL + putVerbose = if Verbose `elem` opts || DryRun `elem` opts + then putStrLn + else \_ -> return () + putInfo = if Quiet `elem` opts then \_ -> return () else hPutStrLn stderr + gotFancyMoveAdd = FancyMoveAdd `elem` opts + gotAllowCaseOnly = AllowCaseOnly `elem` opts + gotAllowWindowsReserved = AllowWindowsReserved `elem` opts + +data AddMessages = + AddMessages + { msg_skipping :: String + , msg_adding :: String + , msg_is :: String + , msg_are :: String + } + +normalMessages, dryRunMessages :: AddMessages +normalMessages = + AddMessages + { msg_skipping = "Skipping" + , msg_adding = "Adding" + , msg_is = "is" + , msg_are = "are" + } +dryRunMessages = + AddMessages + { msg_skipping = "Would skip" + , msg_adding = "Would add" + , msg_is = "would be" + , msg_are = "would be" + } + +-- |FIXME: this documentation makes *no* sense to me, and the +-- ramifications of using this option are not clear. --twb, 2008 +add_help'' :: String +add_help'' = + "The --date-trick option allows you to enable an experimental trick to\n" ++ + "make add conflicts, in which two users each add a file or directory\n" ++ + "with the same name, less problematic. While this trick is completely\n" ++ + "safe, it is not clear to what extent it is beneficial.\n" + +expand_dirs :: [FilePath] -> IO [FilePath] +expand_dirs fs = concat `fmap` mapM expand_one fs +expand_one :: FilePath -> IO [FilePath] +expand_one "" = list_files +expand_one f = do + isdir <- doesDirectoryReallyExist f + if not isdir then return [f] + else do fs <- withCurrentDirectory f list_files + return $ f: map (f ) fs + +get_parents :: Slurpy -> [FilePath] -> IO [FilePath] +get_parents cur fs = + concat `fmap` mapM (get_parent cur) fs +get_parent :: Slurpy -> FilePath -> IO [FilePath] +get_parent cur f = + if slurp_hasdir (fp2fn parentdir) cur + then return [] + else do grandparents <- get_parent cur parentdir + return (grandparents ++ [parentdir]) + where parentdir = takeDirectory f +\end{code} + diff --git a/src/Darcs/Commands/AmendRecord.lhs b/src/Darcs/Commands/AmendRecord.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/AmendRecord.lhs @@ -0,0 +1,195 @@ +% Copyright (C) 2004,2007 David Roundy +% +% 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. + +\darcsCommand{amend-record} +\begin{code} +module Darcs.Commands.AmendRecord ( amendrecord ) where +import Data.List ( sort ) +import Data.Maybe ( isJust ) +import System.Exit ( ExitCode(..), exitWith ) +import Control.Monad ( when ) + +import Darcs.Flags ( DarcsFlag(Author, LogFile, PatchName, + EditLongComment, PromptLongComment) ) +import Darcs.Lock ( world_readable_temp ) +import Darcs.RepoPath ( toFilePath, sp2fn ) +import Darcs.Hopefully ( PatchInfoAnd, n2pia, hopefully, info ) +import Darcs.Repository ( withRepoLock, ($-), withGutsOf, + get_unrecorded_in_files, get_unrecorded_in_files_unsorted, + tentativelyRemovePatches, tentativelyAddPatch, finalizeRepositoryChanges, + sync_repo, amInRepository, + ) +import Darcs.Patch ( RepoPatch, description, Prim, fromPrims, + infopatch, getdeps, adddeps, effect, + sort_coalesceFL, + canonize ) +import Darcs.Patch.Info ( pi_author, pi_name, pi_log, + PatchInfo, patchinfo, is_inverted, invert_name, + ) +import Darcs.Ordered ( FL(..), (:>)(..), (+>+), + nullFL, mapFL_FL, concatFL ) +import Darcs.SelectChanges ( with_selected_changes_to_files', + with_selected_patch_from_repo ) +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Commands.Record ( get_date, get_log ) +import Darcs.Arguments ( DarcsFlag ( All ), + areFileArgs, fixSubPaths, defineChanges, + all_interactive, ignoretimes, + ask_long_comment, author, patchname_option, + leave_test_dir, nocompress, lookforadds, + working_repo_dir, + match_one_nontag, umask_option, + notest, testByDefault, list_registered_files, + get_easy_author, set_scripts_executable + ) +import Darcs.Utils ( askUser ) +import Printer ( putDocLn ) +import Darcs.Gorsvet( invalidateIndex ) + +amendrecord_description :: String +amendrecord_description = + "Improve a patch before it leaves your repository." + +amendrecord_help :: String +amendrecord_help = + "Amend-record updates a `draft' patch with additions or improvements,\n" ++ + "resulting in a single `finished' patch. This is better than recording\n" ++ + "the additions and improvements as separate patches, because then\n" ++ + "whenever the `draft' patch is copied between repositories, you would\n" ++ + "need to make sure all the extra patches are copied, too.\n" ++ + "\n" ++ + "Do not copy draft patches between repositories, because a finished\n" ++ + "patch cannot be copied into a repository that contains a draft of the\n" ++ + "same patch. If this has already happened, `darcs obliterate' can be\n" ++ + "used to remove the draft patch.\n" ++ + "\n" ++ + -- FIXME: is the following still true in Darcs 2.1? --twb + "Do not run amend-record in repository that other developers can pull\n" ++ + "from, because if they pull while an amend-record is in progress, their\n" ++ + "repository may be corrupted.\n" ++ + "\n" ++ + "When recording a draft patch, it is a good idea to start the name with\n" ++ + "`DRAFT:' so that other developers know it is not finished. When\n" ++ + "finished, remove it with `darcs amend-record --edit-long-comment'.\n" ++ + "To change the patch name without starting an editor, use --patch-name.\n" ++ + "\n" ++ + "Like `darcs record', if you call amend-record with files as arguments,\n" ++ + "you will only be asked about changes to those files. So to amend a\n" ++ + "patch to foo.c with improvements in bar.c, you would run:\n" ++ + "\n" ++ + " darcs amend-record --match 'touch foo.c' bar.c\n" ++ + "\n" ++ + "It is usually a bad idea to amend another developer's patch. To make\n" ++ + "amend-record only ask about your own patches by default, you can add\n" ++ + "something like `amend-record match David Roundy' to ~/.darcs/defaults, \n" ++ + "where `David Roundy' is your name. " ++ + "On Windows use C:/Documents And Settings/user/Application Data/darcs/defaults\n" + +amendrecord :: DarcsCommand +amendrecord = DarcsCommand {command_name = "amend-record", + command_help = amendrecord_help, + command_description = amendrecord_description, + command_extra_args = -1, + command_extra_arg_help = ["[FILE or DIRECTORY]..."], + command_command = amendrecord_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = list_registered_files, + command_argdefaults = nodefaults, + command_advanced_options = [nocompress, ignoretimes, umask_option, + set_scripts_executable], + command_basic_options = [match_one_nontag, + notest, + leave_test_dir, + all_interactive, + author, patchname_option, ask_long_comment, + lookforadds, + working_repo_dir]} + +amendrecord_cmd :: [DarcsFlag] -> [String] -> IO () +amendrecord_cmd opts args = + let edit_metadata = has_edit_metadata opts in + withRepoLock (testByDefault opts) $- \repository -> do + files <- sort `fmap` fixSubPaths opts args + when (areFileArgs files) $ + putStrLn $ "Amending changes in "++unwords (map show files)++":\n" + with_selected_patch_from_repo "amend" repository opts $ \ (_ :> oldp) -> do + ch <- if All `elem` opts + then get_unrecorded_in_files_unsorted repository (map sp2fn files) + else get_unrecorded_in_files repository (map sp2fn files) + case ch of + NilFL | not edit_metadata -> putStrLn "No changes!" + _ -> do + date <- get_date opts + with_selected_changes_to_files' "add" (filter (==All) opts) + (map toFilePath files) ch $ \ (chs:>_) -> + if (nullFL chs && not edit_metadata) + then putStrLn "You don't want to record anything!" + else do + let old_pinf = info oldp + prior = (pi_name old_pinf, pi_log old_pinf) + make_log = world_readable_temp "darcs-amend-record" + old_author = pi_author old_pinf + author_here <- get_easy_author + case author_here of + Nothing -> return () + Just ah -> let edit_author = isJust (get_author opts) + in if (edit_author || ah == old_author) + then return () + else do yorn <- askUser $ "You're not "++old_author + ++"! Amend anyway? " + case yorn of ('y':_) -> return () + _ -> exitWith $ ExitSuccess + (new_name, new_log, _) <- get_log opts (Just prior) make_log chs + let new_author = case get_author opts of + Just a -> a + Nothing -> pi_author old_pinf + maybe_invert = if is_inverted old_pinf then invert_name else id + new_pinf <- maybe_invert `fmap` patchinfo date new_name + new_author new_log + let newp = fixp oldp chs new_pinf + defineChanges newp + invalidateIndex repository + withGutsOf repository $ do + tentativelyRemovePatches repository opts (hopefully oldp :>: NilFL) + tentativelyAddPatch repository opts newp + finalizeRepositoryChanges repository + sync_repo repository + putStrLn "Finished amending patch:" + putDocLn $ description newp + +has_edit_metadata :: [DarcsFlag] -> Bool +has_edit_metadata (Author _:_) = True +has_edit_metadata (LogFile _:_) = True +has_edit_metadata (PatchName _:_) = True +has_edit_metadata (EditLongComment:_) = True +has_edit_metadata (PromptLongComment:_) = True +has_edit_metadata (_:fs) = has_edit_metadata fs +has_edit_metadata [] = False + +get_author :: [DarcsFlag] -> Maybe String +get_author (Author a:_) = Just a +get_author (_:as) = get_author as +get_author [] = Nothing + +fixp :: RepoPatch p => PatchInfoAnd p -> FL Prim -> PatchInfo -> PatchInfoAnd p +fixp oldp chs new_pinf = + let pdeps = getdeps $ hopefully oldp + oldchs = effect oldp + infodepspatch pinfo deps p = adddeps (infopatch pinfo p) deps + in n2pia $ infodepspatch new_pinf pdeps $ fromPrims $ concatFL $ mapFL_FL canonize + $ sort_coalesceFL $ concatFL $ mapFL_FL canonize $ oldchs +>+ chs +\end{code} diff --git a/src/Darcs/Commands/Annotate.lhs b/src/Darcs/Commands/Annotate.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Annotate.lhs @@ -0,0 +1,411 @@ +% Copyright (C) 2003 David Roundy +% +% 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. + +\darcsCommand{annotate} +\begin{code} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} + +#include "gadts.h" + +module Darcs.Commands.Annotate ( annotate, created_as_xml ) where + +import Control.Monad ( when ) +import Data.List ( sort ) + +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, + summary, unified, human_readable, + xmloutput, creatorhash, + fixSubPaths, + list_registered_files, + match_one, + ) +import Darcs.SlurpDirectory ( slurp ) +import Darcs.Repository ( Repository, PatchSet, amInRepository, withRepository, ($-), read_repo, + getMarkedupFile ) +import Darcs.Patch ( RepoPatch, Named, LineMark(..), patch2patchinfo, xml_summary ) +import qualified Darcs.Patch ( summary ) +import Darcs.Ordered ( mapRL, concatRL ) +import qualified Data.ByteString.Char8 as BC ( unpack, ByteString ) +import Darcs.PrintPatch ( printPatch, contextualPrintPatch ) +import Darcs.Patch.Info ( PatchInfo, human_friendly, to_xml, make_filename, + showPatchInfo ) +import Darcs.PopulationData ( Population(..), PopTree(..), DirMark(..), + nameI, modifiedByI, modifiedHowI, + createdByI, creationNameI, + ) +import Darcs.Population ( getRepoPopVersion, lookup_pop, lookup_creation_pop, + modified_to_xml, + ) +import Darcs.Hopefully ( info ) +import Darcs.RepoPath ( SubPath, toFilePath ) +import Darcs.Match ( match_patch, have_nonrange_match, get_first_match ) +import Darcs.Lock ( withTempDir ) +import Darcs.Sealed ( Sealed2(..), unseal2 ) +import Printer ( putDocLn, text, errorDoc, ($$), prefix, (<+>), + Doc, empty, vcat, (<>), renderString, packedString ) +#include "impossible.h" + +annotate_description :: String +annotate_description = "Display which patch last modified something." + +annotate_help :: String +annotate_help = + "Annotate displays which patches created or last modified a directory\n"++ + "file or line. It can also display the contents of a particular patch\n"++ + "in darcs format.\n" + +annotate :: DarcsCommand +annotate = DarcsCommand {command_name = "annotate", + command_help = annotate_help, + command_description = annotate_description, + command_extra_args = -1, + command_extra_arg_help = ["[FILE or DIRECTORY]..."], + command_command = annotate_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = list_registered_files, + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [summary,unified, + human_readable, + xmloutput, + match_one, creatorhash, + working_repo_dir]} +\end{code} + +\begin{options} +--human-readable, --summary, --unified, --xml--output +\end{options} + +When called with just a patch name, annotate outputs the patch in darcs format, +which is the same as \verb!--human-readable!. + +\verb!--xml-output! is the alternative to \verb!--human-readable!. + +\verb!--summary! can be used with either the \verb!--xml-output! or the +\verb!--human-readable! options to alter the results. It is documented +fully in the `common options' portion of the manual. + +Giving the \verb!--unified! flag implies \verb!--human-readable!, and causes +the output to remain in a darcs-specific format that is similar to that produced +by \verb!diff --unified!. +\begin{code} +annotate_cmd :: [DarcsFlag] -> [String] -> IO () +annotate_cmd opts [] = withRepository opts $- \repository -> do + when (not $ have_nonrange_match opts) $ + fail $ "Annotate requires either a patch pattern or a " ++ + "file or directory argument." + Sealed2 p <- match_patch opts `fmap` read_repo repository + if Summary `elem` opts + then do putDocLn $ showpi $ patch2patchinfo p + putDocLn $ show_summary p + else if Unified `elem` opts + then withTempDir "context" $ \_ -> + do get_first_match repository opts + c <- slurp "." + contextualPrintPatch c p + else printPatch p + where showpi | MachineReadable `elem` opts = showPatchInfo + | XMLOutput `elem` opts = to_xml + | otherwise = human_friendly + show_summary :: RepoPatch p => Named p C(x y) -> Doc + show_summary = if XMLOutput `elem` opts + then xml_summary + else Darcs.Patch.summary +\end{code} + +If a directory name is given, annotate will output details of the last +modifying patch for each file in the directory and the directory itself. The +details look like this: + +\begin{verbatim} + # Created by [bounce handling patch + # mark**20040526202216] as ./test/m7/bounce_handling.pl + bounce_handling.pl +\end{verbatim} + +If a patch name and a directory are given, these details are output for the time after +that patch was applied. If a directory and a tag name are given, the +details of the patches involved in the specified tagged version will be output. +\begin{code} +annotate_cmd opts args@[_] = withRepository opts $- \repository -> do + r <- read_repo repository + (rel_file_or_directory:_) <- fixSubPaths opts args + let file_or_directory = rel_file_or_directory + pinfo <- if have_nonrange_match opts + then return $ patch2patchinfo `unseal2` (match_patch opts r) + else case mapRL info $ concatRL r of + [] -> fail "Annotate does not currently work correctly on empty repositories." + (x:_) -> return x + pop <- getRepoPopVersion "." pinfo + + -- deal with --creator-hash option + let maybe_creation_pi = find_creation_patchinfo opts r + lookup_thing = case maybe_creation_pi of + Nothing -> lookup_pop + Just cp -> lookup_creation_pop cp + + if toFilePath file_or_directory == "" + then case pop of (Pop _ pt) -> annotate_pop opts pinfo pt + else case lookup_thing (toFilePath file_or_directory) pop of + Nothing -> fail $ "There is no file or directory named '"++ + toFilePath file_or_directory++"'" + Just (Pop _ pt@(PopDir i _)) + | modifiedHowI i == RemovedDir && modifiedByI i /= pinfo -> + errorDoc $ text ("The directory '" ++ toFilePath rel_file_or_directory ++ + "' was removed by") + $$ human_friendly (modifiedByI i) + | otherwise -> annotate_pop opts pinfo pt + Just (Pop _ pt@(PopFile i)) + | modifiedHowI i == RemovedFile && modifiedByI i /= pinfo -> + errorDoc $ text ("The file '" ++ toFilePath rel_file_or_directory ++ + "' was removed by") + $$ human_friendly (modifiedByI i) + | otherwise -> annotate_file repository opts pinfo file_or_directory pt + +annotate_cmd _ _ = fail "annotate accepts at most one argument" + +annotate_pop :: [DarcsFlag] -> PatchInfo -> PopTree -> IO () +annotate_pop opts pinfo pt = putDocLn $ p2format pinfo pt + where p2format = if XMLOutput `elem` opts + then p2xml + else p2s + +indent :: Doc -> [Doc] +-- This is a bit nasty: +indent = map (text . i) . lines . renderString + where i "" = "" + i ('#':s) = ('#':s) + i s = " "++s + +-- Annotate a directory listing +p2s :: PatchInfo -> PopTree -> Doc +p2s pinfo (PopFile inf) = + created_str + $$ f <+> file_change + where f = packedString $ nameI inf + file_created = text "Created by" + <+> showPatchInfo (fromJust $ createdByI inf) + <+> text "as" + <+> packedString (fromJust $ creationNameI inf) + created_str = prefix "# " file_created + file_change = if modifiedByI inf == pinfo + then text $ show (modifiedHowI inf) + else empty +p2s pinfo (PopDir inf pops) = + created_str + $$ dir <+> dir_change + $$ vcat (map (vcat . indent . p2s pinfo) $ sort pops) + where dir = packedString (nameI inf) <> text "/" + dir_created = + if createdByI inf /= Nothing + then text "Created by " + <+> showPatchInfo (fromJust $ createdByI inf) + <+> text "as" + <+> packedString (fromJust $ creationNameI inf) <> text "/" + else text "Root directory" + created_str = prefix "# " dir_created + dir_change = if modifiedByI inf == pinfo + then text $ show (modifiedHowI inf) + else empty + +escapeXML :: String -> Doc +escapeXML = text . strReplace '\'' "'" . strReplace '"' """ . + strReplace '>' ">" . strReplace '<' "<" . strReplace '&' "&" + +strReplace :: Char -> String -> String -> String +strReplace _ _ [] = [] +strReplace x y (z:zs) + | x == z = y ++ (strReplace x y zs) + | otherwise = z : (strReplace x y zs) + +created_as_xml :: PatchInfo -> String -> Doc +created_as_xml pinfo as = text "" + $$ to_xml pinfo + $$ text "" +--removed_by_xml :: PatchInfo -> String +--removed_by_xml pinfo = "\n"++to_xml pinfo++"\n" + +p2xml_open :: PatchInfo -> PopTree -> Doc +p2xml_open _ (PopFile inf) = + text "" + $$ created + $$ modified + where f = BC.unpack $ nameI inf + created = case createdByI inf of + Nothing -> empty + Just ci -> created_as_xml ci + (BC.unpack $ fromJust $ creationNameI inf) + modified = modified_to_xml inf +p2xml_open _ (PopDir inf _) = + text "" + $$ created + $$ modified + where f = BC.unpack $ nameI inf + created = case createdByI inf of + Nothing -> empty + Just ci -> created_as_xml ci + (BC.unpack $ fromJust $ creationNameI inf) + modified = modified_to_xml inf + +p2xml_close :: PatchInfo -> PopTree -> Doc +p2xml_close _(PopFile _) = text "" +p2xml_close _ (PopDir _ _) = text "" + +p2xml :: PatchInfo -> PopTree -> Doc +p2xml pinf p@(PopFile _) = p2xml_open pinf p $$ p2xml_close pinf p +p2xml pinf p@(PopDir _ pops) = p2xml_open pinf p + $$ vcat (map (p2xml pinf) $ sort pops) + $$ p2xml_close pinf p +\end{code} + +If a file name is given, the last modifying patch details of that file will be output, along +with markup indicating patch details when each line was last (and perhaps next) modified. + +If a patch name and a file name are given, these details are output for the time after +that patch was applied. + +\begin{code} +annotate_file :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> PatchInfo -> SubPath -> PopTree -> IO () +annotate_file repository opts pinfo f (PopFile inf) = do + if XMLOutput `elem` opts + then putDocLn $ p2xml_open pinfo (PopFile inf) + else if createdByI inf /= Nothing + then putAnn $ text ("File "++toFilePath f++" created by ") + <> showPatchInfo ci <> text (" as " ++ createdname) + else putAnn $ text $ "File "++toFilePath f + mk <- getMarkedupFile repository ci createdname + old_pis <- (dropWhile (/= pinfo).mapRL info.concatRL) `fmap` read_repo repository + mapM_ (annotate_markedup opts pinfo old_pis) mk + when (XMLOutput `elem` opts) $ putDocLn $ p2xml_close pinfo (PopFile inf) + where ci = fromJust $ createdByI inf + createdname = BC.unpack $ fromJust $ creationNameI inf +annotate_file _ _ _ _ _ = impossible + +annotate_markedup :: [DarcsFlag] -> PatchInfo -> [PatchInfo] + -> (BC.ByteString, LineMark) -> IO () +annotate_markedup opts | XMLOutput `elem` opts = xml_markedup + | otherwise = text_markedup + +text_markedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO () +text_markedup _ _ (l,None) = putLine ' ' l +text_markedup pinfo old_pis (l,RemovedLine wheni) + | wheni == pinfo = putLine '-' l + | wheni `elem` old_pis = return () + | otherwise = putLine ' ' l +text_markedup pinfo old_pis (l,AddedLine wheni) + | wheni == pinfo = putLine '+' l + | wheni `elem` old_pis = do putAnn $ text "Following line added by " + <> showPatchInfo wheni + putLine ' ' l + | otherwise = return () +text_markedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem) + | whenadd == pinfo = do putAnn $ text "Following line removed by " + <> showPatchInfo whenrem + putLine '+' l + | whenrem == pinfo = do putAnn $ text "Following line added by " + <> showPatchInfo whenadd + putLine '-' l + | whenadd `elem` old_pis && not (whenrem `elem` old_pis) = + do putAnn $ text "Following line removed by " <> showPatchInfo whenrem + putAnn $ text "Following line added by " <> showPatchInfo whenadd + putLine ' ' l + | otherwise = return () + +putLine :: Char -> BC.ByteString -> IO () +putLine c s = putStrLn $ c : BC.unpack s +putAnn :: Doc -> IO () +putAnn s = putDocLn $ prefix "# " s + +xml_markedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO () +xml_markedup _ _ (l,None) = putLine ' ' l +xml_markedup pinfo old_pis (l,RemovedLine wheni) + | wheni == pinfo = putDocLn $ text "" + $$ escapeXML (BC.unpack l) + $$ text "" + | wheni `elem` old_pis = return () + | otherwise = putDocLn $ text "" + $$ text "" + $$ to_xml wheni + $$ text "" + $$ escapeXML (BC.unpack l) + $$ text "" +xml_markedup pinfo old_pis (l,AddedLine wheni) + | wheni == pinfo = putDocLn $ text "" + $$ escapeXML (BC.unpack l) + $$ text "" + | wheni `elem` old_pis = putDocLn $ text "" + $$ text "" + $$ to_xml wheni + $$ text "" + $$ escapeXML (BC.unpack l) + $$ text "" + | otherwise = return () +xml_markedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem) + | whenadd == pinfo = + putDocLn $ text "" + $$ text "" + $$ to_xml whenrem + $$ text "" + $$ escapeXML (BC.unpack l) + $$ text "" + | whenrem == pinfo = + putDocLn $ text "" + $$ text "" + $$ to_xml whenadd + $$ text "" + $$ escapeXML (BC.unpack l) + $$ text "" + | whenadd `elem` old_pis && not (whenrem `elem` old_pis) = + putDocLn $ text "" + $$ text "" + $$ to_xml whenrem + $$ text "" + $$ text "" + $$ to_xml whenadd + $$ text "" + $$ escapeXML (BC.unpack l) + $$ text "" + | otherwise = return () +\end{code} + +\begin{options} +--creator-hash HASH +\end{options} + +The \verb!--creator-hash! option should only be used in combination with a +file or directory to be annotated. In this case, the name of that file or +directory is interpreted to be its name \emph{at the time it was created}, +and the hash given along with \verb!--creator-hash! indicates the patch +that created the file or directory. This allows you to (relatively) easily +examine a file even if it has been renamed multiple times. + +\begin{code} +find_creation_patchinfo :: [DarcsFlag] -> PatchSet p C(x) -> Maybe PatchInfo +find_creation_patchinfo [] _ = Nothing +find_creation_patchinfo (CreatorHash h:_) r = find_hash h $ mapRL info $ concatRL r +find_creation_patchinfo (_:fs) r = find_creation_patchinfo fs r + +find_hash :: String -> [PatchInfo] -> Maybe PatchInfo +find_hash _ [] = Nothing +find_hash h (pinf:pinfs) + | take (length h) (make_filename pinf) == h = Just pinf + | otherwise = find_hash h pinfs +\end{code} diff --git a/src/Darcs/Commands/Apply.lhs b/src/Darcs/Commands/Apply.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Apply.lhs @@ -0,0 +1,431 @@ +% Copyright (C) 2003-2005 David Roundy +% +% 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. + +\darcsCommand{apply} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Apply ( apply ) where +import System.Exit ( ExitCode(..), exitWith ) +import Prelude hiding ( catch ) +import System.IO ( hClose, stdin, stdout, stderr ) +import Control.Exception ( catch, throw, Exception( ExitException ) ) +import Control.Monad ( when ) + +import Darcs.Hopefully ( n2pia, conscientiously, info ) +import Darcs.SignalHandler ( withSignalsBlocked ) +import Darcs.Commands ( DarcsCommand(..) ) +import Darcs.CommandsAux ( check_paths ) +import Darcs.Arguments ( DarcsFlag( Reply, Interactive, All, + Verbose, HappyForwarding ), + definePatches, + get_cc, working_repo_dir, + notest, nocompress, apply_conflict_options, + use_external_merge, + ignoretimes, get_sendmail_cmd, + reply, verify, list_files, + fixFilePathOrStd, umask_option, + all_interactive, sendmail_cmd, + leave_test_dir, happy_forwarding, + dry_run, print_dry_run_message_and_exit, + set_scripts_executable, restrict_paths + ) +import qualified Darcs.Arguments as DarcsArguments ( cc ) +import Darcs.RepoPath ( toFilePath, useAbsoluteOrStd ) +import Darcs.Repository ( SealedPatchSet, withRepoLock, ($-), amInRepository, + tentativelyMergePatches, + sync_repo, read_repo, + finalizeRepositoryChanges, + applyToWorking, + ) +import Darcs.Patch ( RepoPatch, description ) +import Darcs.Patch.Info ( human_friendly ) +import Darcs.Ordered ( (:\/:)(..), (:>)(..), unsafeUnRL, + mapFL, nullFL, mapFL_FL, mapRL, concatRL, reverseRL ) +import Darcs.SlurpDirectory ( wait_a_moment ) + +import ByteStringUtils ( linesPS, unlinesPS ) +import qualified Data.ByteString as B (ByteString, null, readFile, hGetContents, init, take, drop) +import qualified Data.ByteString.Char8 as BC (unpack, last, pack) + +import Darcs.External ( sendEmail, sendEmailDoc, resendEmail, + verifyPS ) +import Darcs.Email ( read_email ) +import Darcs.Lock ( withStdoutTemp, readBinFile ) +import Darcs.Patch.Depends ( get_common_and_uncommon_or_missing ) +import Darcs.SelectChanges ( with_selected_changes ) +import Darcs.Patch.Bundle ( scan_bundle ) +import Darcs.Sealed ( Sealed(Sealed) ) +import Printer ( packedString, putDocLn, vcat, text, ($$), errorDoc, empty ) +import Darcs.Gorsvet( invalidateIndex ) +#include "impossible.h" + +apply_description :: String +apply_description = "Apply a patch bundle created by `darcs send'." + +apply_help :: String +apply_help = + "Apply is used to apply a bundle of patches to this repository.\n"++ + "Such a bundle may be created using send.\n" + +stdindefault :: a -> [String] -> IO [String] +stdindefault _ [] = return ["-"] +stdindefault _ x = return x +apply :: DarcsCommand +apply = DarcsCommand {command_name = "apply", + command_help = apply_help, + command_description = apply_description, + command_extra_args = 1, + command_extra_arg_help = [""], + command_command = apply_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = list_files, + command_argdefaults = const stdindefault, + command_advanced_options = [reply, DarcsArguments.cc, + happy_forwarding, + sendmail_cmd, + ignoretimes, nocompress, + set_scripts_executable, umask_option, + restrict_paths], + command_basic_options = [verify, + all_interactive]++dry_run++ + [apply_conflict_options, + use_external_merge, + notest, + leave_test_dir, + working_repo_dir]} + +apply_cmd :: [DarcsFlag] -> [String] -> IO () +apply_cmd _ [""] = fail "Empty filename argument given to apply!" +apply_cmd opts [unfixed_patchesfile] = withRepoLock opts $- \repository -> do + patchesfile <- fixFilePathOrStd opts unfixed_patchesfile + ps <- useAbsoluteOrStd (B.readFile . toFilePath) (B.hGetContents stdin) patchesfile + am_verbose <- return $ Verbose `elem` opts + let from_whom = get_from ps + us <- read_repo repository + either_them <- get_patch_bundle opts ps + them <- case either_them of + Right (Sealed t) -> return t + Left er -> do forwarded <- consider_forwarding opts ps + if forwarded + then exitWith ExitSuccess + else fail er + (_, us':\/:them') <- case get_common_and_uncommon_or_missing (us, them) of + Left pinfo -> + if pinfo `elem` mapRL info (concatRL us) + then cannotApplyPartialRepo pinfo "" + else cannotApplyMissing pinfo + Right x -> return x + when (null $ unsafeUnRL $ head $ unsafeUnRL them') $ + do putStr $ "All these patches have already been applied. " ++ + "Nothing to do.\n" + exitWith ExitSuccess + let their_ps = mapFL_FL (n2pia . conscientiously (text ("We cannot apply this patch " + ++"bundle, since we're missing:") $$)) + $ reverseRL $ head $ unsafeUnRL them' + with_selected_changes "apply" fixed_opts their_ps $ + \ (to_be_applied:>_) -> do + print_dry_run_message_and_exit "apply" opts to_be_applied + when (nullFL to_be_applied) $ + do putStrLn "You don't want to apply any patches, so I'm exiting!" + exitWith ExitSuccess + check_paths opts to_be_applied + redirect_output opts from_whom $ do + when am_verbose $ putStrLn "We have the following extra patches:" + when am_verbose $ putDocLn $ vcat $ mapRL description $ head $ unsafeUnRL us' + when am_verbose $ putStrLn "Will apply the following patches:" + when am_verbose $ putDocLn $ vcat $ mapFL description to_be_applied + definePatches to_be_applied + Sealed pw <- tentativelyMergePatches repository "apply" opts + (reverseRL $ head $ unsafeUnRL us') to_be_applied + invalidateIndex repository + withSignalsBlocked $ do finalizeRepositoryChanges repository + wait_a_moment -- so work will be more recent than rec + applyToWorking repository opts pw `catch` \e -> + fail ("Error applying patch to working dir:\n" ++ show e) + sync_repo repository + putStrLn "Finished applying..." + where fixed_opts = if Interactive `elem` opts + then opts + else All : opts + cannotApplyMissing pinfo + = errorDoc $ text "Cannot apply this patch bundle, since we're missing:" + $$ human_friendly pinfo + cannotApplyPartialRepo pinfo e + = errorDoc $ text ("Cannot apply this patch bundle, " + ++ "this is a \"--partial repository") + $$ text "We don't have the following patch:" + $$ human_friendly pinfo $$ text e +apply_cmd _ _ = impossible +\end{code} + +Darcs apply accepts a single argument, which is the name of the patch +file to be applied. If you omit this argument, the patch is read from +standard input. Darcs also interprets an argument of `\-' to mean it +should read the file from standard input. This allows you to use apply +with a pipe from your email program, for example. + +\begin{options} +--verify +\end{options} + +If you specify the \verb!--verify PUBRING! option, darcs will check that +the patch was GPG-signed by a key which is in \verb!PUBRING! and will +refuse to apply the patch otherwise. + +\begin{code} +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 +\end{code} + +\begin{options} +--cc, --reply +\end{options} + +If you give the \verb!--reply FROM! option to \verb!darcs apply!, it will send the +results of the application to the sender of the patch. This only works if +the patch is in the form of email with its headers intact, so that darcs +can actually know the origin of the patch. The reply email will indicate +whether or not the patch was successfully applied. The \verb!FROM! flag is +the email address that will be used as the ``from'' address when replying. +If the darcs apply is being done automatically, it is important that this +address not be the same as the address at which the patch was received, in +order to avoid automatic email loops. + +If you want to also send the apply email to another address (for example, +to create something like a ``commits'' mailing list), you can use the +\verb!--cc! option to specify additional recipients. Note that the +\verb!--cc! option \emph{requires} the \verb!--reply! option, which +provides the ``From'' address. + +The \verb!--reply! feature of apply is intended primarily for two uses. +When used by itself, it is handy for when you want to apply patches sent to +you by other developers so that they will know when their patch has been +applied. For example, in my \verb!.muttrc! (the config file for my mailer) +I have: +\begin{verbatim} +macro pager A "darcs apply --verbose \ + --reply droundy@abridgegame.org --repodir ~/darcs +\end{verbatim} +which allows me to apply a patch to darcs directly from my mailer, with the +originator of that patch being sent a confirmation when the patch is +successfully applied. NOTE: In an attempt to make sure no one else +can read your email, mutt seems to set the umask +such that patches created with the above macro are not world-readable, so +use it with care. + +When used in combination with the \verb!--verify! option, the +\verb!--reply! option allows for a nice pushable repository. When these +two options are used together, any patches that don't pass the verify will +be forwarded to the \verb!FROM! address of the \verb!--reply! option. This +allows you to set up a repository so that anyone who is authorized can push +to it and have it automatically applied, but if a stranger pushes to it, +the patch will be forwarded to you. Please (for your own sake!)\ be certain +that the \verb!--reply FROM! address is different from the one used to send +patches to a pushable repository, since otherwise an unsigned patch will be +forwarded to the repository in an infinite loop. + +If you use \verb!darcs apply --verify PUBRING --reply! to create a +pushable repository by applying patches automatically as they are received by +email, you will also want to use the \verb!--dont-allow-conflicts! option. + +\begin{options} +--dont-allow-conflicts +\end{options} +The \verb!--dont-allow-conflicts! flag causes apply to fail when applying a +patch would cause conflicts. This flag is recommended on repositories +which will be pushed to or sent to. + +\begin{options} +--allow-conflicts +\end{options} + +\verb!--allow-conflicts! will allow conflicts, but will keep the local and +recorded versions in sync on the repository. This means the conflict will exist +in both locations until it is resolved. + +\begin{options} +--mark-conflicts +\end{options} + +\verb!--mark-conflicts! will add conflict markers to illustrate the the +conflict. + +\begin{options} +--external-merge +\end{options} + +You can use an external interactive merge tool to resolve conflicts with the +flag \verb!--external-merge!. For more details see +subsection~\ref{resolution}. + +\begin{options} +--all, --interactive +\end{options} + +If you provide the \verb!--interactive! flag, darcs will +ask you for each change in the patch bundle whether or not you wish to +apply that change. The opposite is the \verb!--all! flag, which can be +used to override an \verb!interactive! which might be set in your +``defaults'' file. + +\begin{options} +--sendmail-command +\end{options} + +If you want to use a command different from the default one for sending mail, +you need to specify a command line with the \verb!--sendmail-command! option. +The command line can contain the format specifier \verb!%t! for to +and you can add \verb!% String +get_from ps = readFrom $ linesPS ps + where readFrom [] = "" + readFrom (x:xs) + | B.take 5 x == from_start = BC.unpack $ B.drop 5 x + | otherwise = readFrom xs + +redirect_output :: [DarcsFlag] -> String -> IO a -> IO a +redirect_output opts to doit = ro opts + where + cc = get_cc opts + ro [] = doit + ro (Reply f:_) = + withStdoutTemp $ \tempf-> do {a <- doit; + hClose stdout; + hClose stderr; + return a; + } `catch` (sendit tempf) + where sendit tempf e@(ExitException ExitSuccess) = + do sendSanitizedEmail opts f to "Patch applied" cc tempf + throwIO e + sendit tempf (ExitException _) = + do sendSanitizedEmail opts f to "Patch failed!" cc tempf + throwIO $ ExitException ExitSuccess + sendit tempf e = + do sendSanitizedEmail opts f to "Darcs error applying patch!" cc $ + tempf ++ "\n\nCaught exception:\n"++ + show e++"\n" + throwIO $ ExitException ExitSuccess + ro (_:fs) = ro fs + +-- |sendSanitizedEmail sends a sanitized email using the given sendmailcmd +-- It takes @DacrsFlag@ options a file with the mail contents, +-- To:, Subject:, CC:, and mail body +sendSanitizedEmail :: [DarcsFlag] -> String -> String -> String -> String -> String -> IO () +sendSanitizedEmail opts file to subject cc mailtext = + do scmd <- get_sendmail_cmd opts + body <- sanitizeFile mailtext + sendEmail file to subject cc scmd body + +-- sanitizeFile is used to clean up the stdout/stderr before sticking it in +-- an email. + +sanitizeFile :: FilePath -> IO String +sanitizeFile f = sanitize `fmap` readBinFile f + where sanitize s = wash $ remove_backspaces "" s + wash ('\000':s) = "\\NUL" ++ wash s + wash ('\026':s) = "\\EOF" ++ wash s + wash (c:cs) = c : wash cs + wash [] = [] + remove_backspaces rev_sofar "" = reverse rev_sofar + remove_backspaces (_:rs) ('\008':s) = remove_backspaces rs s + remove_backspaces "" ('\008':s) = remove_backspaces "" s + remove_backspaces rs (s:ss) = remove_backspaces (s:rs) ss + +throwIO :: Exception -> IO a +throwIO e = return $ throw e + +forwarding_message :: B.ByteString +forwarding_message = BC.pack $ + "The following patch was either unsigned, or signed by a non-allowed\n"++ + "key, or there was a GPG failure.\n" + +consider_forwarding :: [DarcsFlag] -> B.ByteString -> IO Bool +consider_forwarding opts m = cf opts (get_cc opts) + where cf [] _ = return False + cf (Reply t:_) cc = + case break is_from (linesPS m) of + (m1, f:m2) -> + let m_lines = forwarding_message:m1 ++ m2 + m' = unlinesPS m_lines + f' = BC.unpack (B.drop 5 f) in + if t == f' || t == init f' + then return False -- Refuse possible email loop. + else do + scmd <- get_sendmail_cmd opts + if HappyForwarding `elem` opts + then resendEmail t scmd m + else sendEmailDoc f' t "A forwarded darcs patch" cc + scmd (Just (empty,empty)) + (packedString m') + return True + _ -> return False -- Don't forward emails lacking headers! + cf (_:fs) cc = cf fs cc + is_from l = B.take 5 l == from_start + +from_start :: B.ByteString +from_start = BC.pack "From:" +\end{code} + +\begin{options} +--no-test, --test +\end{options} + +If you specify the \verb!--test! option, apply will run the test (if a test +exists) prior to applying the patch. If the test fails, the patch is not +applied. In this case, if the \verb!--reply! option was used, the results +of the test are sent in the reply email. You can also specify the +\verb!--no-test! option, which will override the \verb!--test! option, and +prevent the test from being run. This is helpful when setting up a +pushable repository, to keep users from running code. + + diff --git a/src/Darcs/Commands/Changes.lhs b/src/Darcs/Commands/Changes.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Changes.lhs @@ -0,0 +1,294 @@ +% Copyright (C) 2003-2004 David Roundy +% +% 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. + +\darcsCommand{changes} +\begin{code} +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP, PatternGuards #-} + +module Darcs.Commands.Changes ( changes ) where + +import Data.List ( intersect, sort ) +import Data.Maybe ( fromMaybe ) +import Control.Monad ( when, unless ) + +import Darcs.Hopefully ( hopefullyM, info ) +import Darcs.Patch.Depends ( slightly_optimize_patchset ) +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag(Context, HumanReadable, MachineReadable, + Interactive, OnlyChangesToFiles, Count, + NumberPatches, XMLOutput, Summary, + Reverse, Verbose, Debug), + fixSubPaths, changes_format, + possibly_remote_repo_dir, get_repourl, + working_repo_dir, only_to_files, + summary, changes_reverse, + match_several_or_range, + match_maxcount, maxCount, + all_interactive, showFriendly, + network_options + ) +import Darcs.RepoPath ( toFilePath, rootDirectory ) +import Darcs.Patch.FileName ( fp2fn, fn2fp, norm_path ) +import Darcs.Repository ( Repository, PatchSet, PatchInfoAnd, + get_unrecorded_in_files_unsorted, + withRepositoryDirectory, ($-), findRepository, + read_repo ) +import Darcs.Patch.Info ( to_xml, showPatchInfo ) +import Darcs.Patch.Depends ( get_common_and_uncommon ) +import Darcs.Patch.TouchesFiles ( look_touch ) +import Darcs.Patch ( RepoPatch, invert, xml_summary, description, apply_to_filepaths, + list_touched_files, effect, identity ) +import Darcs.Ordered ( (:\/:)(..), RL(..), unsafeFL, unsafeUnRL, concatRL, + EqCheck(..), filterFL ) +import Darcs.Match ( first_match, second_match, + match_a_patchread, have_nonrange_match, + match_first_patchset, match_second_patchset, + ) +import Darcs.Commands.Annotate ( created_as_xml ) +import Printer ( Doc, putDocLnWith, simplePrinters, (<+>), + renderString, prefix, text, vcat, vsep, + ($$), empty, errorDoc, insert_before_lastline ) +import Darcs.ColorPrinter ( fancyPrinters ) +import Progress ( setProgressMode, debugMessage ) +import Darcs.SelectChanges ( view_changes ) +import Darcs.Sealed ( unsafeUnseal ) +#include "impossible.h" + +changes_description :: String +changes_description = "Gives a changelog-style summary of the repository history." + +changes_help :: String +changes_help = + "Changes gives a changelog-style summary of the repository history,\n"++ + "including options for altering how the patches are selected and displayed.\n" + +changes :: DarcsCommand +changes = DarcsCommand {command_name = "changes", + command_help = changes_help, + command_description = changes_description, + command_extra_args = -1, + command_extra_arg_help = ["[FILE or DIRECTORY]..."], + command_get_arg_possibilities = return [], + command_command = changes_cmd, + command_prereq = findRepository, + command_argdefaults = nodefaults, + command_advanced_options = network_options, + command_basic_options = [match_several_or_range, + match_maxcount, + only_to_files, + changes_format, + summary, + changes_reverse, + possibly_remote_repo_dir, + working_repo_dir, + all_interactive]} + +changes_cmd :: [DarcsFlag] -> [String] -> IO () +changes_cmd [Context _] [] = return () +changes_cmd opts args | Context rootDirectory `elem` opts = + let repodir = fromMaybe "." (get_repourl opts) in + withRepositoryDirectory opts repodir $- \repository -> do + when (args /= []) $ fail "changes --context cannot accept other arguments" + changes_context repository opts +changes_cmd opts args = + let repodir = fromMaybe "." (get_repourl opts) in + withRepositoryDirectory opts repodir $- \repository -> do + unless (Debug `elem` opts) $ setProgressMode False + files <- sort `fmap` fixSubPaths opts args + unrec <- if null files then return identity + else get_unrecorded_in_files_unsorted repository (map (fp2fn . toFilePath) files) + `catch` \_ -> return identity -- this is triggered when repository is remote + let filez = map (fn2fp . norm_path . fp2fn) $ apply_to_filepaths (invert unrec) $ map toFilePath files + filtered_changes p = maybe_reverse $ get_changes_info opts filez p + debugMessage "About to read the repository..." + patches <- read_repo repository + debugMessage "Done reading the repository." + if Interactive `elem` opts + then do let (fp_and_fs, _, _) = filtered_changes patches + fp = map fst fp_and_fs + view_changes opts (unsafeFL fp) + else do when (not (null files) && not (XMLOutput `elem` opts)) $ + putStrLn $ "Changes to "++unwords filez++":\n" + debugMessage "About to print the changes..." + let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters + ps <- read_repo repository -- read repo again to prevent holding onto + -- values forced by filtered_changes + putDocLnWith printers $ changelog opts ps $ filtered_changes patches + where maybe_reverse (xs,b,c) = if Reverse `elem` opts + then (reverse xs, b, c) + else (xs, b, c) +\end{code} + +When given one or more files or directories as an argument, changes lists only +those patches which affect those files or the contents of those directories or, +of course, the directories themselves. This includes changes that happened to +files before they were moved or renamed. + +\begin{options} +--from-match, --from-patch, --from-tag +\end{options} + +If changes is given a \verb!--from-patch!, \verb!--from-match!, or +\verb!--from-tag! option, it outputs only those changes since that tag or +patch. + +Without any options to limit the scope of the changes, history will be displayed +going back as far as possible. + +\begin{options} +--max-count +\end{options} + +If changes is given a \verb!--max-count! option, it only outputs up to as that +number of changes. + +\begin{code} +get_changes_info :: RepoPatch p => [DarcsFlag] -> [FilePath] -> PatchSet p + -> ([(PatchInfoAnd p, [FilePath])], [FilePath], Doc) +get_changes_info opts plain_fs ps = + case get_common_and_uncommon (p2s,p1s) of + (_,us:\/:_) -> filter_patches_by_names (maxCount opts) fs $ filter pf $ unsafeUnRL $ concatRL us + where fs = map (\x -> "./" ++ x) $ plain_fs + p1s = if first_match opts then unsafeUnseal $ match_first_patchset opts ps + else NilRL:<:NilRL + p2s = if second_match opts then unsafeUnseal $ match_second_patchset opts ps + else ps + pf = if have_nonrange_match opts + then match_a_patchread opts + else \_ -> True + +-- | Take a list of filenames and patches and produce a list of +-- patches that actually touch the given files with list of touched +-- file names, a new file list that represents the same set of files +-- as in input, before the returned patches would have been applied, +-- and possibly an error. Additionaly, the function takes a "depth +-- limit" -- maxcount, that could be Nothing (return everything) or +-- "Just n" -- returns at most n patches touching the file (starting +-- from the beginning of the patch list). +filter_patches_by_names :: RepoPatch p => + Maybe Int -- ^ maxcount + -> [FilePath] -- ^ filenames + -> [PatchInfoAnd p] -- ^ patchlist + -> ([(PatchInfoAnd p,[FilePath])], [FilePath], Doc) +filter_patches_by_names (Just 0) _ _ = ([], [], empty) +filter_patches_by_names _ _ [] = ([], [], empty) +filter_patches_by_names maxcount [] (hp:ps) = + (hp, []) -:- filter_patches_by_names (subtract 1 `fmap` maxcount) [] ps +filter_patches_by_names maxcount fs (hp:ps) + | Just p <- hopefullyM hp = + case look_touch fs (invert p) of + (True, []) -> ([(hp, fs)], fs, empty) + (True, fs') -> (hp, fs) -:- filter_patches_by_names + (subtract 1 `fmap` maxcount) fs' ps + (False, fs') -> filter_patches_by_names maxcount fs' ps +filter_patches_by_names _ _ (hp:_) = + ([], [], text "Can't find changes prior to:" $$ description hp) + +-- | Note, lazy pattern matching is required to make functions like +-- filter_patches_by_names lazy in case you are only not interested in +-- the first element. E.g.: +-- +-- let (fs, _, _) = filter_patches_by_names ... +(-:-) :: a -> ([a],b,c) -> ([a],b,c) +x -:- ~(xs,y,z) = (x:xs,y,z) + +changelog :: RepoPatch p => [DarcsFlag] -> PatchSet p -> ([(PatchInfoAnd p, [FilePath])], [FilePath], Doc) + -> Doc +changelog opts patchset (pis_and_fs, orig_fs, errstring) + | Count `elem` opts = text $ show $ length pis_and_fs + | MachineReadable `elem` opts = + if renderString errstring == "" + then vsep $ map (showPatchInfo.info) pis + else errorDoc errstring + | XMLOutput `elem` opts = + text "" + $$ vcat xml_file_names + $$ vcat actual_xml_changes + $$ text "" + | Summary `elem` opts || Verbose `elem` opts = + vsep (map (number_patch change_with_summary) pis_and_fs) + $$ errstring + | otherwise = vsep (map (number_patch description') pis_and_fs) + $$ errstring + where change_with_summary (hp, fs) + | Just p <- hopefullyM hp = if OnlyChangesToFiles `elem` opts + then description hp $$ text "" $$ + indent (showFriendly opts (filterFL xx $ effect p)) + else showFriendly opts p + | otherwise = description hp + $$ indent (text "[this patch is unavailable]") + where xx x = case list_touched_files x of + ys | null $ ys `intersect` fs -> IsEq + _ -> NotEq + xml_with_summary hp + | Just p <- hopefullyM hp = insert_before_lastline + (to_xml $ info hp) (indent $ xml_summary p) + xml_with_summary hp = to_xml (info hp) + indent = prefix " " + actual_xml_changes = if Summary `elem` opts + then map xml_with_summary pis + else map (to_xml.info) pis + xml_file_names = map (created_as_xml first_change) orig_fs + first_change = if Reverse `elem` opts + then info $ head pis + else info $ last pis + number_patch f x = if NumberPatches `elem` opts + then case get_number (fst x) of + Just n -> text (show n++":") <+> f x + Nothing -> f x + else f x + get_number :: PatchInfoAnd p -> Maybe Int + get_number y = gn 1 (concatRL patchset) + where iy = info y + gn n (b:<:bs) | seq n (info b) == iy = Just n + | otherwise = gn (n+1) bs + gn _ NilRL = Nothing + pis = map fst pis_and_fs + description' = description . fst + +\end{code} + +\begin{options} +--context, --human-readable, --xml-output +\end{options} + +When given the \verb!--context! flag, darcs changes outputs sufficient +information to allow the current state of the repository to be +recreated at a later date. This information should generally be piped to a +file, and then can be used later in conjunction with +\verb!darcs get --context! to recreate the current version. Note that +while the \verb!--context! flag may be used in conjunction with +\verb!--xml-output! or \verb!--human-readable!, in neither case will darcs +get be able to read the output. On the other hand, sufficient information +\emph{will} be output for a knowledgeable human to recreate the current +state of the repository. +\begin{code} +changes_context :: RepoPatch p => Repository p -> [DarcsFlag] -> IO () +changes_context repository opts = do + r <- read_repo repository + putStrLn "\nContext:\n" + when (not $ null (unsafeUnRL r) || null (unsafeUnRL $ head $ unsafeUnRL r)) $ + putDocLnWith simplePrinters $ changelog opts' NilRL $ + get_changes_info opts' [] + (headRL (slightly_optimize_patchset r) :<: NilRL) + where opts' = if HumanReadable `elem` opts || XMLOutput `elem` opts + then opts + else MachineReadable : opts + headRL (x:<:_) = x + headRL NilRL = impossible +\end{code} diff --git a/src/Darcs/Commands/Check.lhs b/src/Darcs/Commands/Check.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Check.lhs @@ -0,0 +1,107 @@ +% Copyright (C) 2002-2005 David Roundy +% +% 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. + +\darcsCommand{check} +\begin{code} +module Darcs.Commands.Check ( check ) where +import Control.Monad ( when ) +import System.Exit ( ExitCode(..), exitWith ) + +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag( Quiet ), + partial_check, notest, testByDefault, + leave_test_dir, working_repo_dir, + ) +import Darcs.Repository.Repair( replayRepository, + RepositoryConsistency(..) ) +import Darcs.Repository ( Repository, amInRepository, withRepository, slurp_recorded, + testRecorded ) +import Darcs.Patch ( RepoPatch, showPatch ) +import Darcs.Ordered ( FL(..) ) +import Darcs.Diff ( unsafeDiff ) +import Darcs.Repository.Prefs ( filetype_function ) +import Printer ( putDocLn, text, ($$), (<+>) ) + +check_description :: String +check_description = "Check the repository for consistency." + +check_help :: String +check_help = + "This command verifies that the patches in the repository, when applied\n" ++ + "successively to an empty tree, result in the pristine tree. If not,\n" ++ + "the differences are printed and Darcs exits unsucessfully (with a\n" ++ + "non-zero exit status).\n" ++ + "\n" ++ + "If the repository is in darcs-1 format and has a checkpoint, you can\n" ++ + "use the --partial option to start checking from the latest checkpoint.\n" ++ + "This is the default for partial darcs-1 repositories; the --complete\n" ++ + "option to forces a full check.\n" ++ + "\n" ++ + "If a regression test is defined (see `darcs setpref') it will be run\n" ++ + "by `darcs check'. Use the --no-test option to disable this.\n" + +check :: DarcsCommand +check = DarcsCommand {command_name = "check", + command_help = check_help, + command_description = check_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = check_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [partial_check, + notest, + leave_test_dir, + working_repo_dir + ]} + +check_cmd :: [DarcsFlag] -> [String] -> IO () +check_cmd opts _ = withRepository opts (check' opts) + +check' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO () +check' opts repository = do + replayRepository repository (testByDefault opts) $ \ state -> do + case state of + RepositoryConsistent -> do + putInfo $ text "The repository is consistent!" + testRecorded repository + exitWith ExitSuccess + BrokenPristine newpris -> do + brokenPristine newpris + exitWith $ ExitFailure 1 + BrokenPatches newpris _ -> do + brokenPristine newpris + putInfo $ text "Found broken patches." + exitWith $ ExitFailure 1 + where + brokenPristine newpris = do + putInfo $ text "Looks like we have a difference..." + mc <- slurp_recorded repository + ftf <- filetype_function + putInfo $ case unsafeDiff opts ftf newpris mc of + NilFL -> text "Nothing" + patch -> text "Difference: " <+> showPatch patch + putInfo $ text "" + $$ text "Inconsistent repository!" + putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s + +\end{code} +%% FIXME: this should go in "common options" or something, since +%% commands like record and amend-record also run the test command. +\input{Darcs/Test.lhs} diff --git a/src/Darcs/Commands/Convert.lhs b/src/Darcs/Commands/Convert.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Convert.lhs @@ -0,0 +1,260 @@ +% Copyright (C) 2002-2005,2007 David Roundy +% +% 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. + +\darcsCommand{convert} +\begin{code} +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +-- , MagicHash #-} + +#include "gadts.h" + +module Darcs.Commands.Convert ( convert ) where + +import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist, + createDirectory ) +import Workaround ( getCurrentDirectory ) +import Control.Monad ( when ) +import GHC.Base ( unsafeCoerce# ) +import Data.Maybe ( catMaybes ) + +import Darcs.Hopefully ( PatchInfoAnd, n2pia, info, hopefully ) +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag( AllowConflicts, NewRepo, + SetScriptsExecutable, UseFormat2, NoUpdateWorking, + Verbose, Quiet ), + reponame, + set_scripts_executable, + network_options ) +import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, read_repo, + createRepository, + slurp_recorded, optimizeInventory, + tentativelyMergePatches, patchSetToPatches, + createPristineDirectoryTree, + revertRepositoryChanges, finalizeRepositoryChanges, sync_repo ) +import Darcs.Global ( darcsdir ) +import Darcs.Patch ( RealPatch, Patch, Named, showPatch, patch2patchinfo, fromPrims, infopatch, + modernize_patch, + adddeps, getdeps, effect, flattenFL, is_merger, patchcontents ) +import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), (=/\=), bunchFL, mapFL, mapFL_FL, + concatFL, concatRL, mapRL ) +import Darcs.Patch.Info ( pi_rename, pi_tag, is_tag ) +import Darcs.Patch.Commute ( public_unravel ) +import Darcs.Patch.Real ( mergeUnravelled ) +import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) +import Darcs.Repository.Motd ( show_motd ) +import Darcs.Utils ( clarify_errors, askUser ) +import Darcs.ProgressPatches ( progressFL ) +import Darcs.Sealed ( FlippedSeal(..) ) +import Printer ( text, putDocLn, ($$) ) +import Darcs.ColorPrinter ( traceDoc ) +import Darcs.SlurpDirectory ( list_slurpy_files ) +import Darcs.Lock ( writeBinFile ) +import Workaround ( setExecutable ) +import qualified Data.ByteString as B (isPrefixOf, readFile) +import qualified Data.ByteString.Char8 as BC (pack) +import Darcs.Gorsvet( invalidateIndex ) + +convert_description :: String +convert_description = "Convert a repository from a legacy format." + +convert_help :: String +convert_help = + "The current repository format is called `darcs-2'. It was introduced\n" ++ + "in Darcs 2.0 and became the default for new projects in Darcs 2.2.\n" ++ + "The `darcs convert' command allows existing projects to migrate to\n" ++ + "this format from the older `darcs-1' format.\n" ++ + "\n" ++ + "This command DOES NOT modify the source repository; a new destination\n" ++ + "repository is created. It is safe to run this command more than once\n" ++ + "on a repository (e.g. for testing), before the final conversion.\n" ++ + "\n" ++ + convert_help' ++ + "\n" ++ + "Due to this limitation, migrating a multi-branch project is a little\n" ++ + "awkward. Sorry! Here is the recommended process:\n" ++ + "\n" ++ + " 1. for each branch `foo', tag that branch with `foo-final';\n" ++ + " 2. merge all branches together (--allow-conflicts may help);\n" ++ + " 3. run `darcs optimize --reorder' on the result;\n" ++ + " 4. run `darcs convert' to create a merged darcs-2 repository;\n" ++ + " 5. re-create each branch by calling `darcs get --tag foo-final' on\n" ++ + " the darcs-2 repository; and finally\n" ++ + " 6. use `darcs obliterate' to delete the foo-final tags.\n" + +-- | This part of the help is split out because it is used twice: in +-- the help string, and in the prompt for confirmation. +convert_help' :: String +convert_help' = + "WARNING: the repository produced by this command is not understood by\n" ++ + "Darcs 1.x, and patches cannot be exchanged between repositories in\n" ++ + "darcs-1 and darcs-2 formats.\n" ++ + "\n" ++ + "Furthermore, darcs 2 repositories created by different invocations of\n" ++ + "this command SHOULD NOT exchange patches, unless those repositories\n" ++ + "had no patches in common when they were converted. (That is, within a\n" ++ + "set of repos that exchange patches, no patch should be converted more\n" ++ + "than once.)\n" + +convert :: DarcsCommand +convert = DarcsCommand {command_name = "convert", + command_help = convert_help, + command_description = convert_description, + command_extra_args = -1, + command_extra_arg_help = ["", "[]"], + command_command = convert_cmd, + command_prereq = \_ -> return $ Right (), + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = network_options, + command_basic_options = [reponame,set_scripts_executable]} + +convert_cmd :: [DarcsFlag] -> [String] -> IO () +convert_cmd opts [inrepodir, outname] = convert_cmd (NewRepo outname:opts) [inrepodir] +convert_cmd orig_opts [inrepodir] = do + putStrLn convert_help' + let vow = "I understand the consequences of my action" + putStrLn "Please confirm that you have read and understood the above" + vow' <- askUser ("by typing `" ++ vow ++ "': ") + when (vow' /= vow) $ fail "User didn't understand the consequences." + let opts = UseFormat2:orig_opts + typed_repodir <- ioAbsoluteOrRemote inrepodir + let repodir = toPath typed_repodir + show_motd opts repodir + mysimplename <- make_repo_name opts repodir + createDirectory mysimplename + setCurrentDirectory mysimplename + createRepository opts + writeBinFile (darcsdir++"/hashed_inventory") "" + withRepoLock (NoUpdateWorking:opts) $- \repositoryfoo -> + withRepositoryDirectory opts repodir $- \themrepobar -> do + -- We really ought to have special versions of withRepoLock and + -- withRepositoryDirectory that check at runtime that it's the right + -- sort of repository and accept a function of (Repository Patch) or + -- (Repository (FL RealPatch)), but that seems like a lot of work + -- when these functions would be used exactly once, right here. So I + -- go with a horrible evil hack. + + -- The other alternative (which is what we used to do) is to use + -- "universal" functions to do the conversion, but that's also + -- unsatisfying. + + let repository = unsafeCoerce# repositoryfoo :: Repository (FL RealPatch) + themrepo = unsafeCoerce# themrepobar :: Repository Patch + theirstuff <- read_repo themrepo + let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff + inOrderTags = iot theirstuff + where iot ((t:<:NilRL):<:r) = info t : iot r + iot (NilRL:<:r) = iot r + iot NilRL = [] + iot ((_:<:x):<:y) = iot (x:<:y) + outOfOrderTags = catMaybes $ mapRL oot $ concatRL theirstuff + where oot t = if is_tag (info t) && not (info t `elem` inOrderTags) + then Just (info t, getdeps $ hopefully t) + else Nothing + fixDep p = case lookup p outOfOrderTags of + Just d -> p : concatMap fixDep d + Nothing -> [p] + convertOne :: Patch -> FL RealPatch + convertOne x | is_merger x = case mergeUnravelled $ public_unravel $ modernize_patch x of + Just (FlippedSeal y) -> + case effect y =/\= effect x of + IsEq -> y :>: NilFL + NotEq -> + traceDoc (text "lossy conversion:" $$ + showPatch x) + fromPrims (effect x) + Nothing -> traceDoc (text + "lossy conversion of complicated conflict:" $$ + showPatch x) + fromPrims (effect x) + | otherwise = case flattenFL x of + NilFL -> NilFL + (x':>:NilFL) -> fromPrims $ effect x' + xs -> concatFL $ mapFL_FL convertOne xs + convertNamed :: Named Patch -> PatchInfoAnd (FL RealPatch) + convertNamed n = n2pia $ + adddeps (infopatch (convertInfo $ patch2patchinfo n) $ + convertOne $ patchcontents n) + (map convertInfo $ concatMap fixDep $ getdeps n) + convertInfo n | n `elem` inOrderTags = n + | otherwise = maybe n (\t -> pi_rename n ("old tag: "++t)) $ pi_tag n + applySome xs = do tentativelyMergePatches repository "convert" (AllowConflicts:opts) NilFL xs + finalizeRepositoryChanges repository -- this is to clean out pristine.hashed + revertRepositoryChanges repository + sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches + invalidateIndex repository + revertable $ createPristineDirectoryTree repository "." + when (SetScriptsExecutable `elem` opts) $ + do putVerbose $ text "Making scripts executable" + c <- list_slurpy_files `fmap` slurp_recorded repository + let setExecutableIfScript f = + do contents <- B.readFile f + when (BC.pack "#!" `B.isPrefixOf` contents) $ do + putVerbose $ text ("Making executable: " ++ f) + setExecutable f True + mapM_ setExecutableIfScript c + sync_repo repository + optimizeInventory repository + putInfo $ text "Finished converting." + where am_verbose = Verbose `elem` orig_opts + am_informative = not $ Quiet `elem` orig_opts + putVerbose s = when am_verbose $ putDocLn s + putInfo s = when am_informative $ putDocLn s + revertable x = x `clarify_errors` unlines + ["An error may have left your new working directory an inconsistent", + "but recoverable state. You should be able to make the new", + "repository consistent again by running darcs revert -a."] + +convert_cmd _ _ = fail "You must provide 'convert' with either one or two arguments." + +make_repo_name :: [DarcsFlag] -> FilePath -> IO String +make_repo_name (NewRepo n:_) _ = + do exists <- doesDirectoryExist n + file_exists <- doesFileExist n + if exists || file_exists + then fail $ "Directory or file named '" ++ n ++ "' already exists." + else return n +make_repo_name (_:as) d = make_repo_name as d +make_repo_name [] d = + case dropWhile (=='.') $ reverse $ + takeWhile (\c -> c /= '/' && c /= ':') $ + dropWhile (=='/') $ reverse d of + "" -> modify_repo_name "anonymous_repo" + base -> modify_repo_name base + +modify_repo_name :: String -> IO String +modify_repo_name name = + if head name == '/' + then mrn name (-1) + else do cwd <- getCurrentDirectory + mrn (cwd ++ "/" ++ name) (-1) + where + mrn :: String -> Int -> IO String + mrn n i = do + exists <- doesDirectoryExist thename + file_exists <- doesFileExist thename + if not exists && not file_exists + then do when (i /= -1) $ + putStrLn $ "Directory '"++ n ++ + "' already exists, creating repository as '"++ + thename ++"'" + return thename + else mrn n $ i+1 + where thename = if i == -1 then n else n++"_"++show i + +\end{code} diff --git a/src/Darcs/Commands/Diff.lhs b/src/Darcs/Commands/Diff.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Diff.lhs @@ -0,0 +1,245 @@ +% Copyright (C) 2003-2004 David Roundy +% +% 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. + +\darcsCommand{diff} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Diff ( diff_command ) where + +import System.FilePath.Posix ( takeFileName ) +import System.Directory ( setCurrentDirectory ) +import Workaround ( getCurrentDirectory ) +import Darcs.Utils ( askUser, withCurrentDirectory ) +import Control.Monad ( when ) +import Data.List ( (\\) ) + +import Darcs.External( diff_program ) +import CommandLine ( parseCmd ) +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag(DiffFlags, Unified, DiffCmd, + LastN, AfterPatch), + match_range, store_in_memory, + diff_cmd_flag, diffflags, unidiff, + working_repo_dir, fixSubPaths, + ) +import Darcs.Hopefully ( info ) +import Darcs.RepoPath ( toFilePath, sp2fn ) +import Darcs.Match ( get_partial_first_match, get_partial_second_match, + first_match, second_match, + match_first_patchset, match_second_patchset ) +import Darcs.Repository ( PatchSet, withRepository, ($-), read_repo, + amInRepository, slurp_recorded_and_unrecorded, + createPristineDirectoryTree, + createPartialsPristineDirectoryTree ) +import Darcs.SlurpDirectory ( get_path_list, writeSlurpy ) +import Darcs.Patch ( RepoPatch ) +import Darcs.Ordered ( mapRL, concatRL ) +import Darcs.Patch.Info ( PatchInfo, human_friendly ) +import Darcs.External ( execPipeIgnoreError, clonePaths ) +import Darcs.Lock ( withTempDir ) +import Darcs.Sealed ( unsafeUnseal ) +import Printer ( Doc, putDoc, vcat, empty, ($$) ) +#include "impossible.h" + +diff_description :: String +diff_description = "Create a diff between two versions of the repository." + +diff_help :: String +diff_help = + "Diff can be used to create a diff between two versions which are in your\n"++ + "repository. Specifying just --from-patch will get you a diff against\n"++ + "your working copy. If you give diff no version arguments, it gives\n"++ + "you the same information as whatsnew except that the patch is\n"++ + "formatted as the output of a diff command\n" + +diff_command :: DarcsCommand +diff_command = DarcsCommand {command_name = "diff", + command_help = diff_help, + command_description = diff_description, + command_extra_args = -1, + command_extra_arg_help + = ["[FILE or DIRECTORY]..."], + command_command = diff_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [match_range, + diff_cmd_flag, + diffflags, unidiff, + working_repo_dir, store_in_memory]} +\end{code} + +\begin{options} +--diff-opts +\end{options} + +Diff calls an external ``diff'' command to do the actual work, and passes +any unrecognized flags to this diff command. Thus you can call +\begin{verbatim} +% darcs diff -t 0.9.8 -t 0.9.10 -- -u +\end{verbatim} +to get a diff in the unified format. Actually, thanks to the wonders of +getopt you need the ``\verb!--!'' shown above before any arguments to diff. +You can also specify additional arguments to diff using the +\verb!--diff-opts! flag. The above command would look like this: +\begin{verbatim} +% darcs diff --diff-opts -u -t 0.9.8 -t 0.9.10 +\end{verbatim} +This may not seem like an improvement, but it really pays off when you want +to always give diff the same options. You can do this by adding +\begin{verbatim} +% diff diff-opts -udp +\end{verbatim} +to your \verb!_darcs/prefs/defaults! file. + +\begin{code} +get_diff_opts :: [DarcsFlag] -> [String] +get_diff_opts [] = [] +get_diff_opts (Unified:fs) = "-u" : get_diff_opts fs +get_diff_opts (DiffFlags f:fs) = f : get_diff_opts fs +get_diff_opts (_:fs) = get_diff_opts fs + +has_diff_cmd_flag :: [DarcsFlag] -> Bool +has_diff_cmd_flag (DiffCmd _:_) = True +has_diff_cmd_flag (_:t) = has_diff_cmd_flag t +has_diff_cmd_flag [] = False + +-- | Returns the command we should use for diff as a tuple (command, arguments). +-- This will either be whatever the user specified via --diff-command or the +-- default 'diff_program'. Note that this potentially involves parsing the +-- user's diff-command, hence the possibility for failure with an exception. +get_diff_cmd_and_args :: String -> [DarcsFlag] -> String -> String + -> Either String (String, [String]) +get_diff_cmd_and_args cmd opts f1 f2 = helper opts where + helper (DiffCmd c:_) = + case parseCmd [ ('1', f1) , ('2', f2) ] c of + Left err -> Left $ show err + Right ([],_) -> bug $ "parseCmd should never return empty list" + Right ((h:t),_) -> Right (h,t) + helper [] = -- if no command specified, use 'diff' + Right (cmd, ("-rN":get_diff_opts opts++[f1,f2])) + helper (_:t) = helper t +\end{code} + +If you want to view only the differences to one or more files, you can do +so with a command such as +\begin{verbatim} +% darcs diff foo.c bar.c baz/ +\end{verbatim} + +\begin{options} +--diff-command +\end{options} + +You can use a different program to view differences by including +the flag \verb!--diff-command!, e.g. +\begin{verbatim} +--diff-command 'opendiff %1 %2'. +\end{verbatim} +The \verb!%1! and \verb!%2! are replaced with the two versions to be +merged. The above example works with the FileMerge.app tool that comes with +Apple's developer tools. To use xxdiff, you would use +\begin{verbatim} +--diff-command 'xxdiff %1 %2' +\end{verbatim} +To use \verb!kdiff3!, you can use +\begin{verbatim} +--diff-command 'kdiff3 %1 %2' +\end{verbatim} + +Note that the command is split into space-separated words and the first one is +\verb!exec!ed with the rest as arguments---it is not a shell command. Also +the substitution of the \verb!%! escapes is only done on complete words. +See \ref{resolution} for how you might work around this fact, for example, +with Emacs' Ediff package. + +Note also that the \verb!--diff-opts! flag is ignored if you use this option. + +\begin{code} +diff_cmd :: [DarcsFlag] -> [String] -> IO () +diff_cmd opts args = withRepository opts $- \repository -> do + when (not (null [i | LastN i <- opts]) + && not (null [p | AfterPatch p <- opts]) + ) $ + fail ("using --patch and --last at the same time with the 'diff' command" + ++ " doesn't make sense. Use --from-patch to create a diff from this" + ++ " patch to the present, or use just '--patch' to view this specific" + ++ " patch.") + formerdir <- getCurrentDirectory + path_list <- if null args + then return [] + else map sp2fn `fmap` fixSubPaths opts args + thename <- return $ takeFileName formerdir + withTempDir ("old-"++thename) $ \odir -> do + setCurrentDirectory formerdir + withTempDir ("new-"++thename) $ \ndir -> do + if first_match opts + then withCurrentDirectory odir $ + get_partial_first_match repository opts path_list + else if null path_list + then createPristineDirectoryTree repository (toFilePath odir) + else createPartialsPristineDirectoryTree repository path_list (toFilePath odir) + if second_match opts + then withCurrentDirectory ndir $ + get_partial_second_match repository opts path_list + else do (_, s) <- slurp_recorded_and_unrecorded repository + let ps = concatMap (get_path_list s . toFilePath) path_list + if null path_list + then withCurrentDirectory ndir $ writeSlurpy s "." + else clonePaths formerdir (toFilePath ndir) ps + thediff <- withCurrentDirectory (toFilePath odir ++ "/..") $ + case path_list of + [] -> rundiff (takeFileName $ toFilePath odir) (takeFileName $ toFilePath ndir) + fs -> vcat `fmap` + mapM (\f -> rundiff + (takeFileName (toFilePath odir) ++ "/" ++ toFilePath f) + (takeFileName (toFilePath ndir) ++ "/" ++ toFilePath f)) fs + morepatches <- read_repo repository + putDoc $ changelog (get_diff_info opts morepatches) + $$ thediff + where rundiff :: String -> String -> IO Doc + rundiff f1 f2 = do + cmd <- diff_program + case get_diff_cmd_and_args cmd opts f1 f2 of + Left err -> fail err + Right (d_cmd, d_args) -> + let other_diff = has_diff_cmd_flag opts in + do when other_diff $ putStrLn $ + "Running command '" ++ unwords (d_cmd:d_args) ++ "'" + output <- execPipeIgnoreError d_cmd d_args empty + when other_diff $ do + askUser "Hit return to move on..." + return () + return output + +get_diff_info :: RepoPatch p => [DarcsFlag] -> PatchSet p -> [PatchInfo] +get_diff_info opts ps = + let pi1s = mapRL info $ concatRL $ if first_match opts + then unsafeUnseal $ match_first_patchset opts ps + else ps + pi2s = mapRL info $ concatRL $ if second_match opts + then unsafeUnseal $ match_second_patchset opts ps + else ps + in pi2s \\ pi1s + +changelog :: [PatchInfo] -> Doc +changelog pis = vcat $ map human_friendly pis +\end{code} + diff --git a/src/Darcs/Commands/Dist.lhs b/src/Darcs/Commands/Dist.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Dist.lhs @@ -0,0 +1,156 @@ +% Copyright (C) 2003 David Roundy +% +% 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. + +\darcsCommand{dist} +\begin{code} +module Darcs.Commands.Dist ( dist ) where +import System.Directory ( setCurrentDirectory ) +import Workaround ( getCurrentDirectory ) +import System.Exit ( ExitCode(..), exitWith ) +import System.Cmd ( system ) +import System.FilePath.Posix ( takeFileName, () ) +import Data.Char ( isAlphaNum ) +import Control.Monad ( when ) + +import Darcs.Commands ( DarcsCommand(DarcsCommand, command_name, command_help, + command_description, command_extra_args, + command_extra_arg_help, command_command, + command_prereq, command_get_arg_possibilities, + command_argdefaults, + command_advanced_options, command_basic_options), + nodefaults ) +import Darcs.Arguments ( DarcsFlag(Verbose, DistName), distname_option, + working_repo_dir, match_one, store_in_memory, + fixSubPaths ) +import Darcs.Match ( get_nonrange_match, have_nonrange_match ) +import Darcs.Repository ( amInRepository, withRepoReadLock, ($-), --withRecorded, + createPartialsPristineDirectoryTree ) +import Darcs.Repository.Prefs ( get_prefval ) +import Darcs.Lock ( withTemp, withTempDir, readBinFile ) +import Darcs.RepoPath ( AbsolutePath, toFilePath ) +import Darcs.Utils ( withCurrentDirectory ) +import Exec ( exec, Redirect(..) ) + +dist_description :: String +dist_description = "Create a distribution tarball." + +dist_help :: String +dist_help = + "The `darcs dist' command creates a compressed archive (a `tarball') in\n" ++ + "the repository's root directory, containing the recorded state of the\n" ++ + "working tree (unrecorded changes and the _darcs directory are\n" ++ + "excluded).\n" ++ + "\n" ++ + "If a predist command is set (see `darcs setpref'), that command will\n" ++ + "be run on the tarball contents prior to archiving. For example,\n" ++ + "autotools projects would set it to `autoconf && automake'.\n" ++ + "\n" ++ + "By default, the tarball (and the top-level directory within the\n" ++ + "tarball) has the same name as the repository, but this can be\n" ++ + "overridden with the --dist-name option.\n" + + -- FIXME: this is tedious and ugly. + {- + ++ "\n" ++ + "Suppose you use a version numbering scheme `major.minor.patch', and\n" ++ + "you tag each release `major.minor'. You can then calculate the\n" ++ + "version number by taking the newest tag and appending a dot and the\n" ++ + "number of patches since that tag. If you use the directory name as\n" ++ + "the project name, you can make tarballs of the form name-version.tgz\n" ++ + "using the following shell script:\n" ++ + "\n" ++ + " major_minor=$(darcs show tags | head -1) &&\n" ++ + " patch_level=$(($(darcs changes --count --from-tag .) - 1)) &&\n" ++ + " version=$major_minor.$patch_level &&\n" ++ + " project=${PWD##*/} &&\n" ++ + " darcs dist --dist-name \"$project\"-\"$version\".tar.gz\n" + -} + +dist :: DarcsCommand +dist = DarcsCommand {command_name = "dist", + command_help = dist_help, + command_description = dist_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = dist_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [distname_option, + working_repo_dir, + match_one, + store_in_memory]} + +dist_cmd :: [DarcsFlag] -> [String] -> IO () +dist_cmd opts args = withRepoReadLock opts $- \repository -> do + distname <- get_dist_name opts + verb <- return $ Verbose `elem` opts + predist <- get_prefval "predist" + formerdir <- getCurrentDirectory + path_list <- if null args + then return [""] + else map toFilePath `fmap` fixSubPaths opts args + resultfile <- return (formerdirdistname++".tar.gz") + withTemp $ \tarfile -> + withTempDir "darcsdist" $ \tempdir -> do + setCurrentDirectory (formerdir) + withTempDir (toFilePath tempdir takeFileName distname) $ \ddir -> do + if have_nonrange_match opts + then withCurrentDirectory ddir $ get_nonrange_match repository opts + else createPartialsPristineDirectoryTree repository path_list (toFilePath ddir) + ec <- case predist of Nothing -> return ExitSuccess + Just pd -> system pd + if (ec == ExitSuccess) then do_dist verb tarfile tempdir ddir resultfile + else + do + putStrLn "Dist aborted due to predist failure" + exitWith ec + +-- | This function performs the actual distribution action itself. +-- NB - it does /not/ perform the pre-dist, that should already +-- have completed successfully before this is invoked. +do_dist :: Bool -> FilePath -> AbsolutePath -> AbsolutePath -> FilePath -> IO () +do_dist verb tarfile tempdir ddir resultfile = do + setCurrentDirectory (toFilePath tempdir) + exec "tar" ["-cf", "-", safename $ takeFileName $ toFilePath ddir] + (Null, File tarfile, AsIs) + when verb $ withTemp $ \tar_listing -> do + exec "tar" ["-tf", "-"] + (File tarfile, File tar_listing, Stdout) + to <- readBinFile tar_listing + putStr to + exec "gzip" ["-c"] + (File tarfile, File resultfile, AsIs) + putStrLn $ "Created dist as "++resultfile + where + safename n@(c:_) | isAlphaNum c = n + safename n = "./" ++ n + +guess_repo_name :: IO String +guess_repo_name = do + pwd <- getCurrentDirectory + if '/' `elem` pwd + then return $ reverse $ takeWhile (/='/') $ reverse pwd + else return "cantguessreponame" + +get_dist_name :: [DarcsFlag] -> IO String +get_dist_name (DistName dn:_) = return dn +get_dist_name (_:fs) = get_dist_name fs +get_dist_name _ = guess_repo_name +\end{code} + diff --git a/src/Darcs/Commands/GZCRCs.lhs b/src/Darcs/Commands/GZCRCs.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/GZCRCs.lhs @@ -0,0 +1,180 @@ +% Copyright (C) 2009 Ganesh Sittampalam +% +% 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. + +\subsection{darcs gzcrcs} +\darcsCommand{gzcrcs} +\begin{code} +module Darcs.Commands.GZCRCs ( gzcrcs, doCRCWarnings ) where + +import Control.Arrow ( (***) ) +import Control.Monad ( when ) +import Control.Monad.Trans ( liftIO ) +import Control.Monad.Writer ( runWriter, runWriterT, tell ) +import Data.List ( intersperse ) +import Data.Monoid ( Any(..), Sum(..) ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL + +import System.Directory ( getDirectoryContents, doesFileExist, doesDirectoryExist ) +import System.Exit ( ExitCode(..), exitWith ) + +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag( Quiet, Verbose, Check, Repair ), + check_or_repair, working_repo_dir, + ) +import Darcs.Repository ( Repository, amInRepository, withRepository ) +import Darcs.Patch ( RepoPatch ) +import Printer ( putDocLn, text ) +import ByteStringUtils ( isGZFile ) +import Darcs.Lock ( gzWriteAtomicFilePSs ) + +-- This command needs access beyond the normal repository APIs (to +-- get at the caches and inspect them directly) +-- Could move the relevant code into Darcs.Repository modules +-- but it doesn't really seem worth it. +import Darcs.Repository.InternalTypes ( extractCache ) +import Darcs.Repository.Cache ( Cache(..), writable, hashedFilePath, allHashedDirs ) + + +#ifdef HAVE_HASKELL_ZLIB +import Darcs.Global ( getCRCWarnings, resetCRCWarnings ) +import ByteStringUtils ( gzDecompress ) +#else +-- These functions aren't available unless we have the Haskell zlib. +-- The gzcrcs command shouldn't be enabled in this case, but we would +-- still like to typecheck this module as much as possible so we include +-- dummy versions +noChecking :: String -> a +noChecking what = error $ "Darcs.Commands.GZCRCs." ++ what ++ ": gz CRC checking is not possible unless " ++ + "darcs has been built with the Haskell zlib. This code should be unreachable." +getCRCWarnings :: IO [FilePath] +getCRCWarnings = noChecking "getCRCWarnings" +resetCRCWarnings :: IO () +resetCRCWarnings = noChecking "resetCRCWarnings" +gzDecompress :: forall m . (Functor m, Monad m) => m () -> Maybe Int -> BL.ByteString -> m [B.ByteString] +gzDecompress = noChecking "gzDecompress" +#endif + +gzcrcs_description :: String +gzcrcs_description = "Check or repair the CRCs of compressed files in the repository." + +gzcrcs_help :: String +gzcrcs_help = formatText + [ + "Versions of darcs >=1.0.4 and <2.2.0 had a bug that caused compressed files " ++ + "with bad CRCs (but valid data) to be written out. CRCs were not checked on " ++ + "reading, so this bug wasn't noticed.", + "This command inspects your repository and caches for this corruption and optionally " ++ + "repairs it.", + "You may wish to also run 'darcs check --complete' before repairing the corruption. " ++ + "This is not done automatically because it might result in needing to fetch extra " ++ + "patches if the repository is lazy.", + "If there are any other problems with your repository, you can still repair the CRCs, " ++ + "but you are advised to first make a backup copy in case the CRC errors are actually " ++ + "caused by bad data and the old CRCs might be useful in recovering that data.", + "If you were warned about CRC errors during an operation involving another repository, " ++ + "then it is possible that the other repository contains the corrupt CRCs, so you " ++ + "should arrange for that repository to also be checked/repaired.", + "Note that readonly caches, or other repositories that were sources for lazy gets, " ++ + "will be checked but not repaired. Also, this command will abort if it encounters " ++ + "any non-CRC corruption in compressed files." + ] + +formatText :: [String] -> String +formatText = unlines . concat . intersperse [""] . map (map unwords . para 80 . words) + +-- |Take a list of words and split it up so that each chunk fits into the specified width +-- when spaces are included. Any words longer than the specified width end up in a chunk +-- of their own. +para :: Int -> [[a]] -> [[[a]]] +para w = para' + where para' [] = [] + para' xs = uncurry (:) $ para'' w xs + para'' r (x:xs) | w == r || length x < r = ((x:) *** id) $ para'' (r - length x - 1) xs + para'' _ xs = ([], para' xs) + +-- |This is designed for use in an atexit handler, e.g. in Darcs.RunCommand +doCRCWarnings :: Bool -> IO () +doCRCWarnings verbose = do + files <- getCRCWarnings + resetCRCWarnings + when (not . null $ files) $ do + putStr . formatText $ + ["", + "Warning: CRC errors found. These are probably harmless but should " ++ + "be repaired. See 'darcs gzcrcs --help' for more information.", + ""] + when verbose $ putStrLn $ unlines ("The following corrupt files were found:":files) + +gzcrcs :: DarcsCommand +gzcrcs = DarcsCommand {command_name = "gzcrcs", + command_help = gzcrcs_help, + command_description = gzcrcs_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = gzcrcs_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [check_or_repair, + working_repo_dir + ]} + +gzcrcs_cmd :: [DarcsFlag] -> [String] -> IO () +gzcrcs_cmd opts _ | Check `elem` opts || Repair `elem` opts = withRepository opts (gzcrcs' opts) +gzcrcs_cmd _ _ = error "You must specify --check or --repair for gzcrcs" + +gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO () +gzcrcs' opts repo = do + let Ca locs = extractCache repo + ((), Any checkFailed) <- runWriterT $ flip mapM_ locs $ \loc -> do + let w = writable loc + flip mapM_ allHashedDirs $ \hdir -> do + let dir = hashedFilePath loc hdir "" + exists <- liftIO $ doesDirectoryExist dir + when exists $ do + liftIO $ putInfo $ text $ "Checking " ++ dir ++ (if w then "" else " (readonly)") + files <- liftIO $ getDirectoryContents dir + ((), Sum (count :: Int)) <- runWriterT $ flip mapM_ files $ \file -> do + let fn = dir ++ file + isfile <- liftIO $ doesFileExist fn + when isfile $ do + gz <- liftIO $ isGZFile fn + case gz of + Nothing -> return () + Just len -> do + contents <- liftIO $ B.readFile fn + let (uncompressed, Any isCorrupt) + = runWriter . gzDecompress (tell (Any True)) (Just len) . BL.fromChunks $ [contents] + when isCorrupt $ do + tell (Sum 1) -- count of files in current directory + liftIO $ putVerbose $ text $ "Corrupt: " ++ fn + when (w && Repair `elem` opts) $ liftIO $ gzWriteAtomicFilePSs fn uncompressed + when (count > 0) $ do + liftIO $ putInfo $ text $ + "Found " ++ show count ++ " corrupt file" ++ (if count > 1 then "s" else "") ++ + (if Repair `elem` opts then (if w then " (repaired)" else " (not repaired") else "") + tell (Any True) -- something corrupt somewhere + when (Check `elem` opts && checkFailed) $ exitWith $ ExitFailure 1 + + where + putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s + putVerbose s = when (Verbose `elem` opts) $ putDocLn s + +\end{code} diff --git a/src/Darcs/Commands/Get.lhs b/src/Darcs/Commands/Get.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Get.lhs @@ -0,0 +1,347 @@ +% Copyright (C) 2002-2005 David Roundy +% +% 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. + +\darcsCommand{get} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Get ( get, clone ) where + +import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist, + createDirectory ) +import Workaround ( getCurrentDirectory ) +import Data.Maybe ( isJust ) +import Control.Monad ( when ) + +import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) +import Darcs.Arguments ( DarcsFlag( NewRepo, Partial, Lazy, + UseFormat2, UseOldFashionedInventory, UseHashedInventory, + SetScriptsExecutable, Quiet, OnePattern ), + get_context, get_inventory_choices, + partial, reponame, + match_one_context, set_default, set_scripts_executable, nolinks, + network_options ) +import Darcs.Repository ( Repository, withRepository, ($-), withRepoLock, identifyRepositoryFor, read_repo, + createPristineDirectoryTree, + tentativelyRemovePatches, patchSetToPatches, patchSetToRepository, + copyRepository, tentativelyAddToPending, + finalizeRepositoryChanges, sync_repo, setScriptsExecutable ) +import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat, + RepoProperty ( Darcs2, HashedInventory ), format_has ) +import Darcs.Repository.DarcsRepo ( write_inventory ) +import qualified Darcs.Repository.DarcsRepo as DR ( read_repo ) +import Darcs.Repository ( PatchSet, SealedPatchSet, copy_oldrepo_patches, + createRepository) +import Darcs.Repository.ApplyPatches ( apply_patches ) +import Darcs.Repository.Checkpoint ( write_checkpoint_patch, get_checkpoint ) +import Darcs.Patch ( RepoPatch, Patch, apply, patch2patchinfo, invert, + effect, description ) +import Darcs.Ordered ( (:\/:)(..), RL(..), unsafeUnRL, mapRL, concatRL, reverseRL, lengthFL ) +import Darcs.External ( copyFileOrUrl, Cachable(..) ) +import Darcs.Patch.Depends ( get_common_and_uncommon, get_patches_beyond_tag ) +import Darcs.Repository.Prefs ( set_defaultrepo ) +import Darcs.Repository.Motd ( show_motd ) +import Darcs.Repository.Pristine ( identifyPristine, createPristineFromWorking, ) +import Darcs.SignalHandler ( catchInterrupt ) +import Darcs.Commands.Init ( initialize ) +import Darcs.Match ( have_patchset_match, get_one_patchset ) +import Darcs.Utils ( catchall, formatPath, withCurrentDirectory, prettyError ) +import Progress ( debugMessage ) +import Printer ( text, vcat, errorDoc, ($$), Doc, putDocLn, ) +import Darcs.Lock ( writeBinFile ) +import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote) +import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal ) +import Darcs.Global ( darcsdir ) +import English ( englishNum, Noun(..) ) +import Darcs.Gorsvet( invalidateIndex ) +#include "impossible.h" + +get_description :: String +get_description = "Create a local copy of a repository." + +get_help :: String +get_help = + "Get creates a local copy of a repository. The optional second\n" ++ + "argument specifies a destination directory for the new copy; if\n" ++ + "omitted, it is inferred from the source location.\n" ++ + "\n" ++ + "By default Darcs will copy every patch from the original repository.\n" ++ + "This means the copy is completely independent of the original; you can\n" ++ + "operate on the new repository even when the original is inaccessible.\n" ++ + "If you expect the original repository to remain accessible, you can\n" ++ + "use --lazy to avoid copying patches until they are needed (`copy on\n" ++ + "demand'). This is particularly useful when copying a remote\n" ++ + "repository with a long history that you don't care about.\n" ++ + "\n" ++ + "The --lazy option isn't as useful for local copies, because Darcs will\n" ++ + "automatically use `hard linking' where possible. As well as saving\n" ++ + "time and space, you can move or delete the original repository without\n" ++ + "affecting a complete, hard-linked copy. Hard linking requires that\n" ++ + "the copy be on the same filesystem and the original repository, and\n" ++ + "that the filesystem support hard linking. This includes NTFS, HFS+\n" ++ + "and all general-purpose Unix filesystems (such as ext3, UFS and ZFS).\n" ++ + "FAT does not support hard links.\n" ++ + "\n" ++ + "Darcs get will not copy unrecorded changes to the source repository's\n" ++ + "working tree.\n" ++ + "\n" ++ + get_help_tag ++ + "\n" ++ + -- The remaining help text covers backwards-compatibility options. + get_help_partial ++ + "\n" ++ + "A repository created by `darcs get' will be in the best available\n" ++ + "format: it will be able to exchange patches with the source\n" ++ + "repository, but will not be directly readable by Darcs binaries older\n" ++ + "than 2.0.0. Use the `--old-fashioned-inventory' option if the latter\n" ++ + "is required.\n" + +get :: DarcsCommand +get = DarcsCommand {command_name = "get", + command_help = get_help, + command_description = get_description, + command_extra_args = -1, + command_extra_arg_help = ["", "[]"], + command_command = get_cmd, + command_prereq = contextExists, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = network_options ++ + command_advanced_options initialize, + command_basic_options = [reponame, + partial, + match_one_context, + set_default, + set_scripts_executable, + nolinks, + get_inventory_choices]} + +clone :: DarcsCommand +clone = command_alias "clone" get + +get_cmd :: [DarcsFlag] -> [String] -> IO () +get_cmd opts [inrepodir, outname] = get_cmd (NewRepo outname:opts) [inrepodir] +get_cmd opts [inrepodir] = do + debugMessage "Starting work on get..." + typed_repodir <- ioAbsoluteOrRemote inrepodir + let repodir = toPath typed_repodir + show_motd opts repodir + when (Partial `elem` opts) $ debugMessage "Reading checkpoint..." + rfsource_or_e <- identifyRepoFormat repodir + rfsource <- case rfsource_or_e of Left e -> fail e + Right x -> return x + debugMessage $ "Found the format of "++repodir++"..." + mysimplename <- make_repo_name opts repodir + createDirectory mysimplename + setCurrentDirectory mysimplename + when (format_has Darcs2 rfsource && UseOldFashionedInventory `elem` opts) $ + putInfo $ text "Warning: 'old-fashioned-inventory' is ignored with a darcs-2 repository\n" + let opts' = if format_has Darcs2 rfsource + then UseFormat2:opts + else if not (UseOldFashionedInventory `elem` opts) + then UseHashedInventory:filter (/= UseFormat2) opts + else UseOldFashionedInventory:filter (/= UseFormat2) opts + createRepository opts' + debugMessage "Finished initializing new directory." + set_defaultrepo repodir opts + + rf_or_e <- identifyRepoFormat "." + rf <- case rf_or_e of Left e -> fail e + Right x -> return x + if format_has HashedInventory rf -- refactor this into repository + then writeBinFile (darcsdir++"/hashed_inventory") "" + else write_inventory "." (NilRL:<:NilRL :: PatchSet Patch) + + if not (null [p | OnePattern p <- opts]) -- --to-match given + && not (Partial `elem` opts) && not (Lazy `elem` opts) + then withRepository opts $- \repository -> do + debugMessage "Using economical get --to-match handling" + fromrepo <- identifyRepositoryFor repository repodir + Sealed patches_to_get <- get_one_patchset fromrepo opts + patchSetToRepository fromrepo patches_to_get opts + debugMessage "Finished converting selected patch set to new repository" + else copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo + where am_informative = not $ Quiet `elem` opts + putInfo s = when am_informative $ putDocLn s + +get_cmd _ _ = fail "You must provide 'get' with either one or two arguments." + +-- | called by get_cmd +-- assumes that the target repo of the get is the current directory, and that an inventory in the +-- right format has already been created. +copy_repo_and_go_to_chosen_version :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> (Doc -> IO ()) -> IO () +copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo = do + copy_repo `catchInterrupt` (putInfo $ text "Using lazy repository.") + withRepository opts $- \repository -> go_to_chosen_version repository putInfo opts + putInfo $ text "Finished getting." + where copy_repo = + withRepository opts $- \repository -> do + if format_has HashedInventory rf || format_has HashedInventory rfsource + then do debugMessage "Identifying and copying repository..." + identifyRepositoryFor repository repodir >>= copyRepository + when (SetScriptsExecutable `elem` opts) setScriptsExecutable + else copy_repo_old_fashioned repository opts repodir + +make_repo_name :: [DarcsFlag] -> FilePath -> IO String +make_repo_name (NewRepo n:_) _ = + do exists <- doesDirectoryExist n + file_exists <- doesFileExist n + if exists || file_exists + then fail $ "Directory or file named '" ++ n ++ "' already exists." + else return n +make_repo_name (_:as) d = make_repo_name as d +make_repo_name [] d = + case dropWhile (=='.') $ reverse $ + takeWhile (\c -> c /= '/' && c /= ':') $ + dropWhile (=='/') $ reverse d of + "" -> modify_repo_name "anonymous_repo" + base -> modify_repo_name base + +modify_repo_name :: String -> IO String +modify_repo_name name = + if head name == '/' + then mrn name (-1) + else do cwd <- getCurrentDirectory + mrn (cwd ++ "/" ++ name) (-1) + where + mrn :: String -> Int -> IO String + mrn n i = do + exists <- doesDirectoryExist thename + file_exists <- doesFileExist thename + if not exists && not file_exists + then do when (i /= -1) $ + putStrLn $ "Directory '"++ n ++ + "' already exists, creating repository as '"++ + thename ++"'" + return thename + else mrn n $ i+1 + where thename = if i == -1 then n else n++"_"++show i + +get_help_tag :: String +get_help_tag = + "It is often desirable to make a copy of a repository that excludes\n" ++ + "some patches. For example, if releases are tagged then `darcs get\n" ++ + "--tag .' would make a copy of the repository as at the latest release.\n" ++ + "\n" ++ + "An untagged repository state can still be identified unambiguously by\n" ++ + "a context file, as generated by `darcs changes --context'. Given the\n" ++ + "name of such a file, the --context option will create a repository\n" ++ + "that includes only the patches from that context. When a user reports\n" ++ + "a bug in an unreleased version of your project, the recommended way to\n" ++ + "find out exactly what version they were running is to have them\n" ++ + "include a context file in the bug report.\n" ++ + "\n" ++ + "You can also make a copy of an untagged state using the --to-patch or\n" ++ + "--to-match options, which exclude patches `after' the first matching\n" ++ + "patch. Because these options treat the set of patches as an ordered\n" ++ + "sequence, you may get different results after reordering with `darcs\n" ++ + "optimize', so tagging is preferred.\n" + +contextExists :: [DarcsFlag] -> IO (Either String ()) +contextExists opts = + case get_context opts of + Nothing -> return $ Right () + Just f -> do exists <- doesFileExist $ toFilePath f + if exists + then return $ Right () + else return . Left $ "Context file "++toFilePath f++" does not exist" + +go_to_chosen_version :: RepoPatch p => Repository p -> (Doc -> IO ()) + -> [DarcsFlag] -> IO () +go_to_chosen_version repository putInfo opts = + when (have_patchset_match opts) $ do + debugMessage "Going to specified version..." + patches <- read_repo repository + Sealed context <- get_one_patchset repository opts + let (_,us':\/:them') = get_common_and_uncommon (patches, context) + case them' of + NilRL:<:NilRL -> return () + _ -> errorDoc $ text "Missing these patches from context:" + $$ (vcat $ mapRL description $ head $ unsafeUnRL them') + let ps = patchSetToPatches us' + putInfo $ text $ "Unapplying " ++ (show $ lengthFL ps) ++ " " ++ + (englishNum (lengthFL ps) (Noun "patch") "") + invalidateIndex repository + withRepoLock opts $- \_ -> + do tentativelyRemovePatches repository opts ps + tentativelyAddToPending repository opts $ invert $ effect ps + finalizeRepositoryChanges repository + apply opts (invert $ effect ps) `catch` \e -> + fail ("Couldn't undo patch in working dir.\n" ++ show e) + sync_repo repository + + +get_help_partial :: String +get_help_partial = + "If the source repository is in a legacy darcs-1 format and contains at\n" ++ + "least one checkpoint (see `darcs optimize'), the --partial option will\n" ++ + "create a partial repository. A partial repository discards history\n" ++ + "from before the checkpoint in order to reduce resource requirements.\n" ++ + "For modern darcs-2 repositories, --partial is a deprecated alias for\n" ++ + "the --lazy option.\n" + +copy_repo_old_fashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO () +copy_repo_old_fashioned repository opts repodir = do + myname <- getCurrentDirectory + fromrepo <- identifyRepositoryFor repository repodir + mch <- get_checkpoint fromrepo + patches <- read_repo fromrepo + debugMessage "Getting the inventory..." + write_inventory "." patches + debugMessage "Copying patches..." + copy_oldrepo_patches opts fromrepo "." + debugMessage "Patches copied" + Sealed local_patches <- DR.read_repo opts "." :: IO (SealedPatchSet Patch) + debugMessage "Repo read" + repo_is_local <- doesDirectoryExist repodir + debugMessage $ "Repo local: " ++ formatPath (show repo_is_local) + if repo_is_local && not (Partial `elem` opts) + then do + debugMessage "Copying prefs" + copyFileOrUrl opts + (repodir++"/"++darcsdir++"/prefs/prefs") (darcsdir++"/prefs/prefs") (MaxAge 600) + `catchall` return () + debugMessage "Writing working directory" + createPristineDirectoryTree fromrepo myname + withCurrentDirectory myname $ do + -- note: SetScriptsExecutable is normally checked in PatchApply + -- but darcs get on local repositories does not apply patches + if SetScriptsExecutable `elem` opts + then setScriptsExecutable + else return () + else do + setCurrentDirectory myname + if Partial `elem` opts && isJust mch + then let Sealed p_ch = fromJust mch + pi_ch = patch2patchinfo p_ch + needed_patches = reverseRL $ concatRL $ unsafeUnflippedseal $ + get_patches_beyond_tag pi_ch local_patches + in do write_checkpoint_patch p_ch + apply opts p_ch `catch` + \e -> fail ("Bad checkpoint!!!\n" ++ prettyError e) + apply_patches opts needed_patches + else apply_patches opts $ reverseRL $ concatRL local_patches + debugMessage "Writing the pristine" + pristine <- identifyPristine + createPristineFromWorking pristine + setCurrentDirectory myname + debugMessage "Syncing the repository..." + sync_repo repository + debugMessage "Repository synced." + +\end{code} diff --git a/src/Darcs/Commands/Help.lhs b/src/Darcs/Commands/Help.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Help.lhs @@ -0,0 +1,266 @@ +% Copyright (C) 2002-2004 David Roundy +% +% 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. + +\darcsCommand{help} +\begin{code} +module Darcs.Commands.Help ( + help_cmd, + command_control_list, environmentHelp, -- these are for preproc.hs + print_version, + list_available_commands ) where + +import Darcs.Arguments ( DarcsFlag(..), environmentHelpSendmail ) +import Darcs.Commands ( + CommandArgs(..), CommandControl(..), DarcsCommand(..), + disambiguate_commands, extract_commands, get_command_help, nodefaults, usage ) +import Darcs.External ( viewDoc ) +import Darcs.Lock ( environmentHelpTmpdir, environmentHelpKeepTmpdir ) +import Darcs.Patch.Match ( helpOnMatchers ) +import Darcs.Repository.Prefs ( binaries_file_help, environmentHelpHome ) +import Darcs.Utils ( withCurrentDirectory, environmentHelpEditor, environmentHelpPager ) +import Data.Char ( isAlphaNum, toLower ) +import Data.List ( groupBy ) +import English ( andClauses ) +import Printer ( text ) +import Ssh ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort ) +import System.Exit ( ExitCode(..), exitWith ) +import ThisVersion ( darcs_version ) +import URL (environmentHelpProxy, environmentHelpProxyPassword) +import Workaround ( getCurrentDirectory ) +import qualified Darcs.TheCommands as TheCommands + +help_description :: String +help_description = "Display help about darcs and darcs commands." + +help_help :: String +help_help = + "Without arguments, `darcs help' prints a categorized list of darcs\n" ++ + "commands and a short description of each one. With an extra argument,\n" ++ + "`darcs help foo' prints detailed help about the darcs command foo.\n" + +help :: DarcsCommand +help = DarcsCommand {command_name = "help", + command_help = help_help, + command_description = help_description, + command_extra_args = -1, + command_extra_arg_help = ["[ [DARCS_SUBCOMMAND]] "], + command_command = \ x y -> help_cmd x y >> exitWith ExitSuccess, + command_prereq = \_ -> return $ Right (), + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = []} + +help_cmd :: [DarcsFlag] -> [String] -> IO () +help_cmd _ ["manpage"] = putStr $ unlines manpageLines +help_cmd _ ["patterns"] = viewDoc $ text $ helpOnMatchers +help_cmd _ ["environment"] = viewDoc $ text $ helpOnEnvironment +help_cmd _ [] = viewDoc $ text $ usage command_control_list + +help_cmd _ (cmd:args) = + let disambiguated = disambiguate_commands command_control_list cmd args + in case disambiguated of + Left err -> fail err + Right (cmds,_) -> + let msg = case cmds of + CommandOnly c -> get_command_help Nothing c + SuperCommandOnly c -> get_command_help Nothing c + SuperCommandSub c s -> get_command_help (Just c) s + in viewDoc $ text msg + +list_available_commands :: IO () +list_available_commands = + do here <- getCurrentDirectory + is_valid <- sequence $ map + (\c-> withCurrentDirectory here $ (command_prereq c) []) + (extract_commands command_control_list) + putStr $ unlines $ map (command_name . fst) $ + filter (isRight.snd) $ + zip (extract_commands command_control_list) is_valid + putStrLn "--help" + putStrLn "--version" + putStrLn "--exact-version" + putStrLn "--overview" + where isRight (Right _) = True + isRight _ = False + +print_version :: IO () +print_version = putStrLn $ "darcs version " ++ darcs_version + +-- avoiding a module import cycle between Help and TheCommands +command_control_list :: [CommandControl] +command_control_list = + Command_data help : TheCommands.command_control_list + +-- | Help on each environment variable in which Darcs is interested. +environmentHelp :: [([String], [String])] +environmentHelp = [ + -- General-purpose + environmentHelpHome, + environmentHelpEditor, + environmentHelpPager, + environmentHelpTmpdir, + environmentHelpKeepTmpdir, + environmentHelpSendmail, + -- Remote Repositories + environmentHelpSsh, + environmentHelpScp, + environmentHelpSshPort, + environmentHelpProxy, + environmentHelpProxyPassword] + +-- | The rendered form of the data in 'environment_help'. +helpOnEnvironment :: String +helpOnEnvironment = + "Environment Variables\n" ++ + "=====================\n\n" ++ + unlines [andClauses ks ++ ":\n" ++ + (unlines $ map (" " ++) ds) + | (ks, ds) <- environmentHelp] + +-- | This module is responsible for emitting a darcs "man-page", a +-- reference document used widely on Unix-like systems. Manpages are +-- primarily used as a quick reference, or "memory jogger", so the +-- output should be terser than the user manual. +-- +-- Before modifying the output, please be sure to read the man(7) and +-- man-pages(7) manpages, as these respectively describe the relevant +-- syntax and conventions. + +-- | The lines of the manpage to be printed. +manpageLines :: [String] +manpageLines = [ + ".TH DARCS 1 \"" ++ darcs_version ++ "\"", + ".SH NAME", + "darcs \\- an advanced revision control system", + ".SH SYNOPSIS", + ".B darcs", ".I command", ".RI < arguments |[ options ]>...", + "", + "Where the", ".I commands", "and their respective", ".I arguments", "are", + "", + unlines synopsis, + ".SH DESCRIPTION", + -- FIXME: this is copy-and-pasted from darcs.cabal, so + -- it'll get out of date as people forget to maintain + -- both in sync. + "Darcs is a free, open source revision control", + "system. It is:", + ".TP 3", "\\(bu", + "Distributed: Every user has access to the full", + "command set, removing boundaries between server and", + "client or committer and non-committers.", + ".TP", "\\(bu", + "Interactive: Darcs is easy to learn and efficient to", + "use because it asks you questions in response to", + "simple commands, giving you choices in your work", + "flow. You can choose to record one change in a file,", + "while ignoring another. As you update from upstream,", + "you can review each patch name, even the full `diff'", + "for interesting patches.", + ".TP", "\\(bu", + "Smart: Originally developed by physicist David", + "Roundy, darcs is based on a unique algebra of", + "patches.", + "This smartness lets you respond to changing demands", + "in ways that would otherwise not be possible. Learn", + "more about spontaneous branches with darcs.", + ".SH OPTIONS", + "Different options are accepted by different Darcs commands.", + "Each command's most important options are listed in the", + ".B COMMANDS", + "section. For a full list of all options accepted by", + "a particular command, run `darcs", ".I command", "--help'.", + ".SS " ++ helpOnMatchers, -- FIXME: this is a kludge. + ".SH COMMANDS", + unlines commands, + unlines environment, + ".SH FILES", + ".SS \"_darcs/prefs/binaries\"", + unlines binaries_file_help, + ".SH BUGS", + "At http://bugs.darcs.net/ you can find a list of known", + "bugs in Darcs. Unknown bugs can be reported at that", + "site (after creating an account) or by emailing the", + "report to bugs@darcs.net.", + -- ".SH EXAMPLE", + -- FIXME: + -- new project: init, rec -la; + -- track upstream project: get, pull -a; + -- contribute to project: add, rec, push/send. + ".SH SEE ALSO", + "A user manual is included with Darcs, in PDF and HTML", + "form. It can also be found at http://darcs.net/manual/."] + where + -- | A synopsis line for each command. Uses 'foldl' because it is + -- necessary to avoid blank lines from Hidden_commands, as groff + -- translates them into annoying vertical padding (unlike TeX). + synopsis :: [String] + synopsis = foldl iter [] command_control_list + where iter :: [String] -> CommandControl -> [String] + iter acc (Group_name _) = acc + iter acc (Hidden_command _) = acc + iter acc (Command_data c@SuperCommand {}) = + acc ++ concatMap + (render (command_name c ++ " ")) + (extract_commands (command_sub_commands c)) + iter acc (Command_data c) = acc ++ render "" c + render :: String -> DarcsCommand -> [String] + render prefix c = + [".B darcs " ++ prefix ++ command_name c] ++ + (map mangle_args $ command_extra_arg_help c) ++ + -- In the output, we want each command to be on its own + -- line, but we don't want blank lines between them. + -- AFAICT this can only be achieved with the .br + -- directive, which is probably a GNUism. + [".br"] + + -- | As 'synopsis', but make each group a subsection (.SS), and + -- include the help text for each command. + commands :: [String] + commands = foldl iter [] command_control_list + where iter :: [String] -> CommandControl -> [String] + iter acc (Group_name x) = acc ++ [".SS \"" ++ x ++ "\""] + iter acc (Hidden_command _) = acc + iter acc (Command_data c@SuperCommand {}) = + acc ++ concatMap + (render (command_name c ++ " ")) + (extract_commands (command_sub_commands c)) + iter acc (Command_data c) = acc ++ render "" c + render :: String -> DarcsCommand -> [String] + render prefix c = + [".B darcs " ++ prefix ++ command_name c] ++ + (map mangle_args $ command_extra_arg_help c) ++ + [".RS 4", command_help c, ".RE"] + + -- | Now I'm showing off: mangle the extra arguments of Darcs commands + -- so as to use the ideal format for manpages, italic words and roman + -- punctuation. + mangle_args :: String -> String + mangle_args s = + ".RI " ++ (unwords $ map show (groupBy cmp $ map toLower $ gank s)) + where cmp x y = not $ xor (isAlphaNum x) (isAlphaNum y) + xor x y = (x && not y) || (y && not x) + gank (' ':'o':'r':' ':xs) = '|' : gank xs + gank (x:xs) = x : gank xs + gank [] = [] + + environment :: [String] + environment = ".SH ENVIRONMENT" : concat + [(".SS \"" ++ andClauses ks ++ "\"") : ds + | (ks, ds) <- environmentHelp] + +\end{code} diff --git a/src/Darcs/Commands/Init.lhs b/src/Darcs/Commands/Init.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Init.lhs @@ -0,0 +1,89 @@ +% Copyright (C) 2002-2003 David Roundy +% +% 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. + +\darcsCommand{initialize} +\begin{code} +module Darcs.Commands.Init ( initialize, initialize_cmd ) where +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag, working_repo_dir, + inventory_choices ) +import Darcs.Repository ( amNotInRepository, createRepository ) + +initialize_description :: String +initialize_description = "Make the current directory a repository." + +initialize_help :: String +initialize_help = + "The `darcs initialize' command turns the current directory into a\n" ++ + "Darcs repository. Any existing files and subdirectories become\n" ++ + "UNSAVED changes in the working tree: record them with `darcs add -r'\n" ++ + "and `darcs record'.\n" ++ + "\n" ++ + -- FIXME: confirm my assertion re conversion is true. --twb, 2008-12-14 + "When converting a project to Darcs from some other VCS, translating\n" ++ + "the full revision history to native Darcs patches is recommended.\n" ++ + "(The Darcs wiki lists utilities for this.) Because Darcs is optimized\n" ++ + "for small patches, simply importing the latest revision as a single\n" ++ + "large patch can PERMANENTLY degrade Darcs performance in your\n" ++ + "repository by an order of magnitude.\n" ++ + "\n" ++ + "This command creates the `_darcs' directory, which stores version\n" ++ + "control metadata. It also contains per-repository settings in\n" ++ + "_darcs/prefs/, which you can read about in the user manual.\n" ++ + "\n" ++ + "In addition to the default `darcs-2' format, there are two backward\n" ++ + "compatibility formats for the _darcs directory. These formats are\n" ++ + "only useful if some of your contributors do not have access to Darcs\n" ++ + "2.0 or higher. In that case, you need to use the original format\n" ++ + "(called `old-fashioned inventory' or `darcs-1') for any repositories\n" ++ + "those contributors access.\n" ++ + "\n" ++ + "As patches cannot be shared between darcs-2 and darcs-1 repositories,\n" ++ + "you cannot use the darcs-2 format for private branches of such a\n" ++ + "project. Instead, you should use the `hashed' format, which provides\n" ++ + "most of the features of the darcs-2 format, while retaining the\n" ++ + "ability to share patches with darcs-1 repositories. The `darcs get'\n" ++ + "command will do this by default.\n" ++ + "\n" ++ + "Once all contributors have access to Darcs 2.0 or higher, a darcs-1\n" ++ + "project can be migrated to darcs-2 using the `darcs convert' command.\n" ++ + "\n" ++ + "Darcs will create a hashed repository by default when you `darcs get'\n" ++ + "a repository in old-fashioned inventory format. Once all contributors\n" ++ + "have upgraded to Darcs 2.0 or later, use `darcs convert' to convert\n" ++ + "the project to the darcs-2 format.\n" ++ + "\n" ++ + "Initialize is commonly abbreviated to `init'.\n" + +initialize :: DarcsCommand +initialize = DarcsCommand {command_name = "initialize", + command_help = initialize_help, + command_description = initialize_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_prereq = amNotInRepository, + command_command = initialize_cmd, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [inventory_choices, + working_repo_dir]} + +initialize_cmd :: [DarcsFlag] -> [String] -> IO () +initialize_cmd opts _ = createRepository opts +\end{code} + diff --git a/src/Darcs/Commands/MarkConflicts.lhs b/src/Darcs/Commands/MarkConflicts.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/MarkConflicts.lhs @@ -0,0 +1,106 @@ +% Copyright (C) 2002-2003,2005 David Roundy +% +% 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. + +\darcsCommand{mark-conflicts} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.MarkConflicts ( markconflicts, resolve ) where +import System.Exit ( ExitCode(..), exitWith ) +import Darcs.SignalHandler ( withSignalsBlocked ) +import Control.Monad ( when ) + +import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) +import Darcs.Arguments ( DarcsFlag, ignoretimes, working_repo_dir, umask_option ) +import Darcs.Repository ( withRepoLock, ($-), amInRepository, add_to_pending, + applyToWorking, + read_repo, sync_repo, get_unrecorded_unsorted, + ) +import Darcs.Patch ( invert ) +import Darcs.Ordered ( FL(..) ) +import Darcs.Sealed ( Sealed(Sealed) ) +import Darcs.Resolution ( patchset_conflict_resolutions ) +import Darcs.Utils ( promptYorn ) +#include "impossible.h" + +markconflicts_description :: String +markconflicts_description = + "Mark unresolved conflicts in working tree, for manual resolution." + +markconflicts_help :: String +markconflicts_help = + "Darcs requires human guidance to unify changes to the same part of a\n" ++ + "source file. When a conflict first occurs, darcs will add both\n" ++ + "choices to the working tree, delimited by the markers `v v v',\n" ++ + "`* * *' and `^ ^ ^'.\n" ++ + "\n" ++ + "However, you might revert or manually delete these markers without\n" ++ + "actually resolving the conflict. In this case, `darcs mark-conflicts'\n" ++ + "is useful to show where any unresolved conflicts. It is also useful\n" ++ + "if `darcs apply' is called with --apply-conflicts, where conflicts\n" ++ + "aren't marked initially.\n" ++ + "\n" ++ + "Any unrecorded changes to the working tree WILL be lost forever when\n" ++ + "you run this command! You will be prompted for confirmation before\n" ++ + "this takes place.\n" ++ + "\n" ++ + "This command was historically called `resolve', and this deprecated\n" ++ + "alias still exists for backwards-compatibility.\n" + +markconflicts :: DarcsCommand +markconflicts = DarcsCommand {command_name = "mark-conflicts", + command_help = markconflicts_help, + command_description = markconflicts_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = markconflicts_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [umask_option], + command_basic_options = [ignoretimes, + working_repo_dir]} + +markconflicts_cmd :: [DarcsFlag] -> [String] -> IO () +markconflicts_cmd opts [] = withRepoLock opts $- \repository -> do + pend <- get_unrecorded_unsorted repository + r <- read_repo repository + Sealed res <- return $ patchset_conflict_resolutions r + case res of NilFL -> do putStrLn "No conflicts to mark." + exitWith ExitSuccess + _ -> return () + case pend of + NilFL -> return () + _ -> do yorn <- promptYorn + ("This will trash any unrecorded changes"++ + " in the working directory.\nAre you sure? ") + when (yorn /= 'y') $ exitWith ExitSuccess + applyToWorking repository opts (invert pend) `catch` \e -> + bug ("Can't undo pending changes!" ++ show e) + sync_repo repository + withSignalsBlocked $ + do add_to_pending repository res + applyToWorking repository opts res `catch` \e -> + bug ("Problem marking conflicts in mark-conflicts!" ++ show e) + putStrLn "Finished marking conflicts." +markconflicts_cmd _ _ = impossible + +-- |resolve is an alias for mark-conflicts. +resolve :: DarcsCommand +resolve = command_alias "resolve" markconflicts +\end{code} diff --git a/src/Darcs/Commands/Move.lhs b/src/Darcs/Commands/Move.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Move.lhs @@ -0,0 +1,186 @@ +% Copyright (C) 2002-2003 David Roundy +% +% 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. + +\darcsCommand{move} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Move ( move, mv ) where +import Control.Monad ( when, unless, zipWithM_ ) +import Data.Maybe ( catMaybes ) +import Darcs.SignalHandler ( withSignalsBlocked ) + +import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) +import Darcs.Arguments ( DarcsFlag( AllowCaseOnly, AllowWindowsReserved ), + fixSubPaths, working_repo_dir, + list_files, allow_problematic_filenames, umask_option, + ) +import Darcs.RepoPath ( toFilePath, sp2fn ) +import System.FilePath.Posix ( (), takeFileName ) +import System.Directory ( renameDirectory ) +import Workaround ( renameFile ) +import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository, + slurp_pending, add_to_pending, + ) +import Darcs.Ordered ( FL(..), unsafeFL ) +import Darcs.Global ( debugMessage ) +import qualified Darcs.Patch +import Darcs.Patch ( RepoPatch, Prim ) +import Darcs.SlurpDirectory ( Slurpy, slurp, slurp_has, slurp_has_anycase, + slurp_remove, slurp_hasdir, slurp_hasfile ) +import Darcs.Patch.FileName ( fp2fn, fn2fp, super_name ) +import qualified System.FilePath.Windows as WindowsFilePath + +import Darcs.Gorsvet( invalidateIndex ) +#include "impossible.h" + +move_description :: String +move_description = "Move or rename files." + +move_help :: String +move_help = + "Darcs cannot reliably distinguish between a file being deleted and a\n" ++ + "new one added, and a file being moved. Therefore Darcs always assumes\n" ++ + "the former, and provides the `darcs mv' command to let Darcs know when\n" ++ + "you want the latter. This command will also move the file in the\n" ++ + "working tree (unlike `darcs remove').\n" ++ + "\n" ++ + -- Note that this paragraph is very similar to one in ./Add.lhs. + "Darcs will not rename a file if another file in the same folder has\n" ++ + "the same name, except for case. The --case-ok option overrides this\n" ++ + "behaviour. Windows and OS X usually use filesystems that do not allow\n" ++ + "files a folder to have the same name except for case (for example,\n" ++ + "`ReadMe' and `README'). If --case-ok is used, the repository might be\n" ++ + "unusable on those systems!\n" + +move :: DarcsCommand +move = DarcsCommand {command_name = "move", + command_help = move_help, + command_description = move_description, + command_extra_args = -1, + command_extra_arg_help = [" ... "], + command_command = move_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = list_files, + command_argdefaults = nodefaults, + command_advanced_options = [umask_option], + command_basic_options = [allow_problematic_filenames, working_repo_dir]} +move_cmd :: [DarcsFlag] -> [String] -> IO () +move_cmd _ [] = fail "The `darcs move' command requires at least two arguments." +move_cmd _ [_] = fail "The `darcs move' command requires at least two arguments." + +move_cmd opts args@[_,_] = withRepoLock opts $- \repository -> do + two_files <- fixSubPaths opts args + [old,new] <- return $ case two_files of + [_,_] -> two_files + [_] -> error "Cannot rename a file or directory onto itself!" + xs -> bug $ "Problem in move_cmd: " ++ show xs + work <- slurp "." + let old_fp = toFilePath old + new_fp = toFilePath new + if slurp_hasdir (sp2fn new) work && slurp_has old_fp work + then move_to_dir repository opts [old_fp] new_fp + else do + cur <- slurp_pending repository + addpatch <- check_new_and_old_filenames opts cur work (old_fp,new_fp) + invalidateIndex repository + withSignalsBlocked $ do + case addpatch of + Nothing -> add_to_pending repository (Darcs.Patch.move old_fp new_fp :>: NilFL) + Just p -> add_to_pending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL) + move_file_or_dir work old_fp new_fp + +move_cmd opts args = + withRepoLock opts $- \repository -> do + relpaths <- map toFilePath `fmap` fixSubPaths opts args + let moved = init relpaths + finaldir = last relpaths + move_to_dir repository opts moved finaldir + +move_to_dir :: RepoPatch p => Repository p -> [DarcsFlag] -> [FilePath] -> FilePath -> IO () +move_to_dir repository opts moved finaldir = + let movefns = map takeFileName moved + movetargets = map (finaldir ) movefns + movepatches = zipWith Darcs.Patch.move moved movetargets + in do + cur <- slurp_pending repository + work <- slurp "." + addpatches <- mapM (check_new_and_old_filenames opts cur work) $ zip moved movetargets + invalidateIndex repository + withSignalsBlocked $ do + add_to_pending repository $ unsafeFL $ catMaybes addpatches ++ movepatches + zipWithM_ (move_file_or_dir work) moved movetargets + +check_new_and_old_filenames + :: [DarcsFlag] -> Slurpy -> Slurpy -> (FilePath, FilePath) -> IO (Maybe Prim) +check_new_and_old_filenames opts cur work (old,new) = do + unless (AllowWindowsReserved `elem` opts || WindowsFilePath.isValid new) $ + fail $ "The filename " ++ new ++ " is not valid under Windows.\n" ++ + "Use --reserved-ok to allow such filenames." + maybe_add_file_thats_been_moved <- + if slurp_has old work -- We need to move the object + then do unless (slurp_hasdir (super_name $ fp2fn new) work) $ + fail $ "The target directory " ++ + (fn2fp $ super_name $ fp2fn new)++ + " isn't known in working directory, did you forget to add it?" + when (it_has new work) $ fail $ already_exists "working directory" + return Nothing + else do unless (slurp_has new work) $ fail $ doesnt_exist "working directory" + return $ Just $ Darcs.Patch.addfile old + if slurp_has old cur + then do unless (slurp_hasdir (super_name $ fp2fn new) cur) $ + fail $ "The target directory " ++ + (fn2fp $ super_name $ fp2fn new)++ + " isn't known in working directory, did you forget to add it?" + when (it_has new cur) $ fail $ already_exists "repository" + else fail $ doesnt_exist "repository" + return maybe_add_file_thats_been_moved + where it_has f s = + let ms2 = slurp_remove (fp2fn old) s + in case ms2 of + Nothing -> False + Just s2 -> if AllowCaseOnly `elem` opts + then slurp_has f s2 + else slurp_has_anycase f s2 + already_exists what_slurpy = + if AllowCaseOnly `elem` opts + then "A file or dir named "++new++" already exists in " + ++ what_slurpy ++ "." + else "A file or dir named "++new++" (or perhaps differing"++ + " only in case)\nalready exists in "++ + what_slurpy ++ ".\n"++ + "Use --case-ok to allow files differing only in case." + doesnt_exist what_slurpy = + "There is no file or dir named " ++ old ++ + " in the "++ what_slurpy ++ "." + +move_file_or_dir :: Slurpy -> FilePath -> FilePath -> IO () +move_file_or_dir work old new = + if slurp_hasfile (fp2fn old) work + then do debugMessage $ unwords ["renameFile",old,new] + renameFile old new + else if slurp_hasdir (fp2fn old) work + then do debugMessage $ unwords ["renameDirectory",old,new] + renameDirectory old new + else return () + +mv :: DarcsCommand +mv = command_alias "mv" move +\end{code} + + diff --git a/src/Darcs/Commands/Optimize.lhs b/src/Darcs/Commands/Optimize.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Optimize.lhs @@ -0,0 +1,314 @@ +% Copyright (C) 2003-2005 David Roundy +% +% 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. + +\darcsCommand{optimize} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Optimize ( optimize ) where +import Control.Monad ( when, unless ) +import Data.Maybe ( isJust ) +import Text.Regex ( mkRegex, matchRegex ) +import System.Directory ( getDirectoryContents, doesDirectoryExist ) + +import Darcs.Hopefully ( hopefully, info ) +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag( Compress, UnCompress, + NoCompress, Reorder, + TagName, CheckPoint, + Relink, RelinkPristine ), + tagname, checkpoint, reorder_patches, + uncompress_nocompress, + relink, relink_pristine, sibling, + flagsToSiblings, + working_repo_dir, umask_option, + ) +import Darcs.Repository.Prefs ( get_preflist ) +import Darcs.Repository ( Repository, PatchSet, withRepoLock, ($-), withGutsOf, + read_repo, optimizeInventory, slurp_recorded, + tentativelyReplacePatches, cleanRepository, + amInRepository, finalizeRepositoryChanges ) +import Darcs.Repository.Checkpoint ( write_checkpoint ) +import Darcs.Ordered ( RL(..), unsafeUnRL, (+<+), mapFL_FL, reverseRL, mapRL, concatRL ) +import Darcs.Patch.Info ( PatchInfo, just_name, human_friendly ) +import Darcs.Patch ( RepoPatch ) +import ByteStringUtils ( gzReadFilePS ) +import Darcs.Patch.Depends ( deep_optimize_patchset, slightly_optimize_patchset, + get_patches_beyond_tag, get_patches_in_tag, + ) +import Darcs.Lock ( maybeRelink, gzWriteAtomicFilePS, writeAtomicFilePS ) +import Darcs.RepoPath ( toFilePath ) +import Darcs.Utils ( withCurrentDirectory ) +import Progress ( debugMessage ) +import Printer ( putDocLn, text, ($$) ) +import Darcs.SlurpDirectory ( slurp, list_slurpy_files ) +import Darcs.Repository.Pristine ( identifyPristine, pristineDirectory ) +import Darcs.Sealed ( FlippedSeal(..), unsafeUnseal ) +import Darcs.Global ( darcsdir ) +#include "impossible.h" + +optimize_description :: String +optimize_description = "Optimize the repository." + +optimize_help :: String +optimize_help = + "The `darcs optimize' command modifies the current repository in an\n" ++ + "attempt to reduce its resource requirements. By default a single\n" ++ + "fast, safe optimization is performed; additional optimization\n" ++ + "techniques can be enabled by passing options to `darcs optimize'.\n" ++ + "\n" ++ optimize_help_inventory ++ + -- "\n" ++ optimize_help_reorder ++ + "\n" ++ optimize_help_relink ++ + -- checkpoints and uncompression are least useful, so they are last. + "\n" ++ optimize_help_compression ++ + "\n" ++ optimize_help_checkpoint ++ + "\n" ++ + "There is one more optimization which CAN NOT be performed by this\n" ++ + "command. Every time your record a patch, a new inventory file is\n" ++ + "written to _darcs/inventories/, and old inventories are never reaped.\n" ++ + "\n" ++ + "If _darcs/inventories/ is consuming a relatively large amount of\n" ++ + "space, you can safely reclaim it by using `darcs get' to make a\n" ++ + "complete copy of the repo. When doing so, don't forget to copy over\n" ++ + "any unsaved changes you have made to the working tree or to\n" ++ + "unversioned files in _darcs/prefs/ (such as _darcs/prefs/author).\n" + +optimize :: DarcsCommand +optimize = DarcsCommand {command_name = "optimize", + command_help = optimize_help, + command_description = optimize_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = optimize_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [uncompress_nocompress, umask_option], + command_basic_options = [checkpoint, + tagname, + working_repo_dir, + reorder_patches, + sibling, relink, + relink_pristine]} + +optimize_cmd :: [DarcsFlag] -> [String] -> IO () +optimize_cmd origopts _ = withRepoLock opts $- \repository -> do + cleanRepository repository + do_reorder opts repository + do_optimize_inventory repository + when (CheckPoint `elem` opts) $ do_checkpoint opts repository + when (Compress `elem` opts || UnCompress `elem` opts) $ optimize_compression opts + when (Relink `elem` opts || (RelinkPristine `elem` opts)) $ + do_relink opts repository + putStrLn "Done optimizing!" + where opts = if UnCompress `elem` origopts then NoCompress:origopts else origopts +is_tag :: PatchInfo -> Bool +is_tag pinfo = take 4 (just_name pinfo) == "TAG " + +optimize_help_inventory :: String +optimize_help_inventory = + "The default optimization moves recent patches (those not included in\n" ++ + "the latest tag) to the `front', reducing the amount that a typical\n" ++ + "remote command needs to download. It should also reduce the CPU time\n" ++ + "needed for some operations.\n" + +do_optimize_inventory :: RepoPatch p => Repository p -> IO () +do_optimize_inventory repository = do + debugMessage "Writing out a nice copy of the inventory." + optimizeInventory repository + debugMessage "Done writing out a nice copy of the inventory." + +optimize_help_checkpoint :: String +optimize_help_checkpoint = + "If the repository is in `old-fashioned-inventory' format, the `darcs\n" ++ + "optimize --checkpoint' command creates a checkpoint of the latest tag.\n" ++ + "This checkpoint is used by `darcs get --partial' to create partial\n" ++ + "repositories. With the `--tag' option, checkpoints for older tags can\n" ++ + "be created. In newer repository formats, this feature has been\n" ++ + "replaced by `darcs get --lazy', which does not require checkpoints.\n" + +do_checkpoint :: RepoPatch p => [DarcsFlag] -> Repository p -> IO () +do_checkpoint opts repository = do + mpi <- get_tag opts repository + case mpi of + Nothing -> return () + Just pinfo -> do putDocLn $ text "Checkpointing tag:" + $$ human_friendly pinfo + write_checkpoint repository pinfo + +get_tag :: RepoPatch p => [DarcsFlag] -> Repository p -> IO (Maybe PatchInfo) +get_tag [] r = do ps <- read_repo r + case filter is_tag $ lasts $ mapRL (mapRL info) ps of + [] -> do putStrLn "There is no tag to checkpoint!" + return Nothing + (pinfo:_) -> return $ Just pinfo +get_tag (TagName t:_) r = + do ps <- read_repo r + case filter (match_tag t) $ lasts $ mapRL (mapRL info) ps of + (pinfo:_) -> return $ Just pinfo + _ -> case filter (match_tag t) $ + lasts $ mapRL (mapRL info) $ deep_optimize_patchset ps of + (pinfo:_) -> return $ Just pinfo + _ -> do putStr "Cannot checkpoint any tag " + putStr $ "matching '"++t++"'\n" + return Nothing +get_tag (_:fs) r = get_tag fs r + +lasts :: [[a]] -> [a] +lasts [] = [] +lasts (x@(_:_):ls) = last x : lasts ls +lasts ([]:ls) = lasts ls + +mymatch :: String -> PatchInfo -> Bool +mymatch r = match_name $ matchRegex (mkRegex r) +match_name :: (String -> Maybe a) -> PatchInfo -> Bool +match_name ch pinfo = isJust $ ch (just_name pinfo) +match_tag :: String -> PatchInfo -> Bool +match_tag ('^':n) = mymatch $ "^TAG "++n +match_tag n = mymatch $ "^TAG .*"++n + + +optimize_help_compression :: String +optimize_help_compression = + "By default patches are compressed with zlib (RFC 1951) to reduce\n" ++ + "storage (and download) size. In exceptional circumstances, it may be\n" ++ + "preferable to avoid compression. In this case the `--dont-compress'\n" ++ + "option can be used (e.g. with `darcs record') to avoid compression.\n" ++ + "\n" ++ + "The `darcs optimize --uncompress' and `darcs optimize --compress'\n" ++ + "commands can be used to ensure existing patches in the current\n" ++ + "repository are respectively uncompressed or compressed. Note that\n" ++ + "repositories in the legacy `old-fashioned-inventory' format have a .gz\n" ++ + "extension on patch files even when uncompressed.\n" + +optimize_compression :: [DarcsFlag] -> IO () +optimize_compression opts = do + putStrLn "Optimizing (un)compression of patches..." + do_compress (darcsdir++"/patches") + putStrLn "Optimizing (un)compression of inventories..." + do_compress (darcsdir++"/inventories") + where do_compress f = + do isd <- doesDirectoryExist f + if isd then withCurrentDirectory f $ + do fs <- filter notdot `fmap` getDirectoryContents "." + mapM_ do_compress fs + else if Compress `elem` opts + then gzReadFilePS f >>= gzWriteAtomicFilePS f + else gzReadFilePS f >>= writeAtomicFilePS f + notdot ('.':_) = False + notdot _ = True + +optimize_help_relink :: String +optimize_help_relink = + "The `darcs optimize --relink' command hard-links patches that the\n" ++ + "current repository has in common with its peers. Peers are those\n" ++ + "repositories listed in _darcs/prefs/sources, or defined with the\n" ++ + "`--sibling' option (which can be used multiple times).\n" ++ + "\n" ++ + "Darcs uses hard-links automatically, so this command is rarely needed.\n" ++ + "It is most useful if you used `cp -r' instead of `darcs get' to copy a\n" ++ + "repository, or if you pulled the same patch from a remote repository\n" ++ + "into multiple local repositories.\n" ++ + "\n" ++ + "A `darcs optimize --relink-pristine' command is also available, but\n" ++ + "generally SHOULD NOT be used. It results in a relatively small space\n" ++ + "saving at the cost of making many Darcs commands MUCH slower.\n" + +do_relink :: RepoPatch p => [DarcsFlag] -> Repository p -> IO () +do_relink opts repository = + do some_siblings <- return (flagsToSiblings opts) + defrepolist <- get_preflist "defaultrepo" + siblings <- return (map toFilePath some_siblings ++ defrepolist) + if (siblings == []) + then putStrLn "No siblings -- no relinking done." + else do when (Relink `elem` opts) $ + do debugMessage "Relinking patches..." + patches <- + (fmap list_slurpy_files) (slurp $ darcsdir++"/patches") + maybeRelinkFiles siblings patches (darcsdir++"/patches") + when (RelinkPristine `elem` opts) $ + do pristine <- identifyPristine + case (pristineDirectory pristine) of + (Just d) -> do + debugMessage "Relinking pristine tree..." + c <- slurp_recorded repository + maybeRelinkFiles + siblings (list_slurpy_files c) d + Nothing -> return () + debugMessage "Done relinking." + return () + return () + +maybeRelinkFiles :: [String] -> [String] -> String -> IO () +maybeRelinkFiles src dst dir = + mapM_ (maybeRelinkFile src) (map ((dir ++ "/") ++) dst) + +maybeRelinkFile :: [String] -> String -> IO () +maybeRelinkFile [] _ = return () +maybeRelinkFile (h:t) f = + do done <- maybeRelink (h ++ "/" ++ f) f + unless done $ + maybeRelinkFile t f + return () + + +\end{code} +\begin{options} +--reorder-patches +\end{options} + +The \verb|--reorder-patches| option causes Darcs to create an optimal +ordering of its internal patch inventory. This may help to produce shorter +`context' lists when sending patches, and may improve performance for some +other operations as well. You should not run \verb!--reorder-patches! on a +repository from which someone may be simultaneously pulling or getting, as +this could lead to repository corruption. +\begin{code} + +-- FIXME: someone needs to grovel through the source and determine +-- just how optimizeInventory differs from do_reorder. The following +-- is purely speculation. --twb, 2009-04 +-- optimize_help_reorder :: String +-- optimize_help_reorder = +-- "The `darcs optimize --reorder' command is a more comprehensive version\n" ++ +-- "of the default optimization. It reorders patches with respect to ALL\n" ++ +-- "tags, rather than just the latest tag.\n" + +do_reorder :: RepoPatch p => [DarcsFlag] -> Repository p -> IO () +do_reorder opts _ | not (Reorder `elem` opts) = return () +do_reorder opts repository = do + debugMessage "Reordering the inventory." + psnew <- choose_order `fmap` read_repo repository + let ps = mapFL_FL hopefully $ reverseRL $ head $ unsafeUnRL psnew + withGutsOf repository $ do tentativelyReplacePatches repository opts ps + finalizeRepositoryChanges repository + debugMessage "Done reordering the inventory." + +choose_order :: RepoPatch p => PatchSet p -> PatchSet p +choose_order ps | isJust last_tag = + case slightly_optimize_patchset $ unsafeUnseal $ get_patches_in_tag lt ps of + ((t:<:NilRL):<:pps) -> case get_patches_beyond_tag lt ps of + FlippedSeal (p :<: NilRL) -> (p+<+(t:<:NilRL)) :<: pps + _ -> impossible + _ -> impossible + where last_tag = case filter is_tag $ mapRL info $ concatRL ps of + (t:_) -> Just t + _ -> Nothing + lt = fromJust last_tag +choose_order ps = ps +\end{code} diff --git a/src/Darcs/Commands/Pull.lhs b/src/Darcs/Commands/Pull.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Pull.lhs @@ -0,0 +1,274 @@ +% Copyright (C) 2002-2005 David Roundy +% +% 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. + +\darcsCommand{pull} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Pull ( pull ) where +import System.Exit ( ExitCode(..), exitWith ) +import Workaround ( getCurrentDirectory ) +import Control.Monad ( when ) +import Data.List ( nub ) + +import Darcs.Commands ( DarcsCommand(..), loggers ) +import Darcs.CommandsAux ( check_paths ) +import Darcs.Arguments ( DarcsFlag( Verbose, Quiet, DryRun, MarkConflicts, XMLOutput, + Intersection, Complement, AllowConflicts, NoAllowConflicts ), + nocompress, ignoretimes, definePatches, + deps_sel, pull_conflict_options, use_external_merge, + match_several, fixUrl, + all_interactive, repo_combinator, + print_dry_run_message_and_exit, + test, dry_run, + set_default, summary, working_repo_dir, remote_repo, + set_scripts_executable, nolinks, + network_options, umask_option, allow_unrelated_repos, restrict_paths + ) +import Darcs.Repository ( Repository, SealedPatchSet, identifyRepositoryFor, withGutsOf, + amInRepository, withRepoLock, ($-), tentativelyMergePatches, + sync_repo, finalizeRepositoryChanges, applyToWorking, + read_repo, checkUnrelatedRepos ) +import Darcs.Hopefully ( info ) +import Darcs.Patch ( RepoPatch, description ) +import Darcs.Ordered ( (:>)(..), (:\/:)(..), RL(..), unsafeUnRL, concatRL, + mapFL, nullFL, reverseRL, mapRL ) +import Darcs.Patch.Permutations ( partitionFL ) +import Darcs.SlurpDirectory ( wait_a_moment ) +import Darcs.Repository.Prefs ( add_to_preflist, defaultrepo, set_defaultrepo, get_preflist ) +import Darcs.Repository.Motd (show_motd ) +import Darcs.Patch.Depends ( get_common_and_uncommon, + patchset_intersection, patchset_union ) +import Darcs.SelectChanges ( with_selected_changes ) +import Darcs.Utils ( clarify_errors, formatPath ) +import Darcs.Sealed ( Sealed(..), seal ) +import Printer ( putDocLn, vcat, ($$), text ) +import Darcs.Gorsvet( invalidateIndex ) +#include "impossible.h" + +pull_description :: String +pull_description = + "Copy and apply patches from another repository to this one." + +pull_help :: String +pull_help = + "Pull is used to bring changes made in another repository into the current\n"++ + "repository (that is, either the one in the current directory, or the one\n"++ + "specified with the --repodir option). Pull allows you to bring over all or\n"++ + "some of the patches that are in that repository but not in this one. Pull\n"++ + "accepts arguments, which are URLs from which to pull, and when called\n"++ + "without an argument, pull will use the repository from which you have most\n"++ + "recently either pushed or pulled.\n" + +pull :: DarcsCommand +pull = DarcsCommand {command_name = "pull", + command_help = pull_help, + command_description = pull_description, + command_extra_args = -1, + command_extra_arg_help = ["[REPOSITORY]..."], + command_command = pull_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = get_preflist "repos", + command_argdefaults = defaultrepo, + command_advanced_options = [repo_combinator, + nocompress, nolinks, + ignoretimes, + remote_repo, + set_scripts_executable, + umask_option, + restrict_paths] ++ + network_options, + command_basic_options = [match_several, + all_interactive, + pull_conflict_options, + use_external_merge, + test]++dry_run++[summary, + deps_sel, + set_default, + working_repo_dir, + allow_unrelated_repos]} + +pull_cmd :: [DarcsFlag] -> [String] -> IO () + +pull_cmd opts unfixedrepodirs@(_:_) = + let (logMessage, _, logDocLn) = loggers opts + putInfo = if (Quiet `elem` opts || XMLOutput `elem` opts) then \_ -> return () else logDocLn + putVerbose = if Verbose `elem` opts then putDocLn else \_ -> return () + in withRepoLock opts $- \repository -> do + here <- getCurrentDirectory + repodirs <- (nub . filter (/= here)) `fmap` mapM (fixUrl opts) unfixedrepodirs + -- Test to make sure we aren't trying to pull from the current repo + when (null repodirs) $ + fail "Can't pull from current repository!" + (Sealed them, Sealed compl) <- read_repos repository opts repodirs + old_default <- get_preflist "defaultrepo" + set_defaultrepo (head repodirs) opts + mapM_ (add_to_preflist "repos") repodirs + when (old_default == repodirs) $ + let pulling = if DryRun `elem` opts then "Would pull" else "Pulling" + in putInfo $ text $ pulling++" from "++concatMap formatPath repodirs++"..." + mapM_ (show_motd opts) repodirs + us <- read_repo repository + (common, us' :\/: them'') <- return $ get_common_and_uncommon (us, them) + (_ , _ :\/: compl') <- return $ get_common_and_uncommon (us, compl) + checkUnrelatedRepos opts common us them + let avoided = mapRL info (concatRL compl') + ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) $ reverseRL $ concatRL them'' + do when (Verbose `elem` opts) $ + do case us' of + (x@(_:<:_):<:_) -> putDocLn $ text "We have the following new (to them) patches:" + $$ (vcat $ mapRL description x) + _ -> return () + when (not $ nullFL ps) $ putDocLn $ text "They have the following patches to pull:" + $$ (vcat $ mapFL description ps) + when (nullFL ps) $ do putInfo $ text "No remote changes to pull in!" + definePatches ps + exitWith ExitSuccess + with_selected_changes "pull" opts ps $ + \ (to_be_pulled:>_) -> do + print_dry_run_message_and_exit "pull" opts to_be_pulled + definePatches to_be_pulled + when (nullFL to_be_pulled) $ do + logMessage "You don't want to pull any patches, and that's fine with me!" + exitWith ExitSuccess + check_paths opts to_be_pulled + putVerbose $ text "Getting and merging the following patches:" + putVerbose $ vcat $ mapFL description to_be_pulled + let merge_opts | NoAllowConflicts `elem` opts = opts + | AllowConflicts `elem` opts = opts + | otherwise = MarkConflicts : opts + Sealed pw <- tentativelyMergePatches repository "pull" merge_opts + (reverseRL $ head $ unsafeUnRL us') to_be_pulled + invalidateIndex repository + withGutsOf repository $ do finalizeRepositoryChanges repository + -- so work will be more recent than rec: + revertable $ do wait_a_moment + applyToWorking repository opts pw + sync_repo repository + putInfo $ text "Finished pulling and applying." + where revertable x = x `clarify_errors` unlines + ["Error applying patch to the working directory.","", + "This may have left your working directory an inconsistent", + "but recoverable state. If you had no un-recorded changes", + "by using 'darcs revert' you should be able to make your", + "working directory consistent again."] +pull_cmd _ [] = fail "No default repository to pull from, please specify one" + +{- Read in the specified pull-from repositories. Perform +Intersection, Union, or Complement read. In patch-theory terms +(stated in set algebra, where + is union and & is intersection +and \ is complement): + + Union = ((R1 + R2 + ... + Rn) \ Rc) + Intersection = ((R1 & R2 & ... & Rn) \ Rc) + Complement = (R1 \ Rc) \ ((R2 + R3 + ... + Rn) \ Rc) + + where Rc = local repo + R1 = 1st specified pull repo + R2, R3, Rn = other specified pull repo + +Since Rc is not provided here yet, the result of read_repos is a +tuple: the first patchset(s) to be complemented against Rc and then +the second patchset(s) to be complemented against Rc. +-} + +read_repos :: RepoPatch p => Repository p -> [DarcsFlag] -> [String] -> IO (SealedPatchSet p,SealedPatchSet p) +read_repos _ _ [] = impossible +read_repos to_repo opts us = + do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo u + ps <- read_repo r + return $ seal ps) us + return $ if Intersection `elem` opts + then (patchset_intersection rs, seal NilRL) + else if Complement `elem` opts + then (head rs, patchset_union $ tail rs) + else (patchset_union rs, seal NilRL) + +\end{code} + +\begin{options} +--intersection, --union [DEFAULT], --complement +\end{options} + +If you provide more than one repository as an argument to pull, darcs' +behavior is determined by the presence of the \verb!--complement!, +\verb!--intersection!, and \verb!--union! flags. + +\begin{itemize} + +\item The default (\verb!--union!) behavior is to pull any patches +that are in any of the specified repositories ($ R_1 \bigcup R_2 +\bigcup R_3 \ldots$). + +\item If you instead specify the \verb!--intersection! flag, darcs +will only pull those patches which are present in all source +repositories ($ R_1 \bigcap R_2 \bigcap R_3 \ldots$). + +\item If you specify the \verb!--complement! flag, darcs will only +pull elements in the first repository that do not exist in any of the +remaining repositories\footnote{The first thing darcs will do is +remove duplicates, keeping only the first specification. This is +noticeable for the complement operation, since mathematically $ S +\backslash S \rightarrow \emptyset $, one would expect that +``\texttt{darcs pull --complement repo1 repo1}'' would result in no +pulls, but the duplicate elimination removes the second +\texttt{repo1}, reducing the above to effectively ``\texttt{darcs pull +repo1}''. The expected functionality could be seen via +``\texttt{darcs get -a repo1 repo2; darcs pull --complement repo1 +repo2}'', but there are easier ways of doing nothing!} ($ R_1 +\backslash (R_2 \bigcup R_3 \bigcup \ldots$)). + +\end{itemize} + + +\begin{options} +--external-merge +\end{options} + +You can use an external interactive merge tool to resolve conflicts with the +flag \verb!--external-merge!. For more details see +subsection~\ref{resolution}. + +\begin{options} +--matches, --patches, --tags, --no-deps +\end{options} + +The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps! +options can be used to select which patches to pull, as described in +subsection~\ref{selecting}. + +\begin{options} +--no-test, --test +\end{options} + +If you specify the \verb!--test! option, pull will run the test (if a test +exists) on a scratch copy of the repository contents prior to actually performing +the pull. If the test fails, the pull will be aborted. + +\begin{options} +--verbose +\end{options} + +Adding the \verb!--verbose! option causes another section to appear in the +output which also displays a summary of patches that you have and the remote +repository lacks. Thus, the following syntax can be used to show you all the patch +differences between two repositories: + +\begin{verbatim} +darcs pull --dry-run --verbose +\end{verbatim} diff --git a/src/Darcs/Commands/Push.lhs b/src/Darcs/Commands/Push.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Push.lhs @@ -0,0 +1,255 @@ +% Copyright (C) 2002-2004 David Roundy +% +% 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. + +\darcsCommand{push} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Push ( push ) where +import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ) ) +import Control.Monad ( when ) +import Data.Char ( toUpper ) +import Workaround ( getCurrentDirectory ) +import Darcs.Commands ( DarcsCommand(..) ) +import Darcs.Arguments ( DarcsFlag( DryRun, Verbose, Quiet, Sign, SignAs, NoSign, SignSSL ), + definePatches, + working_repo_dir, summary, + print_dry_run_message_and_exit, + applyas, match_several, fixUrl, deps_sel, + all_interactive, dry_run, nolinks, + remote_repo, network_options, + set_default, sign, allow_unrelated_repos + ) +import Darcs.Hopefully ( hopefully ) +import Darcs.Repository ( withRepoReadLock, ($-), identifyRepositoryFor, + read_repo, amInRepository, checkUnrelatedRepos ) +import Darcs.Patch ( description ) +import Darcs.Ordered ( RL(..), (:>)(..), (:\/:)(..), + nullFL, reverseRL, mapFL_FL, unsafeUnRL, mapRL, lengthRL ) +import Darcs.Repository.Prefs ( defaultrepo, set_defaultrepo, get_preflist ) +import Darcs.External ( maybeURLCmd, signString ) +import Darcs.URL ( is_url, is_file ) +import Darcs.SelectChanges ( with_selected_changes ) +import Darcs.Utils ( formatPath ) +import Darcs.Patch.Depends ( get_common_and_uncommon ) +import Darcs.Patch.Bundle ( make_bundle ) +import Printer ( vcat, empty, text, ($$), (<+>), putDocLn, errorDoc ) +import Darcs.RemoteApply ( remote_apply, apply_as ) +import Darcs.Email ( make_email ) +import English (englishNum, Noun(..)) +#include "impossible.h" + +push_description :: String +push_description = + "Copy and apply patches from this repository to another one." + +push_help :: String +push_help = + "Push is the opposite of pull. Push allows you to copy changes from the\n"++ + "current repository into another repository.\n" + +push :: DarcsCommand +push = DarcsCommand {command_name = "push", + command_help = push_help, + command_description = push_description, + command_extra_args = 1, + command_extra_arg_help = ["[REPOSITORY]"], + command_command = push_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = get_preflist "repos", + command_argdefaults = defaultrepo, + command_advanced_options = [applyas, + nolinks, + remote_repo] ++ + network_options, + command_basic_options = [match_several, deps_sel, + all_interactive, + sign]++dry_run++[summary, + working_repo_dir, + set_default, + allow_unrelated_repos]} + +push_cmd :: [DarcsFlag] -> [String] -> IO () +push_cmd opts [""] = push_cmd opts [] +push_cmd opts [unfixedrepodir] = + let am_verbose = Verbose `elem` opts + am_quiet = Quiet `elem` opts + putVerbose s = when am_verbose $ putDocLn s + putInfo s = when (not am_quiet) $ putDocLn s + in + do + repodir <- fixUrl opts unfixedrepodir + -- Test to make sure we aren't trying to push to the current repo + here <- getCurrentDirectory + when (repodir == here) $ + fail "Cannot push from repository to itself." + -- absolute '.' also taken into account by fix_filepath + (bundle,num_to_pull) <- withRepoReadLock opts $- \repository -> do + if is_url repodir then do + when (apply_as opts /= Nothing) $ + let msg = text "Cannot --apply-as when pushing to URLs" in + if DryRun `elem` opts + then putInfo $ text "NOTE: " <+> msg + $$ text "" + else errorDoc msg + maybeapply <- maybeURLCmd "APPLY" repodir + when (maybeapply == Nothing) $ + let lprot = takeWhile (/= ':') repodir + prot = map toUpper lprot + msg = text ("Pushing to "++lprot++" URLs is not supported.\n"++ + "You may be able to hack this to work"++ + " using DARCS_APPLY_"++prot) in + if DryRun `elem` opts + then putInfo $ text "NOTE:" <+> msg + $$ text "" + else errorDoc msg + else do + when (want_sign opts) $ + let msg = text "Signing doesn't make sense for local repositories or when pushing over ssh." + in if DryRun `elem` opts + then putInfo $ text "NOTE:" <+> msg + else errorDoc msg + them <- identifyRepositoryFor repository repodir >>= read_repo + old_default <- get_preflist "defaultrepo" + set_defaultrepo repodir opts + when (old_default == [repodir]) $ + let pushing = if DryRun `elem` opts then "Would push" else "Pushing" + in putInfo $ text $ pushing++" to "++formatPath repodir++"..." + us <- read_repo repository + case get_common_and_uncommon (us, them) of + (common, us' :\/: them') -> do + checkUnrelatedRepos opts common us them + putVerbose $ text "We have the following patches to push:" + $$ (vcat $ mapRL description $ head $ unsafeUnRL us') + firstUs <- case us' of + NilRL:<:NilRL -> do putInfo $ text "No recorded local changes to push!" + exitWith ExitSuccess + NilRL -> bug "push_cmd: us' is empty!" + (x:<:_) -> return x + with_selected_changes "push" opts (reverseRL firstUs) $ + \ (to_be_pushed:>_) -> do + definePatches to_be_pushed + print_dry_run_message_and_exit "push" opts to_be_pushed + when (nullFL to_be_pushed) $ do + putInfo $ + text "You don't want to push any patches, and that's fine with me!" + exitWith ExitSuccess + let num_to_pull = lengthRL $ head $ unsafeUnRL them' + bundle = make_bundle [] + (bug "using slurpy in make_bundle called from Push") + common (mapFL_FL hopefully to_be_pushed) + return (bundle, num_to_pull) + sbundle <- signString opts bundle + let body = if is_file repodir + then sbundle + else make_email repodir [] Nothing sbundle Nothing + rval <- remote_apply opts repodir body + let pull_reminder = + if num_to_pull > 0 + then text $ "(By the way, the remote repository has " ++ show num_to_pull ++ " " + ++ englishNum num_to_pull (Noun "patch") " to pull.)" + else empty + case rval of ExitFailure ec -> do putStrLn $ "Apply failed!" + exitWith (ExitFailure ec) + ExitSuccess -> putInfo $ text "Push successful." $$ pull_reminder + +push_cmd _ _ = impossible + +want_sign :: [DarcsFlag] -> Bool +want_sign opts = case opts of + [] -> False + Sign:_ -> True + (SignAs _):_ -> True + (SignSSL _):_ -> True + NoSign:_ -> False + _:opts' -> want_sign opts' +\end{code} + +For obvious reasons, you can only push to repositories to which you have +write access. In addition, you can only push to repos that you access +either on the local file system or with ssh. In order to apply with ssh, +darcs must also be installed on the remote computer. The command invoked +to run ssh may be configured by the \verb!DARCS_SSH! environment variable +(see subsection~\ref{env:DARCS_SSH}). The command invoked via ssh is always +\verb!darcs!, i.e.\ the darcs executable must be in the default path on +the remote machine. + +Push works by creating a patch bundle, and then running darcs apply in the +target repository using that patch bundle. This means that the default +options for \emph{apply} in the \emph{target} repository (such as, for +example, \verb!--test!) will affect the behavior of push. This also means +that push is somewhat less efficient than pull. + +When you receive an error message such as +\begin{verbatim} +bash: darcs: command not found +\end{verbatim} +then this means that the darcs on the remote machine could +not be started. Make sure that the darcs executable is called +\verb!darcs! and is found in the default path. The default path can +be different in interactive and in non-interactive shells. Say +\begin{verbatim} +ssh login@remote.machine darcs +\end{verbatim} +to try whether the remote darcs can be found, or +\begin{verbatim} +ssh login@remote.machine 'echo $PATH' +\end{verbatim} +(note the single quotes) to check the default path. + +\begin{options} +--apply-as +\end{options} + +If you give the \verb!--apply-as! flag, darcs will use sudo to apply the +changes as a different user. This can be useful if you want to set up a +system where several users can modify the same repository, but you don't +want to allow them full write access. This isn't secure against skilled +malicious attackers, but at least can protect your repository from clumsy, +inept or lazy users. + +\begin{options} +--matches, --patches, --tags, --no-deps +\end{options} + +The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps! +options can be used to select which patches to push, as described in +subsection~\ref{selecting}. + +When there are conflicts, the behavior of push is determined by the default +flags to \verb!apply! in the \emph{target} repository. Most commonly, for +pushed-to repositories, you'd like to have \verb!--dont-allow-conflicts! as +a default option to apply (by default, it is already the default\ldots). If +this is the case, when there are conflicts on push, darcs will fail with an +error message. You can then resolve by pulling the conflicting patch, +recording a resolution and then pushing the resolution together with the +conflicting patch. + +Darcs does not have an explicit way to tell you which patch conflicted, only the +file name. You may want to pull all the patches from the remote repository just +to be sure. If you don't want to do this in your working directory, +you can create another darcs working directory for this purpose. + +If you want, you could set the target repository to use \verb!--allow-conflicts!. +In this case conflicting patches will be applied, but the conflicts will +not be marked in the working directory. + +If, on the other hand, you have \verb!--mark-conflicts! specified as a +default flag for apply in the target repository, when there is a conflict, +it will be marked in the working directory of the target repository. In +this case, you should resolve the conflict in the target repository itself. diff --git a/src/Darcs/Commands/Put.lhs b/src/Darcs/Commands/Put.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Put.lhs @@ -0,0 +1,137 @@ +\darcsCommand{put} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Put ( put ) where +import System.Exit ( ExitCode( ExitSuccess, ExitFailure ), exitWith ) +import Control.Monad ( when ) +import Data.Maybe ( catMaybes ) +import System.Directory ( createDirectory ) +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag( Quiet, Verbose, + UseFormat2, UseHashedInventory, UseOldFashionedInventory ), + applyas, match_one_context, fixUrl, + network_options, flagToString, get_inventory_choices, + set_scripts_executable, working_repo_dir, set_default + ) +import Darcs.Repository ( withRepoReadLock, ($-), patchSetToPatches, read_repo, amInRepository ) +import Darcs.Repository.Format ( identifyRepoFormat, + RepoProperty ( Darcs2, HashedInventory ), format_has ) +import Darcs.Patch.Bundle ( make_bundle2 ) +import Darcs.Ordered ( FL(..) ) +import Darcs.Match ( have_patchset_match, get_one_patchset ) +import Darcs.Repository.Prefs ( get_preflist, set_defaultrepo ) +import Darcs.URL ( is_url, is_file ) +import Darcs.Utils ( withCurrentDirectory ) +import Progress ( debugMessage ) +import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) +import Darcs.SlurpDirectory ( empty_slurpy ) +import Darcs.External ( execSSH ) +import Darcs.RemoteApply ( remote_apply ) +import Darcs.Commands.Init ( initialize ) +import Darcs.Email ( make_email ) +import Darcs.Sealed ( Sealed(..), seal ) +#include "impossible.h" + +put_description :: String +put_description = + "Makes a copy of the repository" + +put_help :: String +put_help = + "The `darcs put' command creates a copy of the current repository. It\n" ++ + "is currently very inefficient, so when creating local copies you\n" ++ + "should use `darcs get . x' instead of `darcs put x'.\n" ++ + "\n" ++ + "Currently this command just uses `darcs init' to create the target\n" ++ + "repository, then `darcs push --all' to copy patches to it. Options\n" ++ + "passed to `darcs put' are passed to the init and/or push commands as\n" ++ + "appropriate. See those commands for an explanation of each option.\n" + +put ::DarcsCommand +put = DarcsCommand {command_name = "put", + command_help = put_help, + command_description = put_description, + command_extra_args = 1, + command_extra_arg_help = [""], + command_command = put_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = get_preflist "repos", + command_argdefaults = nodefaults, + command_advanced_options = [applyas] ++ network_options, + command_basic_options = [match_one_context, set_scripts_executable, + get_inventory_choices, + set_default, working_repo_dir]} + +put_cmd :: [DarcsFlag] -> [String] -> IO () +put_cmd _ [""] = fail "Empty repository argument given to put." +put_cmd opts [unfixedrepodir] = + let am_quiet = Quiet `elem` opts + putInfo s = when (not am_quiet) $ putStrLn s + putVerbose = when (Verbose `elem` opts) . putStrLn + in + do + repodir <- fixUrl opts unfixedrepodir + -- Test to make sure we aren't trying to push to the current repo + t_cur_absolute_repo_dir <- ioAbsoluteOrRemote "." + t_req_absolute_repo_dir <- ioAbsoluteOrRemote repodir + let cur_absolute_repo_dir = toPath t_cur_absolute_repo_dir + req_absolute_repo_dir = toPath t_req_absolute_repo_dir + when (cur_absolute_repo_dir == req_absolute_repo_dir) $ + fail "Can't put to current repository!" + when (is_url req_absolute_repo_dir) $ error "Can't put to a URL!" + + debugMessage "Creating repository" + putVerbose "Creating repository" + rf_or_e <- identifyRepoFormat "." + rf <- case rf_or_e of Left e -> fail e + Right x -> return x + let initopts = if format_has Darcs2 rf + then UseFormat2:filter (/= UseOldFashionedInventory) opts + else if format_has HashedInventory rf && + not (UseOldFashionedInventory `elem` opts) + then UseHashedInventory:filter (/= UseFormat2) opts + else UseOldFashionedInventory:filter (/= UseFormat2) opts + if is_file req_absolute_repo_dir + then do createDirectory req_absolute_repo_dir + withCurrentDirectory req_absolute_repo_dir $ (command_command initialize) initopts [] + else do -- is_ssh req_absolute_repo_dir + remoteInit req_absolute_repo_dir initopts + + withCurrentDirectory cur_absolute_repo_dir $ + withRepoReadLock opts $- \repository -> do + set_defaultrepo req_absolute_repo_dir opts + Sealed patchset <- if have_patchset_match opts + then get_one_patchset repository opts -- todo: make sure get_one_patchset has the right type + else read_repo repository >>= (return . seal) + Sealed patchset2 <- if have_patchset_match opts + then get_one_patchset repository opts -- todo: make sure get_one_patchset has the right type + else read_repo repository >>= (return . seal) + let patches = patchSetToPatches patchset + patches2 = patchSetToPatches patchset2 + nullFL NilFL = True + nullFL _ = False + when (nullFL patches) $ do + putInfo "No patches were selected to put. Nothing to be done." + exitWith ExitSuccess + let bundle = (make_bundle2 opts empty_slurpy [] patches patches2) + message = if is_file req_absolute_repo_dir + then bundle + else make_email req_absolute_repo_dir [] Nothing bundle Nothing + putVerbose "Applying patches in new repository..." + rval <- remote_apply opts req_absolute_repo_dir message + case rval of ExitFailure ec -> do putStrLn $ "Apply failed!" + exitWith (ExitFailure ec) + ExitSuccess -> putInfo "Put successful." +put_cmd _ _ = impossible + +remoteInit :: FilePath -> [DarcsFlag] -> IO () +remoteInit repo opts = do + let args = catMaybes $ map (flagToString $ command_basic_options initialize) opts + command = "darcs initialize --repodir='" ++ path ++ "' " ++ unwords args + exitCode <- execSSH addr command + when (exitCode /= ExitSuccess) $ + fail "Couldn't initialize remote repository." + where (addr,':':path) = break (==':') repo +\end{code} diff --git a/src/Darcs/Commands/Record.lhs b/src/Darcs/Commands/Record.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Record.lhs @@ -0,0 +1,511 @@ +% Copyright (C) 2002-2003 David Roundy +% +% 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. + +\darcsCommand{record} +\begin{code} +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP, PatternGuards #-} + +module Darcs.Commands.Record ( record, commit, get_date, get_log, file_exists ) where +import Control.Exception ( handleJust, Exception( ExitException ) ) +import Control.Monad ( filterM, when ) +import System.IO ( hGetContents, stdin ) +import Data.List ( sort, isPrefixOf ) +import System.Exit ( exitWith, exitFailure, ExitCode(..) ) +import System.IO ( hPutStrLn ) +import System.Directory ( doesFileExist, doesDirectoryExist, removeFile ) +import Data.Maybe ( isJust ) + +import Darcs.Lock ( readBinFile, writeBinFile, world_readable_temp, appendToFile, removeFileMayNotExist ) +import Darcs.Hopefully ( info, n2pia ) +import Darcs.Repository ( Repository, amInRepository, withRepoLock, ($-), + get_unrecorded_in_files, + get_unrecorded_in_files_unsorted, withGutsOf, + sync_repo, read_repo, + slurp_recorded, + tentativelyAddPatch, finalizeRepositoryChanges, + ) +import Darcs.Patch ( RepoPatch, Patch, Prim, namepatch, summary, anonymous, + adddeps, fromPrims ) +import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (+>+), + unsafeUnFL, unsafeCompare, + reverseRL, mapFL, mapFL_FL, nullFL ) +import Darcs.Patch.Info ( PatchInfo ) +import Darcs.SlurpDirectory ( slurp_hasfile, slurp_hasdir ) +import Darcs.Patch.Choices ( patch_choices_tps, tp_patch, + force_first, get_choices, tag ) +import Darcs.SelectChanges ( with_selected_changes_to_files', + with_selected_changes_reversed ) +import Darcs.RepoPath ( FilePathLike, SubPath, sp2fn, toFilePath ) +import Darcs.SlurpDirectory ( Slurpy, empty_slurpy ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers, command_stub ) +import Darcs.Arguments ( DarcsFlag( PromptLongComment, NoEditLongComment, + EditLongComment, RmLogFile, LogFile, Pipe, + PatchName, AskDeps, All ), + get_author, working_repo_dir, lookforadds, + fixSubPaths, defineChanges, testByDefault, + ask_long_comment, askdeps, patch_select_flag, + all_pipe_interactive, leave_test_dir, notest, + author, patchname_option, umask_option, ignoretimes, + nocompress, rmlogfile, logfile, list_registered_files, + set_scripts_executable ) +import Darcs.Utils ( askUser, promptYorn, edit_file, clarify_errors ) +import Progress ( debugMessage) +import Darcs.ProgressPatches( progressFL) +import IsoDate ( getIsoDateTime, cleanLocalDate ) +import Printer ( hPutDocLn, text, wrap_text, ($$), renderString ) +import Darcs.Gorsvet( invalidateIndex ) +#include "impossible.h" + +record_description :: String +record_description = + "Save changes in the working copy to the repository as a patch." +\end{code} + +If you provide one or more files or directories as additional arguments +to record, you will only be prompted to changes in those files or +directories. +\begin{code} +record_help :: String +record_help = renderString $ wrap_text 80 $ + "Record is used to name a set of changes and record the patch to the "++ + "repository." + +record :: DarcsCommand +record = DarcsCommand {command_name = "record", + command_help = record_help, + command_description = record_description, + command_extra_args = -1, + command_extra_arg_help = ["[FILE or DIRECTORY]..."], + command_command = record_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = list_registered_files, + command_argdefaults = nodefaults, + command_advanced_options = [logfile, rmlogfile, + nocompress, ignoretimes, + umask_option, + set_scripts_executable], + command_basic_options = [patchname_option, author, + notest, + leave_test_dir, + all_pipe_interactive, + askdeps, + ask_long_comment, + lookforadds, + working_repo_dir]} + +commit_description :: String +commit_description = + "Does not actually do anything, but offers advice on saving changes" + +commit_help :: String +commit_help = + "This command does not do anything.\n"++ + "If you want to save changes locally, use the `darcs record' command.\n"++ + "If you want to save a recorded patch to another repository, use the\n"++ + "`darcs push' or `darcs send' commands instead.\n" + +commit :: DarcsCommand +commit = command_stub "commit" commit_help commit_description record + +file_exists :: Slurpy -> SubPath -> IO Bool +file_exists s rp = do file <- doesFileExist fp + dir <- doesDirectoryExist fp + return (file || dir || + slurp_hasfile (sp2fn rp) s || + slurp_hasdir (sp2fn rp) s) + where fp = toFilePath rp + +record_cmd :: [DarcsFlag] -> [String] -> IO () +record_cmd opts args = do + check_name_is_not_option opts + let (logMessage,_, _) = loggers opts + withRepoLock (testByDefault opts) $- \repository -> do + rec <- if null args then return empty_slurpy + else slurp_recorded repository + files <- sort `fmap` fixSubPaths opts args + let non_repo_files = if null files && (not $ null args) then args else [] + existing_files <- filterM (file_exists rec) files + non_existent_files <- filterM (fmap not . file_exists rec) files + when (not $ null existing_files) $ + logMessage $ "Recording changes in "++unwords (map show existing_files)++":\n" + when (not $ null non_existent_files) $ + logMessage $ "Non existent files or directories: "++unwords (map show non_existent_files)++"\n" + when (((not $ null non_existent_files) || (not $ null non_repo_files)) && null existing_files) $ + fail "None of the files you specified exist!" + debugMessage "About to get the unrecorded changes." + let existing_fns = map sp2fn existing_files + changes <- if All `elem` opts then get_unrecorded_in_files_unsorted repository existing_fns + else get_unrecorded_in_files repository existing_fns + debugMessage "I've gotten unrecorded." + case allow_empty_with_askdeps changes of + Nothing -> do when (Pipe `elem` opts) $ do get_date opts + return () + if ((not $ null existing_files) || (not $ null non_existent_files)) + then logMessage "No changes in selected files or directories!" + else logMessage "No changes!" + Just ch -> do_record repository opts existing_files ch + where allow_empty_with_askdeps NilFL + | AskDeps `elem` opts = Just NilFL + | otherwise = Nothing + allow_empty_with_askdeps p = Just p + + -- check that what we treat as the patch name is not accidentally a command + -- line flag +check_name_is_not_option :: [DarcsFlag] -> IO () +check_name_is_not_option opts = do + let (logMessage, _, _) = loggers opts + patchNames = [n | PatchName n <- opts] + when (length patchNames == 1) $ do + let n = head patchNames + oneLetterName = length n == 1 || (length n == 2 && head n == '-') + if (oneLetterName && not (elem All opts)) + then do + let keepAsking = do + yorn <- promptYorn ("You specified " ++ show n ++ " as the patch name. Is that really what you want?") + case yorn of + 'y' -> return () + 'n' -> do + logMessage "Okay, aborting the record." + exitFailure + _ -> keepAsking + keepAsking + else return () + + +do_record :: RepoPatch p => Repository p -> [DarcsFlag] -> [SubPath] -> FL Prim -> IO () +do_record repository opts files ps = do + let make_log = world_readable_temp "darcs-record" + date <- get_date opts + my_author <- get_author opts + debugMessage "I'm slurping the repository." + debugMessage "About to select changes..." + with_selected_changes_to_files' "record" opts + (map toFilePath files) ps $ \ (chs:>_) -> + do when (is_empty_but_not_askdeps chs) $ + do putStrLn "Ok, if you don't want to record anything, that's fine!" + exitWith ExitSuccess + handleJust only_successful_exits (\_ -> return ()) $ + do deps <- if AskDeps `elem` opts + then ask_about_depends repository chs opts + else return [] + when (AskDeps `elem` opts) $ debugMessage "I've asked about dependencies." + if nullFL chs && null deps + then putStrLn "Ok, if you don't want to record anything, that's fine!" + else do defineChanges chs + (name, my_log, logf) <- get_log opts Nothing make_log chs + do_actual_record repository opts name date + my_author my_log logf deps chs + where is_empty_but_not_askdeps l + | AskDeps `elem` opts = False + -- a "partial tag" patch; see below. + | otherwise = nullFL l + +do_actual_record :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> String -> String + -> [String] -> Maybe String + -> [PatchInfo] -> FL Prim -> IO () +do_actual_record repository opts name date my_author my_log logf deps chs = + do debugMessage "Writing the patch file..." + mypatch <- namepatch date name my_author my_log $ + fromPrims $ progressFL "Writing changes:" chs + tentativelyAddPatch repository opts $ n2pia $ adddeps mypatch deps + invalidateIndex repository + debugMessage "Applying to pristine..." + withGutsOf repository (finalizeRepositoryChanges repository) + `clarify_errors` failuremessage + debugMessage "Syncing timestamps..." + sync_repo repository + when (isJust logf) $ removeFile (fromJust logf) + logMessage $ "Finished recording patch '"++name++"'" + where (logMessage,_,_) = loggers opts + failuremessage = "Failed to record patch '"++name++"'" ++ + case logf of Just lf -> "\nLogfile left in "++lf++"." + Nothing -> "" +\end{code} +Each patch is given a name, which typically would consist of a brief +description of the changes. This name is later used to describe the patch. +The name must fit on one line (i.e.\ cannot have any embedded newlines). If +you have more to say, stick it in the log. +\begin{code} +\end{code} + +The patch is also flagged with the author of the change, taken by default +from the \verb!DARCS_EMAIL! environment variable, and if that doesn't +exist, from the \verb!EMAIL! environment variable. The date on which the +patch was recorded is also included. Currently there is no provision for +keeping track of when a patch enters a given repository. +\begin{code} +get_date :: [DarcsFlag] -> IO String +get_date opts + | Pipe `elem` opts = do cleanLocalDate `fmap` askUser "What is the date? " +get_date _ = getIsoDateTime +\end{code} +\label{DARCS_EDITOR} +Finally, each changeset should have a full log (which may be empty). This +log is for detailed notes which are too lengthy to fit in the name. If you +answer that you do want to create a comment file, darcs will open an editor +so that you can enter the comment in. The choice of editor proceeds as +follows. If one of the \verb!$DARCS_EDITOR!, \verb!$VISUAL! or +\verb!$EDITOR! environment variables is defined, its value is used (with +precedence proceeding in the order listed). If not, ``vi'', ``emacs'', +``emacs~-nw'' and ``nano'' are tried in that order. + +\begin{options} +--logfile +\end{options} + +If you wish, you may specify the patch name and log using the +\verb!--logfile! flag. If you do so, the first line of the specified file +will be taken to be the patch name, and the remainder will be the ``long +comment''. This feature can be especially handy if you have a test that +fails several times on the record (thus aborting the record), so you don't +have to type in the long comment multiple times. The file's contents will +override the \verb!--patch-name! option. + +\begin{code} +data PName = FlagPatchName String | PriorPatchName String | NoPatchName + +get_log :: [DarcsFlag] -> Maybe (String, [String]) -> IO String -> FL Prim -> + IO (String, [String], Maybe String) +get_log opts m_old make_log chs = gl opts + where patchname_specified = patchname_helper opts + patchname_helper (PatchName n:_) | take 4 n == "TAG " = FlagPatchName $ '.':n + | otherwise = FlagPatchName n + patchname_helper (_:fs) = patchname_helper fs + patchname_helper [] = case m_old of Just (p,_) -> PriorPatchName p + Nothing -> NoPatchName + default_log = case m_old of + Nothing -> [] + Just (_,l) -> l + gl (Pipe:_) = do p <- case patchname_specified of + FlagPatchName p -> return p + PriorPatchName p -> return p + NoPatchName -> prompt_patchname False + putStrLn "What is the log?" + thelog <- lines `fmap` hGetContents stdin -- ratify hGetContents: stdin not deleted + return (p, thelog, Nothing) + gl (LogFile f:fs) = + do -- round 1 (patchname) + mlp <- lines `fmap` readBinFile f `catch` (\_ -> return []) + firstname <- case (patchname_specified, mlp) of + (FlagPatchName p, []) -> return p + (_, p:_) -> return p -- logfile trumps prior! + (PriorPatchName p, []) -> return p + (NoPatchName, []) -> prompt_patchname True + -- round 2 + append_info f firstname + when (EditLongComment `elem` fs) $ do edit_file f + return () + (name, thelog, _) <- read_long_comment f firstname + when (RmLogFile `elem` opts) $ removeFileMayNotExist f + return (name, thelog, Nothing) + gl (EditLongComment:_) = + case patchname_specified of + FlagPatchName p -> actually_get_log p + PriorPatchName p -> actually_get_log p + NoPatchName -> prompt_patchname True >>= actually_get_log + gl (NoEditLongComment:_) = + case patchname_specified of + FlagPatchName p + | Just ("",_) <- m_old -> + return (p, default_log, Nothing) -- rollback -m + FlagPatchName p -> return (p, default_log, Nothing) -- record (or amend) -m + PriorPatchName p -> return (p, default_log, Nothing) -- amend + NoPatchName -> do p <- prompt_patchname True -- record + return (p, [], Nothing) + gl (PromptLongComment:fs) = + case patchname_specified of + FlagPatchName p -> prompt_long_comment p -- record (or amend) -m + _ -> gl fs + gl (_:fs) = gl fs + gl [] = case patchname_specified of + FlagPatchName p -> return (p, default_log, Nothing) -- record (or amend) -m + PriorPatchName "" -> prompt_patchname True >>= prompt_long_comment + PriorPatchName p -> return (p, default_log, Nothing) + NoPatchName -> prompt_patchname True >>= prompt_long_comment + prompt_patchname retry = + do n <- askUser "What is the patch name? " + if n == "" || take 4 n == "TAG " + then if retry then prompt_patchname retry + else fail "Bad patch name!" + else return n + prompt_long_comment oldname = + do yorn <- promptYorn "Do you want to add a long comment?" + if yorn == 'y' then actually_get_log oldname + else return (oldname, [], Nothing) + actually_get_log p = do logf <- make_log + writeBinFile logf $ unlines $ p : default_log + append_info logf p + edit_file logf + read_long_comment logf p + read_long_comment :: FilePathLike p => p -> String -> IO (String, [String], Maybe p) + read_long_comment f oldname = + do t <- (lines.filter (/='\r')) `fmap` readBinFile f + case t of [] -> return (oldname, [], Just f) + (n:ls) -> return (n, takeWhile + (not.(eod `isPrefixOf`)) ls, + Just f) + append_info f oldname = + do fc <- readBinFile f + appendToFile f $ \h -> + do case fc of + _ | null (lines fc) -> hPutStrLn h oldname + | last fc /= '\n' -> hPutStrLn h "" + | otherwise -> return () + hPutDocLn h $ text eod + $$ text "" + $$ wrap_text 75 + ("Place the long patch description above the "++ + eod++ + " marker. The first line of this file "++ + "will be the patch name.") + $$ text "" + $$ text "This patch contains the following changes:" + $$ text "" + $$ summary (fromPrims chs :: Patch) + +eod :: String +eod = "***END OF DESCRIPTION***" +\end{code} + +\begin{options} +--ask-deps +\end{options} + +Each patch may depend on any number of previous patches. If you choose to +make your patch depend on a previous patch, that patch is required to be +applied before your patch can be applied to a repository. This can be used, for +example, if a piece of code requires a function to be defined, which was +defined in an earlier patch. + +If you want to manually define any dependencies for your patch, you can use +the \verb!--ask-deps! flag, and darcs will ask you for the patch's +dependencies. + +It is possible to record a patch which has no actual changes but which +has specific dependencies. This type of patch can be thought of as a +``partial tag''. The \verb!darcs tag! command will record a patch +with no actual changes but which depends on the entire current +inventory of the repository. The \verb!darcs record --ask-deps! with +no selected changes will record a patch that depends on only those +patches selected via the \verb!--ask-deps! operation, resulting in a +patch which describes a set of patches; the presence of this primary +patch in a repository implies the presence of (at least) the +depended-upon patches. + +\begin{code} +ask_about_depends :: RepoPatch p => Repository p -> FL Prim -> [DarcsFlag] -> IO [PatchInfo] +ask_about_depends repository pa' opts = do + pps <- read_repo repository + pa <- n2pia `fmap` anonymous (fromPrims pa') + let ps = (reverseRL $ headRL pps)+>+(pa:>:NilFL) + (pc, tps) = patch_choices_tps ps + ta = case filter ((pa `unsafeCompare`) . tp_patch) $ unsafeUnFL tps of + [tp] -> tag tp + [] -> error "ask_about_depends: []" + _ -> error "ask_about_depends: many" + ps' = mapFL_FL tp_patch $ middle_choice $ force_first ta pc + with_selected_changes_reversed "depend on" (filter askdep_allowed opts) ps' + $ \(deps:>_) -> return $ mapFL info deps + where headRL (x:<:_) = x + headRL NilRL = impossible + askdep_allowed = not . patch_select_flag + middle_choice p = mc where (_ :> mc :> _) = get_choices p + + +only_successful_exits :: Exception -> Maybe () +only_successful_exits (ExitException ExitSuccess) = Just () +only_successful_exits _ = Nothing +\end{code} + +\begin{options} +--no-test, --test +\end{options} + +If you configure darcs to run a test suite, darcs will run this test on the +recorded repository to make sure it is valid. Darcs first creates a pristine +copy of the source tree (in a temporary directory), then it runs the test, +using its return value to decide if the record is valid. If it is not valid, +the record will be aborted. This is a handy way to avoid making stupid +mistakes like forgetting to `darcs add' a new file. It also can be +tediously slow, so there is an option (\verb!--no-test!) to skip the test. + +\begin{options} +--set-scripts-executable +\end{options} + +If you pass \verb!--set-scripts-executable! to \verb!darcs record!, darcs will set scripts +executable in the test directory before running the test. + +\begin{options} +--pipe +\end{options} + +If you run record with the \verb!--pipe! option, you will be prompted for +the patch date, author, and the long comment. The long comment will extend +until the end of file or stdin is reached (ctrl-D on Unixy systems, ctrl-Z +on systems running a Microsoft OS). + +This interface is intended for scripting darcs, in particular for writing +repository conversion scripts. The prompts are intended mostly as a useful +guide (since scripts won't need them), to help you understand the format in +which to provide the input. Here's an example of what the \verb!--pipe! +prompts look like: + +\begin{verbatim} + What is the date? Mon Nov 15 13:38:01 EST 2004 + Who is the author? David Roundy + What is the log? One or more comment lines +\end{verbatim} + + +\begin{options} +--interactive +\end{options} + +By default, \verb!record! works interactively. Probably the only thing you need +to know about using this is that you can press \verb!?! at the prompt to be +shown a list of the rest of the options and what they do. The rest should be +clear from there. Here's a +``screenshot'' to demonstrate: + +\begin{verbatim} +hunk ./hello.pl +2 ++#!/usr/bin/perl ++print "Hello World!\n"; +Shall I record this patch? (2/2) [ynWsfqadjk], or ? for help: ? +How to use record... +y: record this patch +n: don't record it +w: wait and decide later, defaulting to no + +s: don't record the rest of the changes to this file +f: record the rest of the changes to this file + +d: record selected patches +a: record all the remaining patches +q: cancel record + +j: skip to next patch +k: back up to previous patch +h or ?: show this help + +: accept the current default (which is capitalized) + +\end{verbatim} +What you can't see in that ``screenshot'' is that \verb!darcs! will also try to use +color in your terminal to make the output even easier to read. diff --git a/src/Darcs/Commands/Remove.lhs b/src/Darcs/Commands/Remove.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Remove.lhs @@ -0,0 +1,131 @@ +% Copyright (C) 2002-2004 David Roundy +% +% 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. + +\darcsCommand{remove} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Remove ( remove, rm, unadd ) where + +import Control.Monad ( when ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, + command_alias, command_stub, + ) +import Darcs.Arguments ( DarcsFlag, fixSubPaths, + list_registered_files, + working_repo_dir, umask_option + ) +import Darcs.RepoPath ( SubPath, toFilePath, sp2fn ) +import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository, + slurp_pending, slurp_recorded, + get_unrecorded_in_files, add_to_pending ) +import Darcs.Patch ( RepoPatch, Prim, apply_to_slurpy, adddir, rmdir, addfile, rmfile ) +import Darcs.Ordered ( FL(..), (+>+) ) +import Darcs.SlurpDirectory ( slurp_removedir, slurp_removefile ) +import Darcs.Repository.Prefs ( filetype_function ) +import Darcs.Diff ( unsafeDiff ) +import Darcs.Gorsvet( invalidateIndex ) +#include "impossible.h" + +remove_description :: String +remove_description = "Remove files from version control." + +remove_help :: String +remove_help = + "The `darcs remove' command exists primarily for symmetry with `darcs\n" ++ + "add', as the normal way to remove a file from version control is\n" ++ + "simply to delete it from the working tree. This command is only\n" ++ + "useful in the unusual case where one wants to record a removal patch\n" ++ + "WITHOUT deleting the copy in the working tree (which can be re-added).\n" ++ + "\n" ++ + "Note that applying a removal patch to a repository (e.g. by pulling\n" ++ + "the patch) will ALWAYS affect the working tree of that repository.\n" + +remove :: DarcsCommand +remove = DarcsCommand {command_name = "remove", + command_help = remove_help, + command_description = remove_description, + command_extra_args = -1, + command_extra_arg_help = [" ..."], + command_command = remove_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = list_registered_files, + command_argdefaults = nodefaults, + command_advanced_options = [umask_option], + command_basic_options = + [working_repo_dir]} + +remove_cmd :: [DarcsFlag] -> [String] -> IO () +remove_cmd opts relargs = + withRepoLock opts $- \repository -> do + args <- fixSubPaths opts relargs + when (null args) $ + putStrLn "Nothing specified, nothing removed." + p <- make_remove_patch repository args + invalidateIndex repository + add_to_pending repository p + +make_remove_patch :: RepoPatch p => Repository p -> [SubPath] -> IO (FL Prim) +make_remove_patch repository files = + do s <- slurp_pending repository + srecorded <- slurp_recorded repository + pend <- get_unrecorded_in_files repository (map sp2fn files) + let sunrec = fromJust $ apply_to_slurpy pend srecorded + wt <- filetype_function + mrp wt s sunrec files + where mrp wt s sunrec (f:fs) = + case slurp_removedir fn s of + Just s' -> + case slurp_removedir fn sunrec of + Just sunrec' -> do rest <- mrp wt s' sunrec' fs + return $ rmdir f_fp :>: rest + Nothing -> do rest <- mrp wt s' sunrec fs + return $ adddir f_fp :>: rmdir f_fp :>: rest + Nothing -> + case slurp_removefile fn s of + Nothing -> fail $ "Can't remove "++f_fp + Just s' -> + case slurp_removefile fn sunrec of + Nothing -> do rest <- mrp wt s' sunrec fs + return $ addfile f_fp :>: rmfile f_fp :>: rest + Just sunrec' -> do rest <- mrp wt s' sunrec' fs + let newp = unsafeDiff [] wt sunrec sunrec' + return $ newp +>+ rest + where fn = sp2fn f + f_fp = toFilePath f + mrp _ _ _ [] = return NilFL + +rm_description :: String +rm_description = "Help newbies find `darcs remove'." + +rm_help :: String +rm_help = + "The `darcs rm' command does nothing.\n" ++ + "\n" ++ + "The normal way to remove a file from version control is simply to\n" ++ + "delete it from the working tree. To remove a file from version\n" ++ + "control WITHOUT affecting the working tree, see `darcs remove'.\n" + +rm :: DarcsCommand +rm = command_stub "rm" rm_help rm_description remove + +unadd :: DarcsCommand +unadd = command_alias "unadd" remove +\end{code} + + diff --git a/src/Darcs/Commands/Repair.lhs b/src/Darcs/Commands/Repair.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Repair.lhs @@ -0,0 +1,70 @@ +% Copyright (C) 2003,2005 David Roundy +% +% 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. + +\darcsCommand{repair} +\begin{code} +module Darcs.Commands.Repair ( repair ) where +import System.IO + +import Darcs.Commands +import Darcs.Arguments ( DarcsFlag(), + working_repo_dir, umask_option, + ) +import Darcs.Repository ( withRepoLock, ($-), amInRepository, + replacePristineFromSlurpy, writePatchSet ) +import Darcs.Repository.Repair( replayRepository, + RepositoryConsistency(..) ) + +repair_description :: String +repair_description = "Repair a corrupted repository." + +repair_help :: String +repair_help = + "The `darcs repair' command attempts to fix corruption in the current\n" ++ + "repository. Currently it can only repair damage to the pristine tree,\n" ++ + "which is where most corruption occurs.\n" + +repair :: DarcsCommand +repair = DarcsCommand {command_name = "repair", + command_help = repair_help, + command_description = repair_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = repair_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [umask_option], + command_basic_options = [working_repo_dir]} + +repair_cmd :: [DarcsFlag] -> [String] -> IO () +repair_cmd opts _ = withRepoLock opts $- \repository -> do + replayRepository repository opts $ \state -> + case state of + RepositoryConsistent -> + putStrLn "The repository is already consistent, no changes made." + BrokenPristine s -> do + putStrLn "Fixing pristine tree..." + replacePristineFromSlurpy repository s + BrokenPatches s newps -> do + putStrLn "Writing out repaired patches..." + writePatchSet newps opts + putStrLn "Fixing pristine tree..." + replacePristineFromSlurpy repository s + return () + +\end{code} diff --git a/src/Darcs/Commands/Replace.lhs b/src/Darcs/Commands/Replace.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Replace.lhs @@ -0,0 +1,232 @@ +% Copyright (C) 2002-2005 David Roundy +% +% 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. + +\darcsCommand{replace} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Replace ( replace ) where + +import Data.Maybe ( isJust ) +import Control.Monad ( unless ) + +import Darcs.Commands ( DarcsCommand(DarcsCommand, command_name, command_help, + command_description, command_extra_args, + command_extra_arg_help, command_command, command_prereq, + command_get_arg_possibilities, command_argdefaults, + command_advanced_options, command_basic_options), + nodefaults ) +import Darcs.Arguments ( DarcsFlag(ForceReplace, Toks), list_registered_files, + ignoretimes, umask_option, tokens, force_replace, + working_repo_dir, fixSubPaths ) +import Darcs.Repository ( withRepoLock, ($-), + add_to_pending, slurp_pending, + amInRepository, slurp_recorded_and_unrecorded, + applyToWorking, + ) +import Darcs.Patch ( Prim, apply_to_slurpy, tokreplace, force_replace_slurpy ) +import Darcs.Ordered ( FL(..), unsafeFL, (+>+), concatFL ) +import Darcs.SlurpDirectory ( slurp_hasfile, Slurpy ) +import RegChars ( regChars ) +import Data.Char ( isSpace ) +import Darcs.Diff ( unsafeDiff ) +import Darcs.RepoPath ( SubPath, sp2fn, toFilePath ) +import Darcs.Repository.Prefs ( FileType(TextFile) ) +#include "impossible.h" + +replace_description :: String +replace_description = "Substitute one word for another." + +replace_help :: String +replace_help = + "In addition to line-based patches, Darcs supports a limited form of\n" ++ + "lexical substitution. Files are treated as sequences of words, and\n" ++ + "each occurrence of the old word is replaced by the new word.\n" ++ + "This is intended to provide a clean way to rename a function or\n" ++ + "variable. Such renamings typically affect lines all through the\n" ++ + "source code, so a traditional line-based patch would be very likely to\n" ++ + "conflict with other branches, requiring manual merging.\n" ++ + "\n" ++ + "Files are tokenized according to one simple rule: words are strings of\n" ++ + "valid token characters, and everything between them (punctuation and\n" ++ + "whitespace) is discarded.\n" ++ + "\n" ++ + "The tokenizer treats files as byte strings, so it is not possible for\n" ++ + "--token-chars to include multi-byte characters, such as the non-ASCII\n" ++ + "parts of UTF-8. Similarly, trying to replace a `high-bit' character\n" ++ + "from a unibyte encoding will also result in replacement of the same\n" ++ + "byte in files with different encodings. For example, an acute a from\n" ++ + "ISO 8859-1 will also match an alpha from ISO 8859-7.\n" ++ + "\n" ++ + -- FIXME: this heuristic is ham-fisted and silly. Can we drop it? + "By default, valid token characters are letters, numbers and the\n" ++ + "underscore (i.e. [A-Za-z0-9_]). However if the old and/or new token\n" ++ + "contains either a hyphen or period, BOTH hyphen and period are treated\n" ++ + "as valid by default (i.e. [A-Za-z0-9_.-]).\n" ++ + "\n" ++ + "The set of valid characters can be customized using the --token-chars\n" ++ + "option. The argument must be surrounded by square brackets. If a\n" ++ + "hyphen occurs between two characters in the set, it is treated as a\n" ++ + "set range. For example, in most locales [A-Z] denotes all uppercase\n" ++ + "letters. If the first character is a caret, valid tokens are taken to\n" ++ + "be the complement of the remaining characters. For example, [^ \\n\\t]\n" ++ + "declares all characters except the space, tab and newline as valid\n" ++ + "within a word. Unlike the tr(1) and grep(1) utilities, character\n" ++ + "classes (such as [[:alnum:]]) are NOT supported.\n" ++ + "\n" ++ + "If you choose to use --token-chars, you are STRONGLY encouraged to do\n" ++ + "so consistently. The consequences of using multiple replace patches\n" ++ + "with different --token-chars arguments on the same file are not well\n" ++ + "tested nor well understood.\n" ++ + "\n" ++ + "By default Darcs will refuse to perform a replacement if the new token\n" ++ + "is already in use, because the replacements would be not be\n" ++ + "distinguishable from the existing tokens. This behaviour can be\n" ++ + "overridden by supplying the --force option, but an attempt to `darcs\n" ++ + "rollback' the resulting patch will affect these existing tokens.\n" + +-- FIXME: can we just delete the remaining text? It seems more an +-- instance of "look how clever I am; I made commutation work" rather +-- than information that is actually useful to users. +\end{code} +There is a potentially confusing difference, however, when a replace is +used to make another replace possible: +\begin{verbatim} +$ darcs replace newtoken aaack ./foo.c +$ darcs replace oldtoken newtoken ./foo.c +$ darcs record +\end{verbatim} +will be valid, even if \verb!newtoken! and \verb!oldtoken! are both present +in the recorded version of foo.c, while the sequence +\begin{verbatim} +$ [manually edit foo.c replacing newtoken with aaack] +$ darcs replace oldtoken newtoken ./foo.c +\end{verbatim} +will fail because ``newtoken'' still exists in the recorded version of +\verb!foo.c!. The reason for the difference is that when recording, a +``replace'' patch always is recorded \emph{before} any manual changes, +which is usually what you want, since often you will introduce new +occurrences of the ``newtoken'' in your manual changes. In contrast, +multiple ``replace'' changes are recorded in the order in which +they were made. +\begin{code} + +replace :: DarcsCommand +replace = DarcsCommand {command_name = "replace", + command_help = replace_help, + command_description = replace_description, + command_extra_args = -1, + command_extra_arg_help = ["","", + " ..."], + command_command = replace_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = list_registered_files, + command_argdefaults = nodefaults, + command_advanced_options = [ignoretimes, umask_option], + command_basic_options = + [tokens, force_replace, working_repo_dir]} + +replace_cmd :: [DarcsFlag] -> [String] -> IO () +replace_cmd opts (old:new:relfs) = withRepoLock opts $- \repository -> do + fs <- fixSubPaths opts relfs + toks <- choose_toks opts old new + let checkToken tok = + unless (is_tok toks tok) $ fail $ "'"++tok++"' is not a valid token!" + checkToken old + checkToken new + (_, work) <- slurp_recorded_and_unrecorded repository + cur <- slurp_pending repository + pswork <- (concatFL . unsafeFL) `fmap` sequence (map (repl toks cur work) fs) + add_to_pending repository pswork + applyToWorking repository opts pswork `catch` \e -> + fail $ "Can't do replace on working!\n" + ++ "Perhaps one of the files already contains '"++ new++"'?\n" + ++ show e + where ftf _ = TextFile + + repl :: String -> Slurpy -> Slurpy -> SubPath -> IO (FL Prim) + repl toks cur work f = + if not $ slurp_hasfile (sp2fn f) work + then do putStrLn $ "Skipping file '"++f_fp++"' which isn't in the repository." + return NilFL + else if ForceReplace `elem` opts || + isJust (apply_to_slurpy (tokreplace f_fp toks old new) work) || + isJust (apply_to_slurpy (tokreplace f_fp toks old new) cur) + then return (get_force_replace f toks work) + else do putStrLn $ "Skipping file '"++f_fp++"'" + putStrLn $ "Perhaps the recorded version of this " ++ + "file already contains '" ++new++"'?" + putStrLn $ "Use the --force option to override." + return NilFL + where f_fp = toFilePath f + + get_force_replace :: SubPath -> String -> Slurpy -> FL Prim + get_force_replace f toks s = + case force_replace_slurpy (tokreplace f_fp toks new old) s of + Nothing -> bug "weird forcing bug in replace." + Just s' -> case unsafeDiff [] ftf s s' of + pfix -> pfix +>+ (tokreplace f_fp toks old new :>: NilFL) + where f_fp = toFilePath f + +replace_cmd _ _ = fail "Usage: darcs replace OLD NEW [FILES]" + +default_toks :: String +default_toks = "A-Za-z_0-9" +filename_toks :: String +filename_toks = "A-Za-z_0-9\\-\\." + +-- | Given a set of characters and a string, returns true iff the +-- string contains only characters from the set. A set beginning with +-- a caret (@^@) is treated as a complementary set. +is_tok :: String -> String -> Bool +is_tok _ "" = False +is_tok toks s = and $ map (regChars toks) s + +-- | This function checks for @--token-chars@ on the command-line. If +-- found, it validates the argument and returns it, without the +-- surrounding square brackets. Otherwise, it returns either +-- 'default_toks' or 'filename_toks' as explained in 'replace_help'. +-- +-- Note: Limitations in the current replace patch file format prevents +-- tokens and token-char specifiers from containing any whitespace. +choose_toks :: [DarcsFlag] -> String -> String -> IO String +choose_toks (Toks t:_) a b + | length t <= 2 = + bad_token_spec $ "It must contain more than 2 characters, because " ++ + "it should be enclosed in square brackets" + | head t /= '[' || last t /= ']' = + bad_token_spec "It should be enclosed in square brackets" + | '^' == head tok && length tok == 1 = + bad_token_spec "Must be at least one character in the complementary set" + | any isSpace t = + bad_token_spec "Space is not allowed in the spec" + | any isSpace a = bad_token_spec $ spacey_token a + | any isSpace b = bad_token_spec $ spacey_token b + | not (is_tok tok a) = bad_token_spec $ not_a_token a + | not (is_tok tok b) = bad_token_spec $ not_a_token b + | otherwise = return tok + where tok = init $ tail t :: String + bad_token_spec msg = fail $ "Bad token spec: '"++ t ++"' ("++ msg ++")" + spacey_token x = x ++ " must not contain any space" + not_a_token x = x ++ " is not a token, according to your spec" +choose_toks (_:fs) a b = choose_toks fs a b +choose_toks [] a b = if is_tok default_toks a && is_tok default_toks b + then return default_toks + else return filename_toks +\end{code} + diff --git a/src/Darcs/Commands/Revert.lhs b/src/Darcs/Commands/Revert.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Revert.lhs @@ -0,0 +1,119 @@ +% Copyright (C) 2002-2005 David Roundy +% +% 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. + +\darcsCommand{revert} +\begin{code} +module Darcs.Commands.Revert ( revert ) where +import System.Exit ( ExitCode(..), exitWith ) +import Control.Monad ( when ) +import Data.List ( sort ) + +import English (englishNum, This(..), Noun(..)) +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag( All, Debug ), + ignoretimes, working_repo_dir, + all_interactive, + fixSubPaths, areFileArgs, + list_registered_files, umask_option, + ) +import Darcs.Utils ( askUser ) +import Darcs.RepoPath ( toFilePath, sp2fn ) +import Darcs.Repository ( withRepoLock, ($-), withGutsOf, + get_unrecorded_in_files, + get_unrecorded_in_files_unsorted, + add_to_pending, sync_repo, + applyToWorking, + amInRepository, slurp_recorded, + ) +import Darcs.Patch ( invert, apply_to_filepaths, commute ) +import Darcs.Ordered ( FL(..), (:>)(..), lengthFL, nullFL, (+>+) ) +import Darcs.SelectChanges ( with_selected_last_changes_to_files' ) +import Darcs.Patch.TouchesFiles ( choose_touching ) +import Darcs.Commands.Unrevert ( write_unrevert ) +import Darcs.Sealed ( unsafeUnseal ) +import Darcs.Gorsvet( invalidateIndex ) + +revert_description :: String +revert_description = "Discard unrecorded changes." + +revert_help :: String +revert_help = + "The `darcs revert' command discards unrecorded changes the working\n" ++ + "tree. As with `darcs record', you will be asked which hunks (changes)\n" ++ + "to revert. The --all switch can be used to avoid such prompting. If\n" ++ + "files or directories are specified, other parts of the working tree\n" ++ + "are not reverted.\n" ++ + "\n" ++ + "In you accidentally reverted something you wanted to keep (for\n" ++ + "example, typing `darcs rev -a' instead of `darcs rec -a'), you can\n" ++ + "immediately run `darcs unrevert' to restore it. This is only\n" ++ + "guaranteed to work if the repository has not changed since `darcs\n" ++ + "revert' ran.\n" + +revert :: DarcsCommand +revert = DarcsCommand {command_name = "revert", + command_help = revert_help, + command_description = revert_description, + command_extra_args = -1, + command_extra_arg_help = ["[FILE or DIRECTORY]..."], + command_command = revert_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = list_registered_files, + command_argdefaults = nodefaults, + command_advanced_options = [ignoretimes, umask_option], + command_basic_options = [all_interactive, + working_repo_dir]} + +revert_cmd :: [DarcsFlag] -> [String] -> IO () +revert_cmd opts args = withRepoLock opts $- \repository -> do + files <- sort `fmap` fixSubPaths opts args + let files_fn = map sp2fn files + when (areFileArgs files) $ + putStrLn $ "Reverting changes in "++unwords (map show files)++"..\n" + changes <- if All `elem` opts + then get_unrecorded_in_files_unsorted repository files_fn + else get_unrecorded_in_files repository files_fn + let pre_changed_files = apply_to_filepaths (invert changes) (map toFilePath files) + rec <- slurp_recorded repository + case unsafeUnseal $ choose_touching pre_changed_files changes of + NilFL -> putStrLn "There are no changes to revert!" + _ -> with_selected_last_changes_to_files' "revert" opts + pre_changed_files changes $ \ (norevert:>p) -> + if nullFL p + then putStrLn $ "If you don't want to revert after all," ++ + " that's fine with me!" + else do + let theseChanges = englishNum (lengthFL p) . This . Noun $ "change" + yorn <- if All `elem` opts + then return "y" + else askUser $ "Do you really want to revert " ++ theseChanges "? " + case yorn of ('y':_) -> return () + _ -> exitWith $ ExitSuccess + withGutsOf repository $ do + invalidateIndex repository + add_to_pending repository $ invert p + when (Debug `elem` opts) $ putStrLn "About to write the unrevert file." + case commute (norevert:>p) of + Just (p':>_) -> write_unrevert repository p' rec NilFL + Nothing -> write_unrevert repository (norevert+>+p) rec NilFL + when (Debug `elem` opts) $ putStrLn "About to apply to the working directory." + applyToWorking repository opts (invert p) `catch` \e -> + fail ("Unable to apply inverse patch!" ++ show e) + sync_repo repository + putStrLn "Finished reverting." +\end{code} + diff --git a/src/Darcs/Commands/Rollback.lhs b/src/Darcs/Commands/Rollback.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Rollback.lhs @@ -0,0 +1,160 @@ +% Copyright (C) 2002-2004,2007 David Roundy +% +% 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. + +\darcsCommand{rollback} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Rollback ( rollback ) where + +import Control.Monad ( when, filterM ) +import System.Exit ( exitWith, ExitCode(..) ) +import Data.List ( sort ) +import Data.Maybe ( isJust ) +import System.Directory ( removeFile ) + +import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers ) +import Darcs.Arguments ( DarcsFlag(MarkConflicts), fixSubPaths, get_author, + definePatches, + working_repo_dir, nocompress, + author, patchname_option, ask_long_comment, + leave_test_dir, notest, list_registered_files, + match_several_or_last, all_interactive, umask_option + ) +import Darcs.RepoPath ( toFilePath ) +import Darcs.Repository ( amInRepository, withRepoLock, ($-), applyToWorking, + read_repo, slurp_recorded, + tentativelyMergePatches, withGutsOf, + finalizeRepositoryChanges, sync_repo ) +import Darcs.Patch ( summary, invert, namepatch, effect, fromPrims, + sort_coalesceFL, canonize ) +import Darcs.Ordered +import Darcs.Hopefully ( n2pia ) +import Darcs.Lock ( world_readable_temp ) +import Darcs.SlurpDirectory ( empty_slurpy, wait_a_moment ) +import Darcs.Match ( first_match ) +import Darcs.SelectChanges ( with_selected_last_changes_to_files_reversed, + with_selected_last_changes_to_files' ) +import Darcs.Commands.Record ( file_exists, get_log ) +import Darcs.Commands.Unrecord ( get_last_patches ) +import Darcs.Utils ( clarify_errors ) +import Printer ( renderString ) +import Progress ( debugMessage ) +import Darcs.Sealed ( Sealed(..), FlippedSeal(..) ) +import IsoDate ( getIsoDateTime ) +import Darcs.Gorsvet( invalidateIndex ) +#include "impossible.h" + +rollback_description :: String +rollback_description = + "Record a new patch reversing some recorded changes." +\end{code} + +If you decide you didn't want to roll back a patch +after all, you can reverse its effect by obliterating the rolled-back patch. + +Rollback can actually allow you to roll back a subset of the changes made +by the selected patch or patches. Many of the options available in +rollback behave similarly to the options for unrecord~\ref{unrecord} and +record~\ref{record}. + +\begin{code} +rollback_help :: String +rollback_help = + "Rollback is used to undo the effects of one or more patches without actually\n"++ + "deleting them. Instead, it creates a new patch reversing selected portions.\n"++ + "of those changes. Unlike obliterate and unrecord (which accomplish a similar\n"++ + "goal) rollback is perfectly safe, since it leaves in the repository a record\n"++ + "of its changes.\n" + +rollback :: DarcsCommand +rollback = DarcsCommand {command_name = "rollback", + command_help = rollback_help, + command_description = rollback_description, + command_extra_args = -1, + command_extra_arg_help = ["[FILE or DIRECTORY]..."], + command_command = rollback_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = list_registered_files, + command_argdefaults = nodefaults, + command_advanced_options = [nocompress,umask_option], + command_basic_options = [match_several_or_last, + all_interactive, + author, patchname_option, ask_long_comment, + notest, leave_test_dir, + working_repo_dir]} + +rollback_cmd :: [DarcsFlag] -> [String] -> IO () +rollback_cmd opts args = withRepoLock opts $- \repository -> do + let (logMessage,_,_) = loggers opts + rec <- if null args then return empty_slurpy + else slurp_recorded repository + files <- sort `fmap` fixSubPaths opts args + existing_files <- map toFilePath `fmap` filterM (file_exists rec) files + non_existent_files <- map toFilePath `fmap` filterM (fmap not . file_exists rec) files + when (not $ null existing_files) $ + logMessage $ "Recording changes in "++unwords existing_files++":\n" + when (not $ null non_existent_files) $ + logMessage $ "Non existent files or directories: "++unwords non_existent_files++"\n" + when ((not $ null non_existent_files) && null existing_files) $ + fail "None of the files you specified exist!" + allpatches <- read_repo repository + FlippedSeal patches <- return $ if first_match opts + then get_last_patches opts allpatches + else FlippedSeal $ concatRL allpatches + with_selected_last_changes_to_files_reversed "rollback" opts existing_files + (reverseRL patches) $ + \ (_ :> ps) -> + do when (nullFL ps) $ do logMessage "No patches selected!" + exitWith ExitSuccess + definePatches ps + with_selected_last_changes_to_files' "rollback" opts + existing_files (concatFL $ mapFL_FL canonize $ + sort_coalesceFL $ effect ps) $ \ (_:>ps'') -> + do when (nullFL ps'') $ do logMessage "No changes selected!" + exitWith ExitSuccess + let make_log = world_readable_temp "darcs-rollback" + newlog = Just ("", "":"rolling back:":"":lines (renderString $ summary ps )) + --tentativelyRemovePatches repository opts (mapFL_FL hopefully ps) + (name, my_log, logf) <- get_log opts newlog make_log $ invert ps'' + date <- getIsoDateTime + my_author <- get_author opts + rbp <- n2pia `fmap` namepatch date name my_author my_log + (fromPrims $ invert ps'') + debugMessage "Adding rollback patch to repository." + Sealed pw <- tentativelyMergePatches repository "rollback" (MarkConflicts : opts) + NilFL (rbp :>: NilFL) + debugMessage "Finalizing rollback changes..." + invalidateIndex repository + withGutsOf repository $ do + finalizeRepositoryChanges repository + debugMessage "About to apply rolled-back changes to working directory." + -- so work will be more recent than rec: + revertable $ do wait_a_moment + applyToWorking repository opts pw + when (isJust logf) $ removeFile (fromJust logf) + sync_repo repository + logMessage $ "Finished rolling back." + where revertable x = x `clarify_errors` unlines + ["Error applying patch to the working directory.","", + "This may have left your working directory an inconsistent", + "but recoverable state. If you had no un-recorded changes", + "by using 'darcs revert' you should be able to make your", + "working directory consistent again."] +\end{code} + diff --git a/src/Darcs/Commands/Send.lhs b/src/Darcs/Commands/Send.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Send.lhs @@ -0,0 +1,444 @@ +% Copyright (C) 2002-2004 David Roundy +% +% 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. + +\darcsCommand{send} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Send ( send ) where +import Data.Char ( isAlpha, isDigit, isSpace, toLower ) +import System.Exit ( exitWith, ExitCode( ExitSuccess ) ) +import System.IO.Error ( ioeGetErrorString ) +import System.IO ( hClose ) +import Control.Monad ( when, unless, forM_ ) +import Data.Maybe ( isJust, isNothing ) + +import Darcs.Commands ( DarcsCommand(..) ) +import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile, RmLogFile, + Target, OutputAutoName, Output, Context, + DryRun, Verbose, Quiet, Unified + ), + fixUrl, definePatches, + get_cc, get_author, working_repo_dir, + edit_description, logfile, rmlogfile, + sign, get_subject, deps_sel, get_in_reply_to, + match_several, set_default, output_auto_name, + output, cc, subject, target, author, sendmail_cmd, + in_reply_to, remote_repo, network_options, + all_interactive, get_sendmail_cmd, + print_dry_run_message_and_exit, + summary, allow_unrelated_repos, + from_opt, dry_run, send_to_context, + ) +import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) +import Darcs.Repository ( PatchSet, Repository, + amInRepository, identifyRepositoryFor, withRepoReadLock, ($-), + read_repo, slurp_recorded, prefsUrl, checkUnrelatedRepos ) +import Darcs.Patch ( RepoPatch, description, apply_to_slurpy, invert ) +import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (:\/:)(..), unsafeUnRL, + mapRL_RL, mapFL, mapRL, reverseRL, mapFL_FL, lengthFL, nullFL ) +import Darcs.Patch.Bundle ( make_bundle, scan_context ) +import Darcs.Patch.Info ( just_name ) +import Darcs.Repository.Prefs ( defaultrepo, set_defaultrepo, get_preflist ) +import Darcs.External ( signString, sendEmailDoc, fetchFilePS, Cachable(..), generateEmail ) +import ByteStringUtils ( mmapFilePS ) +import qualified Data.ByteString.Char8 as BC (unpack) +import Darcs.Lock ( withOpenTemp, writeDocBinFile, readDocBinFile, world_readable_temp, removeFileMayNotExist ) +import Darcs.SelectChanges ( with_selected_changes ) +import Darcs.Patch.Depends ( get_common_and_uncommon ) +import Darcs.Utils ( askUser, catchall, edit_file, formatPath ) +import Progress ( debugMessage ) +import Darcs.Email ( make_email ) +import Printer ( Doc, vsep, vcat, text, ($$), putDocLn, putDoc ) +import Darcs.RepoPath ( toFilePath, AbsolutePath, AbsolutePathOrStd, + getCurrentDirectory, makeAbsoluteOrStd, useAbsoluteOrStd ) +import HTTP ( postUrl ) +#include "impossible.h" + +send_description :: String +send_description = + "Send by email a bundle of one or more patches." + +send_help :: String +send_help = + "Send is used to prepare a bundle of patches that can be applied to a target\n"++ + "repository. Send accepts the URL of the repository as an argument. When\n"++ + "called without an argument, send will use the most recent repository that\n"++ + "was either pushed to, pulled from or sent to. By default, the patch bundle\n"++ + "is sent by email, although you may save it to a file.\n" +\end{code} + +Do not confuse the \verb!--author! options with the return address +that \verb!darcs send! will set for your patch bundle. + +For example, if you have two email addresses A and B: +\begin{description} +\item If you use +\verb!--author A! but your machine is configured to send mail from +address B by default, then the return address on your message will be B. + +\item If you use \verb!--from A! and your mail client supports setting the +From: address arbitrarily (some non-Unix-like mail clients, especially, +may not support this), then the return address will be A; if it does +not support this, then the return address will be B. + +\item If you supply neither \verb!--from! nor \verb!--author!, then the return +address will be B. +\end{description} + +In addition, unless you specify the sendmail command with +\verb!--sendmail-command!, darcs sends email using the default email +command on your computer. This default command is determined by the +\verb!configure! script. Thus, on some non-Unix-like OSes, +\verb!--from! is likely to not work at all. + +\begin{code} +send :: DarcsCommand +send = DarcsCommand {command_name = "send", + command_help = send_help, + command_description = send_description, + command_extra_args = 1, + command_extra_arg_help = ["[REPOSITORY]"], + command_command = send_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = get_preflist "repos", + command_argdefaults = defaultrepo, + command_advanced_options = [logfile, rmlogfile, + remote_repo, + send_to_context] ++ + network_options, + command_basic_options = [match_several, deps_sel, + all_interactive, + from_opt, author, + target,cc,subject, in_reply_to, + output,output_auto_name,sign] + ++dry_run++[summary, + edit_description, + set_default, working_repo_dir, + sendmail_cmd, + allow_unrelated_repos]} + +send_cmd :: [DarcsFlag] -> [String] -> IO () +send_cmd input_opts [""] = send_cmd input_opts [] +send_cmd input_opts [unfixedrepodir] = withRepoReadLock input_opts $- \repository -> do + context_ps <- the_context input_opts + case context_ps of + Just them -> send_to_them repository input_opts [] "CONTEXT" them + Nothing -> do + repodir <- fixUrl input_opts unfixedrepodir + -- Test to make sure we aren't trying to push to the current repo + here <- getCurrentDirectory + when (repodir == toFilePath here) $ + fail ("Can't send to current repository! Did you mean send -"++"-context?") + repo <- identifyRepositoryFor repository repodir + them <- read_repo repo + old_default <- get_preflist "defaultrepo" + set_defaultrepo repodir input_opts + when (old_default == [repodir] && not (Quiet `elem` input_opts)) $ + putStrLn $ "Creating patch to "++formatPath repodir++"..." + wtds <- decide_on_behavior input_opts repo + send_to_them repository input_opts wtds repodir them + where the_context [] = return Nothing + the_context (Context foo:_) + = (Just . scan_context )`fmap` mmapFilePS (toFilePath foo) + the_context (_:fs) = the_context fs +send_cmd _ _ = impossible + +send_to_them :: RepoPatch p => Repository p -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet p -> IO () +send_to_them repo opts wtds their_name them = do + let am_verbose = Verbose `elem` opts + am_quiet = Quiet `elem` opts + putVerbose s = when am_verbose $ putDocLn s + putInfo s = when (not am_quiet) $ putStrLn s + patch_desc p = just_name $ info p + make_fname tbs = patch_filename $ patch_desc $ headFL tbs + headFL (x:>:_) = x + headFL _ = impossible + us <- read_repo repo + case get_common_and_uncommon (us, them) of + (common, us' :\/: _) -> do + checkUnrelatedRepos opts common us them + case us' of + NilRL:<:NilRL -> do putInfo "No recorded local changes to send!" + exitWith ExitSuccess + _ -> putVerbose $ text "We have the following patches to send:" + $$ (vcat $ mapRL description $ head $ unsafeUnRL us') + s <- slurp_recorded repo + let our_ps = reverseRL $ head $ unsafeUnRL us' + with_selected_changes "send" opts our_ps $ + \ (to_be_sent :> _) -> do + print_dry_run_message_and_exit "send" opts to_be_sent + when (nullFL to_be_sent) $ do + putInfo "You don't want to send any patches, and that's fine with me!" + exitWith ExitSuccess + definePatches to_be_sent + bundle <- signString opts $ make_bundle (Unified:opts) + (fromJust $ apply_to_slurpy + (invert $ + mapRL_RL hopefully $ head $ unsafeUnRL us') s) + common (mapFL_FL hopefully to_be_sent) + let outname = get_output opts (make_fname to_be_sent) + case outname of + Just fname -> do (d,f) <- get_description opts to_be_sent + let putabs a = do writeDocBinFile a (d $$ bundle) + putStrLn $ "Wrote patch to " ++ toFilePath a ++ "." + putstd = putDoc (d $$ bundle) + useAbsoluteOrStd putabs putstd fname + cleanup f + Nothing -> + let + auto_subject (p:>:NilFL) = "darcs patch: " ++ trim (patch_desc p) 57 + auto_subject (p:>:ps) = "darcs patch: " ++ trim (patch_desc p) 43 ++ + " (and " ++ show (lengthFL ps) ++ " more)" + auto_subject _ = error "Tried to get a name from empty patch list." + trim st n = if length st <= n then st + else take (n-3) st ++ "..." + in do + thetargets <- get_targets wtds + from <- get_author opts + let thesubject = case get_subject opts of + Nothing -> auto_subject to_be_sent + Just subj -> subj + (mailcontents, mailfile) <- get_description opts to_be_sent + let body = make_email their_name + (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . get_in_reply_to $ opts) + (Just mailcontents) + bundle + (Just $ make_fname to_be_sent) + contentAndBundle = Just (mailcontents, bundle) + + sendmail = do + sm_cmd <- get_sendmail_cmd opts + (sendEmailDoc from (lt [t | SendMail t <- thetargets]) (thesubject) (get_cc opts) + sm_cmd contentAndBundle body >> + putInfo ("Successfully sent patch bundle to: " + ++ lt [ t | SendMail t <- thetargets ] + ++ ccs (get_cc opts) ++".")) + `catch` \e -> let msg = "Email body left in " in + do case mailfile of + Just mf -> putStrLn $ msg++mf++"." + Nothing -> return () + fail $ ioeGetErrorString e + ccs [] = [] + ccs cs = " and cc'ed " ++ cs + + when (null [ p | Post p <- thetargets]) sendmail + nbody <- withOpenTemp $ \ (fh,fn) -> do + generateEmail fh from (lt [t | SendMail t <- thetargets]) thesubject (get_cc opts) body + hClose fh + mmapFilePS fn + forM_ [ p | Post p <- thetargets] + (\url -> do + putInfo $ "Posting patch to " ++ url + postUrl url (BC.unpack nbody) "message/rfc822") + `catch` const sendmail + cleanup mailfile + + where cleanup (Just mailfile) = when (isNothing (get_fileopt opts) || (RmLogFile `elem` opts)) $ + removeFileMayNotExist mailfile + cleanup Nothing = return () + lt [t] = t + lt [t,""] = t + lt (t:ts) = t++" , "++lt ts + lt [] = "" + +safeFileChar :: Char -> Char +safeFileChar c | isAlpha c = toLower c + | isDigit c = c + | isSpace c = '-' +safeFileChar _ = '_' + +patch_filename :: String -> String +patch_filename the_summary = name ++ ".dpatch" + where name = map safeFileChar the_summary +\end{code} + +\begin{options} +--output, --to, --cc +\end{options} + +The \verb!--output!, \verb!--output-auto-name!, and \verb!--to! flags determine +what darcs does with the patch bundle after creating it. If you provide an +\verb!--output! argument, the patch bundle is saved to that file. If you +specify \verb!--output-auto-name!, the patch bundle is saved to a file with an +automatically generated name. If you give one or more \verb!--to! arguments, +the bundle of patches is sent to those locations. The locations may either be email +addresses or urls that the patch should be submitted to via HTTP. + +If you don't provide any of these options, darcs will look at the contents of +the \verb!_darcs/prefs/email! file in the target repository (if it exists), and +send the patch by email to that address. In this case, you may use the +\verb!--cc! option to specify additional recipients without overriding the +default repository email address. + +If \texttt{\_darcs/prefs/post} exists in the target repository, darcs will +upload to the URL contained in that file, which may either be a +\texttt{mailto:} URL, or an \texttt{http://} URL. In the latter case, the +patch is posted to that URL. + +If there is no email address associated with the repository, darcs will +prompt you for an email address. + +\begin{options} +--subject +\end{options} + +Use the \verb!--subject! flag to set the subject of the e-mail to be sent. +If you don't provide a subject on the command line, darcs will make one up +based on names of the patches in the patch bundle. + +\begin{options} +--in-reply-to +\end{options} + +Use the \verb!--in-reply-to! flag to set the In-Reply-To and References headers +of the e-mail to be sent. By default no additional headers are included so e-mail +will not be treated as reply by mail readers. + +\begin{code} + +data WhatToDo + = Post String -- ^ POST the patch via HTTP + | SendMail String -- ^ send patch via email + + +decide_on_behavior :: RepoPatch p => [DarcsFlag] -> Repository p -> IO [WhatToDo] +decide_on_behavior opts the_remote_repo = + case the_targets of + [] -> + if isJust $ get_output opts "" + then return [] + else + do wtds <- check_post + unless (null wtds) $ announce_recipients wtds + return wtds + ts -> do announce_recipients ts + return ts + where the_targets = collect_targets opts +#ifdef HAVE_HTTP + -- the ifdef above is to so that darcs only checks the remote + -- _darcs/post if we have an implementation of postUrl. See + -- our HTTP module for more details + check_post = do p <- ((readPost . BC.unpack) `fmap` + fetchFilePS (prefsUrl the_remote_repo++"/post") + (MaxAge 600)) `catchall` return [] + emails <- who_to_email + return (p++emails) + readPost p = map pp (lines p) where + pp ('m':'a':'i':'l':'t':'o':':':s) = SendMail s + pp s = Post s +#else + check_post = who_to_email +#endif + who_to_email = + do email <- (BC.unpack `fmap` + fetchFilePS (prefsUrl the_remote_repo++"/email") + (MaxAge 600)) + `catchall` return "" + if '@' `elem` email then return . map SendMail $ lines email + else return [] + putInfoLn s = unless (Quiet `elem` opts) $ putStrLn s + announce_recipients emails = + let pn (SendMail s) = s + pn (Post p) = p + in if DryRun `elem` opts + then putInfoLn $ "Patch bundle would be sent to: "++unwords (map pn emails) + else when (null the_targets) $ + putInfoLn $ "Patch bundle will be sent to: "++unwords (map pn emails) + +get_output :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd +get_output (Output a:_) _ = return a +get_output (OutputAutoName a:_) f = return $ makeAbsoluteOrStd a f +get_output (_:flags) f = get_output flags f +get_output [] _ = Nothing + +get_targets :: [WhatToDo] -> IO [WhatToDo] +get_targets [] = do fmap ((:[]) . SendMail) $ askUser "What is the target email address? " +get_targets wtds = return wtds + +collect_targets :: [DarcsFlag] -> [WhatToDo] +collect_targets flags = [ f t | Target t <- flags ] where + f url@('h':'t':'t':'p':':':_) = Post url + f em = SendMail em + + +\end{code} + +\begin{options} +--matches, --patches, --tags, --no-deps +\end{options} + +The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps! +options can be used to select which patches to send, as described in +subsection~\ref{selecting}. + +\begin{options} +--edit-description +\end{options} + +If you want to include a description or explanation along with the bundle +of patches, you need to specify the \verb!--edit-description! flag, which +will cause darcs to open up an editor with which you can compose a message +to go along with your patches. + +\begin{options} +--sendmail-command +\end{options} + +If you want to use a command different from the default one for sending email, +you need to specify a command line with the \verb!--sendmail-command! option. The +command line can contain some format specifiers which are replaced by the actual +values. Accepted format specifiers are \verb!%s! for subject, \verb!%t! for to, +\verb!%c! for cc, \verb!%b! for the body of the mail, \verb!%f! for from, \verb!%a! +for the patch bundle and the same specifiers in uppercase for the URL-encoded values. +Additionally you can add \verb!% [DarcsFlag] -> FL (PatchInfoAnd p) -> IO (Doc, Maybe String) +get_description opts patches = + case get_filename of + Just f -> do file <- f + when (EditDescription `elem` opts) $ do + when (isNothing $ get_fileopt opts) $ + writeDocBinFile file patchdesc + debugMessage $ "About to edit file " ++ file + edit_file file + return () + doc <- readDocBinFile file + return (doc, Just file) + Nothing -> return (patchdesc, Nothing) + where patchdesc = vsep $ mapFL description patches + get_filename = case get_fileopt opts of + Just f -> Just $ return $ toFilePath f + Nothing -> if EditDescription `elem` opts + then Just tempfile + else Nothing + tempfile = world_readable_temp "darcs-temp-mail" + +get_fileopt :: [DarcsFlag] -> Maybe AbsolutePath +get_fileopt (LogFile f:_) = Just f +get_fileopt (_:flags) = get_fileopt flags +get_fileopt [] = Nothing +\end{code} diff --git a/src/Darcs/Commands/SetPref.lhs b/src/Darcs/Commands/SetPref.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/SetPref.lhs @@ -0,0 +1,108 @@ +% Copyright (C) 2003 David Roundy +% +% 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. + +\darcsCommand{setpref} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.SetPref ( setpref ) where + +import System.Exit ( exitWith, ExitCode(..) ) +import Control.Monad (when) + +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag, working_repo_dir, umask_option ) +import Darcs.Repository ( amInRepository, add_to_pending, withRepoLock, ($-) ) +import Darcs.Patch ( changepref ) +import Darcs.Ordered ( FL(..) ) +import Darcs.Repository.Prefs ( get_prefval, change_prefval, ) +import English ( orClauses ) +#include "impossible.h" + +-- | A list of all valid preferences for @_darcs/prefs/prefs@. +valid_pref_data :: [(String, String)] -- ^ (name, one line description) +valid_pref_data = + [("test", "a shell command that runs regression tests"), + ("predist", "a shell command to run before `darcs dist'"), + ("boringfile", "the path to a version-controlled boring file"), + ("binariesfile", "the path to a version-controlled binaries file")] + +valid_prefs :: [String] +valid_prefs = map fst valid_pref_data + +setpref_description :: String +setpref_description = + "Set a preference (" ++ orClauses valid_prefs ++ ")." + +setpref_help :: String +setpref_help = + "When working on project with multiple repositories and contributors,\n" ++ + "it is sometimes desirable for a preference to be set consistently\n" ++ + "project-wide. This is achieved by treating a preference set with\n" ++ + "`darcs setpref' as an unrecorded change, which can then be recorded\n" ++ + "and then treated like any other patch.\n" ++ + "\n" ++ + "Valid preferences are:\n" ++ + "\n" ++ + unlines [" "++x++" -- "++y | (x,y) <- valid_pref_data] ++ + "\n" ++ + "For example, a project using GNU autotools, with a `make test' target\n" ++ + "to perform regression tests, might enable Darcs' integrated regression\n" ++ + "testing with the following command:\n" ++ + "\n" ++ + " darcs setpref test 'autoconf && ./configure && make && make test'\n" ++ + "\n" ++ + "Note that merging is not currently implemented for preferences: if two\n" ++ + "patches attempt to set the same preference, the last patch applied to\n" ++ + "the repository will always take precedence. This is considered a\n" ++ + "low-priority bug, because preferences are seldom set.\n" + +setpref :: DarcsCommand +setpref = DarcsCommand {command_name = "setpref", + command_help = setpref_help, + command_description = setpref_description, + command_extra_args = 2, + command_extra_arg_help = ["", + ""], + command_command = setpref_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return valid_prefs, + command_argdefaults = nodefaults, + command_advanced_options = [umask_option], + command_basic_options = + [working_repo_dir]} + +setpref_cmd :: [DarcsFlag] -> [String] -> IO () +setpref_cmd opts [pref,val] = withRepoLock opts $- \repository -> do + when (' ' `elem` pref) $ do + putStrLn $ "'"++pref++ + "' is not a valid preference name: no spaces allowed!" + exitWith $ ExitFailure 1 + when (not $ pref `elem` valid_prefs) $ do + putStrLn $ "'"++pref++"' is not a valid preference name!" + putStrLn $ "Try one of: " ++ unwords valid_prefs + exitWith $ ExitFailure 1 + oval <- get_prefval pref + old <- case oval of Just v -> return v + Nothing -> return "" + change_prefval pref old val + putStrLn $ "Changing value of "++pref++" from '"++old++"' to '"++val++"'" + add_to_pending repository (changepref pref old val :>: NilFL) +setpref_cmd _ _ = impossible +\end{code} + diff --git a/src/Darcs/Commands/Show.lhs b/src/Darcs/Commands/Show.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Show.lhs @@ -0,0 +1,77 @@ +% Copyright (C) 2002-2004 David Roundy +% +% 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. + +\begin{code} +module Darcs.Commands.Show ( show_command, list, query ) where + +import Darcs.Commands ( DarcsCommand(..), + CommandControl(Command_data, Hidden_command), + command_alias, + ) +import Darcs.Commands.ShowAuthors ( show_authors ) +import Darcs.Commands.ShowBug ( show_bug ) +import Darcs.Commands.ShowContents ( show_contents ) +import Darcs.Commands.ShowFiles ( show_files, show_manifest ) +import Darcs.Commands.ShowTags ( show_tags ) +import Darcs.Commands.ShowRepo ( show_repo ) +import Darcs.Commands.ShowIndex ( show_index, show_pristine ) +import Darcs.Repository ( amInRepository ) + +show_description :: String +show_description = "Show information which is stored by darcs." + +show_help :: String +show_help = + "Use the --help option with the subcommands to obtain help for\n"++ + "subcommands (for example, \"darcs show files --help\").\n" ++ + "\n" ++ + "In previous releases, this command was called `darcs query'.\n" ++ + "Currently this is a deprecated alias.\n" + +show_command :: DarcsCommand +show_command = SuperCommand {command_name = "show", + command_help = show_help, + command_description = show_description, + command_prereq = amInRepository, + command_sub_commands = [Hidden_command show_bug, + Command_data show_contents, + Command_data show_files, Hidden_command show_manifest, + Command_data show_index, + Command_data show_pristine, + Command_data show_repo, + Command_data show_authors, + Command_data show_tags] + } + +query :: DarcsCommand +query = command_alias "query" show_command + +list :: DarcsCommand +list = command_alias "list" show_command +\end{code} + +\subsection{darcs show} + +The show command provides access to several subcommands which can be +used to investigate the state of a repository. + +\input{Darcs/Commands/ShowAuthors.lhs} +\input{Darcs/Commands/ShowContents.lhs} +\input{Darcs/Commands/ShowFiles.lhs} +\input{Darcs/Commands/ShowTags.lhs} +\input{Darcs/Commands/ShowRepo.lhs} + diff --git a/src/Darcs/Commands/ShowAuthors.lhs b/src/Darcs/Commands/ShowAuthors.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/ShowAuthors.lhs @@ -0,0 +1,160 @@ +% Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael +% +% 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. + +\darcsCommand{show authors} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +module Darcs.Commands.ShowAuthors ( show_authors ) where + +import Control.Arrow ((&&&), (***)) +import Data.List ( sort, sortBy, group, groupBy, isInfixOf, isPrefixOf ) +import Data.Ord (comparing) +import Data.Char ( toLower, isSpace ) +import Text.Regex ( Regex, mkRegexWithOpts, matchRegex ) + +import Darcs.Arguments ( DarcsFlag(..), working_repo_dir ) +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.External ( viewDoc ) +import Darcs.Hopefully ( info ) +import Darcs.Repository ( amInRepository, read_repo, withRepository, ($-) ) +import Darcs.Patch.Info ( pi_author ) +import Darcs.Ordered ( mapRL, concatRL ) +import Printer ( text ) +import Data.Function (on) + +show_authors_description :: String +show_authors_description = "List authors by patch count." + +show_authors_help :: String +show_authors_help = + "The `darcs show authors' command lists the authors of the current\n" ++ + "repository, sorted by the number of patches contributed. With the\n" ++ + "--verbose option, this command simply lists the author of each patch\n" ++ + "(without aggregation or sorting).\n" ++ + "\n" ++ + "An author's name or email address may change over time. To tell Darcs\n" ++ + "when multiple author strings refer to the same individual, create an\n" ++ + "`.authorspellings' file in the root of the working tree. Each line in\n" ++ + "this file begins with an author's canonical name and address, and may\n" ++ + "be followed by a comma and zero or more extended regular expressions,\n" ++ + "separated by commas. Blank lines and lines beginning with two\n" ++ + "hyphens, are ignored.\n" ++ + "\n" ++ + "Any patch with an author string that matches the canonical address or\n" ++ + "any of the associated regexps is considered to be the work of that\n" ++ + "author. All matching is case-insensitive and partial (it can match a\n" ++ + "substring).\n" ++ + "\n" ++ + "Currently this canonicalization step is done only in `darcs show\n" ++ + "authors'. Other commands, such as `darcs changes' use author strings\n" ++ + "verbatim.\n" ++ + "\n" ++ + "An example .authorspelling file is:\n" ++ + "\n" ++ + " -- This is a comment.\n" ++ + " Fred Nurk \n" ++ + " John Snagge , John, snagge@, js@(si|mit).edu\n" + +show_authors :: DarcsCommand +show_authors = DarcsCommand { + command_name = "authors", + command_help = show_authors_help, + command_description = show_authors_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = authors_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [working_repo_dir] } + +authors_cmd :: [DarcsFlag] -> [String] -> IO () +authors_cmd opts _ = withRepository opts $- \repository -> do + patches <- read_repo repository + spellings <- compiled_author_spellings + let authors = mapRL (pi_author . info) $ concatRL patches + viewDoc $ text $ unlines $ + if Verbose `elem` opts + then authors + else -- A list of the form [" "]... + + -- Turn the final result into a list of strings. + map (\ (count, name) -> show count ++ "\t" ++ name) $ + -- Sort by descending patch count. + reverse $ sortBy (comparing fst) $ + -- Combine duplicates from a list [(count, canonized name)] + -- with duplicates canonized names (see next comment). + map ((sum *** head) . unzip) $ + groupBy ((==) `on` snd) $ + sortBy (comparing snd) $ + -- Because it would take a long time to canonize "foo" into + -- "foo " once per patch, the code below + -- generates a list [(count, canonized name)]. + map (length &&& (canonize_author spellings . head)) $ + group $ sort authors + +canonize_author :: [(String,[Regex])] -> String -> String +canonize_author [] a = a +canonize_author spellings a = safehead a $ canonicalsfor a + where + safehead x xs = if null xs then x else head xs + canonicalsfor s = map fst $ filter (ismatch s) spellings + ismatch s (canonical,regexps) = + (not (null email) && (s `contains` email)) || (any (s `contains_regex`) regexps) + where email = takeWhile (/= '>') $ drop 1 $ dropWhile (/= '<') canonical + +contains :: String -> String -> Bool +a `contains` b = lower b `isInfixOf` (lower a) where lower = map toLower + +contains_regex :: String -> Regex -> Bool +a `contains_regex` r = case matchRegex r a of + Just _ -> True + _ -> False + +compiled_author_spellings :: IO [(String,[Regex])] +compiled_author_spellings = do + ss <- author_spellings_from_file + return $ map compile $ ss + where + compile [] = error "each author spelling should contain at least the canonical form" + compile (canonical:pats) = (canonical, map mkregex pats) + mkregex pat = mkRegexWithOpts pat True False + +authorspellingsfile :: FilePath +authorspellingsfile = ".authorspellings" + +author_spellings_from_file :: IO [[String]] +author_spellings_from_file = do + s <- readFile -- ratify readFile: never unlinked from within darcs + authorspellingsfile `catch` (\_ -> return "") + let noncomments = filter (not . ("--" `isPrefixOf`)) $ + filter (not . null) $ map strip $ lines s + return $ map (map strip . split_on ',') noncomments + +split_on :: Eq a => a -> [a] -> [[a]] +split_on e l = + case dropWhile (e==) l of + [] -> [] + l' -> first : split_on e rest + where + (first,rest) = break (e==) l' + +strip :: String -> String +strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse + +\end{code} diff --git a/src/Darcs/Commands/ShowBug.lhs b/src/Darcs/Commands/ShowBug.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/ShowBug.lhs @@ -0,0 +1,53 @@ +% Copyright (C) 2007 Eric Kow +% +% 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. + +\darcsCommand{show bug} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.ShowBug ( show_bug ) where + +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag, working_repo_dir ) +import Darcs.Repository ( findRepository ) +#include "impossible.h" + +show_bug_description :: String +show_bug_description = "Simulate a run-time failure." + +show_bug_help :: String +show_bug_help = + "Show bug can be used to see what darcs would show you if you encountered.\n" + ++"a bug in darcs.\n" + +show_bug :: DarcsCommand +show_bug = DarcsCommand {command_name = "bug", + command_help = show_bug_help, + command_description = show_bug_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = show_bug_cmd, + command_prereq = findRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [working_repo_dir]} + +show_bug_cmd :: [DarcsFlag] -> [String] -> IO () +show_bug_cmd _ _ = bug "This is actually a fake bug in darcs." +\end{code} diff --git a/src/Darcs/Commands/ShowContents.lhs b/src/Darcs/Commands/ShowContents.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/ShowContents.lhs @@ -0,0 +1,72 @@ +% Copyright (C) 2007 Eric Kow +% +% 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. + +\darcsCommand{show contents} +\begin{code} +module Darcs.Commands.ShowContents ( show_contents ) where + +import Control.Monad ( filterM ) +import System.IO ( stdout ) +import System.FilePath.Posix ( takeFileName ) + +import qualified Data.ByteString as B +import Workaround ( getCurrentDirectory ) + +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag, match_one, + working_repo_dir, fixSubPaths ) +import Darcs.RepoPath ( toFilePath, sp2fn ) +import Darcs.IO ( mReadFilePS, mDoesFileExist ) +import Darcs.Match ( get_partial_nonrange_match, have_nonrange_match ) +import Darcs.Repository ( withRepository, ($-), findRepository, + createPartialsPristineDirectoryTree ) +import Darcs.Lock ( withTempDir ) + +show_contents_description :: String +show_contents_description = "Outputs a specific version of a file." + +show_contents_help :: String +show_contents_help = + "Show contents can be used to display an earlier version of some file(s).\n"++ + "If you give show contents no version arguments, it displays the recorded\n"++ + "version of the file(s).\n" + +show_contents :: DarcsCommand +show_contents = DarcsCommand {command_name = "contents", + command_help = show_contents_help, + command_description = show_contents_description, + command_extra_args = -1, + command_extra_arg_help + = ["[FILE]..."], + command_command = show_contents_cmd, + command_prereq = findRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [match_one, working_repo_dir]} + +show_contents_cmd :: [DarcsFlag] -> [String] -> IO () +show_contents_cmd opts args = withRepository opts $- \repository -> do + formerdir <- getCurrentDirectory + path_list <- map sp2fn `fmap` fixSubPaths opts args + thename <- return $ takeFileName formerdir + withTempDir thename $ \dir -> do + if have_nonrange_match opts + then get_partial_nonrange_match repository opts path_list + else createPartialsPristineDirectoryTree repository path_list (toFilePath dir) + filterM mDoesFileExist path_list >>= mapM_ (\f -> mReadFilePS f >>= B.hPut stdout) +\end{code} diff --git a/src/Darcs/Commands/ShowFiles.lhs b/src/Darcs/Commands/ShowFiles.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/ShowFiles.lhs @@ -0,0 +1,99 @@ +% Copyright (C) 2005 Florian Weimer +% +% 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. + +\darcsCommand{show files} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} +#include "gadts.h" +module Darcs.Commands.ShowFiles ( show_files, show_manifest ) where +import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, + files, directories, pending, nullFlag ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) +import Darcs.Repository ( Repository, amInRepository, slurp_pending, slurp_recorded, + withRepository ) +import Darcs.Patch ( RepoPatch ) +import Darcs.SlurpDirectory ( Slurpy, list_slurpy, list_slurpy_files, list_slurpy_dirs ) + +show_files_description :: String +show_files_description = "Show version-controlled files in the working copy." + +show_files_help :: String +show_files_help = + "The `darcs show files' command lists those files and directories in\n" ++ + "the working tree that are under version control. This command is\n" ++ + "primarily for scripting purposes; end users will probably want `darcs\n" ++ + "whatsnew --summary'.\n" ++ + "\n" ++ + "A file is `pending' if it has been added but not recorded. By\n" ++ + "default, pending files (and directories) are listed; the --no-pending\n" ++ + "option prevents this.\n" ++ + "\n" ++ + "By default `darcs show files' lists both files and directories, but\n" ++ + "the alias `darcs show manifest' only lists files. The --files,\n" ++ + "--directories, --no-files and --no-directories modify this behaviour.\n" ++ + "\n" ++ + "By default entries are one-per-line (i.e. newline separated). This\n" ++ + "can cause problems if the files themselves contain newlines or other\n" ++ + "control characters. To get aroudn this, the --null option uses the\n" ++ + "null character instead. The script interpreting output from this\n" ++ + "command needs to understand this idiom; `xargs -0' is such a command.\n" ++ + "\n" ++ + "For example, to list version-controlled files by size:\n" ++ + "\n" ++ + " darcs show files -0 | xargs -0 ls -ldS\n" + +show_files :: DarcsCommand +show_files = DarcsCommand { + command_name = "files", + command_help = show_files_help, + command_description = show_files_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = manifest_cmd to_list_files, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [files, directories, pending, nullFlag, + working_repo_dir] } + +show_manifest :: DarcsCommand +show_manifest = command_alias "manifest" show_files { + command_command = manifest_cmd to_list_manifest +} + +to_list_files, to_list_manifest :: [DarcsFlag] -> Slurpy -> [FilePath] +to_list_files opts = files_dirs (NoFiles `notElem` opts) (NoDirectories `notElem` opts) +to_list_manifest opts = files_dirs (NoFiles `notElem` opts) (Directories `elem` opts) + +files_dirs :: Bool -> Bool -> Slurpy -> [FilePath] +files_dirs False False = \_ -> [] +files_dirs False True = list_slurpy_dirs +files_dirs True False = list_slurpy_files +files_dirs True True = list_slurpy + +manifest_cmd :: ([DarcsFlag] -> Slurpy -> [FilePath]) -> [DarcsFlag] -> [String] -> IO () +manifest_cmd to_list opts _ = do + list <- (to_list opts) `fmap` withRepository opts slurp + mapM_ output list + where slurp :: RepoPatch p => Repository p C(r u r) -> IO Slurpy + slurp = if NoPending `notElem` opts + then slurp_pending else slurp_recorded + output_null name = do { putStr name ; putChar '\0' } + output = if NullFlag `elem` opts then output_null else putStrLn +\end{code} diff --git a/src/Darcs/Commands/ShowIndex.lhs b/src/Darcs/Commands/ShowIndex.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/ShowIndex.lhs @@ -0,0 +1,94 @@ +% Copyright (C) 2009 Petr Rockai +% +% Permission is hereby granted, free of charge, to any person +% obtaining a copy of this software and associated documentation +% files (the "Software"), to deal in the Software without +% restriction, including without limitation the rights to use, copy, +% modify, merge, publish, distribute, sublicense, and/or sell copies +% of the Software, and to permit persons to whom the Software is +% furnished to do so, subject to the following conditions: +% +% The above copyright notice and this permission notice shall be +% included in all copies or substantial portions of the Software. +% +% THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +% EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +% MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +% NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +% BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +% ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +% CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +% SOFTWARE. + +\darcsCommand{show index} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} +#include "gadts.h" +module Darcs.Commands.ShowIndex ( show_index, show_pristine ) where +import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, + files, directories, nullFlag ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) +import Darcs.Repository ( amInRepository, withRepository, ($-) ) + +import Darcs.Gorsvet( checkIndex, readIndex ) +import Storage.Hashed( readDarcsPristine, floatPath ) +import Storage.Hashed.Darcs( darcsFormatHash ) +import Storage.Hashed.Tree( list, expand, itemHash, TreeItem( SubTree ) ) +import Storage.Hashed.AnchoredPath( anchorPath ) + +import qualified Data.ByteString.Char8 as BS + +show_index :: DarcsCommand +show_index = DarcsCommand { + command_name = "index", + command_description = "Dump contents of working tree index.", + command_help = + "The `darcs show index' command lists all version-controlled files and " ++ + "directories along with their hashes as stored in _darcs/index. " ++ + "For files, the fields correspond to file size, sha256 of the current " ++ + "file content and the filename.", + command_extra_args = 0, + command_extra_arg_help = [], + command_command = show_index_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [files, directories, nullFlag, working_repo_dir] } + +show_pristine :: DarcsCommand +show_pristine = command_alias "pristine" show_index { + command_command = show_pristine_cmd, + command_description = "Dump contents of pristine cache.", + command_help = + "The `darcs show pristine' command lists all version-controlled files " ++ + "and directories along with the hashes of their pristine copies. " ++ + "For files, the fields correspond to file size, sha256 of the pristine " ++ + "file content and the filename." } + +dump opts tree = do + let line | NullFlag `elem` opts = \t -> putStr t >> putChar '\0' + | otherwise = putStrLn + output (p, i) = do + let hash = case itemHash i of + Just h -> BS.unpack $ darcsFormatHash h + Nothing -> "(no hash available)" + path = anchorPath "" p + isdir = case i of + SubTree _ -> "/" + _ -> "" + line $ hash ++ " " ++ path ++ isdir + x <- expand tree + mapM_ output $ (floatPath ".", SubTree x) : list x + +show_index_cmd :: [DarcsFlag] -> [String] -> IO () +show_index_cmd opts _ = withRepository opts $- \repo -> do + checkIndex repo + readIndex >>= dump opts + +show_pristine_cmd :: [DarcsFlag] -> [String] -> IO () +show_pristine_cmd opts _ = withRepository opts $- \repo -> do + readDarcsPristine "." >>= dump opts + +\end{code} diff --git a/src/Darcs/Commands/ShowRepo.lhs b/src/Darcs/Commands/ShowRepo.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/ShowRepo.lhs @@ -0,0 +1,178 @@ +% Copyright (C) 2007 Kevin Quick +% +% 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. + +\darcsCommand{show repo} + +The \verb!show repo! displays information about +the current repository: the location, the type, etc. + +This is provided as informational output for two purposes: curious +users and scripts invoking darcs. For the latter, this information +can be parsed to facilitate the script; for example, +\verb!darcs show repo | grep Root: | awk {print $2}! +can be used to locate the +top-level \verb!_darcs! directory from anyplace within a darcs repository +working directory. + +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} +#include "gadts.h" +module Darcs.Commands.ShowRepo ( show_repo ) where + +import Data.Char ( toLower, isSpace ) +import Data.List ( intersperse ) +import Control.Monad ( when, unless ) +import Text.Html ( tag, stringToHtml ) +import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, files, xmloutput ) +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Repository ( withRepository, ($-), amInRepository, read_repo ) +import Darcs.Repository.Internal ( Repository(..), RepoType(..) ) +import Darcs.Repository.Format ( RepoFormat(..) ) +import Darcs.Repository.Prefs ( get_preflist ) +import Darcs.Repository.Motd ( get_motd ) +import Darcs.Patch ( RepoPatch ) +import Darcs.Ordered ( lengthRL, concatRL ) +import qualified Data.ByteString.Char8 as BC (unpack) + +show_repo_help :: String +show_repo_help = + "The repo command displays information about the current repository\n" ++ + "(location, type, etc.). Some of this information is already available\n" ++ + "by inspecting files within the _darcs directory and some is internal\n" ++ + "information that is informational only (i.e. for developers). This\n" ++ + "command collects all of the repository information into a readily\n" ++ + "available source.\n" + +show_repo_description :: String +show_repo_description = "Show repository summary information" + +show_repo :: DarcsCommand +show_repo = DarcsCommand { command_name = "repo", + command_help = show_repo_help, + command_description = show_repo_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = repo_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [working_repo_dir, files, xmloutput] } +\end{code} + +\begin{options} +--files, --no-files +\end{options} + +If the \verb!--files! option is specified (the default), then the +\verb!show repo! operation will read patch information from the +repository and display the number of patches in the repository. The +\verb!--no-files! option can be used to suppress this operation (and +improve performance). + +\begin{code} +repo_cmd :: [DarcsFlag] -> [String] -> IO () +repo_cmd opts _ = let put_mode = if XMLOutput `elem` opts then showInfoXML else showInfoUsr + in withRepository opts $- \repository -> showRepo (putInfo put_mode) repository +\end{code} + +\begin{options} +--human-readable, --xml-output +\end{options} + +By default, the \verb!show repo! displays output in human readable +form, but the \verb!--xml-output! option can be used to obtain +XML-formatted to facilitate regular parsing by external tools. + +\begin{code} +-- Some convenience functions to output a labelled text string or an +-- XML tag + value (same API). If no value, output is suppressed +-- entirely. Borrow some help from Text.Html to perform XML output. + +type ShowInfo = String -> String -> String + +showInfoXML :: ShowInfo +showInfoXML t i = show $ tag (safeTag t) $ stringToHtml i + +safeTag :: String -> String +safeTag [] = [] +safeTag (' ':cs) = safeTag cs +safeTag ('#':cs) = "num_" ++ (safeTag cs) +safeTag (c:cs) = toLower c : safeTag cs + +-- labelled strings: labels are right-aligned at 14 characters; +-- subsequent lines in multi-line output are indented accordingly. +showInfoUsr :: ShowInfo +showInfoUsr t i = (replicate (14 - length(t)) ' ') ++ t ++ ": " ++ + (concat $ intersperse ('\n' : (replicate 16 ' ')) $ lines i) ++ "\n" + +type PutInfo = String -> String -> IO () +putInfo :: ShowInfo -> PutInfo +putInfo m t i = unless (null i) (putStr $ m t i) + +-- Primary show-repo operation. Determines ordering of output for +-- sub-displays. The `out' argument is one of the above operations to +-- output a labelled text string or an XML tag and contained value. + +showRepo :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO () +showRepo out r@(Repo loc opts rf rt) = do + when (XMLOutput `elem` opts) (putStr "\n") + showRepoType out rt + when (Verbose `elem` opts) (out "Show" $ show r) + showRepoFormat out rf + out "Root" loc + showRepoAux out rt + showRepoPrefs out + unless (NoFiles `elem` opts) (numPatches r >>= (out "Num Patches" . show )) + showRepoMOTD out r + when (XMLOutput `elem` opts) (putStr "\n") + +-- Most of the actual elements being displayed are part of the Show +-- class; that's fine for a Haskeller, but not for the common user, so +-- the routines below work to provide more human-readable information +-- regarding the repository elements. + +showRepoType :: PutInfo -> RepoType p -> IO () +showRepoType out (DarcsRepository _ _) = out "Type" "darcs" + +showRepoFormat :: PutInfo -> RepoFormat -> IO () +showRepoFormat out (RF rf) = out "Format" $ + concat $ intersperse ", " (map (concat . intersperse "|" . map BC.unpack) rf) + +showRepoAux :: PutInfo -> RepoType p -> IO () +showRepoAux out (DarcsRepository pris cs) = + do out "Pristine" $ show pris + out "Cache" $ concat $ intersperse ", " $ lines $ show cs + + +showRepoPrefs :: PutInfo -> IO () +showRepoPrefs out = do + get_preflist "prefs" >>= mapM_ prefOut + get_preflist "author" >>= out "Author" . unlines + get_preflist "defaultrepo" >>= out "Default Remote" . unlines + where prefOut = uncurry out . (\(p,v) -> (p++" Pref", (dropWhile isSpace v))) . break isSpace + +showRepoMOTD :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO () +showRepoMOTD out (Repo loc _ _ _) = get_motd loc >>= out "MOTD" . BC.unpack + +-- Support routines to provide information used by the PutInfo operations above. + +numPatches :: RepoPatch p => Repository p C(r u r) -> IO Int +numPatches r = read_repo r >>= (return . lengthRL . concatRL) + +\end{code} diff --git a/src/Darcs/Commands/ShowTags.lhs b/src/Darcs/Commands/ShowTags.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/ShowTags.lhs @@ -0,0 +1,80 @@ +% Copyright (C) 2007 Florian Weimer +% +% 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. + +\darcsCommand{show tags} +\begin{code} +module Darcs.Commands.ShowTags ( show_tags ) where +import Darcs.Arguments ( DarcsFlag(..), working_repo_dir ) +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Hopefully ( info ) +import Darcs.Repository ( amInRepository, read_repo, withRepository, ($-) ) +import Darcs.Patch.Info ( pi_tag ) +import Darcs.Ordered ( mapRL, concatRL ) +import System.IO ( stderr, hPutStrLn ) +-- import Printer ( renderPS ) + +show_tags_description :: String +show_tags_description = "Show all tags in the repository." + +show_tags_help :: String +show_tags_help = + "The tags command writes a list of all tags in the repository to standard\n"++ + "output.\n" ++ + "\n" ++ + "Tab characters (ASCII character 9) in tag names are changed to spaces\n" ++ + "for better interoperability with shell tools. A warning is printed if\n" ++ + "this happens." + +show_tags :: DarcsCommand +show_tags = DarcsCommand { + command_name = "tags", + command_help = show_tags_help, + command_description = show_tags_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = tags_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [working_repo_dir] } + +tags_cmd :: [DarcsFlag] -> [String] -> IO () +tags_cmd opts _ = withRepository opts $- \repository -> do + patches <- read_repo repository + sequence_ $ mapRL process $ concatRL patches + where process hp = + case pi_tag $ info hp of + Just t -> do + t' <- normalize t t False + putStrLn t' + Nothing -> return () + normalize :: String -> String -> Bool -> IO String + normalize _ [] _ = return [] + normalize t (x : xs) flag = + if x == '\t' then do + if flag + then return () + else hPutStrLn stderr + ("warning: tag with TAB character: " ++ t) + rest <- (normalize t xs True) + return $ ' ' : rest + else do + rest <- (normalize t xs flag) + return $ x : rest + +\end{code} diff --git a/src/Darcs/Commands/Tag.lhs b/src/Darcs/Commands/Tag.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Tag.lhs @@ -0,0 +1,127 @@ +% Copyright (C) 2003-2004 David Roundy +% +% 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. + +\darcsCommand{tag} +\begin{code} +module Darcs.Commands.Tag ( tag ) where +import Control.Monad ( when ) + +import Darcs.Commands ( DarcsCommand(DarcsCommand, command_name, command_help, + command_description, command_extra_args, + command_extra_arg_help, command_command, command_prereq, + command_get_arg_possibilities, command_argdefaults, + command_advanced_options, command_basic_options), + nodefaults ) +import Darcs.Arguments ( nocompress, umask_option, patchname_option, author, + checkpoint, pipe_interactive, ask_long_comment, + working_repo_dir, get_author ) +import Darcs.Hopefully ( n2pia ) +import Darcs.Repository ( amInRepository, withRepoLock, ($-), read_repo, + tentativelyAddPatch, finalizeRepositoryChanges, + ) +import Darcs.Repository.Checkpoint ( write_recorded_checkpoint ) +import Darcs.Patch ( infopatch, identity, adddeps ) +import Darcs.Patch.Info ( patchinfo ) +import Darcs.Patch.Depends ( get_tags_right ) +import Darcs.Commands.Record ( get_date, get_log ) +import Darcs.Ordered ( FL(..) ) +import Darcs.Lock ( world_readable_temp ) +import Darcs.Flags ( DarcsFlag(..) ) +import System.IO ( hPutStr, stderr ) + +tag_description :: String +tag_description = "Name the current repository state for future reference." + +tag_help :: String +tag_help = + "The `darcs tag' command names the current repository state, so that it\n" ++ + "can easily be referred to later. Every `important' state should be\n" ++ + "tagged; in particular it is good practice to tag each stable release\n" ++ + "with a number or codename. Advice on release numbering can be found\n" ++ + "at http://producingoss.com/en/development-cycle.html.\n" ++ + "\n" ++ + "To reproduce the state of a repository `R' as at tag `t', use the\n" ++ + "command `darcs get --tag t R'. The command `darcs show tags' lists\n" ++ + "all tags in the current repository.\n" ++ + "\n" ++ + "Tagging also provides significant performance benefits: when Darcs\n" ++ + "reaches a shared tag that depends on all antecedent patches, it can\n" ++ + "simply stop processing.\n" ++ + "\n" ++ + "Like normal patches, a tag has a name, an author, a timestamp and an\n" ++ + "optional long description, but it does not change the working tree.\n" ++ + "A tag can have any name, but it is generally best to pick a naming\n" ++ + "scheme and stick to it.\n" ++ + "\n" ++ + "The `darcs tag' command accepts the --pipe and --checkpoint options,\n" ++ + "which behave as described in `darcs record' and `darcs optimize'\n" ++ + "respectively.\n" + +tag :: DarcsCommand +tag = DarcsCommand {command_name = "tag", + command_help = tag_help, + command_description = tag_description, + command_extra_args = -1, + command_extra_arg_help = ["[TAGNAME]"], + command_command = tag_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [nocompress,umask_option], + command_basic_options = [patchname_option, author, + checkpoint, + pipe_interactive, + ask_long_comment, + working_repo_dir]} + +tag_cmd :: [DarcsFlag] -> [String] -> IO () +tag_cmd opts args = withRepoLock opts $- \repository -> do + date <- get_date opts + the_author <- get_author opts + deps <- get_tags_right `fmap` read_repo repository + (name, long_comment) <- get_name_log opts args + myinfo <- patchinfo date name the_author long_comment + let mypatch = infopatch myinfo identity + tentativelyAddPatch repository opts $ n2pia $ adddeps mypatch deps + finalizeRepositoryChanges repository + when (CheckPoint `elem` opts) $ write_recorded_checkpoint repository myinfo + putStrLn $ "Finished tagging patch '"++name++"'" + where get_name_log :: [DarcsFlag] -> [String] -> IO (String, [String]) + get_name_log o a = do let o2 = if null a then o else (add_patch_name o (unwords a)) + (name, comment, _) <- get_log o2 Nothing (world_readable_temp "darcs-tag") NilFL + when (length name < 2) $ hPutStr stderr $ + "Do you really want to tag '" + ++name++"'? If not type: darcs obliterate --last=1\n" + return ("TAG " ++ name, comment) + add_patch_name :: [DarcsFlag] -> String -> [DarcsFlag] + add_patch_name o a| has_patch_name o = o + | otherwise = [PatchName a] ++ o + has_patch_name (PatchName _:_) = True + has_patch_name (_:fs) = has_patch_name fs + has_patch_name [] = False + +-- This may be useful for developers, but users don't care about +-- internals: +-- +-- A tagged version automatically depends on all patches in the +-- repository. This allows you to later reproduce precisely that +-- version. The tag does this by depending on all patches in the +-- repository, except for those which are depended upon by other tags +-- already in the repository. In the common case of a sequential +-- series of tags, this means that the tag depends on all patches +-- since the last tag, plus that tag itself. +\end{code} diff --git a/src/Darcs/Commands/TrackDown.lhs b/src/Darcs/Commands/TrackDown.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/TrackDown.lhs @@ -0,0 +1,149 @@ +% Copyright (C) 2002-2005 David Roundy +% +% 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. + +\darcsCommand{trackdown} +\begin{code} +module Darcs.Commands.TrackDown ( trackdown ) where +import Prelude hiding ( init ) +import System.Exit ( ExitCode(..) ) +import System.Cmd ( system ) +import System.IO ( hFlush, stdout ) +import Control.Monad( when ) + +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag(SetScriptsExecutable), working_repo_dir, + set_scripts_executable ) +import Darcs.Hopefully ( hopefully ) +import Darcs.Repository ( amInRepository, read_repo, withRepoReadLock, ($-), withRecorded, + setScriptsExecutable ) +import Darcs.Ordered ( unsafeUnRL, concatRL ) +import Darcs.Patch ( RepoPatch, Named, description, apply, invert ) +import Printer ( putDocLn ) +import Darcs.Test ( get_test ) +import Darcs.Lock ( withTempDir ) + +trackdown_description :: String +trackdown_description = "Locate the most recent version lacking an error." + +trackdown_help :: String +trackdown_help = + "Trackdown tries to find the most recent version in the repository which\n"++ + "passes a test. Given no arguments, it uses the default repository test.\n"++ + "Given one argument, it treats it as a test command. Given two arguments,\n"++ + "the first is an initialization command with is run only once, and the\n"++ + "second is the test command.\n" + +trackdown :: DarcsCommand +trackdown = DarcsCommand {command_name = "trackdown", + command_help = trackdown_help, + command_description = trackdown_description, + command_extra_args = -1, + command_extra_arg_help = ["[[INITIALIZATION]", + "COMMAND]"], + command_command = trackdown_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [set_scripts_executable], + command_basic_options = [working_repo_dir]} + +trackdown_cmd :: [DarcsFlag] -> [String] -> IO () +trackdown_cmd opts args = withRepoReadLock opts $- \repository -> do + patches <- read_repo repository + (init,test) <- case args of + [] -> + do t <- get_test opts + return (return ExitSuccess, t) + [cmd] -> + do putStrLn $ "Tracking down command:\n"++cmd + return $ (return ExitSuccess, system cmd) + [init,cmd] -> + do putStrLn $ "Initializing with command:\n"++init + putStrLn $ "Tracking down command:\n"++cmd + return $ (system init, system cmd) + _ -> fail "Trackdown expects zero to two arguments." + withRecorded repository (withTempDir "trackingdown") $ \_ -> do + when (SetScriptsExecutable `elem` opts) setScriptsExecutable + init + track_next opts test $ map (invert . hopefully) $ unsafeUnRL $ concatRL patches + +track_next :: RepoPatch p => [DarcsFlag] -> (IO ExitCode) -> [Named p] -> IO () +track_next opts test (p:ps) = do + test_result <- test + if test_result == ExitSuccess + then putStrLn "Success!" + else do apply opts p `catch` \e -> fail ("Bad patch:\n" ++ show e) + putStrLn "Trying without the patch:" + putDocLn $ description $ invert p + hFlush stdout + track_next opts test ps +track_next _ _ [] = putStrLn "Noone passed the test!" +\end{code} + +Trackdown is helpful for locating when something was broken. It creates +a temporary directory with the latest repository content in it and cd to it. +First, and only once, it runs the initialization command if any, +for example +\begin{verbatim} +'autoconf; ./configure >/dev/null' +\end{verbatim} +Then it runs the test command, for example +\begin{verbatim} +'make && cd tests && sh /tmp/test.sh' +\end{verbatim} +While the test command exits with an error return code, darcs +``unapplies'' one patch from the version controlled files to retrieve +an earlier version, and repeats the test command. If the test command +finally succeeds, the name of the hunted down patch is found in the +output before the last test run. + +FIXME: It is +still rather primitive. Currently it just goes back over the history in +reverse order trying each version. I'd like for it to explore different +patch combinations, to try to find the minimum number of patches that you +would need to obliterate in order to make the test succeed. + +FIXME: I also would like to add an interface by which you can tell it which +patches it should consider not including. Without such a feature, the +following command: +\begin{verbatim} +% darcs trackdown 'make && false' +\end{verbatim} +would result in compiling every version in the repository--which is a +rather tedious prospect. + +\subsubsection{Example usage} +If you want to find the last version of darcs that had a FIXME note in the +file Record.lhs, you could run +\begin{verbatim} +% darcs trackdown 'grep FIXME Record.lhs' +\end{verbatim} + +To find the latest version that compiles, you can run +\begin{verbatim} +% darcs trackdown 'autoconf' './configure && make' +\end{verbatim} + +Trackdown can also be used to see how other features of the code changed +with time. For example +\begin{verbatim} +% darcs trackdown 'autoconf; ./configure' \ + "make darcs > /dev/null && cd ~/darcs && time darcs check && false" +\end{verbatim} +would let you see how long `darcs check' takes to run on each previous +version of darcs that will actually compile. The ``\verb!&& false!'' +ensures that trackdown keeps going. diff --git a/src/Darcs/Commands/TransferMode.lhs b/src/Darcs/Commands/TransferMode.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/TransferMode.lhs @@ -0,0 +1,88 @@ +% Copyright (C) 2008 David Roundy +% +% 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. + +\darcsCommand{transfer-mode} +\begin{code} +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP, PatternGuards #-} + +-- The pragma above is only for pattern guards. +module Darcs.Commands.TransferMode ( transfer_mode ) where + +import Prelude hiding ( catch ) +import Control.Exception ( catch ) +import System.IO ( stdout, hFlush ) + +import Darcs.Utils ( withCurrentDirectory, prettyException ) +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag, working_repo_dir ) +import Darcs.Repository ( amInRepository ) +import Progress ( setProgressMode ) +import Darcs.Global ( darcsdir ) + +import qualified Data.ByteString as B (hPut, readFile, length, ByteString) + +transfer_mode_description :: String +transfer_mode_description = "Internal command for efficient ssh transfers." + +transfer_mode_help :: String +transfer_mode_help = + "When pulling from or pushing to a remote repository over ssh, if both\n" ++ + "the local and remote ends have Darcs 2, the `transfer-mode' command\n" ++ + "will be invoked on the remote end. This allows Darcs to intelligently\n" ++ + "transfer information over a single ssh connection.\n" ++ + "\n" ++ + "If either end runs Darcs 1, a separate ssh connection will be created\n" ++ + "for each transfer. As well as being less efficient, this means users\n" ++ + "who do not run ssh-agent will be prompted for the ssh password tens or\n" ++ + "hundreds of times!\n" + +transfer_mode :: DarcsCommand +transfer_mode = DarcsCommand {command_name = "transfer-mode", + command_help = transfer_mode_help, + command_description = transfer_mode_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_get_arg_possibilities = return [], + command_command = transfer_mode_cmd, + command_prereq = amInRepository, + command_argdefaults = nodefaults, + command_advanced_options = [], + command_basic_options = [working_repo_dir]} + +transfer_mode_cmd :: [DarcsFlag] -> [String] -> IO () +transfer_mode_cmd _ _ = do setProgressMode False + putStrLn "Hello user, I am darcs transfer mode" + hFlush stdout + withCurrentDirectory darcsdir $ transfer + +transfer :: IO () +transfer = do 'g':'e':'t':' ':fn <- getLine + x <- readfile fn + case x of + Right c -> do putStrLn $ "got " ++ fn + putStrLn $ show $ B.length c + B.hPut stdout c + hFlush stdout + Left e -> do putStrLn $ "error " ++ fn + putStrLn $ show e + hFlush stdout + transfer + +readfile :: String -> IO (Either String B.ByteString) +readfile fn = (Right `fmap` B.readFile fn) `catch` (\e -> return $ Left (prettyException e)) +\end{code} diff --git a/src/Darcs/Commands/Unrecord.lhs b/src/Darcs/Commands/Unrecord.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Unrecord.lhs @@ -0,0 +1,326 @@ +% Copyright (C) 2002-2005 David Roundy +% +% 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. + +\darcsCommand{unrecord} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Commands.Unrecord ( unrecord, unpull, obliterate, get_last_patches ) where +import Control.Monad ( when ) +import System.Exit ( exitWith, ExitCode( ExitSuccess ) ) + +import Darcs.SlurpDirectory ( wait_a_moment ) +import Darcs.Hopefully ( hopefully ) +import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers, command_alias ) +import Darcs.Arguments ( DarcsFlag( Verbose ), + working_repo_dir, nocompress, definePatches, + match_several_or_last, deps_sel, + ignoretimes, + all_interactive, umask_option, summary + ) +import Darcs.Match ( first_match, match_first_patchset, match_a_patchread ) +import Darcs.Repository ( PatchSet, PatchInfoAnd, withGutsOf, + withRepoLock, ($-), + tentativelyRemovePatches, finalizeRepositoryChanges, + tentativelyAddToPending, + applyToWorking, + get_unrecorded, read_repo, amInRepository, + sync_repo, + ) +import Darcs.Patch ( Patchy, RepoPatch, invert, commutex, effect ) +import Darcs.Ordered ( RL(..), (:<)(..), (:>)(..), (:\/:)(..), (+<+), + mapFL_FL, nullFL, + concatRL, reverseRL, mapRL ) +import Darcs.Patch.Depends ( get_common_and_uncommon ) +import Darcs.SelectChanges ( with_selected_last_changes_reversed ) +import Progress ( debugMessage ) +import Darcs.Sealed ( Sealed(..), FlippedSeal(..), mapFlipped ) +import Darcs.Gorsvet( invalidateIndex ) +#include "gadts.h" + +unrecord_description :: String +unrecord_description = + "Remove recorded patches without changing the working copy." +\end{code} + +Unrecord can be thought of as undo-record. +If a record is followed by an unrecord, everything looks like before +the record; all the previously unrecorded changes are back, and can be +recorded again in a new patch. The unrecorded patch however is actually +removed from your repository, so there is no way to record it again to get +it back.\footnote{The patch file itself is not actually deleted, but its +context is lost, so it cannot be reliably read---your only choice would be +to go in by hand and read its contents.}. + +If you want to remove +the changes from the working copy too (where they otherwise will show +up as unrecorded changes again), you'll also need to \verb!darcs revert!. +To do unrecord and revert in one go, you can use \verb!darcs obliterate!. + +If you don't revert after unrecording, then the changes made by the +unrecorded patches are left in your working tree. If these patches are +actually from another repository, interaction (either pushes or pulls) with +that repository may be massively slowed down, as darcs tries to cope with +the fact that you appear to have made a large number of changes that +conflict with those present in the other repository. So if you really want +to undo the result of a \emph{pull} operation, use obliterate! Unrecord is +primarily intended for when you record a patch, realize it needs just one +more change, but would rather not have a separate patch for just that one +change. + +\newcommand{\pullwarning}[1]{ +\textbf{WARNING:} #1 should not be run when there is a possibility +that another user may be pulling from the same repository. Attempting to do so +may cause repository corruption.} + +\pullwarning{Unrecord} + +\begin{options} +--from-match, --from-patch, --from-tag, --last +\end{options} + +Usually you only want to unrecord the latest changes, +and almost never would you want to unrecord changes before a tag---you +would have to have unrecorded the tag as well to do that. +Therefore, and for efficiency, darcs only prompts you for the latest patches, +after some optimal tag. + +If you do want to unrecord more patches in one go, +there are the \verb!--from! and \verb!--last! options +to set the earliest patch selectable to unrecord. + +\begin{options} +--matches, --patches, --tags, --no-deps +\end{options} + +The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps! +options can be used to select which patches to unrecord, as described in +subsection~\ref{selecting}. + +With these options you can specify +what patch or patches to be prompted for by unrecord. +This is especially useful when you want to unrecord patches with dependencies, +since all the dependent patches (but no others) will be included in the choices. +Or if you use \verb!--no-deps! you won't be asked about patches that can't be +unrecorded due to depending patches. + +Selecting patches can be slow, so darcs cuts the search at the last +optimized tag. Use the \verb!--from! or \verb!--last! options to search +more or fewer patches. + +\begin{code} +unrecord_help :: String +unrecord_help = + "Unrecord does the opposite of record in that it makes the changes from\n"++ + "patches active changes again which you may record or revert later. The\n"++ + "working copy itself will not change.\n"++ + "Beware that you should not use this command if you are going to\n"++ + "re-record the changes in any way and there is a possibility that\n"++ + "another user may have already pulled the patch.\n" + +unrecord :: DarcsCommand +unrecord = DarcsCommand {command_name = "unrecord", + command_help = unrecord_help, + command_description = unrecord_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = unrecord_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [nocompress,umask_option], + command_basic_options = [match_several_or_last, + deps_sel, + all_interactive, + working_repo_dir]} + +unrecord_cmd :: [DarcsFlag] -> [String] -> IO () +unrecord_cmd opts _ = withRepoLock opts $- \repository -> do + let (logMessage,_,_) = loggers opts + allpatches <- read_repo repository + FlippedSeal patches <- return $ if first_match opts + then get_last_patches opts allpatches + else matchingHead opts allpatches + with_selected_last_changes_reversed "unrecord" opts + (reverseRL patches) $ + \ (_ :> to_unrecord) -> do + when (nullFL to_unrecord) $ do logMessage "No patches selected!" + exitWith ExitSuccess + when (Verbose `elem` opts) $ + logMessage "About to write out (potentially) modified patches..." + definePatches to_unrecord + invalidateIndex repository + withGutsOf repository $ do tentativelyRemovePatches repository opts $ + mapFL_FL hopefully to_unrecord + finalizeRepositoryChanges repository + sync_repo repository + logMessage "Finished unrecording." + +get_last_patches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(r) + -> FlippedSeal (RL (PatchInfoAnd p)) C(r) +get_last_patches opts ps = + case match_first_patchset opts ps of + Sealed p1s -> case get_common_and_uncommon (ps,p1s) of + (_,us :\/: _) -> FlippedSeal $ concatRL us + +unpull_description :: String +unpull_description = + "Opposite of pull; unsafe if patch is not in remote repository." + +unpull_help :: String +unpull_help = + "Unpull completely removes recorded patches from your local repository.\n"++ + "The changes will be undone in your working copy and the patches will not be\n"++ + "shown in your changes list anymore.\n"++ + "Beware that if the patches are not still present in another repository you\n"++ + "will lose precious code by unpulling!\n" + +unpull :: DarcsCommand +unpull = (command_alias "unpull" obliterate) + {command_help = unpull_help, + command_description = unpull_description, + command_command = unpull_cmd} + +unpull_cmd :: [DarcsFlag] -> [String] -> IO () +unpull_cmd = generic_obliterate_cmd "unpull" + +\end{code} +\darcsCommand{obliterate} +\begin{code} + +obliterate_description :: String +obliterate_description = + "Delete selected patches from the repository. (UNSAFE!)" + +obliterate_help :: String +obliterate_help = + "Obliterate completely removes recorded patches from your local repository.\n"++ + "The changes will be undone in your working copy and the patches will not be\n"++ + "shown in your changes list anymore.\n"++ + "Beware that you can lose precious code by obliterating!\n" + +\end{code} +Obliterate deletes a patch from the repository \emph{and} removes those +changes from the working directory. It is therefore a \emph{very +dangerous} command. When there are no local changes, obliterate is +equivalent to an unrecord followed by a revert, except that revert can be +unreverted. In the case of tags, obliterate removes the tag itself, not +any other patches. + +Note that unpull was the old name for obliterate. Unpull is still an +hidden alias for obliterate. + +\pullwarning{Obliterate} + +\begin{options} +--from-match, --from-patch, --from-tag, --last +\end{options} + +Usually you only want to obliterate the latest changes, and almost never would +you want to obliterate changes before a tag---you would have to have obliterated +the tag as well to do that. Therefore, and for efficiency, darcs only +prompts you for the latest patches, after some optimal tag. + +If you do want to obliterate more patches in one go, there are the +\verb!--from! and \verb!--last! options to set the earliest patch +selectable to obliterate. + +\begin{options} +--matches, --patches, --tags, --no-deps +\end{options} + +The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps! +options can be used to select which patches to obliterate, as described in +subsection~\ref{selecting}. + +With these options you can specify what patch or patches to be prompted for +by obliterate. This is especially useful when you want to obliterate patches with +dependencies, since all the dependent patches (but no others) will be +included in the choices. Or if you use \verb!--no-deps! you won't be asked +about patches that can't be obliterated due to depending patches. + +Selecting patches can be slow, so darcs cuts the search at the last +optimized tag. Use the \verb!--from! or \verb!--last! options to search +more or fewer patches. + +\begin{code} +obliterate :: DarcsCommand +obliterate = DarcsCommand {command_name = "obliterate", + command_help = obliterate_help, + command_description = obliterate_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = obliterate_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [nocompress,ignoretimes,umask_option], + command_basic_options = [match_several_or_last, + deps_sel, + all_interactive, + working_repo_dir, + summary]} +obliterate_cmd :: [DarcsFlag] -> [String] -> IO () +obliterate_cmd = generic_obliterate_cmd "obliterate" + +-- | generic_obliterate_cmd is the function that executes the "obliterate" and +-- "unpull" commands. +generic_obliterate_cmd :: String -- ^ The name under which the command is invoked (@unpull@ or @obliterate@) + -> [DarcsFlag] -- ^ The flags given on the command line + -> [String] -- ^ Files given on the command line (unused) + -> IO () +generic_obliterate_cmd cmdname opts _ = withRepoLock opts $- \repository -> do + let (logMessage,_,_) = loggers opts + pend <- get_unrecorded repository + allpatches <- read_repo repository + FlippedSeal patches <- return $ if first_match opts + then get_last_patches opts allpatches + else matchingHead opts allpatches + with_selected_last_changes_reversed cmdname opts + (reverseRL patches) $ + \ (_ :> ps) -> + case commutex (pend :< effect ps) of + Nothing -> fail $ "Can't "++ cmdname ++ + " patch without reverting some unrecorded change." + Just (p_after_pending:<_) -> do + when (nullFL ps) $ do logMessage "No patches selected!" + exitWith ExitSuccess + definePatches ps + invalidateIndex repository + withGutsOf repository $ + do tentativelyRemovePatches repository opts (mapFL_FL hopefully ps) + tentativelyAddToPending repository opts $ invert $ effect ps + finalizeRepositoryChanges repository + debugMessage "Waiting a bit for timestamps to differ..." + wait_a_moment + debugMessage "Applying patches to working directory..." + applyToWorking repository opts (invert p_after_pending) `catch` \e -> + fail ("Couldn't undo patch in working dir.\n" ++ show e) + sync_repo repository + logMessage $ "Finished " ++ present_participle cmdname ++ "." + +matchingHead :: Patchy p => [DarcsFlag] -> PatchSet p C(r) -> FlippedSeal (RL (PatchInfoAnd p)) C(r) +matchingHead opts (x:<:_) | or (mapRL (match_a_patchread opts) x) = FlippedSeal x +matchingHead opts (x:<:xs) = (x +<+) `mapFlipped` matchingHead opts xs +matchingHead _ NilRL = FlippedSeal NilRL + +present_participle :: String -> String +present_participle v | last v == 'e' = init v ++ "ing" + | otherwise = v ++ "ing" +\end{code} + diff --git a/src/Darcs/Commands/Unrevert.lhs b/src/Darcs/Commands/Unrevert.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Unrevert.lhs @@ -0,0 +1,136 @@ +% Copyright (C) 2003-2005 David Roundy +% +% 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. + +\darcsCommand{unrevert} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Commands.Unrevert ( unrevert, write_unrevert ) where +import System.Exit ( ExitCode(..), exitWith ) + +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag( Unified, MarkConflicts ), + ignoretimes, working_repo_dir, + all_interactive, umask_option, + ) +import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, ($-), + unrevertUrl, considerMergeToWorking, + tentativelyAddToPending, finalizeRepositoryChanges, + sync_repo, get_unrecorded, + read_repo, amInRepository, + slurp_recorded, + applyToWorking ) +import Darcs.Patch ( RepoPatch, Prim, commutex, namepatch, fromPrims ) +import Darcs.Ordered ( RL(..), FL(..), (:<)(..), (:>)(..), (:\/:)(..), reverseRL, + (+>+) ) +import Darcs.SelectChanges ( with_selected_changes_to_files' ) +import Darcs.SlurpDirectory ( Slurpy ) +import qualified Data.ByteString as B +import Darcs.Lock ( writeDocBinFile, removeFileMayNotExist ) +import Darcs.Patch.Depends ( get_common_and_uncommon ) +import Darcs.Utils ( askUser, catchall ) +import Darcs.Patch.Bundle ( scan_bundle, make_bundle ) +import IsoDate ( getIsoDateTime ) +import Darcs.SignalHandler ( withSignalsBlocked ) +import Progress ( debugMessage ) +import Darcs.Sealed ( Sealed(Sealed) ) +#include "impossible.h" + +unrevert_description :: String +unrevert_description = + "Undo the last revert (may fail if changes after the revert)." + +unrevert_help :: String +unrevert_help = + "Unrevert is a rescue command in case you accidentally reverted\n" ++ + "something you wanted to keep (for example, typing `darcs rev -a'\n" ++ + "instead of `darcs rec -a').\n" ++ + "\n" ++ + "This command may fail if the repository has changed since the revert\n" ++ + "took place. Darcs will ask for confirmation before executing an\n" ++ + "interactive command that will DEFINITELY prevent unreversion.\n" + +unrevert :: DarcsCommand +unrevert = DarcsCommand {command_name = "unrevert", + command_help = unrevert_help, + command_description = unrevert_description, + command_extra_args = 0, + command_extra_arg_help = [], + command_command = unrevert_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = return [], + command_argdefaults = nodefaults, + command_advanced_options = [umask_option], + command_basic_options = [ignoretimes, + all_interactive, + working_repo_dir]} + +unrevert_cmd :: [DarcsFlag] -> [String] -> IO () +unrevert_cmd opts [] = withRepoLock opts $- \repository -> do + us <- read_repo repository + Sealed them <- unrevert_patch_bundle repository + rec <- slurp_recorded repository + unrec <- get_unrecorded repository + case get_common_and_uncommon (us, them) of + (_, (h_us:<:NilRL) :\/: (h_them:<:NilRL)) -> do + Sealed pw <- considerMergeToWorking repository "pull" (MarkConflicts:opts) + (reverseRL h_us) (reverseRL h_them) + with_selected_changes_to_files' "unrevert" opts [] pw $ + \ (p :> skipped) -> do + tentativelyAddToPending repository opts p + withSignalsBlocked $ + do finalizeRepositoryChanges repository + applyToWorking repository opts p `catch` \e -> + fail ("Error applying unrevert to working directory...\n" + ++ show e) + debugMessage "I'm about to write_unrevert." + write_unrevert repository skipped rec (unrec+>+p) + sync_repo repository + debugMessage "Finished unreverting." + _ -> impossible +unrevert_cmd _ _ = impossible + +write_unrevert :: RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> Slurpy -> FL Prim C(r x) -> IO () +write_unrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository +write_unrevert repository ps rec pend = do + case commutex (ps :< pend) of + Nothing -> do really <- askUser "You will not be able to unrevert this operation! Proceed? " + case really of ('y':_) -> return () + _ -> exitWith $ ExitSuccess + write_unrevert repository NilFL rec pend + Just (_ :< p') -> do + rep <- read_repo repository + case get_common_and_uncommon (rep,rep) of + (common,_ :\/: _) -> do + date <- getIsoDateTime + np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p') + writeDocBinFile (unrevertUrl repository) $ + make_bundle [Unified] rec common (np :>: NilFL) + where fromRepoPrims :: RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> p C(r y) + fromRepoPrims _ xs = fromPrims xs + +unrevert_patch_bundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p) +unrevert_patch_bundle repository = do + pf <- B.readFile (unrevertUrl repository) + `catchall` fail "There's nothing to unrevert!" + case scan_bundle pf of + Right ps -> return ps + Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err +\end{code} diff --git a/src/Darcs/Commands/WhatsNew.lhs b/src/Darcs/Commands/WhatsNew.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/WhatsNew.lhs @@ -0,0 +1,160 @@ +% Copyright (C) 2002-2004 David Roundy +% +% 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. + +\darcsCommand{whatsnew} +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Commands.WhatsNew ( whatsnew ) where +import System.Exit ( ExitCode(..), exitWith ) +import Data.List ( sort ) +import Control.Monad ( when ) + +import Darcs.Commands ( DarcsCommand(..), nodefaults ) +import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, lookforadds, + ignoretimes, noskip_boring, + unified, summary, no_cache, + areFileArgs, fixSubPaths, + list_registered_files, + ) +import Darcs.RepoPath ( SubPath, sp2fn ) + +import Darcs.Repository ( Repository, withRepository, ($-), slurp_recorded, + get_unrecorded_no_look_for_adds, + get_unrecorded_in_files, amInRepository ) +import Darcs.Repository.Prefs ( filetype_function ) +import Darcs.Diff ( unsafeDiff ) +import Darcs.Patch ( RepoPatch, Prim, summarize, apply_to_slurpy, is_hunk ) +import Darcs.Patch.Permutations ( partitionRL ) +import Darcs.Patch.Real ( RealPatch, prim2real ) +import Darcs.Patch.FileName ( fn2fp ) +import Darcs.PrintPatch ( printPatch, contextualPrintPatch ) +import Darcs.Ordered ( FL(..), mapFL_FL, reverseRL, reverseFL, (:>)(..), nullFL ) + +import Darcs.Gorsvet( unrecordedChanges, restrictBoring, readRecordedAndPending ) +import Storage.Hashed.Monad( virtualTreeIO, exists ) +import Storage.Hashed( readPlainTree ) +import Storage.Hashed( floatPath ) + +import Printer ( putDocLn, renderString, vcat, text ) +#include "impossible.h" + +whatsnew_description :: String +whatsnew_description = "List unrecorded changes in the working tree." + +whatsnew_help :: String +whatsnew_help = + "The `darcs whatsnew' command lists unrecorded changes to the working\n" ++ + "tree. If you specify a set of files and directories, only unrecorded\n" ++ + "changes to those files and directories are listed.\n" ++ + "\n" ++ + "With the --summary option, the changes are condensed to one line per\n" ++ + "file, with mnemonics to indicate the nature and extent of the change.\n" ++ + "The --look-for-adds option causes candidates for `darcs add' to be\n" ++ + "included in the summary output.\n" ++ + "\n" ++ + "By default, `darcs whatsnew' uses Darcs' internal format for changes.\n" ++ + "To see some context (unchanged lines) around each change, use the\n" ++ + "--unified option. To view changes in conventional `diff' format, use\n" ++ + "the `darcs diff' comand; but note that `darcs whatsnew' is faster.\n" ++ + "\n" ++ + "This command exits unsuccessfully (returns a non-zero exit status) if\n" ++ + "there are no unrecorded changes.\n" + +whatsnew :: DarcsCommand +whatsnew = DarcsCommand {command_name = "whatsnew", + command_help = whatsnew_help, + command_description = whatsnew_description, + command_extra_args = -1, + command_extra_arg_help = ["[FILE or DIRECTORY]..."], + command_command = whatsnew_cmd, + command_prereq = amInRepository, + command_get_arg_possibilities = list_registered_files, + command_argdefaults = nodefaults, + command_advanced_options = [ignoretimes, noskip_boring, no_cache], + command_basic_options = [summary, unified, + lookforadds, + working_repo_dir]} + +announce_files :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO () +announce_files repo files = + when (areFileArgs files) $ do + nonboring <- restrictBoring + working <- nonboring `fmap` readPlainTree "." + pristine <- readRecordedAndPending repo + let paths = map (fn2fp . sp2fn) files + check = virtualTreeIO (mapM exists $ map floatPath paths) + (in_working, _) <- check working + (in_pending, _) <- check pristine + mapM_ maybe_warn $ zip3 paths in_working in_pending + putStrLn $ "What's new in "++unwords (map show files)++":\n" + where maybe_warn (file, False, False) = + putStrLn $ "WARNING: File '"++file++"' does not exist!" + maybe_warn (file, True, False) = + putStrLn $ "WARNING: File '" ++ file ++ "' not in repository!" + maybe_warn _ = return () + +whatsnew_cmd :: [DarcsFlag] -> [String] -> IO () +whatsnew_cmd opts' args + | LookForAdds `elem` opts' && NoSummary `notElem` opts' = + -- add Summary to the opts since 'darcs whatsnew --look-for-adds' + -- implies summary + withRepository (Summary:opts') $- \repository -> do + files <- fixSubPaths opts' args + announce_files repository files + all_changes <- get_unrecorded_in_files repository (map sp2fn files) + chold <- get_unrecorded_no_look_for_adds repository (map sp2fn files) + s <- slurp_recorded repository + ftf <- filetype_function + cho_adds :> _ <- return $ partitionRL is_hunk $ reverseFL chold + cha :> _ <- return $ partitionRL is_hunk $ reverseFL all_changes + let chn = unsafeDiff [LookForAdds,Summary] ftf + (fromJust $ apply_to_slurpy (reverseRL cho_adds) s) + (fromJust $ apply_to_slurpy (reverseRL cha) s) + exitOnNoChanges (chn, chold) + putDocLn $ summarize chold + printSummary chn + where lower_as x = vcat $ map (text . l_as) $ lines x + l_as ('A':x) = 'a':x + l_as x = x + exitOnNoChanges :: (FL Prim C(x y), FL p C(u v)) -> IO () + exitOnNoChanges (NilFL, NilFL) = do putStrLn "No changes!" + exitWith $ ExitFailure 1 + exitOnNoChanges _ = return () + printSummary :: FL Prim C(x y) -> IO () + printSummary NilFL = return () + printSummary new = putDocLn $ lower_as $ renderString $ summarize new + +whatsnew_cmd opts args + | otherwise = + withRepository opts $- \repository -> do + files <- sort `fmap` fixSubPaths opts args + announce_files repository files + changes <- unrecordedChanges opts repository files + when (nullFL changes) $ putStrLn "No changes!" >> (exitWith $ ExitFailure 1) + printSummary repository $ mapFL_FL prim2real changes + where printSummary :: RepoPatch p => Repository p C(r u t) -> FL RealPatch C(r y) -> IO () + printSummary _ NilFL = do putStrLn "No changes!" + exitWith $ ExitFailure 1 + printSummary r ch | Summary `elem` opts = putDocLn $ summarize ch + | Unified `elem` opts = do s <- slurp_recorded r + contextualPrintPatch s ch + | otherwise = printPatch ch +\end{code} diff --git a/src/Darcs/CommandsAux.hs b/src/Darcs/CommandsAux.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/CommandsAux.hs @@ -0,0 +1,112 @@ +-- Copyright (C) 2006 Tommy Pettersson +-- +-- 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. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.CommandsAux ( check_paths, malicious_patches, has_malicious_path, + ) where +import Darcs.Flags ( DarcsFlag( RestrictPaths, DontRestrictPaths ) ) +import Darcs.Patch ( Patchy, list_touched_files ) +import Darcs.Ordered ( FL, mapFL ) +import Darcs.Sealed ( Sealed2(..), unseal2 ) +import Darcs.Global ( darcsdir ) +import Data.List ( intersect ) +import System.FilePath ( splitDirectories ) + +-- * File paths +{- + Darcs will operate on files and directories with the invoking user's + privileges. The paths for these files and directories are stored in + patches, which darcs receives in various ways. Even though darcs will not + create patches with "unexpected" file paths, there are no such guarantees + for received patches. A spoofed patch could inflict changes on any file + or directory which the invoking user is privileged to modify. + + There is no one single "apply" function that can check paths, so each + command is responsible for not applying patches without first checking + them with one of these function when appropriate. +-} + +{- | + A convenience function to call from all darcs command functions before + applying any patches. It checks for malicious paths in patches, and + prints an error message and fails if it finds one. +-} +check_paths :: Patchy p => [DarcsFlag] -> FL p C(x y) -> IO () +check_paths opts patches + = if check_is_on && or (mapFL has_malicious_path patches) + then fail $ unlines $ ["Malicious path in patch:"] ++ + (map (\s -> " " ++ s) $ concat $ mapFL malicious_paths patches) ++ + ["", "If you are sure this is ok then you can run again with the --dont-restrict-paths option."] + -- TODO: print patch(es) + -- NOTE: should use safe Doc printer, this can be evil chars + else return () + where + check_is_on = DontRestrictPaths `notElem` opts || + RestrictPaths `elem` opts + +-- | Filter out patches that contains some malicious file path +malicious_patches :: Patchy p => [Sealed2 p] -> [Sealed2 p] +malicious_patches to_check = filter (unseal2 has_malicious_path) to_check + +has_malicious_path :: Patchy p => p C(x y) -> Bool +has_malicious_path patch = + case malicious_paths patch of + [] -> False + _ -> True + +malicious_paths :: Patchy p => p C(x y) -> [String] +malicious_paths patch = + let paths = list_touched_files patch in + filter is_malicious_path paths + +{-| + What is a malicious path? + + A spoofed path is a malicious path. + + 1. Darcs only creates explicitly relative paths (beginning with @\".\/\"@), + so any not explicitly relative path is surely spoofed. + + 2. Darcs normalizes paths so they never contain @\"\/..\/\"@, so paths with + @\"\/..\/\"@ are surely spoofed. + + A path to a darcs repository's meta data can modify \"trusted\" patches or + change safety defaults in that repository, so we check for paths + containing @\"\/_darcs\/\"@ which is the entry to darcs meta data. + + To do? + + * How about get repositories? + + * Would it be worth adding a --semi-safe-paths option for allowing + changes to certain preference files (_darcs\/prefs\/) in sub + repositories'? +-} +is_malicious_path :: String -> Bool +is_malicious_path fp = + not (is_explicitly_relative fp) || + splitDirectories fp `contains_any` [ "..", darcsdir ] + where + contains_any a b = not . null $ intersect a b + +is_explicitly_relative :: String -> Bool +is_explicitly_relative ('.':'/':_) = True -- begins with "./" +is_explicitly_relative _ = False diff --git a/src/Darcs/Compat.hs b/src/Darcs/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Compat.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +module Darcs.Compat (stdout_is_a_pipe, mk_stdout_temp, canonFilename, + maybeRelink, atomic_create, sloppy_atomic_create) where + +import Prelude hiding ( catch ) + +import Darcs.Utils ( withCurrentDirectory ) +#ifdef WIN32 +import Darcs.Utils ( showHexLen ) +import Data.Bits ( (.&.) ) +import System.Random ( randomIO ) +#else +import Foreign.C.String ( peekCString ) +#endif + +import Control.Monad ( unless ) +import Foreign.C.Types ( CInt ) +import Foreign.C.String ( CString, withCString ) +import Foreign.C.Error ( throwErrno, eEXIST, getErrno ) +import System.Directory ( getCurrentDirectory ) +import System.IO ( hFlush, stdout, stderr, hSetBuffering, + BufferMode(NoBuffering) ) +import System.IO.Error ( mkIOError, alreadyExistsErrorType ) +import System.Posix.Files ( stdFileMode ) +import System.Posix.IO ( openFd, closeFd, stdOutput, stdError, + dupTo, defaultFileFlags, exclusive, + OpenMode(WriteOnly) ) +import System.Posix.Types ( Fd(..) ) + +import Darcs.SignalHandler ( stdout_is_a_pipe ) + +canonFilename :: FilePath -> IO FilePath +canonFilename f@(_:':':_) = return f -- absolute windows paths +canonFilename f@('/':_) = return f +canonFilename ('.':'/':f) = do cd <- getCurrentDirectory + return $ cd ++ "/" ++ f +canonFilename f = case reverse $ dropWhile (/='/') $ reverse f of + "" -> fmap (++('/':f)) getCurrentDirectory + rd -> withCurrentDirectory rd $ + do fd <- getCurrentDirectory + return $ fd ++ "/" ++ simplefilename + where + simplefilename = reverse $ takeWhile (/='/') $ reverse f + +#ifdef WIN32 +mkstemp_core :: FilePath -> IO (Fd, String) +mkstemp_core fp + = do r <- randomIO + let fp' = fp ++ (showHexLen 6 (r .&. 0xFFFFFF :: Int)) + fd <- openFd fp' WriteOnly (Just stdFileMode) flags + return (fd, fp') + where flags = defaultFileFlags { exclusive = True } +#else +mkstemp_core :: String -> IO (Fd, String) +mkstemp_core str = withCString (str++"XXXXXX") $ + \cstr -> do fd <- c_mkstemp cstr + if fd < 0 + then throwErrno $ "Failed to create temporary file "++str + else do str' <- peekCString cstr + fname <- canonFilename str' + return (Fd fd, fname) + +foreign import ccall unsafe "static stdlib.h mkstemp" + c_mkstemp :: CString -> IO CInt +#endif + +mk_stdout_temp :: String -> IO String +mk_stdout_temp str = do (fd, fn) <- mkstemp_core str + hFlush stdout + hFlush stderr + dupTo fd stdOutput + dupTo fd stdError + hFlush stdout + hFlush stderr + hSetBuffering stdout NoBuffering + hSetBuffering stderr NoBuffering + return fn + + + +foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink + :: CString -> CString -> CInt -> IO CInt + +-- Checks whether src and dst are identical. If so, makes dst into a +-- link to src. Returns True if dst is a link to src (either because +-- we linked it or it already was). Safe against changes to src if +-- they are not in place, but not to dst. +maybeRelink :: String -> String -> IO Bool +maybeRelink src dst = + withCString src $ \csrc -> + withCString dst $ \cdst -> + do rc <- maybe_relink csrc cdst 1 + (case rc of + 0 -> return True + 1 -> return True + -1 -> throwErrno ("Relinking " ++ dst) + -2 -> return False + -3 -> do putStrLn ("Relinking: race condition avoided on file " ++ + dst) + return False + _ -> fail ("Unexpected situation when relinking " ++ dst)) + +sloppy_atomic_create :: FilePath -> IO () +sloppy_atomic_create fp + = do fd <- openFd fp WriteOnly (Just stdFileMode) flags + closeFd fd + where flags = defaultFileFlags { exclusive = True } + +atomic_create :: FilePath -> IO () +atomic_create fp = withCString fp $ \cstr -> do + rc <- c_atomic_create cstr + unless (rc >= 0) $ + do errno <- getErrno + pwd <- getCurrentDirectory + if errno == eEXIST + then ioError $ mkIOError alreadyExistsErrorType + ("atomic_create in "++pwd) + Nothing (Just fp) + else throwErrno $ "atomic_create "++fp++" in "++pwd + +foreign import ccall unsafe "atomic_create.h atomic_create" c_atomic_create + :: CString -> IO CInt diff --git a/src/Darcs/Diff.hs b/src/Darcs/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Diff.hs @@ -0,0 +1,375 @@ +-- Copyright (C) 2002-2003 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Diff ( unsafeDiffAtPaths, unsafeDiff, sync, cmp +#ifndef GADT_WITNESSES + , diff_files +#endif + ) where + +import System.Posix + ( setFileTimes ) +import System.IO ( IOMode(ReadMode), hFileSize, hClose ) +import System.Directory ( doesDirectoryExist, doesFileExist, + getDirectoryContents, + ) +import Control.Monad ( when ) +import Data.List ( sort +#ifndef GADT_WITNESSES + , intersperse, isPrefixOf +#endif + ) +#ifndef GADT_WITNESSES +import Data.Maybe ( catMaybes ) +#endif + +#ifndef GADT_WITNESSES +import ByteStringUtils ( is_funky, linesPS) +import qualified Data.ByteString.Char8 as BC (last) +import qualified Data.ByteString as B (null, empty, take, ByteString) +#endif +import qualified Data.ByteString as B (hGet, length) + +import Darcs.SlurpDirectory ( Slurpy, slurp_name, is_dir, is_file, +#ifndef GADT_WITNESSES + get_slurp, +#endif + get_dircontents, get_filecontents, + get_mtime, get_length, + undefined_time +#ifndef GADT_WITNESSES + , FileContents, undefined_size +#endif + ) +#ifndef GADT_WITNESSES +import System.FilePath.Posix ( () ) +#endif +import Darcs.Patch ( Prim +#ifndef GADT_WITNESSES + , hunk, canonize, rmfile, rmdir + , addfile, adddir + , binary, invert +#endif + ) +#ifndef GADT_WITNESSES +import Darcs.Patch.FileName( fp2fn, breakup ) +#endif +import System.IO ( openBinaryFile ) +import Darcs.Repository.Prefs ( FileType(..) ) +import Darcs.Flags ( DarcsFlag(..) ) +import Darcs.Utils ( catchall ) +import Darcs.Ordered ( FL(..) +#ifndef GADT_WITNESSES + , (+>+) +#endif + ) +#ifndef GADT_WITNESSES +#include "impossible.h" +#endif + +-- | The unsafeDiffAtPaths function calls diff_at_path for a set of files and +-- and directories, and returns all changes to those files. It recurses into +-- given directories when searching for changes. +-- +-- Comparing paths and not slurpies is useful when the user +-- requests a diff for a file that is created or removed in the working copy: +-- then there is no slurpy for the file in the /current/ or /working/ slurpy +-- respectively. +-- +-- The given paths must always be fixed repository paths starting with a +-- ".". It is safe to pass overlapping paths. +-- +-- The booleans in the first argument tell whether to ignore mtimes, whether +-- we must look for additions and if we're diffing for a summary only. +-- +-- It returns an FL of patches, that contains all the changes that have been +-- made at all those paths. +unsafeDiffAtPaths :: (Bool, Bool, Bool) -> (FilePath -> FileType) -> + Slurpy -> Slurpy -> [FilePath] -> FL Prim C(x y) +#ifdef GADT_WITNESSES +unsafeDiffAtPaths = undefined +#else +unsafeDiffAtPaths flags filetypeFunction s1 s2 paths = + foldr (+>+) NilFL (catMaybes diffsPerPath) + where diffsPerPath = map differ safePaths + differ = diff_at_path flags filetypeFunction s1 s2 + safePaths = make_nonoverlapping_path_set paths + +diff_at_path :: (Bool, Bool, Bool) -> (FilePath -> FileType) + -> Slurpy -> Slurpy -> FilePath -> Maybe (FL Prim) +diff_at_path (ignoreTimes, lookForAdds, summary) filetypeFunction s1 s2 path = + case (pathIn1, pathIn2) of + (Nothing, Nothing) -> Nothing + (Nothing, Just s2PathSlurpy) -> do + Just $ diff_added summary filetypeFunction initialFps s2PathSlurpy NilFL + (Just s1PathSlurpy, Nothing) -> do + Just $ diff_removed filetypeFunction initialFps s1PathSlurpy NilFL + (Just s1PathSlurpy, Just s2PathSlurpy) -> + Just $ gendiff (ignoreTimes, lookForAdds, summary) filetypeFunction + initialFps s1PathSlurpy s2PathSlurpy NilFL + where pathIn1 = get_slurp (fp2fn path) s1 + pathIn2 = get_slurp (fp2fn path) s2 + initialFps = tail $ reverse (breakup path) + +make_nonoverlapping_path_set :: [FilePath] -> [FilePath] +make_nonoverlapping_path_set = map unbreakup . delete_overlapping . map breakup . sort + where + delete_overlapping :: [[FilePath]] -> [[FilePath]] + delete_overlapping (p1:p2:ps) = if p1 `isPrefixOf` p2 + then delete_overlapping (p1:ps) + else p1 : delete_overlapping (p2:ps) + delete_overlapping ps = ps + unbreakup = concat . intersperse "/" +#endif + +-- The diff function takes a recursive diff of two slurped-up directory trees. +-- The code involved is actually pretty trivial. \verb!paranoid_diff! runs a +-- diff in which we don't make the assumption that files with the same +-- modification time are identical. + +unsafeDiff :: [DarcsFlag] + -> (FilePath -> FileType) -> Slurpy -> Slurpy -> FL Prim C(x y) +#ifdef GADT_WITNESSES +unsafeDiff = undefined +#else +unsafeDiff opts wt s1 s2 + = case diff_at_path (ignoreTimes, lookForAdds, summary) wt s1 s2 "" of + Just d -> d + _ -> impossible -- because "" always exists in a slurpy + where -- NoSummary/Summary both present gives False + -- Just Summary gives True + -- Just NoSummary gives False + -- Neither gives False + summary = Summary `elem` opts && NoSummary `notElem` opts + lookForAdds = LookForAdds `elem` opts + ignoreTimes = IgnoreTimes `elem` opts + +mk_filepath :: [FilePath] -> FilePath +mk_filepath fps = concat $ intersperse "/" $ reverse fps + +gendiff :: (Bool,Bool,Bool) + -> (FilePath -> FileType) -> [FilePath] -> Slurpy -> Slurpy + -> (FL Prim -> FL Prim) +gendiff opts@(isparanoid,_,_) wt fps s1 s2 + | is_file s1 && is_file s2 = diff_regular_files isparanoid wt f s1 s2 + | is_dir s1 && is_dir s2 = + let fps' = case n2 of + "." -> fps + _ -> n2:fps + in fps' `seq` recur_diff opts (wt . (n2)) fps' dc1 dc2 + | otherwise = id + where n2 = slurp_name s2 + f = mk_filepath (n2:fps) + dc1 = get_dircontents s1 + dc2 = get_dircontents s2 + +-- recur_diff or recursive diff +-- First parameter is (IgnoreTimes?, LookforAdds?, Summary?) +recur_diff :: (Bool,Bool,Bool) + -> (FilePath -> FileType) -> [FilePath] -> [Slurpy] -> [Slurpy] + -> (FL Prim -> FL Prim) +recur_diff _ _ _ [] [] = id +recur_diff opts@(_,doadd,summary) wt fps (s:ss) (s':ss') + -- this is the case if a file has been removed in the working directory + | s < s' = diff_removed wt fps s . recur_diff opts wt fps ss (s':ss') + -- this next case is when there is a file in the directory that is not + -- in the repository (ie, not managed by darcs) + | s > s' = let rest = recur_diff opts wt fps (s:ss) ss' + in if not doadd then rest + else diff_added summary wt fps s' . rest + -- actually compare the files because the names match + | s == s' = gendiff opts wt fps s s' . recur_diff opts wt fps ss ss' +recur_diff opts wt fps (s:ss) [] = + diff_removed wt fps s . recur_diff opts wt fps ss [] +recur_diff opts@(_,True,summary) wt fps [] (s':ss') = + diff_added summary wt fps s' . recur_diff opts wt fps [] ss' +recur_diff (_,False,_) _ _ [] _ = id +recur_diff _ _ _ _ _ = impossible + +-- diff, taking into account paranoidness and file type, two regular files +diff_regular_files :: Bool -> (FilePath -> FileType) -> FilePath -> Slurpy -> Slurpy -> (FL Prim -> FL Prim) +diff_regular_files ignoreTimes filetypeFunction f s1 s2 = + if maybe_differ + then case filetypeFunction (slurp_name s2) of + TextFile -> diff_files f b1 b2 + BinaryFile -> if b1 /= b2 then (binary f b1 b2:>:) + else id + else id + where maybe_differ = ignoreTimes + || get_mtime s1 == undefined_time + || get_mtime s1 /= get_mtime s2 + || get_length s1 == undefined_size + || get_length s1 /= get_length s2 + b1 = get_filecontents s1 + b2 = get_filecontents s2 + +-- creates a diff for a file or directory which needs to be added to the +-- repository +diff_added :: Bool -> (FilePath -> FileType) -> [FilePath] -> Slurpy + -> (FL Prim -> FL Prim) +diff_added summary wt fps s + | is_file s = case wt n of + TextFile -> (addfile f:>:) . + (if summary + then id + else diff_from_empty id f (get_filecontents s)) + BinaryFile -> (addfile f:>:) . + (if summary then id else + (bin_patch f B.empty (get_filecontents s))) + | otherwise {- is_dir s -} = + (adddir f:>:) + . foldr (.) id (map (diff_added summary wt (n:fps)) (get_dircontents s)) + where n = slurp_name s + f = mk_filepath (n:fps) + +get_text :: FileContents -> [B.ByteString] +get_text = linesPS + +empt :: FileContents +empt = B.empty + +diff_files :: FilePath -> FileContents -> FileContents + -> (FL Prim -> FL Prim) +diff_files f o n | get_text o == [B.empty] && get_text n == [B.empty] = id + | get_text o == [B.empty] = diff_from_empty id f n + | get_text n == [B.empty] = diff_from_empty invert f o +diff_files f o n = if o == n + then id + else if has_bin o || has_bin n + then (binary f o n:>:) + else (canonize (hunk f 1 (linesPS o) (linesPS n)) +>+) + +diff_from_empty :: (Prim -> Prim) -> FilePath -> FileContents + -> (FL Prim -> FL Prim) +diff_from_empty inv f b = + if b == B.empty + then id + else let p = if has_bin b + then binary f B.empty b + else if BC.last b == '\n' + then hunk f 1 [] $ init $ linesPS b + else hunk f 1 [B.empty] $ linesPS b + in (inv p:>:) + +{- | We take a B.ByteString which represents a file's contents, and we check to see +whether it is a 'binary' file or a 'textual' file. We define a textual file as any file +which does not contain two magic characters, '\0' (the NULL character on Unix) and '^Z' +(Control-Z, a DOS convention). + +Note that to improve performance, we won't examine *all* of the string, because that +falls down on large files, but just the first 4096 characters. -} +has_bin :: FileContents -> Bool +has_bin = is_funky . B.take 4096 +#endif + +#ifndef GADT_WITNESSES +bin_patch :: FilePath -> B.ByteString -> B.ByteString + -> FL Prim -> FL Prim +bin_patch f o n | B.null o && B.null n = id + | otherwise = (binary f o n:>:) +#endif + +#ifndef GADT_WITNESSES +diff_removed :: (FilePath -> FileType) -> [FilePath] -> Slurpy + -> (FL Prim -> FL Prim) +diff_removed wt fps s + | is_file s = case wt n of + TextFile -> diff_files f (get_filecontents s) empt + . (rmfile f:>:) + BinaryFile -> (bin_patch f + (get_filecontents s) B.empty) + . (rmfile f:>:) + | otherwise {- is_dir s -} + = foldr (.) (rmdir f:>:) + $ map (diff_removed wt (n:fps)) (get_dircontents s) + where n = slurp_name s + f = mk_filepath (n:fps) +#endif + +sync :: String -> Slurpy -> Slurpy -> IO () +sync path s1 s2 + | is_file s1 && is_file s2 && + (get_mtime s1 == undefined_time || get_mtime s1 /= get_mtime s2) && + get_length s1 == get_length s2 && + get_filecontents s1 == get_filecontents s2 = + set_mtime n (get_mtime s2) + | is_dir s1 && is_dir s2 + = n2 `seq` recur_sync n (get_dircontents s1) (get_dircontents s2) + | otherwise = return () + where n2 = slurp_name s2 + n = path++"/"++n2 + set_mtime fname ctime = setFileTimes fname ctime ctime + `catchall` return () + recur_sync _ [] _ = return () + recur_sync _ _ [] = return () + recur_sync p (s:ss) (s':ss') + | s < s' = recur_sync p ss (s':ss') + | s > s' = recur_sync p (s:ss) ss' + | otherwise = do sync p s s' + recur_sync p ss ss' + + +cmp :: FilePath -> FilePath -> IO Bool +cmp p1 p2 = do + dir1 <- doesDirectoryExist p1 + dir2 <- doesDirectoryExist p2 + file1 <- doesFileExist p1 + file2 <- doesFileExist p2 + if dir1 && dir2 + then cmpdir p1 p2 + else if file1 && file2 + then cmpfile p1 p2 + else return False +cmpdir :: FilePath -> FilePath -> IO Bool +cmpdir d1 d2 = do + fn1 <- fmap (filter (\f->f/="." && f /="..")) $ getDirectoryContents d1 + fn2 <- fmap (filter (\f->f/="." && f /="..")) $ getDirectoryContents d2 + if sort fn1 /= sort fn2 + then return False + else andIO $ map (\fn-> cmp (d1++"/"++fn) (d2++"/"++fn)) fn1 +andIO :: [IO Bool] -> IO Bool +andIO (iob:iobs) = do b <- iob + if b then andIO iobs else return False +andIO [] = return True +cmpfile :: FilePath -> FilePath -> IO Bool +cmpfile f1 f2 = do + h1 <- openBinaryFile f1 ReadMode + h2 <- openBinaryFile f2 ReadMode + l1 <- hFileSize h1 + l2 <- hFileSize h2 + if l1 /= l2 + then do hClose h1 + hClose h2 + putStrLn $ "different file lengths for "++f1++" and "++f2 + return False + else do b <- hcmp h1 h2 + when (not b) $ putStrLn $ "files "++f1++" and "++f2++" differ" + hClose h1 + hClose h2 + return b + where hcmp h1 h2 = do c1 <- B.hGet h1 1024 + c2 <- B.hGet h2 1024 + if c1 /= c2 + then return False + else if B.length c1 == 1024 + then hcmp h1 h2 + else return True diff --git a/src/Darcs/Email.hs b/src/Darcs/Email.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Email.hs @@ -0,0 +1,234 @@ +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} +module Darcs.Email ( make_email, read_email, formatHeader ) where + +import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper ) +import Data.List ( isInfixOf ) +import qualified UTF8 ( encode ) +import Printer ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS) + +import ByteStringUtils (dropSpace, linesPS, betweenLinesPS ) +import qualified Data.ByteString as B (ByteString, length, null, tail + ,drop, head, concat, singleton + ,pack, append, empty + ) +import qualified Data.ByteString.Char8 as BC (index, head, pack) +import Data.ByteString.Internal as B (c2w, createAndTrim) +import System.IO.Unsafe ( unsafePerformIO ) +import Foreign.Ptr ( Ptr, plusPtr ) +import Foreign.Storable ( poke ) +import Data.Word ( Word8 ) + +-- line_max is maximum number of characters in an e-mail line excluding the CRLF +-- at the end. qline_max is the number of characters in a q-encoded or +-- quoted-printable-encoded line. +line_max, qline_max :: Int +line_max = 78 +qline_max = 75 + +-- | Formats an e-mail header by encoding any non-ascii characters using UTF-8 +-- and Q-encoding, and folding lines at appropriate points. It doesn't do +-- more than that, so the header name and header value should be +-- well-formatted give or take line length and encoding. So no non-ASCII +-- characters within quoted-string, quoted-pair, or atom; no semantically +-- meaningful signs in names; no non-ASCII characters in the header name; +-- etcetera. +formatHeader :: String -> String -> B.ByteString +formatHeader headerName headerValue = + B.append nameColon encodedValue + where nameColon = B.pack (map B.c2w (headerName ++ ":")) -- space for folding + encodedValue = fold_and_encode (' ':headerValue) + (B.length nameColon) False False + +-- run through a string and encode non-ascii words and fold where appropriate. +-- the integer argument is the current position in the current line. +-- the string in the first argument must begin with whitespace, or be empty. +fold_and_encode :: String -> Int -> Bool -> Bool -> B.ByteString +fold_and_encode [] _ _ _ = B.empty +fold_and_encode s p lastWordEncoded inMidWord = + let newline = B.singleton 10 + space = B.singleton 32 + s2bs = B.pack . map B.c2w + -- the twelve there is the max number of ASCII chars to encode a single + -- character: 4 * 3, 4 UTF-8 bytes times 3 ASCII chars per byte + safeEncChunkLength = (qline_max - B.length encoded_word_start + - B.length encoded_word_end) `div` 12 + (curSpace, afterCurSpace) = break (not . (== ' ')) s + (curWord, afterCurWord) = break (== ' ') afterCurSpace + qEncWord | lastWordEncoded = qEncode (curSpace ++ curWord) + | otherwise = qEncode curWord + mustEncode = inMidWord + || any (\c -> not (isPrint c) || (ord c) > 127) curWord + || length curWord > line_max - 1 + || isInfixOf "=?" curWord + mustFold + | mustEncode && lastWordEncoded + = p + 1 + B.length qEncWord > line_max + | mustEncode + = p + length curSpace + B.length qEncWord > line_max + | otherwise + = p + length curSpace + length curWord > line_max + mustSplit = (B.length qEncWord > qline_max && mustEncode) + || length curWord > line_max - 1 + spaceToInsert | mustEncode && lastWordEncoded = space + | otherwise = s2bs curSpace + wordToInsert + | mustEncode && mustSplit = qEncode (take safeEncChunkLength curWord) + | mustEncode = qEncWord + | otherwise = s2bs curWord + doneChunk | mustFold = B.concat [newline, spaceToInsert, wordToInsert] + | otherwise = B.concat [spaceToInsert, wordToInsert] + (rest, nextP) + | mustSplit + = (drop safeEncChunkLength curWord ++ afterCurWord, qline_max + 1) + | mustEncode && mustFold + = (afterCurWord, B.length spaceToInsert + B.length wordToInsert) + | otherwise + = (afterCurWord, p + B.length doneChunk) + in B.append doneChunk (fold_and_encode rest nextP mustEncode mustSplit) + +-- | Turns a piece of string into a q-encoded block +-- Applies q-encoding, for use in e-mail header values, as defined in RFC 2047. +-- It just takes a string and builds an encoded-word from it, it does not check +-- length or necessity. +qEncode :: String -> B.ByteString +qEncode s = B.concat [encoded_word_start, + encodedString, + encoded_word_end] + where encodedString = B.concat (map q_encode_char s) + +encoded_word_start, encoded_word_end :: B.ByteString +encoded_word_start = B.pack (map B.c2w "=?UTF-8?Q?") +encoded_word_end = B.pack (map B.c2w "?=") + +-- turns a character into its q-encoded bytestring value. For most printable +-- ASCII characters, that's just the singleton bytestring with that char. +q_encode_char :: Char -> B.ByteString +q_encode_char c + | c == ' ' = c2bs '_' + | isPrint c + && not (c `elem` ['?', '=', '_']) + && ord c < 128 = c2bs c + | otherwise = B.concat (map qbyte (UTF8.encode [c])) + where c2bs = B.singleton . B.c2w + -- qbyte turns a byte into its q-encoded "=hh" representation + qbyte b = B.pack (map B.c2w ['=' + ,word8ToUDigit (b `div` 16) + ,word8ToUDigit (b `mod` 16) + ]) + word8ToUDigit :: Word8 -> Char + word8ToUDigit = toUpper . intToDigit . fromIntegral + +-- TODO is this doing mime encoding?? +qpencode :: B.ByteString -> B.ByteString +qpencode s = unsafePerformIO + -- Really only (3 + 2/75) * length or something in the worst case + $ B.createAndTrim (4 * B.length s) (\buf -> encode s qline_max buf 0) + +encode :: B.ByteString -> Int -> Ptr Word8 -> Int -> IO Int +encode ps _ _ bufi | B.null ps = return bufi +encode ps n buf bufi = case B.head ps of + c | c == newline -> + do poke (buf `plusPtr` bufi) newline + encode ps' qline_max buf (bufi+1) + | n == 0 && B.length ps > 1 -> + do poke (buf `plusPtr` bufi) equals + poke (buf `plusPtr` (bufi+1)) newline + encode ps qline_max buf (bufi + 2) + | (c == tab || c == space) -> + if B.null ps' || B.head ps' == newline + then do poke (buf `plusPtr` bufi) c + poke (buf `plusPtr` (bufi+1)) equals + poke (buf `plusPtr` (bufi+2)) newline + encode ps' qline_max buf (bufi + 3) + else do poke (buf `plusPtr` bufi) c + encode ps' (n - 1) buf (bufi + 1) + | (c >= bang && c /= equals && c <= tilde) -> + do poke (buf `plusPtr` bufi) c + encode ps' (n - 1) buf (bufi + 1) + | n < 3 -> + encode ps 0 buf bufi + | otherwise -> + do let (x, y) = c `divMod` 16 + h1 = intToUDigit x + h2 = intToUDigit y + poke (buf `plusPtr` bufi) equals + poke (buf `plusPtr` (bufi+1)) h1 + poke (buf `plusPtr` (bufi+2)) h2 + encode ps' (n - 3) buf (bufi + 3) + where ps' = B.tail ps + newline = B.c2w '\n' + tab = B.c2w '\t' + space = B.c2w ' ' + bang = B.c2w '!' + tilde = B.c2w '~' + equals = B.c2w '=' + intToUDigit i + | i >= 0 && i <= 9 = B.c2w '0' + i + | i >= 10 && i <= 15 = B.c2w 'A' + i - 10 + | otherwise = error $ "intToUDigit: '"++show i++"'not a digit" + +qpdecode :: B.ByteString -> B.ByteString +qpdecode s = unsafePerformIO + -- Add 1 as linesPS "\n" -> ["", ""] -> "\n\n" + $ B.createAndTrim (B.length s + 1) (\buf -> decode (linesPS s) buf 0) + +decode :: [B.ByteString] -> Ptr Word8 -> Int -> IO Int +decode [] _ bufi = return bufi +decode (ps:pss) buf bufi + | B.null (dropSpace ps) + = do poke (buf `plusPtr` bufi) newline + decode pss buf (bufi+1) + | is_equals && B.length ps >= 3 && isHexDigit c1 && isHexDigit c2 + = do poke (buf `plusPtr` bufi) + (toWord8 $ digitToInt c1 * 16 + digitToInt c2) + decode (B.drop 3 ps:pss) buf (bufi+1) + | is_equals && B.null (dropSpace (B.tail ps)) = decode pss buf bufi + | otherwise = do poke (buf `plusPtr` bufi) (B.head ps) + decode (B.tail ps:pss) buf (bufi+1) + where is_equals = BC.head ps == '=' + c1 = BC.index ps 1 + c2 = BC.index ps 2 + newline = B.c2w '\n' + toWord8 :: Int -> Word8 + toWord8 = fromIntegral + +make_email :: String -> [(String, String)] -> (Maybe Doc) -> Doc -> (Maybe String) -> Doc +make_email repodir headers mcontents bundle mfilename = + text "DarcsURL:" <+> text repodir + $$ foldl (\m (h,v) -> m $$ (text (h ++ ":") <+> text v)) empty headers + $$ text "MIME-Version: 1.0" + $$ text "Content-Type: multipart/mixed; boundary=\"=_\"" + $$ text "" + $$ text "--=_" + $$ (case mcontents of + Just contents -> + text "Content-Type: text/plain" + $$ text "Content-Transfer-Encoding: quoted-printable" + $$ text "" + $$ packedString (qpencode (renderPS contents)) + $$ text "" + $$ text "--=_" + Nothing -> empty) + $$ text "Content-Type: text/x-darcs-patch" <> + (case mfilename of + Just filename -> text "; name=\"" <> text filename <> text "\"" + Nothing -> empty) + $$ text "Content-Transfer-Encoding: quoted-printable" + $$ text "Content-Description: A darcs patch for your repository!" + $$ text "" + $$ packedString (qpencode (renderPS bundle)) + $$ text "--=_--" + $$ text "" + $$ text "." + $$ text "" + $$ text "" + +read_email :: B.ByteString -> B.ByteString +read_email s = + case betweenLinesPS + (BC.pack "Content-Description: A darcs patch for your repository!") + (BC.pack "--=_--") s of + Nothing -> s -- if it wasn't an email in the first place, just pass along. + Just s' -> qpdecode s' + diff --git a/src/Darcs/External.hs b/src/Darcs/External.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/External.hs @@ -0,0 +1,656 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +module Darcs.External ( + backupByRenaming, backupByCopying, + copyFileOrUrl, speculateFileOrUrl, copyFilesOrUrls, copyLocal, cloneFile, + cloneTree, cloneTreeExcept, clonePartialsTree, clonePaths, + fetchFilePS, gzFetchFilePS, + sendEmail, generateEmail, sendEmailDoc, resendEmail, + signString, verifyPS, + execDocPipe, execPipeIgnoreError, + getTermNColors, + pipeDoc, pipeDocSSH, execSSH, + maybeURLCmd, + Cachable(Cachable, Uncachable, MaxAge), + viewDoc, viewDocWith, + sendmail_path, diff_program + ) where + +import Data.Maybe ( isJust, isNothing, maybeToList ) +import Control.Monad ( when, zipWithM_, filterM, liftM2 ) +import System.Exit ( ExitCode(..) ) +import System.Environment ( getEnv ) +import System.IO ( hPutStr, hPutStrLn, hGetContents, hClose, + openBinaryFile, IOMode( ReadMode ), + openBinaryTempFile, + hIsTerminalDevice, stdout, stderr, Handle ) +import System.IO.Error ( isDoesNotExistError ) +import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory ) +import System.Directory ( createDirectory, getDirectoryContents, + doesFileExist, doesDirectoryExist, + renameFile, renameDirectory, copyFile, + findExecutable ) +import System.Process ( runProcess, runInteractiveProcess, waitForProcess ) +import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar ) +import Control.Exception ( bracket, try, finally ) +import Data.Char ( toUpper ) +#if defined (HAVE_MAPI) +import Foreign.C ( CString, withCString ) +#endif +#ifdef HAVE_MAPI +import Foreign.Ptr ( nullPtr ) +import Darcs.Lock ( canonFilename, writeDocBinFile ) +#endif +#ifdef HAVE_TERMINFO +import System.Console.Terminfo( tiGetNum, setupTermFromEnv, getCapability ) +#endif +import System.Posix.Files ( createLink ) +import System.Directory ( createDirectoryIfMissing ) +import System.FilePath.Posix ( (), takeDirectory, normalise ) + +import Darcs.Flags ( DarcsFlag( SignAs, Sign, SignSSL, NoLinks, + Verify, VerifySSL ) ) +import Darcs.RepoPath ( AbsolutePath, toFilePath ) +import Darcs.Utils ( withCurrentDirectory, breakCommand, get_viewer, ortryrunning, ) +import Progress ( withoutProgress, progressList, debugMessage ) + +import ByteStringUtils (gzReadFilePS, linesPS, unlinesPS) +import qualified Data.ByteString as B (ByteString, empty, null, readFile -- ratify readFile: Just an import from ByteString + ,hGetContents, writeFile, hPut, length -- ratify hGetContents: importing from ByteString + ,take, concat, drop, isPrefixOf, singleton, append) +import qualified Data.ByteString.Char8 as BC (unpack, pack) + +import Darcs.Lock ( withTemp, withOpenTemp, tempdir_loc, removeFileMayNotExist ) +import CommandLine ( parseCmd, addUrlencoded ) +import URL ( copyUrl, copyUrlFirst, waitUrl ) +import Ssh ( getSSH, copySSH, copySSHs, SSHCmd(..) ) +import URL ( Cachable(..) ) +import Exec ( exec, Redirect(..), withoutNonBlock ) +import Darcs.URL ( is_file, is_url, is_ssh ) +import Darcs.Utils ( catchall ) +import Printer ( Doc, Printers, putDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), renderPS, + simplePrinters, + text, empty, packedString, vcat, renderString ) +import Darcs.Email ( formatHeader ) + +sendmail_path :: IO String +sendmail_path = do + l <- filterM doesFileExist $ liftM2 () + [ "/usr/sbin", "/sbin", "/usr/lib" ] + [ "sendmail" ] + ex <- findExecutable "sendmail" + when (isNothing ex && null l) $ fail "Cannot find the \"sendmail\" program." + return $ head $ maybeToList ex ++ l + +diff_program :: IO String +diff_program = do + l <- filterM (fmap isJust . findExecutable) [ "gdiff", "gnudiff", "diff" ] + when (null l) $ fail "Cannot find the \"diff\" program." + return $ head l + +backupByRenaming :: FilePath -> IO () +backupByRenaming = backupBy rename + where rename x y = do + isD <- doesDirectoryExist x + if isD then renameDirectory x y else renameFile x y + +backupByCopying :: FilePath -> IO () +backupByCopying = backupBy copy + where + copy x y = do + isD <- doesDirectoryExist x + if isD then do createDirectory y + cloneTree (normalise x) (normalise y) + else copyFile x y + +backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO () +backupBy backup f = + do hasBF <- doesFileExist f + hasBD <- doesDirectoryExist f + when (hasBF || hasBD) $ helper (0::Int) + where + helper i = do existsF <- doesFileExist next + existsD <- doesDirectoryExist next + if (existsF || existsD) + then helper (i + 1) + else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")" + backup f next + where next = f ++ suffix + suffix = "-darcs-backup" ++ show i + +-- | @fetchFile fileOrUrl cache@ returns the content of its argument +-- (either a file or an URL). If it has to download an url, then it +-- will use a cache as required by its second argument. +fetchFilePS :: String -> Cachable -> IO B.ByteString +fetchFilePS fou _ | is_file fou = B.readFile fou +fetchFilePS fou cache = withTemp $ \t -> do copyFileOrUrl [] fou t cache + B.readFile t + +gzFetchFilePS :: String -> Cachable -> IO B.ByteString +gzFetchFilePS fou _ | is_file fou = gzReadFilePS fou +gzFetchFilePS fou cache = withTemp $ \t-> do copyFileOrUrl [] fou t cache + gzReadFilePS t + + +copyFileOrUrl :: [DarcsFlag] -> FilePath -> FilePath -> Cachable -> IO () +copyFileOrUrl opts fou out _ | is_file fou = copyLocal opts fou out +copyFileOrUrl _ fou out cache | is_url fou = copyRemote fou out cache +copyFileOrUrl _ fou out _ | is_ssh fou = copySSH fou out +copyFileOrUrl _ fou _ _ = fail $ "unknown transport protocol: " ++ fou + +speculateFileOrUrl :: String -> FilePath -> IO () +speculateFileOrUrl fou out | is_url fou = speculateRemote fou out + | otherwise = return () + +copyLocal :: [DarcsFlag] -> String -> FilePath -> IO () +copyLocal opts fou out | NoLinks `elem` opts = cloneFile fou out + | otherwise = createLink fou out `catchall` cloneFile fou out + +clonePaths :: FilePath -> FilePath -> [FilePath] -> IO () +clonePaths source dest = mapM_ (clonePath source dest) + +clonePath :: FilePath -> FilePath -> FilePath -> IO () +clonePath source dest path + = do let source' = source path + dest' = dest path + fs <- getSymbolicLinkStatus source' + if isDirectory fs then do + createDirectoryIfMissing True dest' + else if isRegularFile fs then do + createDirectoryIfMissing True (dest takeDirectory path) + cloneFile source' dest' + else fail ("clonePath: Bad file " ++ source') + `catch` fail ("clonePath: Bad file " ++ source path) + +clonePartialsTree :: FilePath -> FilePath -> [FilePath] -> IO () +clonePartialsTree source dest = mapM_ (clonePartialTree source dest) + +clonePartialTree :: FilePath -> FilePath -> FilePath -> IO () +clonePartialTree source dest "" = cloneTree source dest +clonePartialTree source dest pref + = do createDirectoryIfMissing True (dest takeDirectory pref) + cloneSubTree (source pref) (dest pref) + +cloneTree :: FilePath -> FilePath -> IO () +cloneTree = cloneTreeExcept [] + +cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO () +cloneTreeExcept except source dest = + do fs <- getSymbolicLinkStatus source + if isDirectory fs then do + fps <- getDirectoryContents source + let fps' = filter (`notElem` (".":"..":except)) fps + mk_source fp = source fp + mk_dest fp = dest fp + zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') + else fail ("cloneTreeExcept: Bad source " ++ source) + `catch` fail ("cloneTreeExcept: Bad source " ++ source) + +cloneSubTree :: FilePath -> FilePath -> IO () +cloneSubTree source dest = + do fs <- getSymbolicLinkStatus source + if isDirectory fs then do + createDirectory dest + fps <- getDirectoryContents source + let fps' = filter (`notElem` [".", ".."]) fps + mk_source fp = source fp + mk_dest fp = dest fp + zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') + else if isRegularFile fs then do + cloneFile source dest + else fail ("cloneSubTree: Bad source "++ source) + `catch` (\e -> if isDoesNotExistError e + then return () + else ioError e) + +cloneFile :: FilePath -> FilePath -> IO () +cloneFile = copyFile + +maybeURLCmd :: String -> String -> IO(Maybe(String)) +maybeURLCmd what url = + do let prot = map toUpper $ takeWhile (/= ':') url + fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot)) + `catch` \_ -> return Nothing + +speculateRemote :: String -> FilePath -> IO () -- speculations are always Cachable +#if defined(HAVE_CURL) || defined(HAVE_HTTP) +speculateRemote u v = + do maybeget <- maybeURLCmd "GET" u + case maybeget of + Just _ -> return () -- can't pipeline these + Nothing -> copyUrl u v Cachable +#else +speculateRemote u _ = maybeURLCmd "GET" u >> return () +#endif + +copyRemote :: String -> FilePath -> Cachable -> IO () +copyRemote u v cache = + do maybeget <- maybeURLCmd "GET" u + case maybeget of + Nothing -> copyRemoteNormal u v cache + Just get -> + do let (cmd,args) = breakCommand get + r <- exec cmd (args++[u]) (Null, File v, AsIs) + when (r /= ExitSuccess) $ + fail $ "(" ++ get ++ ") failed to fetch: " ++ u + +copyRemoteNormal :: String -> FilePath -> Cachable -> IO () +copyRemoteNormal u v cache = copyUrlFirst u v cache >> waitUrl u + +copyFilesOrUrls :: [DarcsFlag]->FilePath->[String]->FilePath->Cachable->IO () +copyFilesOrUrls opts dou ns out _ | is_file dou = copyLocals opts dou ns out +copyFilesOrUrls _ dou ns out c | is_url dou = copyRemotes dou ns out c +copyFilesOrUrls _ dou ns out _ | is_ssh dou = copySSHs dou ns out +copyFilesOrUrls _ dou _ _ _ = fail $ "unknown transport protocol: "++dou + + +copyLocals :: [DarcsFlag] -> String -> [String] -> FilePath -> IO () +copyLocals opts u ns d = + doWithPatches (\n -> copyLocal opts (u++"/"++n) (d++"/"++n)) ns + +copyRemotes :: String -> [String] -> FilePath -> Cachable -> IO() +copyRemotes u ns d cache = + do maybeget <- maybeURLCmd "GET" u + maybemget <- maybeURLCmd "MGET" u + case (maybeget, maybemget) of + (Nothing, _) -> copyRemotesNormal u ns d cache + (Just _, Nothing) -> doWithPatches (\n -> copyRemote (u++"/"++n) (d++"/"++n) cache) ns + (Just _, Just mget) -> mgetRemotes mget u ns d + +stringToInt :: String -> Int -> Int +stringToInt num def = case reads num of [(x,"")] -> x + _ -> def + +mgetRemotes :: String -> String -> [String] -> FilePath -> IO() +mgetRemotes _ _ [] _ = return () +mgetRemotes mget u ns d = do + mgetmax <- getEnv "DARCS_MGETMAX" `catch` \_ -> return "" + let (nsnow, nslater) = splitAt (stringToInt mgetmax 200) ns + (cmd, args) = breakCommand mget + urls = map (\n -> u++"/"++n) nsnow + withCurrentDirectory d $ do + r <- exec cmd (args++urls) (Null,Null,AsIs) + when (r /= ExitSuccess) $ + fail $ unlines $ + ["(" ++ mget ++ ") failed to fetch files.", + "source directory: " ++ d, + "source files:"] ++ (upto 5 nsnow) ++ + ["still to go:"] ++ (upto 5 nslater) + mgetRemotes mget u nslater d + where + upto :: Integer -> [String] -> [String] + upto _ [] = [] + upto 0 l = [ "(" ++ (show (length l)) ++ " more)" ] + upto n (h : t) = h : (upto (n - 1) t) + +copyRemotesNormal :: String -> [String] -> FilePath -> Cachable -> IO() +copyRemotesNormal u ns d cache = + do mapM_ (\n -> copyUrl (u++"/"++n) (d++"/"++n) cache) ns + doWithPatches (\n -> waitUrl (u++"/"++n)) ns + +doWithPatches :: (String -> IO ()) -> [String] -> IO () +doWithPatches f patches = mapM_ (\p -> seq p $ f p) $ progressList "Copying patch" patches + +-- | Run a command on a remote location without passing it any input or +-- reading its output. Return its ExitCode +execSSH :: String -> String -> IO ExitCode +execSSH remoteAddr command = + do (ssh, ssh_args) <- getSSH SSH remoteAddr + debugMessage $ unwords (ssh:ssh_args++[remoteAddr,command]) + withoutProgress $ do hid <- runProcess ssh (ssh_args++[remoteAddr,command]) + Nothing Nothing Nothing Nothing Nothing + waitForProcess hid + +pipeDoc :: String -> [String] -> Doc -> IO ExitCode +pipeDoc c args inp = withoutNonBlock $ withoutProgress $ + do debugMessage $ unwords (c:args) + (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing + mvare <- newEmptyMVar + forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed + hPutStr stderr) + `finally` putMVar mvare ()) + mvaro <- newEmptyMVar + forkIO ((hGetContents o >>= -- ratify hGetContents: it's immediately consumed + hPutStr stdout) + `finally` putMVar mvaro ()) + hPutDoc i inp + hClose i + rval <- waitForProcess pid + takeMVar mvare + takeMVar mvaro + when (rval == ExitFailure 127) $ + putStrLn $ "Command not found:\n "++ show (c:args) + return rval + +pipeDocSSH :: String -> [String] -> Doc -> IO ExitCode +pipeDocSSH remoteAddr args input = + do (ssh, ssh_args) <- getSSH SSH remoteAddr + pipeDoc ssh (ssh_args++ (remoteAddr:args)) input + +sendEmail :: String -> String -> String -> String -> String -> String -> IO () +sendEmail f t s cc scmd body = + sendEmailDoc f t s cc scmd Nothing (text body) + + +generateEmail + :: Handle -- ^ handle to write email to + -> String -- ^ From + -> String -- ^ To + -> String -- ^ Subject + -> String -- ^ CC + -> Doc -- ^ body + -> IO () +generateEmail h f t s cc body = do + putHeader "To" t + putHeader "From" f + putHeader "Subject" s + when (not (null cc)) (putHeader "Cc" cc) + putHeader "X-Mail-Originator" "Darcs Version Control System" + hPutDocLn h body + where putHeader field value + = B.hPut h (B.append (formatHeader field value) newline) + newline = B.singleton 10 + +have_sendmail :: IO Bool +have_sendmail = (sendmail_path >> return True) `catch` (\_ -> return False) + +-- | Send an email, optionally containing a patch bundle +-- (more precisely, its description and the bundle itself) +sendEmailDoc + :: String -- ^ from + -> String -- ^ to + -> String -- ^ subject + -> String -- ^ cc + -> String -- ^ send command + -> Maybe (Doc, Doc) -- ^ (content,bundle) + -> Doc -- ^ body + -> IO () +sendEmailDoc _ "" _ "" _ _ _ = return () +sendEmailDoc f "" s cc scmd mbundle body = + sendEmailDoc f cc s "" scmd mbundle body +sendEmailDoc f t s cc scmd mbundle body = do + use_sendmail <- have_sendmail + if use_sendmail || scmd /= "" then do + withOpenTemp $ \(h,fn) -> do + generateEmail h f t s cc body + hClose h + withOpenTemp $ \(hat,at) -> do + ftable' <- case mbundle of + Just (content,bundle) -> do + hPutDocLn hat $ bundle + return [ ('b', renderString content) , ('a', at) ] + Nothing -> + return [ ('b', renderString body) ] + hClose hat + let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable' + r <- execSendmail ftable scmd fn + when (r /= ExitSuccess) $ fail ("failed to send mail to: " + ++ t ++ cc_list cc + ++ "\nPerhaps sendmail is not configured.") +#ifdef HAVE_MAPI + else do + r <- withCString t $ \tp -> + withCString f $ \fp -> + withCString cc $ \ccp -> + withCString s $ \sp -> + withOpenTemp $ \(h,fn) -> do + hPutDoc h body + hClose h + writeDocBinFile "mailed_patch" body + cfn <- canonFilename fn + withCString cfn $ \pcfn -> + c_send_email fp tp ccp sp nullPtr pcfn + when (r /= 0) $ fail ("failed to send mail to: " ++ t) +#else + else fail $ "no mail facility (sendmail or mapi) located at configure time!" +#endif + where addressOnly a = + case dropWhile (/= '<') a of + ('<':a2) -> takeWhile (/= '>') a2 + _ -> a + + cc_list [] = [] + cc_list c = " and cc'ed " ++ c + +resendEmail :: String -> String -> B.ByteString -> IO () +resendEmail "" _ _ = return () +resendEmail t scmd body = do + use_sendmail <- have_sendmail + if use_sendmail || scmd /= "" + then do + withOpenTemp $ \(h,fn) -> do + hPutStrLn h $ "To: "++ t + hPutStrLn h $ find_from (linesPS body) + hPutStrLn h $ find_subject (linesPS body) + hPutDocLn h $ fixit $ linesPS body + hClose h + let ftable = [('t',t)] + r <- execSendmail ftable scmd fn + when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t) + else +#ifdef HAVE_MAPI + fail "Don't know how to resend email with MAPI" +#else + fail "no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!" +#endif + where br = BC.pack "\r" + darcsurl = BC.pack "DarcsURL:" + content = BC.pack "Content-" + from_start = BC.pack "From:" + subject_start = BC.pack "Subject:" + fixit (l:ls) + | B.null l = packedString B.empty $$ vcat (map packedString ls) + | l == br = packedString B.empty $$ vcat (map packedString ls) + | B.take 9 l == darcsurl || B.take 8 l == content + = packedString l $$ fixit ls + | otherwise = fixit ls + fixit [] = empty + find_from (l:ls) | B.take 5 l == from_start = BC.unpack l + | otherwise = find_from ls + find_from [] = "From: unknown" + find_subject (l:ls) | B.take 8 l == subject_start = BC.unpack l + | otherwise = find_subject ls + find_subject [] = "Subject: (no subject)" + +execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode +execSendmail ftable scmd fn = + if scmd == "" then do + cmd <- sendmail_path + exec cmd ["-i", "-t"] (File fn, Null, AsIs) + else case parseCmd (addUrlencoded ftable) scmd of + Right (arg0:opts, wantstdin) -> + do let stdin = if wantstdin then File fn else Null + exec arg0 opts (stdin, Null, AsIs) + Left e -> fail $ ("failed to send mail, invalid sendmail-command: "++(show e)) + _ -> fail $ ("failed to send mail, invalid sendmail-command") + +#ifdef HAVE_MAPI +foreign import ccall "win32/send_email.h send_email" c_send_email + :: CString -> {- sender -} + CString -> {- recipient -} + CString -> {- cc -} + CString -> {- subject -} + CString -> {- body -} + CString -> {- path -} + IO Int +#endif + +execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString +execPSPipe c args ps = fmap renderPS + $ execDocPipe c args + $ packedString ps + +execDocPipe :: String -> [String] -> Doc -> IO Doc +execDocPipe c args instr = withoutProgress $ + do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing + forkIO $ hPutDoc i instr >> hClose i + mvare <- newEmptyMVar + forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed + hPutStr stderr) + `finally` putMVar mvare ()) + out <- B.hGetContents o + rval <- waitForProcess pid + takeMVar mvare + case rval of + ExitFailure ec ->fail $ "External program '"++c++ + "' failed with exit code "++ show ec + ExitSuccess -> return $ packedString out + +-- The following is needed for diff, which returns non-zero whenever +-- the files differ. +execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc +execPipeIgnoreError c args instr = withoutProgress $ + do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing + forkIO $ hPutDoc i instr >> hClose i + mvare <- newEmptyMVar + forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed + hPutStr stderr) + `finally` putMVar mvare ()) + out <- B.hGetContents o + waitForProcess pid + takeMVar mvare + return $ packedString out + +signString :: [DarcsFlag] -> Doc -> IO Doc +signString [] d = return d +signString (Sign:_) d = signPGP [] d +signString (SignAs keyid:_) d = signPGP ["--local-user", keyid] d +signString (SignSSL idf:_) d = signSSL idf d +signString (_:os) d = signString os d + +signPGP :: [String] -> Doc -> IO Doc +signPGP args t = execDocPipe "gpg" ("--clearsign":args) t + +signSSL :: String -> Doc -> IO Doc +signSSL idfile t = + withTemp $ \cert -> do + opensslPS ["req", "-new", "-key", idfile, + "-outform", "PEM", "-days", "365"] + (BC.pack "\n\n\n\n\n\n\n\n\n\n\n") + >>= opensslPS ["x509", "-req", "-extensions", + "v3_ca", "-signkey", idfile, + "-outform", "PEM", "-days", "365"] + >>= opensslPS ["x509", "-outform", "PEM"] + >>= B.writeFile cert + opensslDoc ["smime", "-sign", "-signer", cert, + "-inkey", idfile, "-noattr", "-text"] t + where opensslDoc = execDocPipe "openssl" + opensslPS = execPSPipe "openssl" + + +verifyPS :: [DarcsFlag] -> B.ByteString -> IO (Maybe B.ByteString) +verifyPS [] ps = return $ Just ps +verifyPS (Verify pks:_) ps = verifyGPG pks ps +verifyPS (VerifySSL auks:_) ps = verifySSL auks ps +verifyPS (_:os) ps = verifyPS os ps + +verifyGPG :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString) +verifyGPG goodkeys s = + withOpenTemp $ \(th,tn) -> do + B.hPut th s + hClose th + rval <- exec "gpg" ["--batch","--no-default-keyring", + "--keyring",fix_path $ toFilePath goodkeys, "--verify"] + (File tn, Null, Null) + case rval of + ExitSuccess -> return $ Just gpg_fixed_s + _ -> return Nothing + where gpg_fixed_s = let + not_begin_signature x = + x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----" + && + x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----\r" + in unlinesPS $ map fix_line $ tail $ dropWhile not_begin_signature $ linesPS s + fix_line x | B.length x < 3 = x + | BC.pack "- -" `B.isPrefixOf` x = B.drop 2 x + | otherwise = x +#if defined(WIN32) + fix_sep c | c=='/' = '\\' | otherwise = c + fix_path p = map fix_sep p +#else + fix_path p = p +#endif + +verifySSL :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString) +verifySSL goodkeys s = do + certdata <- opensslPS ["smime", "-pk7out"] s + >>= opensslPS ["pkcs7", "-print_certs"] + cruddy_pk <- opensslPS ["x509", "-pubkey"] certdata + let key_used = B.concat $ tail $ + takeWhile (/= BC.pack"-----END PUBLIC KEY-----") + $ linesPS cruddy_pk + in do allowed_keys <- linesPS `fmap` B.readFile (toFilePath goodkeys) + if not $ key_used `elem` allowed_keys + then return Nothing -- Not an allowed key! + else withTemp $ \cert -> + withTemp $ \on -> + withOpenTemp $ \(th,tn) -> do + B.hPut th s + hClose th + B.writeFile cert certdata + rval <- exec "openssl" ["smime", "-verify", "-CAfile", + cert, "-certfile", cert] + (File tn, File on, Null) + case rval of + ExitSuccess -> Just `fmap` B.readFile on + _ -> return Nothing + where opensslPS = execPSPipe "openssl" + + +{- + - This function returns number of colors supported by current terminal + - or -1 if color output not supported or error occured. + - Terminal type determined by TERM env. variable. + -} +getTermNColors :: IO Int +#ifdef HAVE_TERMINFO +getTermNColors = do + t <- setupTermFromEnv + return $ case getCapability t $ tiGetNum "colors" of + Nothing -> (-1) + Just x -> x +#else +getTermNColors = return (-1) +#endif + +viewDoc :: Doc -> IO () +viewDoc = viewDocWith simplePrinters + +viewDocWith :: Printers -> Doc -> IO () +viewDocWith pr msg = do + isTerminal <- hIsTerminalDevice stdout + if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg) + then do viewer <- get_viewer + pipeDocToPager viewer [] pr msg + `ortryrunning` pipeDocToPager "less" [] pr msg + `ortryrunning` pipeDocToPager "more" [] pr msg +#ifdef WIN32 + `ortryrunning` pipeDocToPager "more.com" [] pr msg +#endif + `ortryrunning` pipeDocToPager "" [] pr msg + else pipeDocToPager "" [] pr msg + return () + where lengthGreaterThan n _ | n <= 0 = True + lengthGreaterThan _ [] = False + lengthGreaterThan n (_:xs) = lengthGreaterThan (n-1) xs + +pipeDocToPager :: String -> [String] -> Printers -> Doc -> IO ExitCode + +pipeDocToPager "" _ pr inp = do + putDocLnWith pr inp + return ExitSuccess + +pipeDocToPager c args pr inp = withoutNonBlock $ withoutProgress $ do + tmp <- tempdir_loc + bracket (openBinaryTempFile tmp "darcs-pager") cleanup $ \(fn,fh) -> + do hPutDocWith pr fh inp + hClose fh + bracket (openBinaryFile fn ReadMode) hClose $ \h -> + do x <- do pid <- runProcess c args Nothing Nothing (Just h) Nothing Nothing + waitForProcess pid + when (x == ExitFailure 127) $ + putStrLn $ "Command not found:\n "++ show (c:args) + return x + where + cleanup (f,h) = do try $ hClose h + removeFileMayNotExist f diff --git a/src/Darcs/FilePathMonad.hs b/src/Darcs/FilePathMonad.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/FilePathMonad.hs @@ -0,0 +1,83 @@ +-- Copyright (C) 2005 David Roundy +-- +-- 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. + + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.FilePathMonad ( FilePathMonad, withFilePaths ) where + +import Control.Monad ( MonadPlus, mplus, mzero ) +import Data.Maybe ( catMaybes ) + +import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) ) +import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp, super_name, break_on_dir, + norm_path, movedirfilename ) +#include "impossible.h" + +data FilePathMonad a = FPM ([FileName] -> ([FileName], a)) + +withFilePaths :: [FilePath] -> FilePathMonad a -> [FilePath] +withFilePaths fps (FPM x) = map fn2fp $ fst $ x $ map fp2fn fps + +instance Functor FilePathMonad where + fmap f m = m >>= return . f + +instance Monad FilePathMonad where + (FPM x) >>= y = FPM z where z fs = case x fs of + (fs', a) -> case y a of + FPM yf -> yf fs' + return x = FPM $ \fs -> (fs, x) + +instance MonadPlus FilePathMonad where + mzero = fail "mzero FilePathMonad" -- yuck! + a `mplus` _ = a + +instance ReadableDirectory FilePathMonad where + -- We can't check it actually is a directory here + mDoesDirectoryExist d = + FPM $ \fs -> (fs, norm_path d `elem` map norm_path fs) + -- We can't check it actually is a file here + mDoesFileExist f = + FPM $ \fs -> (fs, norm_path f `elem` map norm_path fs) + mInCurrentDirectory d (FPM j) = + FPM $ \fs -> (fs, snd $ j $ catMaybes $ map indir fs) + where indir f = do (d',f') <- break_on_dir f + if d == d' then Just f' + else Nothing + mGetDirectoryContents = + FPM $ \fs -> (fs, filter (\f -> fp2fn "." == super_name f) fs) + mReadFilePS = bug "can't mReadFilePS in FilePathMonad!" + +instance WriteableDirectory FilePathMonad where + mWithCurrentDirectory d (FPM j) = + FPM $ \fs -> + let splitfs = map splitf fs + others = catMaybes $ map snd splitfs + (myfs, a) = j $ catMaybes $ map fst splitfs + splitf f = case break_on_dir f of + Just (d', f') | d' == d -> (Just f', Nothing) + _ -> (Nothing, Just f) + in (others ++ myfs, a) + mSetFileExecutable _ _ = return () + mWriteFilePS _ _ = return () + mCreateDirectory _ = return () + mRemoveFile f = FPM $ \fs -> (filter (/= f) fs, ()) + mRemoveDirectory f = FPM $ \fs -> (filter (/= f) fs, ()) + mRename a b = FPM $ \fs -> (map (movedirfilename a b) fs, ()) + mModifyFilePS _ _ = return () + mModifyFilePSs _ _ = return () diff --git a/src/Darcs/Flags.hs b/src/Darcs/Flags.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Flags.hs @@ -0,0 +1,116 @@ +-- Copyright (C) 2002-2004 David Roundy +-- +-- 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. + +module Darcs.Flags ( DarcsFlag( .. ), Compression( .. ), compression, want_external_merge, isInteractive, + maxCount, + ) where +import Darcs.Patch.MatchData ( PatchMatch ) +import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd ) + +-- | The 'DarcsFlag' type is a list of all flags that can ever be +-- passed to darcs, or to one of its commands. +data DarcsFlag = Help | ListOptions | NoTest | Test + | OnlyChangesToFiles + | LeaveTestDir | NoLeaveTestDir + | Timings | Debug | DebugVerbose | DebugHTTP + | Verbose | NormalVerbosity | Quiet + | Target String | Cc String + | Output AbsolutePathOrStd | OutputAutoName AbsolutePath + | Subject String | InReplyTo String + | SendmailCmd String | Author String | PatchName String + | OnePatch String | SeveralPatch String + | AfterPatch String | UpToPatch String + | TagName String | LastN Int | MaxCount Int | PatchIndexRange Int Int + | NumberPatches + | OneTag String | AfterTag String | UpToTag String + | Context AbsolutePath | Count + | LogFile AbsolutePath | RmLogFile + | DistName String | All + | Recursive | NoRecursive | Reorder + | RestrictPaths | DontRestrictPaths + | AskDeps | NoAskDeps | IgnoreTimes | LookForAdds | NoLookForAdds + | AnyOrder | CreatorHash String + | Intersection | Union | Complement + | Sign | SignAs String | NoSign | SignSSL String + | HappyForwarding + | Verify AbsolutePath | VerifySSL AbsolutePath + | SSHControlMaster | NoSSHControlMaster + | EditDescription | NoEditDescription + | Toks String + | EditLongComment | NoEditLongComment | PromptLongComment + | AllowConflicts | MarkConflicts | NoAllowConflicts + | Boring | AllowCaseOnly | AllowWindowsReserved + | DontGrabDeps | DontPromptForDependencies | PromptForDependencies + | Compress | NoCompress | UnCompress + | WorkRepoDir String | WorkRepoUrl String | RemoteRepo String + | NewRepo String + | Reply String | ApplyAs String + | MachineReadable | HumanReadable + | Pipe | Interactive + | DiffCmd String + | ExternalMerge String | Summary | NoSummary + | Unified | Reverse + | CheckPoint | Partial | Complete | Lazy | Ephemeral + | FixFilePath AbsolutePath AbsolutePath | DiffFlags String + | XMLOutput + | ForceReplace + | OnePattern PatchMatch | SeveralPattern PatchMatch + | AfterPattern PatchMatch | UpToPattern PatchMatch + | NonApply | NonVerify | NonForce + | DryRun | SetDefault | NoSetDefault + | FancyMoveAdd | NoFancyMoveAdd + | Disable | SetScriptsExecutable | DontSetScriptsExecutable + | UseHashedInventory | UseOldFashionedInventory + | UseFormat2 + | PristinePlain | PristineNone | NoUpdateWorking + | Sibling AbsolutePath | Relink | RelinkPristine | NoLinks + | Files | NoFiles | Directories | NoDirectories + | Pending | NoPending + | PosthookCmd String | NoPosthook | AskPosthook | RunPosthook + | PrehookCmd String | NoPrehook | AskPrehook | RunPrehook + | UMask String + | StoreInMemory + | HTTPPipelining | NoHTTPPipelining + | NoCache + | AllowUnrelatedRepos + | Check | Repair + | NullFlag + deriving ( Eq, Show ) + +data Compression = NoCompression | GzipCompression +compression :: [DarcsFlag] -> Compression +compression f | NoCompress `elem` f = NoCompression + | otherwise = GzipCompression + +want_external_merge :: [DarcsFlag] -> Maybe String +want_external_merge [] = Nothing +want_external_merge (ExternalMerge c:_) = Just c +want_external_merge (_:fs) = want_external_merge fs + +isInteractive :: [DarcsFlag] -> Bool +isInteractive = isInteractive_ True + where + isInteractive_ def [] = def + isInteractive_ _ (Interactive:_) = True + isInteractive_ _ (All:_) = False + isInteractive_ _ (DryRun:fs) = isInteractive_ False fs + isInteractive_ def (_:fs) = isInteractive_ def fs + +maxCount :: [DarcsFlag] -> Maybe Int +maxCount (MaxCount n : _) = Just n +maxCount (_:xs) = maxCount xs +maxCount [] = Nothing diff --git a/src/Darcs/Global.hs b/src/Darcs/Global.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Global.hs @@ -0,0 +1,158 @@ +-- Copyright (C) 2005 Tomasz Zielonka +-- +-- 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. + +-- | This was originally Tomasz Zielonka's AtExit module, slightly generalised +-- to include global variables. Here, we attempt to cover broad, global +-- features, such as exit handlers. These features slightly break the Haskellian +-- purity of darcs, in favour of programming convenience. +module Darcs.Global ( atexit, with_atexit, + sshControlMasterDisabled, setSshControlMasterDisabled, + verboseMode, setVerboseMode, + timingsMode, setTimingsMode, + whenDebugMode, withDebugMode, setDebugMode, + debugMessage, debugFail, putTiming, +#ifdef HAVE_HASKELL_ZLIB + addCRCWarning, getCRCWarnings, resetCRCWarnings, +#endif + darcsdir + ) where + +import Control.Monad ( when ) +import Control.Concurrent.MVar +import Control.Exception (bracket_, catch, block, unblock) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +#ifdef HAVE_HASKELL_ZLIB +import Data.IORef ( modifyIORef ) +#endif +import System.IO.Unsafe (unsafePerformIO) +import System.IO (hPutStrLn, hPutStr, stderr) +import System.Time ( calendarTimeToString, toCalendarTime, getClockTime ) +import Prelude hiding (catch) + +{-# NOINLINE atexit_actions #-} +atexit_actions :: MVar (Maybe [IO ()]) +atexit_actions = unsafePerformIO (newMVar (Just [])) + +-- | Registers an IO action to run just before darcs exits. Useful +-- for removing temporary files and directories, for example. +atexit :: IO () -> IO () +atexit action = do + modifyMVar_ atexit_actions $ \ml -> do + case ml of + Just l -> do + return (Just (action : l)) + Nothing -> do + hPutStrLn stderr "It's too late to use atexit" + return Nothing + +with_atexit :: IO a -> IO a +with_atexit prog = do + bracket_ + (return ()) + exit + prog + where + exit = block $ do + Just actions <- swapMVar atexit_actions Nothing + -- from now on atexit will not register new actions + mapM_ runAction actions + runAction action = do + catch (unblock action) $ \exn -> do + hPutStrLn stderr $ "Exception thrown by an atexit registered action:" + hPutStrLn stderr $ show exn + + +-- Write-once-read-many global variables make it easier to implement flags, such +-- as --no-ssh-cm. Using global variables reduces the number of parameters +-- that we have to pass around, but it is rather unsafe and should be used sparingly. + +{-# NOINLINE _debugMode #-} +_debugMode :: IORef Bool +_debugMode = unsafePerformIO $ newIORef False + +setDebugMode :: IO () +setDebugMode = writeIORef _debugMode True + +whenDebugMode :: IO () -> IO () +whenDebugMode j = do b <- readIORef _debugMode + when b j + +withDebugMode :: (Bool -> IO a) -> IO a +withDebugMode j = readIORef _debugMode >>= j + + +debugMessage :: String -> IO () +debugMessage m = whenDebugMode $ do putTiming; hPutStrLn stderr m + +debugFail :: String -> IO a +debugFail m = debugMessage m >> fail m + +putTiming :: IO () +putTiming = when timingsMode $ do t <- getClockTime >>= toCalendarTime + hPutStr stderr (calendarTimeToString t++": ") + +{-# NOINLINE _timingsMode #-} +_timingsMode :: IORef Bool +_timingsMode = unsafePerformIO $ newIORef False + +setTimingsMode :: IO () +setTimingsMode = writeIORef _timingsMode True + +{-# NOINLINE timingsMode #-} +timingsMode :: Bool +timingsMode = unsafePerformIO $ readIORef _timingsMode + +{-# NOINLINE _verboseMode #-} +_verboseMode :: IORef Bool +_verboseMode = unsafePerformIO $ newIORef False + +setVerboseMode :: IO () +setVerboseMode = writeIORef _verboseMode True + +{-# NOINLINE verboseMode #-} +verboseMode :: Bool +verboseMode = unsafePerformIO $ readIORef _verboseMode + +{-# NOINLINE _sshControlMasterDisabled #-} +_sshControlMasterDisabled :: IORef Bool +_sshControlMasterDisabled = unsafePerformIO $ newIORef False + +setSshControlMasterDisabled :: IO () +setSshControlMasterDisabled = writeIORef _sshControlMasterDisabled True + +{-# NOINLINE sshControlMasterDisabled #-} +sshControlMasterDisabled :: Bool +sshControlMasterDisabled = unsafePerformIO $ readIORef _sshControlMasterDisabled + +#ifdef HAVE_HASKELL_ZLIB +type CRCWarningList = [FilePath] +{-# NOINLINE _crcWarningList #-} +_crcWarningList :: IORef CRCWarningList +_crcWarningList = unsafePerformIO $ newIORef [] + +addCRCWarning :: FilePath -> IO () +addCRCWarning fp = modifyIORef _crcWarningList (fp:) + +getCRCWarnings :: IO [FilePath] +getCRCWarnings = readIORef _crcWarningList + +resetCRCWarnings :: IO () +resetCRCWarnings = writeIORef _crcWarningList [] +#endif + +darcsdir :: String +darcsdir = "_darcs" diff --git a/src/Darcs/Gorsvet.hs b/src/Darcs/Gorsvet.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Gorsvet.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE CPP, FlexibleInstances #-} +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} + +-- Copyright (C) 2009 Petr Rockai +-- +-- Permission is hereby granted, free of charge, to any person +-- obtaining a copy of this software and associated documentation +-- files (the "Software"), to deal in the Software without +-- restriction, including without limitation the rights to use, copy, +-- modify, merge, publish, distribute, sublicense, and/or sell copies +-- of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be +-- included in all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +-- SOFTWARE. + +#include "gadts.h" + +module Darcs.Gorsvet where + +import Prelude hiding ( read, filter, writeFile, readFile ) + +-- darcs stuff +import ByteStringUtils( is_funky ) +import Darcs.Repository ( Repository, slurp_pending ) +import Darcs.Repository.Internal ( read_pending ) +import Darcs.External ( backupByCopying ) +import Darcs.Patch ( RepoPatch, Prim, hunk, canonize, binary, apply + , sort_coalesceFL, addfile, rmfile, adddir, rmdir, invert) +import Darcs.Ordered ( FL(..), (+>+) ) +import Darcs.Repository.Prefs ( filetype_function, FileType(..) ) +import Darcs.IO +import Darcs.Sealed ( Sealed(Sealed), seal ) +import Darcs.Patch( apply_to_filepaths ) +import Darcs.Patch.TouchesFiles ( choose_touching ) +import Darcs.Patch.FileName ( fn2fp ) + +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.ByteString.Char8 as BS +import Control.Monad.State.Strict +import System.Directory( removeFile, doesFileExist ) +import Data.Maybe +import Data.List( union ) + +import Darcs.Arguments ( DarcsFlag( LookForAdds, IgnoreTimes ) ) +import Darcs.RepoPath ( SubPath, sp2fn ) + +import Text.Regex( matchRegex ) +import Darcs.Repository.Prefs( boring_regexps ) + +import Storage.Hashed +import Storage.Hashed.Tree +import qualified Storage.Hashed.Index as I +import Storage.Hashed.AnchoredPath +import Storage.Hashed.Darcs( darcsFormatHash, darcsTreeHash ) +import Storage.Hashed.Monad + ( virtualTreeIO, hashedTreeIO, plainTreeIO + , unlink, rename, createDirectory, writeFile + , readFile -- ratify readFile: haskell_policy je natvrdlá + , cwd, tree, TreeIO ) +import Storage.Hashed + +floatFn = floatPath . fn2fp + +instance ReadableDirectory TreeIO where + mDoesDirectoryExist d = gets (\x -> isJust $ findTree (tree x) (floatFn d)) + mDoesFileExist f = gets (\x -> isJust $ findFile (tree x) (floatFn f)) + mInCurrentDirectory d action = do -- TODO bracket? + wd <- gets cwd + modify (\x -> x { cwd = floatFn d }) + x <- action + modify (\x -> x { cwd = wd }) + return x + mGetDirectoryContents = error "get dir contents" + mReadFilePS p = do x <- readFile (floatFn p) -- ratify readFile: ... + return $ BS.concat (BL.toChunks x) + +instance WriteableDirectory TreeIO where + mWithCurrentDirectory = mInCurrentDirectory + mSetFileExecutable _ _ = return () + mWriteFilePS p ps = writeFile -- ratify readFile: haskell_policy is stupid. + (floatFn p) (BL.fromChunks [ps]) + mCreateDirectory p = createDirectory (floatFn p) + mRename from to = rename (floatFn from) (floatFn to) + mRemoveDirectory = unlink . floatFn + mRemoveFile = unlink . floatFn + +treeDiff :: (FilePath -> FileType) -> Tree -> Tree -> IO (FL Prim C(x y)) +#ifdef GADT_WITNESSES +treeDiff = undefined -- Sigh. +#else +treeDiff ft t1 t2 = do + (from, to) <- diffTrees t1 t2 + diffs <- sequence $ zipTrees diff from to + return $ foldr (+>+) NilFL diffs + where diff :: AnchoredPath -> Maybe TreeItem -> Maybe TreeItem + -> IO (FL Prim) + diff _ (Just (SubTree _)) (Just (SubTree _)) = return NilFL + diff p (Just (SubTree _)) Nothing = + return $ rmdir (anchorPath "" p) :>: NilFL + diff p Nothing (Just (SubTree _)) = + return $ adddir (anchorPath "" p) :>: NilFL + diff p Nothing b'@(Just (File _)) = + do diff <- diff p (Just (File emptyBlob)) b' + return $ addfile (anchorPath "" p) :>: diff + diff p a'@(Just (File _)) Nothing = + do diff <- diff p a' (Just (File emptyBlob)) + return $ diff +>+ (rmfile (anchorPath "" p) :>: NilFL) + diff p (Just (File a')) (Just (File b')) = + do a <- read a' + b <- read b' + let path = anchorPath "" p + case ft path of + TextFile | no_bin a && no_bin b -> + return $ text_diff path a b + _ -> return $ if a /= b + then binary path (strict a) (strict b) :>: NilFL + else NilFL + diff p _ _ = fail $ "Missing case at path " ++ show p + text_diff p a b + | BL.null a && BL.null b = NilFL + | BL.null a = diff_from_empty p b + | BL.null b = diff_to_empty p a + | otherwise = line_diff p (lines a) (lines b) + line_diff p a b = canonize (hunk p 1 a b) + diff_to_empty p x | BL.last x == '\n' = line_diff p (init $ lines x) [] + | otherwise = line_diff p (lines x) [BS.empty] + diff_from_empty p x = invert (diff_to_empty p x) + no_bin = not . is_funky . strict . BL.take 4096 + lines = map strict . BL.split '\n' + strict = BS.concat . BL.toChunks +#endif + +readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO Tree +readRecordedAndPending repo = do + pristine <- readDarcsPristine "." + Sealed pending <- pendingChanges repo [] + (_, t) <- virtualTreeIO (apply [] pending) pristine + return t + +pendingChanges :: (RepoPatch p) => Repository p C(r u t) + -> [SubPath] -> IO (Sealed (FL Prim C(r))) +pendingChanges repo paths = do + slurp_pending repo -- XXX: only here to get us the "pending conflicts" check + -- that I don't know yet how to implement properly + Sealed pending <- read_pending repo + let files = map (fn2fp . sp2fn) paths + pre_files = apply_to_filepaths (invert pending) files + relevant = case paths of + [] -> seal pending + _ -> choose_touching pre_files pending + return relevant + +readIndex :: IO Tree +readIndex = I.readIndex "_darcs/index" darcsTreeHash + +unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t) + -> [SubPath] -> IO (FL Prim C(r y)) +unrecordedChanges opts repo paths = do + checkIndex repo + pristine <- readDarcsPristine "." + Sealed pending <- pendingChanges repo paths + (_, current') <- virtualTreeIO (apply [] pending) pristine + relevant <- restrictSubpaths repo paths + nonboring <- restrictBoring + + let current = relevant current' + working <- case (LookForAdds `elem` opts, IgnoreTimes `elem` opts) of + (False, False) -> do + all <- readIndex + expand (relevant all) + (False, True) -> do + guide <- expand current + all <- readPlainTree "." + return $ relevant $ (restrict guide) all + (True, _) -> do + all <- readPlainTree "." + return $ relevant $ nonboring all + + ft <- filetype_function + diff <- treeDiff ft current working + return $ sort_coalesceFL (pending +>+ diff) + +applyToTentativePristine _ patches = + do pristine <- readDarcsPristine "." + (_, tree) <- hashedTreeIO (apply [] patches) + pristine "_darcs/pristine.hashed" + BS.writeFile "_darcs/tentative_pristine" $ + BS.concat [BS.pack "pristine:" + , darcsFormatHash (fromJust $ treeHash tree)] + +applyToWorking :: (RepoPatch p) => Repository p C(r u t) + -> Sealed (FL Prim C(u)) -> IO Tree +applyToWorking _ (Sealed patches) = + do working <- readIndex + snd `fmap` plainTreeIO (apply [] patches) working "." + +filter_paths files = + \p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files + +restrict_paths files = if null files + then id + else filter $ filter_paths files + +restrict_subpaths = restrict_paths . map (floatPath . fn2fp . sp2fn) + +restrictSubpaths repo subpaths = do + Sealed pending <- read_pending repo + let paths = map (fn2fp . sp2fn) subpaths + paths' = paths `union` apply_to_filepaths pending paths + anchored = map floatPath paths' + return $ restrict_paths anchored + +restrictBoring = do + boring <- boring_regexps + let boring' (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False + boring' p _ = not $ any (\rx -> isJust $ matchRegex rx p') boring + where p' = anchorPath "" p + return $ filter boring' + +checkIndex repo = do + invalid <- doesFileExist "_darcs/index_invalid" + exist <- doesFileExist "_darcs/index" + when (not exist || invalid) $ updateIndex repo + when invalid $ removeFile "_darcs/index_invalid" + +updateIndex repo = do + pristine <- readRecordedAndPending repo >>= expand + I.updateIndexFrom "_darcs/index" darcsTreeHash pristine >>= expand + return () + +invalidateIndex _ = do + BS.writeFile "_darcs/index_invalid" BS.empty diff --git a/src/Darcs/Hopefully.hs b/src/Darcs/Hopefully.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Hopefully.hs @@ -0,0 +1,185 @@ +-- Copyright (C) 2006 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Hopefully ( Hopefully, PatchInfoAnd, + piap, n2pia, patchInfoAndPatch, + conscientiously, hopefully, info, + hopefullyM, createHashed, extractHash, + actually, unavailable ) where + +import System.IO.Unsafe ( unsafeInterleaveIO ) + +import Darcs.SignalHandler ( catchNonSignal ) +import Printer ( Doc, renderString, errorDoc, text, ($$) ) +import Darcs.Patch.Info ( PatchInfo, human_friendly, idpatchinfo ) +import Darcs.Patch ( RepoPatch, Named, patch2patchinfo ) +import Darcs.Patch.Prim ( Effect(..), Conflict(..) ) +import Darcs.Patch.Patchy ( Patchy, ReadPatch(..), Apply(..), Invert(..), + ShowPatch(..), Commute(..) ) +import Darcs.Ordered ( MyEq, unsafeCompare, (:>)(..), (:\/:)(..), (:/\:)(..) ) +import Darcs.Sealed ( Sealed(Sealed), seal, mapSeal ) +import Darcs.Utils ( prettyException ) + +-- | @'Hopefully' p C@ @(x y)@ is @'Either' String (p C@ @(x y))@ in a +-- form adapted to darcs patches. The @C@ @(x y)@ represents the type +-- witness for the patch that should be there. The @Hopefully@ type +-- just tells whether we expect the patch to be hashed or not, and +-- 'SimpleHopefully' does the real work of emulating +-- 'Either'. @Hopefully sh@ represents an expected unhashed patch, and +-- @Hashed hash sh@ represents an expected hashed patch with its hash. +data Hopefully a C(x y) = Hopefully (SimpleHopefully a C(x y)) | Hashed String (SimpleHopefully a C(x y)) + +-- | @SimpleHopefully@ is a variant of @Either String@ adapted for +-- type witnesses. @Actually@ is the equivalent of @Right@, while +-- @Unavailable@ is @Left@. +data SimpleHopefully a C(x y) = Actually (a C(x y)) | Unavailable String + +-- | @'PatchInfoAnd' p C(a b)@ represents a hope we have to get a +-- patch through its info. We're not sure we have the patch, but we +-- know its info. +data PatchInfoAnd p C(a b) = PIAP !PatchInfo (Hopefully (Named p) C(a b)) + +fmapH :: (a C(x y) -> b C(w z)) -> Hopefully a C(x y) -> Hopefully b C(w z) +fmapH f (Hopefully sh) = Hopefully (ff sh) + where ff (Actually a) = Actually (f a) + ff (Unavailable e) = Unavailable e +fmapH f (Hashed h sh) = Hashed h (ff sh) + where ff (Actually a) = Actually (f a) + ff (Unavailable e) = Unavailable e + +info :: PatchInfoAnd p C(a b) -> PatchInfo +info (PIAP i _) = i + +-- | @'piap' i p@ creates a PatchInfoAnd containing p with info i. +piap :: PatchInfo -> Named p C(a b) -> PatchInfoAnd p C(a b) +piap i p = PIAP i (Hopefully $ Actually p) + +-- | @n2pia@ creates a PatchInfoAnd represeting a @Named@ patch. +n2pia :: Named p C(x y) -> PatchInfoAnd p C(x y) +n2pia x = patch2patchinfo x `piap` x + +patchInfoAndPatch :: PatchInfo -> Hopefully (Named p) C(a b) -> PatchInfoAnd p C(a b) +patchInfoAndPatch = PIAP + +-- | @'hopefully' hp@ tries to get a patch from a 'PatchInfoAnd' +-- value. If it fails, it outputs an error \"failed to read patch: +-- \\". We get the description of the patch +-- from the info part of 'hp' +hopefully :: PatchInfoAnd p C(a b) -> Named p C(a b) +hopefully = conscientiously $ \e -> text "failed to read patch:" $$ e + +-- | @'conscientiously' er hp@ tries to extract a patch from a 'PatchInfoAnd'. +-- If it fails, it applies the error handling function @er@ to a description +-- of the patch info component of @hp@. +conscientiously :: (Doc -> Doc) + -> PatchInfoAnd p C(a b) -> Named p C(a b) +conscientiously er (PIAP pinf hp) = + case hopefully2either hp of + Right p -> p + Left e -> errorDoc $ er (human_friendly pinf $$ text e) + +-- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a +-- monad instead of erroring. +hopefullyM :: Monad m => PatchInfoAnd p C(a b) -> m (Named p C(a b)) +hopefullyM (PIAP pinf hp) = case hopefully2either hp of + Right p -> return p + Left e -> fail $ renderString (human_friendly pinf $$ text e) + +-- Any recommendations for a nice adverb to name the below? +hopefully2either :: Hopefully a C(x y) -> Either String (a C(x y)) +hopefully2either (Hopefully (Actually p)) = Right p +hopefully2either (Hashed _ (Actually p)) = Right p +hopefully2either (Hopefully (Unavailable e)) = Left e +hopefully2either (Hashed _ (Unavailable e)) = Left e + +actually :: a C(x y) -> Hopefully a C(x y) +actually = Hopefully . Actually + +createHashed :: String -> (String -> IO (Sealed (a C(x)))) -> IO (Sealed (Hopefully a C(x))) +createHashed h f = do mapSeal (Hashed h) `fmap` unsafeInterleaveIO (f' `catchNonSignal` handler) + where + f' = do Sealed x <- f h + return (Sealed (Actually x)) + handler e = return $ seal $ Unavailable $ prettyException e + +extractHash :: PatchInfoAnd p C(a b) -> Either (Named p C(a b)) String +extractHash (PIAP _ (Hashed s _)) = Right s +extractHash hp = Left $ conscientiously (\e -> text "unable to read patch:" $$ e) hp + +unavailable :: String -> Hopefully a C(x y) +unavailable = Hopefully . Unavailable + +instance MyEq p => MyEq (PatchInfoAnd p) where + unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2 + +--instance Invert (p C(x y)) => Invert (PatchInfoAnd (p C(x y))) where +instance Invert p => Invert (PatchInfoAnd p) where + identity = PIAP idpatchinfo (actually identity) + invert (PIAP i p) = PIAP i (invert `fmapH` p) + +instance (Conflict p, Effect p, ShowPatch p) => ShowPatch (PatchInfoAnd p) where + showPatch (PIAP n p) = case hopefully2either p of + Right x -> showPatch x + Left _ -> human_friendly n + showContextPatch s (PIAP n p) = case hopefully2either p of + Right x -> showContextPatch s x + Left _ -> human_friendly n + description (PIAP n _) = human_friendly n + summary (PIAP n p) = case hopefully2either p of + Right x -> summary x + Left _ -> human_friendly n + showNicely (PIAP n p) = case hopefully2either p of + Right x -> showNicely x + Left _ -> human_friendly n + +instance Commute p => Commute (PatchInfoAnd p) where + commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y) + return $ (info y `piap` y') :> (info x `piap` x') + list_touched_files = list_touched_files . hopefully + merge (x :\/: y) = case merge (hopefully x :\/: hopefully y) of + y' :/\: x' -> (info y `piap` y') :/\: (info x `piap` x') + +instance Apply p => Apply (PatchInfoAnd p) where + apply opts p = apply opts $ hopefully p + applyAndTryToFix p = do mp' <- applyAndTryToFix $ hopefully p + case mp' of + Nothing -> return Nothing + Just (e,p') -> return $ Just (e, n2pia p') + +instance ReadPatch p => ReadPatch (PatchInfoAnd p) where + readPatch' wanteof = do x <- readPatch' wanteof + case x of + Just (Sealed p) -> return $ Just $ Sealed $ n2pia p + Nothing -> return Nothing + +instance Effect p => Effect (PatchInfoAnd p) where + effect = effect . hopefully + effectRL = effectRL . hopefully + +instance Conflict p => Conflict (PatchInfoAnd p) where + list_conflicted_files = list_conflicted_files . hopefully + resolve_conflicts = resolve_conflicts . hopefully + commute_no_conflicts (x:>y) = do y':>x' <- commute_no_conflicts (hopefully x :> hopefully y) + return (info y `piap` y' :> info x `piap` x') + conflictedEffect = conflictedEffect . hopefully + +instance RepoPatch p => Patchy (PatchInfoAnd p) diff --git a/src/Darcs/IO.hs b/src/Darcs/IO.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/IO.hs @@ -0,0 +1,249 @@ +-- Copyright (C) 2005 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -fglasgow-exts #-} +module Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..), + TolerantIO, runTolerantly, runSilently, + ) where + +import Prelude hiding ( catch ) +import Data.Char ( toLower ) +import Data.List ( isSuffixOf ) +import System.IO.Error ( isDoesNotExistError, isPermissionError ) +import Control.Exception ( catch, catchJust, ioErrors ) +import Control.Monad.Error +import System.Directory ( getDirectoryContents, createDirectory, + removeDirectory, removeFile, + renameFile, renameDirectory, + doesDirectoryExist, doesFileExist, + ) + +import ByteStringUtils ( linesPS, unlinesPS) +import qualified Data.ByteString as B (ByteString, empty, null, readFile) +import qualified Data.ByteString.Char8 as BC (unpack, pack) + +import Darcs.Utils ( withCurrentDirectory, prettyException ) +import Darcs.External ( backupByCopying, backupByRenaming ) +import Printer ( Doc, renderPS ) +import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn ) +import Darcs.Lock ( writeBinFile, readBinFile, writeAtomicFilePS ) +import Workaround ( setExecutable ) + +class (Functor m, MonadPlus m) => ReadableDirectory m where + mDoesDirectoryExist :: FileName -> m Bool + mDoesFileExist :: FileName -> m Bool + mInCurrentDirectory :: FileName -> m a -> m a + mGetDirectoryContents :: m [FileName] + mReadBinFile :: FileName -> m String + mReadBinFile f = liftM BC.unpack $ mReadFilePS f + mReadFilePS :: FileName -> m B.ByteString + mReadFilePSs :: FileName -> m [B.ByteString] + mReadFilePSs f = linesPS `liftM` mReadFilePS f + +class ReadableDirectory m => WriteableDirectory m where + mWithCurrentDirectory :: FileName -> m a -> m a + mSetFileExecutable :: FileName -> Bool -> m () + mWriteBinFile :: FileName -> String -> m () + mWriteBinFile fn s = mWriteFilePS fn $ BC.pack s + mWriteFilePS :: FileName -> B.ByteString -> m () + mWriteFilePSs :: FileName -> [B.ByteString] -> m () + mWriteFilePSs f ss = mWriteFilePS f (unlinesPS ss) + mCreateDirectory :: FileName -> m () + mRemoveDirectory :: FileName -> m () + mWriteDoc :: FileName -> Doc -> m () + mWriteDoc f d = mWriteFilePS f (renderPS d) + mCreateFile :: FileName -> m () + mCreateFile f = mWriteFilePS f B.empty + mRemoveFile :: FileName -> m () + mRename :: FileName -> FileName -> m () + mModifyFilePS :: FileName -> (B.ByteString -> m B.ByteString) -> m () + mModifyFilePS f j = do ps <- mReadFilePS f + ps' <- j ps + mWriteFilePS f ps' + mModifyFilePSs :: FileName -> ([B.ByteString] -> m [B.ByteString]) -> m () + mModifyFilePSs f j = do ps <- mReadFilePSs f + ps' <- j ps + mWriteFilePSs f ps' + +instance ReadableDirectory IO where + mDoesDirectoryExist = doesDirectoryExist . fn2fp + mDoesFileExist = doesFileExist . fn2fp + mInCurrentDirectory = withCurrentDirectory . fn2fp + mGetDirectoryContents = map fp2fn `liftM` getDirectoryContents "." + mReadBinFile = readBinFile . fn2fp + mReadFilePS = B.readFile . fn2fp + +instance WriteableDirectory IO where + mWithCurrentDirectory = mInCurrentDirectory + mSetFileExecutable = setExecutable . fn2fp + mWriteBinFile = writeBinFile . fn2fp + mWriteFilePS = writeAtomicFilePS . fn2fp + mCreateDirectory = createDirectory . fn2fp + mCreateFile f = do exf <- mDoesFileExist f + if exf then fail $ "File '"++fn2fp f++"' already exists!" + else do exd <- mDoesDirectoryExist f + if exd then fail $ "File '"++fn2fp f++"' already exists!" + else mWriteFilePS f B.empty + mRemoveFile f = do let fp = fn2fp f + x <- B.readFile fp + when (not $ B.null x) $ + fail $ "Cannot remove non-empty file "++fp + removeFile fp + mRemoveDirectory = removeDirectory . fn2fp + mRename a b = catchJust ioErrors + (renameDirectory x y `mplus` renameFile x y) + -- We need to catch does not exist errors, since older + -- versions of darcs allowed users to rename nonexistent + -- files. :( + (\e -> if isDoesNotExistError e + then return () + else ioError e) + where x = fn2fp a + y = fn2fp b + +class Monad m => TolerantMonad m where + warning :: IO () -> m () + runIO :: m a -> IO a + runTM :: IO a -> m a + +newtype TolerantIO a = TIO { runTolerantly :: IO a } +instance TolerantMonad TolerantIO where + warning io = TIO $ io `catch` \e -> putStrLn $ "Warning: " ++ prettyException e + runIO (TIO io) = io + runTM io = TIO io + +newtype SilentIO a = SIO { runSilently :: IO a } +instance TolerantMonad SilentIO where + warning io = SIO $ io `catch` \_ -> return () + runIO (SIO io) = io + runTM io = SIO io + +-- NOTE: The following instance declarations are duplicated merely to avoid +-- enabling -fallow-undecidable-instances. If we used +-- -fallow-undecidable-instances, we would write instead: + +-- instance TolerantMonad m => Monad m where +-- ... + +-- etc. +instance Functor TolerantIO where + fmap f m = m >>= return . f + +instance Monad TolerantIO where + f >>= g = runTM $ runIO f >>= runIO . g + f >> g = runTM $ runIO f >> runIO g + fail s = runTM $ fail s + return x = runTM $ return x + +instance Functor SilentIO where + fmap f m = m >>= return . f + +instance Monad SilentIO where + f >>= g = runTM $ runIO f >>= runIO . g + f >> g = runTM $ runIO f >> runIO g + fail s = runTM $ fail s + return x = runTM $ return x + +instance MonadPlus TolerantIO where + mzero = runTM mzero + mplus a b = runTM (mplus (runIO a) (runIO b)) +instance MonadPlus SilentIO where + mzero = runTM mzero + mplus a b = runTM (mplus (runIO a) (runIO b)) + +instance ReadableDirectory TolerantIO where + mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d + mDoesFileExist f = runTM $ mDoesFileExist f + mInCurrentDirectory i j = runTM $ mInCurrentDirectory i (runIO j) + mGetDirectoryContents = runTM mGetDirectoryContents + mReadBinFile f = runTM $ mReadBinFile f + mReadFilePS f = runTM $ mReadFilePS f +instance ReadableDirectory SilentIO where + mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d + mDoesFileExist f = runTM $ mDoesFileExist f + mInCurrentDirectory i j = runTM $ mInCurrentDirectory i (runIO j) + mGetDirectoryContents = runTM mGetDirectoryContents + mReadBinFile f = runTM $ mReadBinFile f + mReadFilePS f = runTM $ mReadFilePS f + +instance WriteableDirectory TolerantIO where + mWithCurrentDirectory = mInCurrentDirectory + mSetFileExecutable f e = warning $ mSetFileExecutable f e + mWriteBinFile f s = warning $ mWriteBinFile f s + mWriteFilePS f s = warning $ mWriteFilePS f s + mCreateFile f = warning $ backup f >> mWriteFilePS f B.empty + mCreateDirectory d = warning $ backup d >> mCreateDirectory d + mRemoveFile f = warning $ mRemoveFile f + mRemoveDirectory d = warning $ catchJust ioErrors + (mRemoveDirectory d) + (\e -> + if "(Directory not empty)" `isSuffixOf` show e + then ioError $ userError $ + "Not deleting " ++ fn2fp d ++ " because it is not empty." + else ioError $ userError $ + "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e) + mRename a b = warning $ catchJust ioErrors + (let do_backup = if (map toLower x == map toLower y) + then backupByCopying y -- avoid making the original vanish + else backupByRenaming y + in do_backup >> mRename a b) + (\e -> case () of + _ | isPermissionError e -> ioError $ userError $ + couldNotRename ++ "." + | isDoesNotExistError e -> ioError $ userError $ + couldNotRename ++ " because " ++ x ++ " does not exist." + | otherwise -> ioError e + ) + where + x = fn2fp a + y = fn2fp b + couldNotRename = "Could not rename " ++ x ++ " to " ++ y +instance WriteableDirectory SilentIO where + mWithCurrentDirectory = mInCurrentDirectory + mSetFileExecutable f e = warning $ mSetFileExecutable f e + mWriteBinFile f s = warning $ mWriteBinFile f s + mWriteFilePS f s = warning $ mWriteFilePS f s + mCreateFile f = warning $ backup f >> mWriteFilePS f B.empty + mCreateDirectory d = warning $ backup d >> mCreateDirectory d + mRemoveFile f = warning $ mRemoveFile f + mRemoveDirectory d = warning $ catchJust ioErrors + (mRemoveDirectory d) + (\e -> + if "(Directory not empty)" `isSuffixOf` show e + then ioError $ userError $ + "Not deleting " ++ fn2fp d ++ " because it is not empty." + else ioError $ userError $ + "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e) + mRename a b = warning $ catchJust ioErrors + (let do_backup = if (map toLower x == map toLower y) + then backupByCopying y -- avoid making the original vanish + else backupByRenaming y + in do_backup >> mRename a b) + (\e -> case () of + _ | isPermissionError e -> ioError $ userError $ + couldNotRename ++ "." + | isDoesNotExistError e -> ioError $ userError $ + couldNotRename ++ " because " ++ x ++ " does not exist." + | otherwise -> ioError e + ) + where + x = fn2fp a + y = fn2fp b + couldNotRename = "Could not rename " ++ x ++ " to " ++ y + +backup :: FileName -> IO () +backup f = backupByRenaming $ fn2fp f diff --git a/src/Darcs/Lock.hs b/src/Darcs/Lock.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Lock.hs @@ -0,0 +1,333 @@ +-- Copyright (C) 2003 David Roundy +-- +-- 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 CPP, ForeignFunctionInterface #-} + +module Darcs.Lock ( withLock, withLockCanFail, + withTemp, withOpenTemp, withStdoutTemp, + withTempDir, withPermDir, withDelayedDir, withNamedTemp, + writeToFile, appendToFile, + writeBinFile, writeDocBinFile, appendBinFile, appendDocBinFile, + readBinFile, readDocBinFile, + writeAtomicFilePS, + gzWriteAtomicFilePS, gzWriteAtomicFilePSs, gzWriteDocFile, + rm_recursive, removeFileMayNotExist, + canonFilename, maybeRelink, + world_readable_temp, tempdir_loc, + environmentHelpTmpdir, environmentHelpKeepTmpdir + ) where + +import Prelude hiding ( catch ) +import Data.List ( inits ) +import Data.Maybe ( isJust, listToMaybe ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.IO ( openBinaryFile, openBinaryTempFile, + hClose, hPutStr, Handle, + IOMode(WriteMode, AppendMode), hFlush, stdout ) +import System.IO.Error ( isDoesNotExistError, isAlreadyExistsError ) +import Control.Exception ( bracket, catchJust, ioErrors, throwIO, + Exception(IOException), catch, try ) +import System.Directory ( removeFile, removeDirectory, + doesFileExist, doesDirectoryExist, + getDirectoryContents, createDirectory, + getTemporaryDirectory, + ) +import System.FilePath.Posix ( splitDirectories ) +import Workaround ( renameFile ) +import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO ) +import Control.Monad ( unless, when ) + +import Darcs.URL ( is_relative ) +import Darcs.Utils ( catchall, add_to_error_loc ) +import Darcs.RepoPath ( AbsolutePath, FilePathLike, toFilePath, + getCurrentDirectory, setCurrentDirectory ) + +import ByteStringUtils ( gzWriteFilePSs) +import qualified Data.ByteString as B (null, readFile, hPut, ByteString) +import qualified Data.ByteString.Char8 as BC (unpack) + +import Darcs.SignalHandler ( withSignalsBlocked ) +import Printer ( Doc, hPutDoc, packedString, empty, renderPSs ) +import Darcs.Global ( atexit, darcsdir ) +import Darcs.Compat ( mk_stdout_temp, canonFilename, maybeRelink, + atomic_create, sloppy_atomic_create ) +import System.Posix.Files ( getSymbolicLinkStatus, isDirectory, + fileMode, getFileStatus, setFileMode ) +import System.Posix ( sleep ) +#include "impossible.h" + +withLock :: String -> IO a -> IO a +releaseLock :: String -> IO () + +withLock s job = bracket (getlock s 30) releaseLock (\_ -> job) + +-- | Tries to perform some task if it can obtain the lock, +-- Otherwise, just gives up without doing the task +withLockCanFail :: String -> IO a -> IO (Either () a) +withLockCanFail s job = + bracket (takeLock s) + (\l -> if l then releaseLock s else return ()) + (\l -> if l then job >>= (return.Right) + else return $ Left ()) + +getlock :: String -> Int -> IO String +getlock l 0 = do putStrLn $ "Couldn't get lock "++l + exitWith $ ExitFailure 1 +getlock lbad tl = do l <- canonFilename lbad + gotit <- takeLock l + if gotit then return l + else do putStrLn $ "Waiting for lock "++l + hFlush stdout -- for Windows + done <- sleep 2 + if done == 0 + then getlock l (tl - 1) + else getlock l 0 + +removeFileMayNotExist :: FilePathLike p => p -> IO () +removeFileMayNotExist f = catchNonExistence (removeFile $ toFilePath f) () + +catchNonExistence :: IO a -> a -> IO a +catchNonExistence job nonexistval = + catchJust ioErrors job $ + \e -> if isDoesNotExistError e then return nonexistval + else ioError e + +releaseLock s = removeFileMayNotExist s + +takeLock :: FilePathLike p => p -> IO Bool +takeLock fp = + do atomic_create $ toFilePath fp + return True + `catch` \e -> case e of + IOException e' + | isAlreadyExistsError e' -> + return False + _ -> do pwd <- getCurrentDirectory + throwIO $ add_to_error_loc e + ("takeLock "++toFilePath fp++" in "++toFilePath pwd) + +takeFile :: FilePath -> IO Bool +takeFile fp = + do sloppy_atomic_create fp + return True + `catch` \e -> case e of + IOException e' + | isAlreadyExistsError e' -> + return False + _ -> do pwd <- getCurrentDirectory + throwIO $ add_to_error_loc e + ("takeFile "++fp++" in "++toFilePath pwd) + +-- |'withTemp' safely creates an empty file (not open for writing) and +-- returns its name. +-- +-- The temp file operations are rather similar to the locking operations, in +-- that they both should always try to clean up, so exitWith causes trouble. +withTemp :: (String -> IO a) -> IO a +withTemp = bracket get_empty_file removeFileMayNotExist + where get_empty_file = do (f,h) <- openBinaryTempFile "." "darcs" + hClose h + return f + +-- |'withOpenTemp' creates an already open temporary +-- file. Both of them run their argument and then delete the file. Also, +-- both of them (to my knowledge) are not susceptible to race conditions on +-- the temporary file (as long as you never delete the temporary file; that +-- would reintroduce a race condition). +withOpenTemp :: ((Handle, String) -> IO a) -> IO a +withOpenTemp = bracket get_empty_file cleanup + where cleanup (h,f) = do try $ hClose h + removeFileMayNotExist f + get_empty_file = invert `fmap` openBinaryTempFile "." "darcs" + invert (a,b) = (b,a) + +withStdoutTemp :: (String -> IO a) -> IO a +withStdoutTemp = bracket (mk_stdout_temp "stdout_") removeFileMayNotExist + +tempdir_loc :: IO FilePath +tempdir_loc = firstJustIO [ readBinFile (darcsdir++"/prefs/tmpdir") >>= return . Just . head.words >>= chkdir, + maybeGetEnv "DARCS_TMPDIR" >>= chkdir, + getTemporaryDirectory >>= chkdir . Just, + getCurrentDirectorySansDarcs, + return $ Just "." -- always returns a Just + ] + >>= return . fromJust + where chkdir Nothing = return Nothing + chkdir (Just d) = doesDirectoryExist d >>= return . \e -> if e then Just (d++"/") else Nothing + +environmentHelpTmpdir :: ([String], [String]) +environmentHelpTmpdir = (["DARCS_TMPDIR", "TMPDIR"], [ + "Darcs often creates temporary directories. For example, the `darcs", + "diff' command creates two for the working trees to be diffed. By", + "default temporary directories are created in /tmp, or if that doesn't", + "exist, in _darcs (within the current repo). This can be overridden by", + "specifying some other directory in the file _darcs/prefs/tmpdir or the", + "environment variable $DARCS_TMPDIR or $TMPDIR."]) + +getCurrentDirectorySansDarcs :: IO (Maybe FilePath) +getCurrentDirectorySansDarcs = do + c <- getCurrentDirectory + return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits $ toFilePath c + where no_darcs x = not $ darcsdir `elem` splitDirectories x + +data WithDirKind = Perm | Temp | Delayed + +withDir :: WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a +withDir _ "" _ = bug "withDir called with empty directory name" +withDir kind abs_or_relative_name job = do + absolute_name <- if is_relative abs_or_relative_name + then fmap (++ abs_or_relative_name) tempdir_loc + else return abs_or_relative_name + formerdir <- getCurrentDirectory + bracket (create_directory absolute_name 0) + (\dir -> do setCurrentDirectory formerdir + k <- keep_tmpdir + unless k $ do case kind of + Perm -> return () + Temp -> rm_recursive (toFilePath dir) + Delayed -> atexit $ rm_recursive (toFilePath dir)) + job + where newname name 0 = name + newname name n = name ++ "-" ++ show n + create_directory :: FilePath -> Int -> IO AbsolutePath + create_directory name n + = do createDirectory $ newname name n + setCurrentDirectory $ newname name n + getCurrentDirectory + `catch` (\e -> case e of + IOException e' + | isAlreadyExistsError e' -> + create_directory name (n+1) + _ -> throwIO e) + keep_tmpdir = isJust `fmap` maybeGetEnv "DARCS_KEEP_TMPDIR" + +environmentHelpKeepTmpdir :: ([String], [String]) +environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[ + "If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will", + "not remove the temporary directories it creates. This is intended", + "primarily for debugging Darcs itself, but it can also be useful, for", + "example, to determine why your test preference (see `darcs setpref')", + "is failing when you run `darcs record', but working when run manually."]) + +-- |'withPermDir' is like 'withTempDir', except that it doesn't +-- delete the directory afterwards. +withPermDir :: String -> (AbsolutePath -> IO a) -> IO a +withPermDir = withDir Perm + +-- |'withTempDir' creates an empty directory and then removes it when it +-- is no longer needed. withTempDir creates a temporary directory. The +-- location of that directory is determined by the contents of +-- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if +-- that doesn't exist then whatever your operating system considers to be a +-- a temporary directory (e.g. @$TMPDIR@ under Unix, @$TEMP@ under +-- Windows). +-- +-- If none of those exist it creates the temporary directory +-- in the current directory, unless the current directory is under a _darcs +-- directory, in which case the temporary directory in the parent of the highest +-- _darcs directory to avoid accidentally corrupting darcs's internals. +-- This should not fail, but if it does indeed fail, we go ahead and use the +-- current directory anyway. If @$DARCS_KEEP_TMPDIR@ variable is set +-- temporary directory is not removed, this can be useful for debugging. +withTempDir :: String -> (AbsolutePath -> IO a) -> IO a +withTempDir = withDir Temp + +withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a +withDelayedDir = withDir Delayed + +doesDirectoryReallyExist :: FilePath -> IO Bool +doesDirectoryReallyExist f = + catchNonExistence (isDirectory `fmap` getSymbolicLinkStatus f) False + +rm_recursive :: FilePath -> IO () +rm_recursive d = + do isd <- doesDirectoryReallyExist d + if not isd + then removeFile d + else when isd $ do conts <- actual_dir_contents + withCurrentDirectory d $ + mapM_ rm_recursive conts + removeDirectory d + where actual_dir_contents = -- doesn't include . or .. + do c <- getDirectoryContents d + return $ filter (/=".") $ filter (/="..") c + +world_readable_temp :: String -> IO String +world_readable_temp f = wrt 0 + where wrt :: Int -> IO String + wrt 100 = fail $ "Failure creating temp named "++f + wrt n = let f_new = f++"-"++show n + in do ok <- takeFile f_new + if ok then do atexit $ removeFileMayNotExist f_new + return f_new + else wrt (n+1) + +withNamedTemp :: String -> (String -> IO a) -> IO a +withNamedTemp n = bracket get_empty_file removeFileMayNotExist + where get_empty_file = world_readable_temp n + +readBinFile :: FilePathLike p => p -> IO String +readBinFile = fmap BC.unpack . B.readFile . toFilePath + +readDocBinFile :: FilePathLike p => p -> IO Doc +readDocBinFile fp = do ps <- B.readFile $ toFilePath fp + return $ if B.null ps then empty else packedString ps + +appendBinFile :: FilePathLike p => p -> String -> IO () +appendBinFile f s = appendToFile f $ \h -> hPutStr h s + +appendDocBinFile :: FilePathLike p => p -> Doc -> IO () +appendDocBinFile f d = appendToFile f $ \h -> hPutDoc h d + +writeBinFile :: FilePathLike p => p -> String -> IO () +writeBinFile f s = writeToFile f $ \h -> hPutStr h s + +writeDocBinFile :: FilePathLike p => p -> Doc -> IO () +writeDocBinFile f d = writeToFile f $ \h -> hPutDoc h d + +writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO () +writeAtomicFilePS f ps = writeToFile f $ \h -> B.hPut h ps + +gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO () +gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps] + +gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO () +gzWriteAtomicFilePSs f pss = + withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do + gzWriteFilePSs newf pss + already_exists <- doesFileExist $ toFilePath f + when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f) + setFileMode newf mode + `catchall` return () + renameFile newf (toFilePath f) + +gzWriteDocFile :: FilePathLike p => p -> Doc -> IO () +gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs d + +writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO () +writeToFile f job = + withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do + bracket (openBinaryFile newf WriteMode) hClose job + already_exists <- doesFileExist (toFilePath f) + when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f) + setFileMode newf mode + `catchall` return () + renameFile newf (toFilePath f) + +appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO () +appendToFile f job = withSignalsBlocked $ + bracket (openBinaryFile (toFilePath f) AppendMode) hClose job diff --git a/src/Darcs/Match.lhs b/src/Darcs/Match.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Match.lhs @@ -0,0 +1,568 @@ +% Copyright (C) 2004-2005 David Roundy +% +% 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. + +\begin{code} +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, Rank2Types #-} + +#include "gadts.h" + +module Darcs.Match ( match_first_patchset, match_second_patchset, + match_patch, + match_a_patch, match_a_patchread, + get_first_match, get_nonrange_match, + get_partial_first_match, get_partial_second_match, + get_partial_nonrange_match, + first_match, second_match, have_nonrange_match, + have_patchset_match, get_one_patchset, + checkMatchSyntax, + ) where + +import Text.Regex ( mkRegex, matchRegex ) +import Control.Monad ( when ) +import Data.Maybe ( isJust ) + +import Darcs.Hopefully ( PatchInfoAnd, info, piap, + conscientiously, hopefully ) +import Darcs.Patch.Info ( just_name ) +import Darcs.Patch ( RepoPatch, Patch, Patchy, Named, invert, invertRL, patch2patchinfo, apply ) +import Darcs.Repository ( Repository, PatchSet, SealedPatchSet, read_repo, + slurp_recorded, createPristineDirectoryTree ) +import Darcs.Repository.ApplyPatches ( apply_patches ) +import Darcs.Patch.Depends ( get_patches_in_tag, get_patches_beyond_tag ) +import Darcs.Ordered ( RL(..), concatRL, consRLSealed ) + +import ByteStringUtils ( mmapFilePS ) +import qualified Data.ByteString as B (ByteString) + +import Darcs.Flags ( DarcsFlag( OnePatch, SeveralPatch, Context, + StoreInMemory, + AfterPatch, UpToPatch, LastN, PatchIndexRange, + OneTag, AfterTag, UpToTag, + OnePattern, SeveralPattern, + AfterPattern, UpToPattern ) ) +import Darcs.Patch.Bundle ( scan_context ) +import Darcs.Patch.Match ( Matcher, MatchFun, match_pattern, apply_matcher, make_matcher, parseMatch ) +import Darcs.Patch.MatchData ( PatchMatch ) +import Printer ( text, ($$) ) + +import Darcs.RepoPath ( toFilePath ) +import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) ) +import Darcs.SlurpDirectory ( SlurpMonad, writeSlurpy, withSlurpy ) +import Darcs.Patch.FileName ( FileName, super_name, norm_path, (///) ) +import Darcs.Sealed ( FlippedSeal(..), Sealed2(..), + seal, flipSeal, seal2, unsealFlipped, unseal2, unseal ) +#include "impossible.h" +\end{code} + +\paragraph{Selecting patches}\label{selecting} + +Many commands operate on a patch or patches that have already been recorded. +There are a number of options that specify which patches are selected for +these operations: \verb!--patch!, \verb!--match!, \verb!--tag!, and variants +on these, which for \verb!--patch! are \verb!--patches!, +\verb!--from-patch!, and \verb!--to-patch!. The \verb!--patch! and +\verb!--tag! forms simply take (POSIX extended, aka \verb!egrep!) regular +expressions and match them against tag and patch names. \verb!--match!, +described below, allows more powerful patterns. + +The plural forms of these options select all matching patches. The singular +forms select the last matching patch. The range (from and to) forms select +patches after or up to (both inclusive) the last matching patch. + +These options use the current order of patches in the repository. darcs may +reorder patches, so this is not necessarily the order of creation or the +order in which patches were applied. However, as long as you are just +recording patches in your own repository, they will remain in order. + +% NOTE --no-deps is implemented in SelectChanges.lhs, but documented here +% for concistency. +When a patch or a group of patches is selected, all patches they depend on +get silently selected too. For example: \verb!darcs pull --patches bugfix! +means ``pull all the patches with `bugfix' in their name, along with any +patches they require.'' If you really only want patches with `bugfix' in +their name, you should use the \verb!--no-deps! option, which makes darcs +exclude any matched patches from the selection which have dependencies that +are themselves not explicitly matched by the selection. + +For \verb!unrecord!, \verb!unpull! and \verb!obliterate!, patches that +depend on the selected patches are silently included, or if +\verb!--no-deps! is used selected patches with dependencies on not selected +patches are excluded from the selection. + +\begin{code} +data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq + +-- | @have_nonrange_match flags@ tells whether there is a flag in +-- @flags@ which corresponds to a match that is "non-range". Thus, +-- @--match@, @--patch@ and @--index@ make @have_nonrange_match@ +-- true, but not @--from-patch@ or @--to-patch@. +have_nonrange_match :: [DarcsFlag] -> Bool +have_nonrange_match fs = isJust (has_index_range fs) || isJust (nonrange_matcher fs::Maybe (Matcher Patch)) + +-- | @have_patchset_match flags@ tells whether there is a "patchset +-- match" in the flag list. A patchset match is @--match@ or +-- @--patch@, or @--context@, but not @--from-patch@ nor (!) +-- @--index@. +-- Question: Is it supposed not to be a subset of @have_nonrange_match@? +have_patchset_match :: [DarcsFlag] -> Bool +have_patchset_match fs = isJust (nonrange_matcher fs::Maybe (Matcher Patch)) || hasC fs + where hasC [] = False + hasC (Context _:_) = True + hasC (_:xs) = hasC xs + +get_nonrange_match :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO () +get_nonrange_match r fs = withRecordedMatchSmart fs r (get_nonrange_match_s fs) + +get_partial_nonrange_match :: RepoPatch p => Repository p C(r u t) + -> [DarcsFlag] -> [FileName] -> IO () +get_partial_nonrange_match r fs files = + withRecordedMatchOnlySomeSmart fs r files (get_nonrange_match_s fs) + +get_nonrange_match_s :: (MatchMonad m p, RepoPatch p) => + [DarcsFlag] -> PatchSet p C(x) -> m () +get_nonrange_match_s fs repo = + case nonrange_matcher fs of + Just m -> if nonrange_matcher_is_tag fs + then get_tag_s m repo + else get_matcher_s Exclusive m repo + Nothing -> fail "Pattern not specified in get_nonrange_match." + +-- | @first_match fs@ tells whether @fs@ implies a "first match", that +-- is if we match against patches from a point in the past on, rather +-- than against all patches since the creation of the repository. +first_match :: [DarcsFlag] -> Bool +first_match fs = isJust (has_lastn fs) + || isJust (first_matcher fs::Maybe (Matcher Patch)) + || isJust (has_index_range fs) + +get_first_match :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO () +get_first_match r fs = withRecordedMatchSmart fs r (get_first_match_s fs) + +get_partial_first_match :: RepoPatch p => Repository p C(r u t) + -> [DarcsFlag] -> [FileName] -> IO () +get_partial_first_match r fs files = + withRecordedMatchOnlySomeSmart fs r files (get_first_match_s fs) + +get_first_match_s :: (MatchMonad m p, RepoPatch p) => + [DarcsFlag] -> PatchSet p C(x) -> m () +get_first_match_s fs repo = + case has_lastn fs of + Just n -> applyInvRL `unsealFlipped` (safetake n $ concatRL repo) + Nothing -> case first_matcher fs of + Nothing -> fail "Pattern not specified in get_first_match." + Just m -> if first_matcher_is_tag fs + then get_tag_s m repo + else get_matcher_s Inclusive m repo + + +-- | @second_match fs@ tells whether @fs@ implies a "second match", that +-- is if we match against patches up to a point in the past on, rather +-- than against all patches until now. +second_match :: [DarcsFlag] -> Bool +second_match fs = isJust (second_matcher fs::Maybe (Matcher Patch)) || isJust (has_index_range fs) + +get_partial_second_match :: RepoPatch p => Repository p C(r u t) + -> [DarcsFlag] -> [FileName] -> IO () +get_partial_second_match r fs files = + withRecordedMatchOnlySomeSmart fs r files $ \repo -> + case second_matcher fs of + Nothing -> fail "Two patterns not specified in get_second_match." + Just m -> if second_matcher_is_tag fs + then get_tag_s m repo + else get_matcher_s Exclusive m repo + +checkMatchSyntax :: [DarcsFlag] -> IO () +checkMatchSyntax opts = do + case get_match_pattern opts of + Nothing -> return () + Just p -> either fail (const $ return ()) $ (parseMatch p::Either String (MatchFun Patch)) + +get_match_pattern :: [DarcsFlag] -> Maybe PatchMatch +get_match_pattern [] = Nothing +get_match_pattern (OnePattern m:_) = Just m +get_match_pattern (SeveralPattern m:_) = Just m +get_match_pattern (_:fs) = get_match_pattern fs + +tagmatch :: String -> Matcher p +tagmatch r = make_matcher ("tag-name "++r) tm + where tm (Sealed2 p) = + let n = just_name (info p) in + take 4 n == "TAG " && isJust (matchRegex (mkRegex r) $ drop 4 n) + +mymatch :: String -> Matcher p +mymatch r = make_matcher ("patch-name "++r) mm + where mm (Sealed2 p) = isJust . matchRegex (mkRegex r) . just_name . info $ p + + +-- | strictJust is a strict version of the Just constructor, used to ensure +-- that if we claim we've got a pattern match, that the pattern will +-- actually match (rathern than fail to compile properly). +-- +-- /First matcher, Second matcher and Nonrange matcher/ +-- +-- When we match for patches, we have a PatchSet, of which we want a +-- subset. This subset is formed by the patches in a given interval +-- which match a given criterion. If we represent time going left to +-- right (which means the 'PatchSet' is written right to left), then +-- we have (up to) three 'Matcher's: the 'nonrange_matcher' is the +-- criterion we use to select among patches in the interval, the +-- 'first_matcher' is the left bound of the interval, and the +-- 'last_matcher' is the right bound. Each of these matchers can be +-- present or not according to the options. +strictJust :: a -> Maybe a +strictJust x = Just $! x + +-- | @nonrange_matcher@ is the criterion that is used to match against +-- patches in the interval. It is 'Just m' when the @--patch@, @--match@, +-- @--tag@ options are passed (or their plural variants). +nonrange_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p) +nonrange_matcher [] = Nothing +nonrange_matcher (OnePattern m:_) = strictJust $ match_pattern m +nonrange_matcher (OneTag t:_) = strictJust $ tagmatch t +nonrange_matcher (OnePatch p:_) = strictJust $ mymatch p +nonrange_matcher (SeveralPattern m:_) = strictJust $ match_pattern m +nonrange_matcher (SeveralPatch p:_) = strictJust $ mymatch p +nonrange_matcher (_:fs) = nonrange_matcher fs + +-- | @nonrange_matcher_is_tag@ returns true if the matching option was +-- '--tag' +nonrange_matcher_is_tag :: [DarcsFlag] -> Bool +nonrange_matcher_is_tag [] = False +nonrange_matcher_is_tag (OneTag _:_) = True +nonrange_matcher_is_tag (_:fs) = nonrange_matcher_is_tag fs + +-- | @first_matcher@ returns the left bound of the matched interval. +-- This left bound is also specified when we use the singular versions +-- of @--patch@, @--match@ and @--tag@. Otherwise, @first_matcher@ +-- returns @Nothing@. +first_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p) +first_matcher [] = Nothing +first_matcher (OnePattern m:_) = strictJust $ match_pattern m +first_matcher (AfterPattern m:_) = strictJust $ match_pattern m +first_matcher (AfterTag t:_) = strictJust $ tagmatch t +first_matcher (OnePatch p:_) = strictJust $ mymatch p +first_matcher (AfterPatch p:_) = strictJust $ mymatch p +first_matcher (_:fs) = first_matcher fs + +first_matcher_is_tag :: [DarcsFlag] -> Bool +first_matcher_is_tag [] = False +first_matcher_is_tag (AfterTag _:_) = True +first_matcher_is_tag (_:fs) = first_matcher_is_tag fs + +second_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p) +second_matcher [] = Nothing +second_matcher (OnePattern m:_) = strictJust $ match_pattern m +second_matcher (UpToPattern m:_) = strictJust $ match_pattern m +second_matcher (OnePatch p:_) = strictJust $ mymatch p +second_matcher (UpToPatch p:_) = strictJust $ mymatch p +second_matcher (UpToTag t:_) = strictJust $ tagmatch t +second_matcher (_:fs) = second_matcher fs + +second_matcher_is_tag :: [DarcsFlag] -> Bool +second_matcher_is_tag [] = False +second_matcher_is_tag (UpToTag _:_) = True +second_matcher_is_tag (_:fs) = second_matcher_is_tag fs + +-- | @match_a_patchread fs p@ tells whether @p@ matches the matchers in +-- the flags listed in @fs@. +match_a_patchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool +match_a_patchread fs = case nonrange_matcher fs of + Nothing -> const True + Just m -> apply_matcher m + +-- | @match_a_patch fs p@ tells whether @p@ matches the matchers in +-- the flags @fs@ +match_a_patch :: Patchy p => [DarcsFlag] -> Named p C(x y) -> Bool +match_a_patch fs p = + case nonrange_matcher fs of + Nothing -> True + Just m -> apply_matcher m (patch2patchinfo p `piap` p) + +match_patch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> Sealed2 (Named p) +match_patch fs ps = + case has_index_range fs of + Just (a,a') | a == a' -> case (unseal myhead) $ dropn (a-1) ps of + Just (Sealed2 p) -> seal2 $ hopefully p + Nothing -> error "Patch out of range!" + | otherwise -> bug ("Invalid index range match given to match_patch: "++ + show (PatchIndexRange a a')) + where myhead :: PatchSet p C(x) -> Maybe (Sealed2 (PatchInfoAnd p)) + myhead (NilRL:<:x) = myhead x + myhead ((x:<:_):<:_) = Just $ seal2 x + myhead NilRL = Nothing + Nothing -> case nonrange_matcher fs of + Nothing -> bug "Couldn't match_patch" + Just m -> find_a_patch m ps + +get_one_patchset :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO (SealedPatchSet p) +get_one_patchset repository fs = + case nonrange_matcher fs of + Just m -> do ps <- read_repo repository + if nonrange_matcher_is_tag fs + then return $ get_matching_tag m ps + else return $ match_a_patchset m ps + Nothing -> (seal . scan_context) `fmap` mmapFilePS (toFilePath $ context_f fs) + where context_f [] = bug "Couldn't match_nonrange_patchset" + context_f (Context f:_) = f + context_f (_:xs) = context_f xs + +-- | @has_lastn fs@ return the @--last@ argument in @fs@, if any. +has_lastn :: [DarcsFlag] -> Maybe Int +has_lastn [] = Nothing +has_lastn (LastN (-1):_) = error "--last requires a positive integer argument." +has_lastn (LastN n:_) = Just n +has_lastn (_:fs) = has_lastn fs + +has_index_range :: [DarcsFlag] -> Maybe (Int,Int) +has_index_range [] = Nothing +has_index_range (PatchIndexRange x y:_) = Just (x,y) +has_index_range (_:fs) = has_index_range fs + +-- | @match_first_patchset fs ps@ returns the part of @ps@ before its +-- first matcher, ie the one that comes first dependencywise. Hence, +-- patches in @match_first_patchset fs ps@ are the ones we don't want. +-- +-- Question: are they really? Florent +match_first_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p +match_first_patchset fs patchset = + case has_lastn fs of + Just n -> dropn n patchset + Nothing -> + case has_index_range fs of + Just (_,b) -> dropn b patchset + Nothing -> + case first_matcher fs of + Nothing -> bug "Couldn't match_first_patchset" + Just m -> unseal (dropn 1) $ if first_matcher_is_tag fs + then get_matching_tag m patchset + else match_a_patchset m patchset + +-- | @dropn n ps@ drops the @n@ last patches from @ps@. +dropn :: Int -> PatchSet p C(x) -> SealedPatchSet p +dropn n ps | n <= 0 = seal ps +dropn n (NilRL:<:ps) = dropn n ps +dropn _ NilRL = seal $ NilRL:<:NilRL +dropn n ((_:<:ps):<:xs) = dropn (n-1) $ ps:<:xs + +-- | @match_second_patchset fs ps@ returns the part of @ps@ before its +-- second matcher, ie the one that comes last dependencywise. +match_second_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p +match_second_patchset fs ps = + case has_index_range fs of + Just (a,_) -> dropn (a-1) ps + Nothing -> + case second_matcher fs of + Nothing -> bug "Couldn't match_second_patchset" + Just m -> if second_matcher_is_tag fs + then get_matching_tag m ps + else match_a_patchset m ps + +-- | @find_a_patch m ps@ returns the last patch in @ps@ matching @m@, and +-- calls 'error' if there is none. +find_a_patch :: RepoPatch p => Matcher p -> PatchSet p C(x) -> Sealed2 (Named p) +find_a_patch m NilRL = error $ "Couldn't find patch matching " ++ show m +find_a_patch m (NilRL:<:xs) = find_a_patch m xs +find_a_patch m ((p:<:ps):<:xs) | apply_matcher m p = seal2 $ hopefully p + | otherwise = find_a_patch m (ps:<:xs) + +-- | @match_a_patchset m ps@ returns a (the largest?) subset of @ps@ +-- ending in patch which matches @m@. Calls 'error' if there is none. +match_a_patchset :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p +match_a_patchset m NilRL = error $ "Couldn't find patch matching " ++ show m +match_a_patchset m (NilRL:<:xs) = match_a_patchset m xs +match_a_patchset m ((p:<:ps):<:xs) | apply_matcher m p = seal ((p:<:ps):<:xs) + | otherwise = match_a_patchset m (ps:<:xs) + +-- | @get_matching_tag m ps@, where @m@ is a 'Matcher' which matches tags +-- returns a 'SealedPatchSet' containing all patches in the last tag which +-- matches @m@. Last tag means the most recent tag in repository order, +-- i.e. the last one you'd see if you ran darcs changes -t @m@. Calls +-- 'error' if there is no matching tag. +get_matching_tag :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p +get_matching_tag m NilRL = error $ "Couldn't find a tag matching " ++ show m +get_matching_tag m (NilRL:<:xs) = get_matching_tag m xs +get_matching_tag m xxx@((p:<:ps):<:xs) + | apply_matcher m p = get_patches_in_tag (info p) xxx + | otherwise = get_matching_tag m (ps:<:xs) + +-- | @match_exists m ps@ tells whether there is a patch matching +-- @m@ in @ps@ +match_exists :: Matcher p -> PatchSet p C(x) -> Bool +match_exists _ NilRL = False +match_exists m (NilRL:<:xs) = match_exists m xs +match_exists m ((p:<:ps):<:xs) | apply_matcher m $ p = True + | otherwise = match_exists m (ps:<:xs) + +apply_inv_to_matcher :: (RepoPatch p, WriteableDirectory m) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m () +apply_inv_to_matcher _ _ NilRL = impossible +apply_inv_to_matcher ioe m (NilRL:<:xs) = apply_inv_to_matcher ioe m xs +apply_inv_to_matcher ioe m ((p:<:ps):<:xs) + | apply_matcher m p = when (ioe == Inclusive) (apply_invp p) + | otherwise = apply_invp p >> apply_inv_to_matcher ioe m (ps:<:xs) + +-- | @maybe_read_file@ recursively gets the contents of all files +-- in a directory, or just the contents of a file if called on a +-- simple file. +maybe_read_file :: ReadableDirectory m => FileName -> m ([(FileName, B.ByteString)]) +maybe_read_file file = do + d <- mDoesDirectoryExist file + if d + then do + children <- mInCurrentDirectory file mGetDirectoryContents + maybe_read_files [file /// ch | ch <- children] + else do + e <- mDoesFileExist file + if e + then do + contents <- mReadFilePS file + return [(norm_path file, contents)] + else return [] + where maybe_read_files [] = return [] + maybe_read_files (f:fs) = do + x <- maybe_read_file f + y <- maybe_read_files fs + return $ concat [x,y] + +get_matcher_s :: (MatchMonad m p, RepoPatch p) => + InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m () +get_matcher_s ioe m repo = + if match_exists m repo + then apply_inv_to_matcher ioe m repo + else fail $ "Couldn't match pattern "++ show m + +get_tag_s :: (MatchMonad m p, RepoPatch p) => + Matcher p -> PatchSet p C(x) -> m () +get_tag_s match repo = do + let pinfo = patch2patchinfo `unseal2` (find_a_patch match repo) + case get_patches_beyond_tag pinfo repo of + FlippedSeal (extras:<:NilRL) -> applyInvRL $ extras + _ -> impossible + +-- | @apply_invp@ tries to get the patch that's in a 'PatchInfoAnd +-- patch', and to apply its inverse. If we fail to fetch the patch +-- (presumably in a partial repositiory), then we share our sorrow +-- with the user. +apply_invp :: (Patchy p, WriteableDirectory m) => PatchInfoAnd p C(x y) -> m () +apply_invp hp = apply [] (invert $ fromHopefully hp) + where fromHopefully = conscientiously $ \e -> + text "Sorry, partial repository problem. Patch not available:" + $$ e + $$ text "" + $$ text "If you think what you're trying to do is ok then" + $$ text "report this as a bug on the darcs-user list." + +-- | a version of 'take' for 'RL' lists that cater for contexts. +safetake :: Int -> RL a C(x y) -> FlippedSeal (RL a) C(y) +safetake 0 _ = flipSeal NilRL +safetake _ NilRL = error "There aren't that many patches..." +safetake i (a:<:as) = a `consRLSealed` safetake (i-1) as + +-- | A @MatchMonad p m@ is a monad in which we match patches from @p@ +-- by playing with them in @m@, a 'WriteableDirectory' monad. How we +-- play with the patches depends on the instance of @MatchMonad@ we're +-- using. If we use @IO@, then we'll apply the patches directly in +-- @m@, if we use @SlurpMonad@, then we'll apply the patches to a +-- slurpy, and write to disk at the end. Note that both @IO@ and +-- @SlurpMonad@ have an instance of 'WriteableDirectory' that +-- implicitely writes in the current directory. +class (RepoPatch p, WriteableDirectory m) => MatchMonad m p where + withRecordedMatch :: Repository p C(r u t) + -> (PatchSet p C(r) -> m ()) -> IO () + -- ^ @withRecordedMatch@ is responsible for getting the recorded state + -- into the monad, and then applying the second argument, and + -- finally placing the resulting state into the current directory. + withRecordedMatchOnlySomeFiles + :: Repository p C(r u t) -> [FileName] + -> (PatchSet p C(r) -> m ()) -> IO () + -- ^ @withRecordedMatchOnlySomeFiles@ is a variant of + -- withRecordedMatch that may only return some of the files + -- (e.g. if we want to run diff on just a few files). + withRecordedMatchOnlySomeFiles r _ j = withRecordedMatch r j + applyInvRL :: RL (PatchInfoAnd p) C(x r) -> m () + applyInvRL NilRL = return () + applyInvRL (p:<:ps) = apply_invp p >> applyInvRL ps + +withRecordedMatchIO :: RepoPatch p => Repository p C(r u t) + -> (PatchSet p C(r) -> IO ()) -> IO () +withRecordedMatchIO = withRecordedMatch + +-- | @withRecordedMatchSmart@ hides away the choice of the +-- 'SlurpMonad' to use in order to apply 'withRecordedMatch'. +-- If we have the @--store-in-memory@ flag, then use 'SlurpMonad', else +-- use @IO@. In both case, the result is in the @IO@ monad. +-- +-- Suggestion: shouldn't we name @withRecordedMatchSmart@ +-- @withRecordedMatch@, and give the monad function another name such +-- as @withRecordedMatchRaw@? +withRecordedMatchSmart :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) + -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ()) + -> IO () +withRecordedMatchSmart opts r j = + do if StoreInMemory `elem` opts then withSM r j + else withRecordedMatchIO r j + where withSM :: RepoPatch p => Repository p C(r u t) + -> (PatchSet p C(r) -> SlurpMonad ()) -> IO () + withSM = withRecordedMatch + +-- | @withRecordedMatchOnlySomeSmart@ is the smart version of +-- 'withRecordedMatchOnlySome'. It runs 'withRecordedMatchOnlySome' +-- either in the 'SlurpMonad' or in @IO@ according to the +-- @--store-in-memory@ flag. +withRecordedMatchOnlySomeSmart :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) + -> [FileName] + -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ()) + -> IO () +withRecordedMatchOnlySomeSmart opts r [] j = withRecordedMatchSmart opts r j +withRecordedMatchOnlySomeSmart opts r files j = + do if StoreInMemory `elem` opts then withSM r files j + else withIO r files j + where withSM :: RepoPatch p => Repository p C(r u t) -> [FileName] + -> (PatchSet p C(r) -> SlurpMonad ()) -> IO () + withSM = withRecordedMatchOnlySomeFiles + withIO :: RepoPatch p => Repository p C(r u t) -> [FileName] + -> (PatchSet p C(r) -> IO ()) -> IO () + withIO = withRecordedMatchOnlySomeFiles + +instance RepoPatch p => MatchMonad IO p where + withRecordedMatch r job = do createPristineDirectoryTree r "." + read_repo r >>= job + applyInvRL = apply_patches [] . invertRL -- this gives nicer feedback + +instance RepoPatch p => MatchMonad SlurpMonad p where + withRecordedMatch r job = + do ps <- read_repo r + s <- slurp_recorded r + case withSlurpy s (job ps) of + Left err -> fail err + Right (s',_) -> writeSlurpy s' "." + withRecordedMatchOnlySomeFiles r fs job = + do ps <- read_repo r + s <- slurp_recorded r + case withSlurpy s (job ps >> mapM maybe_read_file fs) of + Left err -> fail err + Right (_,fcs) -> mapM_ createAFile $ concat fcs + where createAFile (p,c) = do ensureDirectories $ super_name p + mWriteFilePS p c + ensureDirectories d = + do isPar <- mDoesDirectoryExist d + if isPar + then return () + else do ensureDirectories $ super_name d + mCreateDirectory d + +\end{code} diff --git a/src/Darcs/Ordered.hs b/src/Darcs/Ordered.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Ordered.hs @@ -0,0 +1,277 @@ +-- Copyright (C) 2007 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +-- , MagicHash, TypeOperators, GADTs #-} + +#include "gadts.h" + +module Darcs.Ordered ( EqCheck(..), isEq, (:>)(..), (:<)(..), (:\/:)(..), (:/\:)(..), + FL(..), RL(..),Proof(..), +#ifndef GADT_WITNESSES + unsafeUnFL, unsafeFL, unsafeRL, unsafeUnRL, +#endif + lengthFL, mapFL, mapFL_FL, spanFL, foldlFL, allFL, + splitAtFL, bunchFL, foldlRL, + lengthRL, isShorterThanRL, mapRL, mapRL_RL, zipWithFL, + unsafeMap_l2f, filterE, filterFL, + reverseFL, reverseRL, (+>+), (+<+), + nullFL, concatFL, concatRL, concatReverseFL, headRL, + MyEq, unsafeCompare, (=\/=), (=/\=), + consRLSealed, nullRL, + unsafeCoerceP, unsafeCoerceP2 + ) where + +#include "impossible.h" +import GHC.Base (unsafeCoerce#) +import Darcs.Show +import Darcs.Sealed ( FlippedSeal(..), flipSeal ) + +data EqCheck C(a b) where + IsEq :: EqCheck C(a a) + NotEq :: EqCheck C(a b) + +instance Eq (EqCheck C(a b)) where + IsEq == IsEq = True + NotEq == NotEq = True + _ == _ = False + +isEq :: EqCheck C(a b) -> Bool +isEq IsEq = True +isEq NotEq = False + +instance Show (EqCheck C(a b)) where + show IsEq = "IsEq" + show NotEq = "NotEq" + +data Proof a C(x y) where + Proof :: a -> Proof a C(x x) + +data (a1 :> a2) C(x y) = FORALL(z) (a1 C(x z)) :> (a2 C(z y)) +infixr 1 :> +data (a1 :< a2) C(x y) = FORALL(z) (a1 C(z y)) :< (a2 C(x z)) +infix 1 :< +infix 1 :/\:, :\/: +data (a1 :\/: a2) C(x y) = FORALL(z) (a1 C(z x)) :\/: (a2 C(z y)) +data (a1 :/\: a2) C(x y) = FORALL(z) (a1 C(x z)) :/\: (a2 C(y z)) +class MyEq p where + -- Minimal definition defines any one of unsafeCompare, =\/= and =/\=. + unsafeCompare :: p C(a b) -> p C(c d) -> Bool + unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b) + (=\/=) :: p C(a b) -> p C(a c) -> EqCheck C(b c) + a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq + | otherwise = NotEq + (=/\=) :: p C(a c) -> p C(b c) -> EqCheck C(a b) + a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq + | otherwise = NotEq + +infix 4 =\/=, =/\= + +unsafeCoerceP :: a C(x y) -> a C(b c) +unsafeCoerceP = unsafeCoerce# + +unsafeCoerceP2 :: t C(w x y z) -> t C(a b c d) +unsafeCoerceP2 = unsafeCoerce# + +instance (Show2 a, Show2 b) => Show ( (a :> b) C(x y) ) where + showsPrec d (x :> y) = showOp2 1 ":>" d x y + +instance (Show2 a, Show2 b) => Show2 (a :> b) where + showsPrec2 = showsPrec + +instance (Show2 a, Show2 b) => Show ( (a :\/: b) C(x y) ) where + showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y + +instance (Show2 a, Show2 b) => Show2 (a :\/: b) where + showsPrec2 = showsPrec + +infixr 5 :>:, :<:, +>+, +<+ + +-- forward list +data FL a C(x z) where + (:>:) :: a C(x y) -> FL a C(y z) -> FL a C(x z) + NilFL :: FL a C(x x) + +instance Show2 a => Show (FL a C(x z)) where + showsPrec _ NilFL = showString "NilFL" + showsPrec d (x :>: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x . + showString " :>: " . showsPrec (prec + 1) xs + where prec = 5 + +instance Show2 a => Show2 (FL a) where + showsPrec2 = showsPrec + +-- reverse list +data RL a C(x z) where + (:<:) :: a C(y z) -> RL a C(x y) -> RL a C(x z) + NilRL :: RL a C(x x) + +nullFL :: FL a C(x z) -> Bool +nullFL NilFL = True +nullFL _ = False + +nullRL :: RL a C(x z) -> Bool +nullRL NilRL = True +nullRL _ = False + +filterFL :: (FORALL(x y) p C(x y) -> EqCheck C(x y)) -> FL p C(w z) -> FL p C(w z) +filterFL _ NilFL = NilFL +filterFL f (x:>:xs) | IsEq <- f x = filterFL f xs + | otherwise = x :>: filterFL f xs + +filterE :: (a -> EqCheck C(x y)) -> [a] -> [Proof a C(x y)] +filterE _ [] = [] +filterE p (x:xs) + | IsEq <- p x = Proof x : filterE p xs + | otherwise = filterE p xs + +(+>+) :: FL a C(x y) -> FL a C(y z) -> FL a C(x z) +NilFL +>+ ys = ys +(x:>:xs) +>+ ys = x :>: xs +>+ ys + +(+<+) :: RL a C(y z) -> RL a C(x y) -> RL a C(x z) +NilRL +<+ ys = ys +(x:<:xs) +<+ ys = x :<: xs +<+ ys + +reverseFL :: FL a C(x z) -> RL a C(x z) +reverseFL xs = r NilRL xs + where r :: RL a C(l m) -> FL a C(m o) -> RL a C(l o) + r ls NilFL = ls + r ls (a:>:as) = r (a:<:ls) as + +reverseRL :: RL a C(x z) -> FL a C(x z) +reverseRL xs = r NilFL xs -- r (xs :> NilFL) + where r :: FL a C(m o) -> RL a C(l m) -> FL a C(l o) + r ls NilRL = ls + r ls (a:<:as) = r (a:>:ls) as + +concatFL :: FL (FL a) C(x z) -> FL a C(x z) +concatFL NilFL = NilFL +concatFL (a:>:as) = a +>+ concatFL as + +concatRL :: RL (RL a) C(x z) -> RL a C(x z) +concatRL NilRL = NilRL +concatRL (a:<:as) = a +<+ concatRL as + +spanFL :: (FORALL(w y) a C(w y) -> Bool) -> FL a C(x z) -> (FL a :> FL a) C(x z) +spanFL f (x:>:xs) | f x = case spanFL f xs of + ys :> zs -> (x:>:ys) :> zs +spanFL _ xs = NilFL :> xs + +splitAtFL :: Int -> FL a C(x z) -> (FL a :> FL a) C(x z) +splitAtFL 0 xs = NilFL :> xs +splitAtFL _ NilFL = NilFL :> NilFL +splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of + (xs':>xs'') -> (x:>:xs' :> xs'') + +-- 'bunchFL n' groups patches into batches of n, except that it always puts +-- the first patch in its own group, this being a recognition that the +-- first patch is often *very* large. + +bunchFL :: Int -> FL a C(x y) -> FL (FL a) C(x y) +bunchFL _ NilFL = NilFL +bunchFL n (x:>:xs) = (x :>: NilFL) :>: bFL xs + where bFL :: FL a C(x y) -> FL (FL a) C(x y) + bFL NilFL = NilFL + bFL bs = case splitAtFL n bs of + a :> b -> a :>: bFL b + + +allFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> Bool +allFL f xs = and $ mapFL f xs + +foldlFL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> FL b C(x z) -> a +foldlFL _ x NilFL = x +foldlFL f x (y:>:ys) = foldlFL f (f x y) ys + +foldlRL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> RL b C(x z) -> a +foldlRL _ x NilRL = x +foldlRL f x (y:<:ys) = foldlRL f (f x y) ys + +mapFL_FL :: (FORALL(w y) a C(w y) -> b C(w y)) -> FL a C(x z) -> FL b C(x z) +mapFL_FL _ NilFL = NilFL +mapFL_FL f (a:>:as) = f a :>: mapFL_FL f as + +zipWithFL :: (FORALL(x y) a -> p C(x y) -> q C(x y)) + -> [a] -> FL p C(w z) -> FL q C(w z) +zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys +zipWithFL _ _ NilFL = NilFL +zipWithFL _ [] (_:>:_) = bug "zipWithFL called with too short a list" + +mapRL_RL :: (FORALL(w y) a C(w y) -> b C(w y)) -> RL a C(x z) -> RL b C(x z) +mapRL_RL _ NilRL = NilRL +mapRL_RL f (a:<:as) = f a :<: mapRL_RL f as + +mapFL :: (FORALL(w z) a C(w z) -> b) -> FL a C(x y) -> [b] +mapFL _ NilFL = [] +mapFL f (a :>: b) = f a : mapFL f b + +mapRL :: (FORALL(w z) a C(w z) -> b) -> RL a C(x y) -> [b] +mapRL _ NilRL = [] +mapRL f (a :<: b) = f a : mapRL f b + +unsafeMap_l2f :: (FORALL(w z) a -> b C(w z)) -> [a] -> FL b C(x y) +unsafeMap_l2f _ [] = unsafeCoerceP NilFL +unsafeMap_l2f f (x:xs) = f x :>: unsafeMap_l2f f xs + +lengthFL :: FL a C(x z) -> Int +lengthFL xs = l xs 0 + where l :: FL a C(x z) -> Int -> Int + l NilFL n = n + l (_:>:as) n = l as $! n+1 + +lengthRL :: RL a C(x z) -> Int +lengthRL xs = l xs 0 + where l :: RL a C(x z) -> Int -> Int + l NilRL n = n + l (_:<:as) n = l as $! n+1 + +isShorterThanRL :: RL a C(x y) -> Int -> Bool +isShorterThanRL _ n | n <= 0 = False +isShorterThanRL NilRL _ = True +isShorterThanRL (_:<:xs) n = isShorterThanRL xs (n-1) + +concatReverseFL :: FL (RL a) C(x y) -> RL a C(x y) +concatReverseFL = concatRL . reverseFL + +headRL :: RL a C(x y) -> FlippedSeal a C(y) +headRL (x:<:_) = flipSeal x +headRL _ = impossible + +consRLSealed :: a C(y z) -> FlippedSeal (RL a) C(y) -> FlippedSeal (RL a) C(z) +consRLSealed a (FlippedSeal as) = flipSeal $ a :<: as + +#ifndef GADT_WITNESSES +-- These are useful for interfacing with modules outside of +-- patch theory, such as Show.lhs +unsafeUnFL :: FL a -> [a] +unsafeUnFL NilFL = [] +unsafeUnFL (a:>:as) = a : unsafeUnFL as + +unsafeUnRL :: RL a -> [a] +unsafeUnRL NilRL = [] +unsafeUnRL (a:<:as) = a : unsafeUnRL as + +unsafeFL :: [a] -> FL a +unsafeFL [] = NilFL +unsafeFL (a:as) = a :>: unsafeFL as + +unsafeRL :: [a] -> RL a +unsafeRL [] = NilRL +unsafeRL (a:as) = a :<: unsafeRL as +#endif diff --git a/src/Darcs/Patch.lhs b/src/Darcs/Patch.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch.lhs @@ -0,0 +1,151 @@ +% Copyright (C) 2002-2003 David Roundy +% +% 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. + +\chapter{Theory of patches} +\label{Patch} + +\newtheorem{thm}{Theorem} +\newtheorem{dfn}{Definition} + +\section{Background} + +I think a little background on the author is in order. I am a physicist, +and think like a physicist. The proofs and theorems given here are what I +would call ``physicist'' proofs and theorems, which is to say that while +the proofs may not be rigorous, they are practical, and the theorems are +intended to give physical insight. It would be great to have a +mathematician work on this to give patch theory better formalized +foundations. + +From the beginning of this theory, which originated as the result of a +series of email discussions with Tom Lord, I have looked at patches as +being analogous to the operators of quantum mechanics. I include in this +appendix footnotes explaining the theory of patches in terms of the theory +of quantum mechanics. I advise against taking this analogy too seriously, +although it could provide some insight into how a physicist might think +about darcs. + +\begin{code} +{-# OPTIONS_GHC -cpp -fno-warn-orphans #-} +#include "gadts.h" +module Darcs.Patch ( RepoPatch, Prim, Patch, RealPatch, Named, Patchy, + flattenFL, joinPatches, + fromPrim, fromPrims, + is_null_patch, nullP, + rmfile, addfile, rmdir, adddir, move, + hunk, tokreplace, namepatch, anonymous, + binary, + description, + showContextPatch, showPatch, showNicely, + infopatch, changepref, + thing, things, + is_similar, is_addfile, is_hunk, is_setpref, +#ifndef GADT_WITNESSES + merger, is_merger, merge, + commute, commutex, list_touched_files, + -- for PatchTest + unravel, elegant_merge, +#else + Commute(..), +#endif + resolve_conflicts, + Effect, effect, + is_binary, gzWritePatch, writePatch, is_adddir, + invert, invertFL, invertRL, identity, + commuteFL, commuteRL, + readPatch, + canonize, sort_coalesceFL, + try_to_shrink, + apply_to_slurpy, patchname, patchcontents, + apply_to_filepaths, force_replace_slurpy, apply, + patch2patchinfo, + LineMark(AddedLine, RemovedLine, AddedRemovedLine, None), + MarkedUpFile, markup_file, empty_markedup_file, + summary, summarize, xml_summary, + adddeps, getdeps, + list_conflicted_files, + modernize_patch, + -- for Population + DirMark(..), patchChanges, applyToPop, + ) where +import Darcs.PopulationData ( DirMark(..) ) +import Darcs.Patch.Core ( Patch, Named, + flattenFL, + adddeps, namepatch, + anonymous, +#ifndef GADT_WITNESSES + is_merger, +#endif + getdeps, + is_null_patch, nullP, infopatch, + patch2patchinfo, patchname, patchcontents ) +import Darcs.Patch.Read ( readPatch ) +import Darcs.Patch.Patchy ( Patchy, writePatch, gzWritePatch, + showPatch, showNicely, showContextPatch, + invert, invertRL, invertFL, identity, + thing, things, + commuteFL, commuteRL, apply, + description, summary, +#ifndef GADT_WITNESSES + commute, commutex, list_touched_files, +#else + Commute(..) +#endif + ) +import Darcs.Patch.Viewing ( xml_summary, summarize ) +import Darcs.Patch.Apply ( applyToPop, patchChanges, empty_markedup_file, + markup_file, force_replace_slurpy, + apply_to_filepaths, apply_to_slurpy, + LineMark(..), MarkedUpFile ) +import Darcs.Patch.Commute ( modernize_patch, +#ifndef GADT_WITNESSES + unravel, + merger, merge, elegant_merge, +#endif + ) +import Darcs.Patch.Prim ( FromPrims, fromPrims, joinPatches, FromPrim, fromPrim, + Conflict, Effect(effect), list_conflicted_files, resolve_conflicts, + Prim, canonize, + sort_coalesceFL, + rmdir, rmfile, tokreplace, adddir, addfile, + binary, changepref, hunk, move, + is_adddir, is_addfile, + is_hunk, is_binary, is_setpref, + is_similar, + try_to_shrink ) +import Darcs.Ordered ( FL ) +import Darcs.Patch.Real ( RealPatch ) + +instance Patchy Patch +instance (Conflict p, Effect p, Patchy p) => Patchy (Named p) + +class (Patchy p, Effect p, FromPrim p, Conflict p) => RepoPatchBase p +instance RepoPatchBase Patch +instance RepoPatchBase RealPatch + +class (Patchy p, Effect p, FromPrims p, Conflict p) => RepoPatch p +instance RepoPatch Patch +instance RepoPatchBase p => RepoPatch (FL p) + +\end{code} + +\input{Darcs/Patch/Apply.lhs} +\input{Darcs/Patch/Core.lhs} +\input{Darcs/Patch/Prim.lhs} +\input{Darcs/Patch/Commute.lhs} +\input{Darcs/Patch/Show.lhs} + diff --git a/src/Darcs/Patch/Apply.lhs b/src/Darcs/Patch/Apply.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Apply.lhs @@ -0,0 +1,522 @@ +% Copyright (C) 2002-2005 David Roundy +% +% 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. + + +\begin{code} +{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Patch.Apply ( apply_to_filepaths, apply_to_slurpy, + forceTokReplace, + markup_file, empty_markedup_file, + patchChanges, + applyToPop, + LineMark(..), MarkedUpFile, + force_replace_slurpy ) + where + +import Prelude hiding ( catch, pi ) +import Darcs.Flags ( DarcsFlag( SetScriptsExecutable ) ) + +import qualified Data.ByteString.Char8 as BC (split, break, pack, singleton) + +import qualified Data.ByteString as B (ByteString, null, empty, concat, isPrefixOf) +import ByteStringUtils ( linesPS, unlinesPS, break_after_nth_newline, break_before_nth_newline, ) + +import Darcs.Patch.FileName ( fn2ps, fn2fp, fp2fn, + movedirfilename ) +import Darcs.PopulationData ( Population(..), PopTree(..), Info(..), DirMark(..) ) +import Data.List ( intersperse ) +import Data.Maybe ( catMaybes ) +import Darcs.Patch.Patchy ( Apply, apply, applyAndTryToFixFL, applyAndTryToFix, + mapMaybeSnd ) +import Darcs.Patch.Commute () +import Darcs.Patch.Core ( Patch(..), Named(..) ) +import Darcs.Patch.Prim ( Prim(..), Effect(effect), + DirPatchType(..), FilePatchType(..), + try_tok_internal ) +import Darcs.Patch.Info ( PatchInfo ) +import Control.Monad ( when ) +import Darcs.SlurpDirectory ( FileContents, Slurpy, withSlurpy, slurp_modfile ) +import RegChars ( regChars ) +import Darcs.Repository.Prefs ( change_prefval ) +import Darcs.Global ( darcsdir ) +import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) ) +import Darcs.FilePathMonad ( withFilePaths ) +#include "impossible.h" +import Darcs.Ordered ( FL(..), (:>)(..), + mapFL, mapFL_FL, spanFL, foldlFL ) +\end{code} + + + +\section{Introduction} + +A patch describes a change to the tree. It could be either a primitive +patch (such as a file add/remove, a directory rename, or a hunk replacement +within a file), or a composite patch describing many such changes. Every +patch type must satisfy the conditions described in this appendix. The +theory of patches is independent of the data which the patches manipulate, +which is what makes it both powerful and useful, as it provides a framework +upon which one can build a revision control system in a sane manner. + +Although in a sense, the defining property of any patch is that it can be +applied to a certain tree, and thus make a certain change, this change does +not wholly define the patch. A patch is defined by a +\emph{representation}, together with a set of rules for how it behaves +(which it has in common with its patch type). The \emph{representation} of +a patch defines what change that particular patch makes, and must be +defined in the context of a specific tree. The theory of patches is a +theory of the many ways one can change the representation of a patch to +place it in the context of a different tree. The patch itself is not +changed, since it describes a single change, which must be the same +regardless of its representation\footnote{For those comfortable with +quantum mechanics, think of a patch as a quantum mechanical operator, and +the representation as the basis set. The analogy breaks down pretty +quickly, however, since an operator could be described in any complete +basis set, while a patch modifying the file {\tt foo} can only be described +in the rather small set of contexts which have a file {\tt foo} to be +modified.}. + +So how does one define a tree, or the context of a patch? The simplest way +to define a tree is as the result of a series of patches applied to the +empty tree\footnote{This is very similar to the second-quantized picture, +in which any state is seen as the result of a number of creation operators +acting on the vacuum, and provides a similar set of simplifications---in +particular, the exclusion principle is very elegantly enforced by the +properties of the anti-hermitian fermion creation operators.}. Thus, the +context of a patch consists of the set of patches that precede it. + +\section{Applying patches} + + +\begin{code} +apply_to_filepaths :: Apply p => p C(x y) -> [FilePath] -> [FilePath] +apply_to_filepaths pa fs = withFilePaths fs (apply [] pa) + +apply_to_slurpy :: (Apply p, Monad m) => p C(x y) -> Slurpy -> m Slurpy +apply_to_slurpy p s = case withSlurpy s (apply [] p) of + Left err -> fail err + Right (s', ()) -> return s' + +instance Apply p => Apply (Named p) where + apply opts (NamedP _ _ p) = apply opts p + applyAndTryToFix (NamedP n d p) = mapMaybeSnd (NamedP n d) `fmap` applyAndTryToFix p + +instance Apply Patch where + apply opts p = applyFL opts $ effect p + applyAndTryToFixFL (PP x) = mapMaybeSnd (mapFL_FL PP) `fmap` applyAndTryToFixFL x + applyAndTryToFixFL (ComP xs) = mapMaybeSnd (\xs' -> ComP xs' :>: NilFL) `fmap` applyAndTryToFix xs + applyAndTryToFixFL x = do apply [] x; return Nothing + applyAndTryToFix (ComP xs) = mapMaybeSnd ComP `fmap` applyAndTryToFix xs + applyAndTryToFix x = do mapMaybeSnd ComP `fmap` applyAndTryToFixFL x + +force_replace_slurpy :: Prim C(x y) -> Slurpy -> Maybe Slurpy +force_replace_slurpy (FP f (TokReplace tcs old new)) s = + slurp_modfile f (forceTokReplace tcs old new) s +force_replace_slurpy _ _ = bug "Can only force_replace_slurpy on a replace." + +instance Apply Prim where + apply opts (Split ps) = applyFL opts ps + apply _ Identity = return () + apply _ (FP f RmFile) = mRemoveFile f + apply _ (FP f AddFile) = mCreateFile f + apply opts p@(FP _ (Hunk _ _ _)) = applyFL opts (p :>: NilFL) + apply _ (FP f (TokReplace t o n)) = mModifyFilePSs f doreplace + where doreplace ls = + case mapM (try_tok_internal t (BC.pack o) (BC.pack n)) ls of + Nothing -> fail $ "replace patch to " ++ fn2fp f + ++ " couldn't apply." + Just ls' -> return $ map B.concat ls' + apply _ (FP f (Binary o n)) = mModifyFilePS f doapply + where doapply oldf = if o == oldf + then return n + else fail $ "binary patch to " ++ fn2fp f + ++ " couldn't apply." + apply _ (DP d AddDir) = mCreateDirectory d + apply _ (DP d RmDir) = mRemoveDirectory d + apply _ (Move f f') = mRename f f' + apply _ (ChangePref p f t) = + do b <- mDoesDirectoryExist (fp2fn $ darcsdir++"/prefs") + when b $ change_prefval p f t + applyAndTryToFixFL (FP f RmFile) = + do x <- mReadFilePS f + if B.null x then do mRemoveFile f + return Nothing + else do mWriteFilePS f B.empty + mRemoveFile f + return $ Just ("WARNING: Fixing removal of non-empty file "++fn2fp f, + FP f (Binary x B.empty) :>: FP f RmFile :>: NilFL ) + applyAndTryToFixFL p = do apply [] p; return Nothing + +applyFL :: WriteableDirectory m => [DarcsFlag] -> FL Prim C(x y) -> m () +applyFL _ NilFL = return () +applyFL opts ((FP f h@(Hunk _ _ _)):>:the_ps) + = case spanFL f_hunk the_ps of + (xs :> ps') -> + do let foo = h :>: mapFL_FL (\(FP _ h') -> h') xs + mModifyFilePS f $ hunkmod foo + case h of + (Hunk 1 _ (n:_)) | BC.pack "#!" `B.isPrefixOf` n && + SetScriptsExecutable `elem` opts + -> mSetFileExecutable f True + _ -> return () + applyFL opts ps' + where f_hunk (FP f' (Hunk _ _ _)) | f == f' = True + f_hunk _ = False + hunkmod :: WriteableDirectory m => FL FilePatchType C(x y) + -> B.ByteString -> m B.ByteString + hunkmod NilFL ps = return ps + hunkmod (Hunk line old new:>:hs) ps + = case applyHunkLines [(line,old,new)] ps of + Just ps' -> hunkmod hs ps' + Nothing -> fail $ "Error applying hunk to file " ++ fn2fp f + hunkmod _ _ = impossible +applyFL opts (p:>:ps) = do apply opts p + applyFL opts ps +\end{code} + +\subsection{Hunk patches} + +Hunks are an example of a complex filepatch. A hunk is a set of lines of a +text file to be replaced by a different set of lines. Either of these sets +may be empty, which would mean a deletion or insertion of lines. +\begin{code} +applyHunks :: [(Int, [B.ByteString], [B.ByteString])] + -> B.ByteString -> Maybe [B.ByteString] +applyHunks [] ps = Just [ps] +applyHunks ((l, [], n):hs) ps + = case break_before_nth_newline (l - 2) ps of + (prfix, after_prefix) -> do rest <- applyHunks hs after_prefix + return $ intersperse nl (prfix:n) ++ rest + where nl = BC.singleton '\n' +applyHunks ((l, o, n):hs) ps + = case break_before_nth_newline (l - 2) ps of + (prfix, after_prefix) -> + case break_before_nth_newline (length o) after_prefix of + (oo, _) | oo /= unlinesPS (B.empty:o) -> fail "applyHunks error" + (_, suffix) -> + do rest <- applyHunks hs suffix + return $ intersperse nl (prfix:n) ++ rest + where nl = BC.singleton '\n' + +applyHunkLines :: [(Int, [B.ByteString], [B.ByteString])] + -> FileContents -> Maybe FileContents +applyHunkLines [] c = Just c +applyHunkLines [(1, [], n)] ps | B.null ps = Just $ unlinesPS (n++[B.empty]) +applyHunkLines hs@((l, o, n):hs') ps = + do pss <- case l of + 1 -> case break_after_nth_newline (length o) ps of + Nothing -> if ps == unlinesPS o + then return $ intersperse nl n + else fail "applyHunkLines: Unexpected hunks" + Just (shouldbeo, suffix) + | shouldbeo /= unlinesPS (o++[B.empty]) -> + fail $ "applyHunkLines: Bad patch!" + | null n -> + do x <- applyHunkLines hs' suffix + return [x] + | otherwise -> + do rest <- applyHunks hs' suffix + return $ intersperse nl n ++ nl:rest + _ | l < 0 -> bug "Prim.applyHunkLines: After -ve lines?" + | otherwise -> applyHunks hs ps + let result = B.concat pss + return result + where nl = BC.singleton '\n' +\end{code} + +\subsection{Token replace patches}\label{token_replace} + +Although most filepatches will be hunks, darcs is clever enough to support +other types of changes as well. A ``token replace'' patch replaces all +instances of a given token with some other version. A token, here, is +defined by a regular expression, which must be of the simple [a--z\ldots]\ type, +indicating which characters are allowed in a token, with all other +characters acting as delimiters. For example, a C identifier would be a +token with the flag \verb![A-Za-z_0-9]!. + +\begin{code} +forceTokReplace :: String -> String -> String + -> FileContents -> Maybe FileContents +forceTokReplace t os ns c = Just $ unlinesPS $ map forceReplace $ linesPS c + where o = BC.pack os + n = BC.pack ns + tokchar = regChars t + toks_and_intratoks ps | B.null ps = [] + toks_and_intratoks ps = + let (before,s') = BC.break tokchar ps + (tok, after) = BC.break (not . tokchar) s' + in before : tok : toks_and_intratoks after + forceReplace ps = B.concat $ map o_t_n $ toks_and_intratoks ps + o_t_n s | s == o = n + | otherwise = s +\end{code} + +What makes the token replace patch special is the fact that a token replace +can be merged with almost any ordinary hunk, giving exactly what you would +want. For example, you might want to change the patch type {\tt +TokReplace} to {\tt TokenReplace} (if you decided that saving two +characters of space was stupid). If you did this using hunks, it would +modify every line where {\tt TokReplace} occurred, and quite likely provoke +a conflict with another patch modifying those lines. On the other hand, if +you did this using a token replace patch, the only change that it could +conflict with would be if someone else had used the token ``{\tt +TokenReplace}'' in their patch rather than TokReplace---and that actually +would be a real conflict! + +%\section{Outputting interesting and useful information} + +%Just being able to manipulate patches and trees is not enough. We also +%want to be able to view the patches and files. This requires another set +%of functions, closely related to the patch application functions, which +%will give us the necessary information to browse the changes we have made. +%It is \emph{not} the Patch module's responsibility to add any sort of +%markup or formatting, but simply to provide the information necessary for an +%external module to do the formatting. + +\begin{code} +data LineMark = AddedLine PatchInfo | RemovedLine PatchInfo + | AddedRemovedLine PatchInfo PatchInfo | None + deriving (Show) +type MarkedUpFile = [(B.ByteString, LineMark)] +empty_markedup_file :: MarkedUpFile +empty_markedup_file = [(B.empty, None)] + +markup_file :: Effect p => PatchInfo -> p C(x y) + -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) +markup_file x p = mps (effect p) + where mps :: FL Prim C(a b) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) + mps NilFL = id + mps (pp:>:pps) = mps pps . markup_prim x pp + +markup_prim :: PatchInfo -> Prim C(x y) + -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) +markup_prim _ (Split NilFL) (f, mk) = (f, mk) +markup_prim n (Split (p:>:ps)) (f, mk) = markup_prim n (Split ps) $ + markup_prim n p (f, mk) +markup_prim _ (FP _ AddFile) (f, mk) = (f, mk) +markup_prim _ (FP _ RmFile) (f, mk) = (f, mk) +markup_prim n (FP f' (Hunk line old new)) (f, mk) + | fn2fp f' /= f = (f, mk) + | otherwise = (f, markup_hunk n line old new mk) +markup_prim name (FP f' (TokReplace t o n)) (f, mk) + | fn2fp f' /= f = (f, mk) + | otherwise = (f, markup_tok name t o n mk) +markup_prim _ (DP _ _) (f, mk) = (f, mk) +markup_prim _ (Move d d') (f, mk) = (fn2fp $ movedirfilename d d' (fp2fn f), mk) +markup_prim _ (ChangePref _ _ _) (f,mk) = (f,mk) +markup_prim _ Identity (f,mk) = (f,mk) +markup_prim n (FP f' (Binary _ _)) (f,mk) + | fn2fp f' == f = (f,(BC.pack "Binary file", AddedLine n):mk) + | otherwise = (f,mk) + +markup_hunk :: PatchInfo -> Int -> [B.ByteString] -> [B.ByteString] + -> MarkedUpFile -> MarkedUpFile +markup_hunk n l old new ((sf, RemovedLine pi):mk) = + (sf, RemovedLine pi) : markup_hunk n l old new mk +markup_hunk n l old new ((sf, AddedRemovedLine po pn):mk) = + (sf, AddedRemovedLine po pn) : markup_hunk n l old new mk + +markup_hunk name 1 old (n:ns) mk = + (n, AddedLine name) : markup_hunk name 1 old ns mk +markup_hunk n 1 (o:os) [] ((sf, None):mk) + | o == sf = (sf, RemovedLine n) : markup_hunk n 1 os [] mk + | otherwise = [(BC.pack "Error in patch application", AddedLine n)] +markup_hunk n 1 (o:os) [] ((sf, AddedLine nold):mk) + | o == sf = (sf, AddedRemovedLine nold n) : markup_hunk n 1 os [] mk + | otherwise = [(BC.pack "Error in patch application", AddedLine n)] +markup_hunk _ 1 [] [] mk = mk + +markup_hunk n l old new ((sf, AddedLine pi):mk) + | l > 1 = (sf, AddedLine pi) : markup_hunk n (l-1) old new mk + | l < 1 = (sf, AddedLine pi) : markup_hunk n (l-1) old new mk +markup_hunk n l old new ((sf, None):mk) + | l > 1 = (sf, None) : markup_hunk n (l-1) old new mk + | l < 1 = (sf, None) : markup_hunk n (l-1) old new mk + +markup_hunk _ _ _ _ [] = [] + +markup_hunk _ _ _ _ mk = (BC.pack "Error: ",None) : mk + +markup_tok :: PatchInfo -> String -> String -> String + -> MarkedUpFile -> MarkedUpFile +markup_tok name t ostr nstr mk = concatMap mt mk + where o = BC.pack ostr + n = BC.pack nstr + mt (sf, AddedLine pi) = + case B.concat `fmap` try_tok_internal t o n sf of + Just sf' | sf' == sf -> [(sf, AddedLine pi)] + | otherwise -> [(sf, AddedRemovedLine pi name), + (sf', AddedLine name)] + Nothing -> + [(sf, AddedLine pi), + (BC.pack "There seems to be an inconsistency...", None), + (BC.pack "Please run darcs check.", None)] + mt mark = [mark] +\end{code} + +%files or directories, changed by a patch +%we get it solely from the patch here +%instead of performing patch apply on a population +%we !could! achieve the same by applying a patch to a cleaned population +%and getting modified files and dirs +%but this should be significantly slower when the population grows large +%This could be useful for just presenting a summary of what a patch does +%(especially useful for larger repos) + +\begin{code} +patchChanges :: Prim C(x y) -> [(String,DirMark)] +patchChanges (Move f1 f2) = [(fn2fp f1,MovedFile $ fn2fp f2), + (fn2fp f2,MovedFile $ fn2fp f1)] +patchChanges (DP d AddDir) = [(fn2fp d,AddedDir)] +patchChanges (DP d RmDir) = [(fn2fp d,RemovedDir)] +patchChanges (FP f AddFile) = [(fn2fp f,AddedFile)] +patchChanges (FP f RmFile) = [(fn2fp f,RemovedFile)] +patchChanges (FP f _) = [(fn2fp f,ModifiedFile)] +patchChanges (Split ps) = concat $ mapFL patchChanges ps +patchChanges (ChangePref _ _ _) = [] +patchChanges Identity = [] +\end{code} + +%apply a patch to a population at a given time + +\begin{code} +applyToPop :: PatchInfo -> FL Prim C(x y) -> Population -> Population +applyToPop _ NilFL = id +applyToPop pinf (p:>:ps) = applyToPop pinf ps . applyToPop' pinf p + +applyToPop' + :: PatchInfo -> Prim C(x y) -> Population -> Population +applyToPop' pi patch (Pop _ tree) + = Pop pi (applyToPopTree patch tree) + -- ``pi'' is global below! + where applyToPopTree :: Prim C(x y) -> PopTree -> PopTree + applyToPopTree (Split ps) tr = + foldlFL (\t p -> applyToPopTree p t) tr ps + applyToPopTree p@(FP f AddFile) tr = + let xxx = BC.split '/' (fn2ps f) in + popChange xxx p $ fst $ breakP xxx tr + applyToPopTree p@(FP f _) tr = popChange (BC.split '/' (fn2ps f)) p tr + applyToPopTree p@(DP f AddDir) tr = + let xxx = BC.split '/' (fn2ps f) in + popChange xxx p $ fst $ breakP xxx tr + applyToPopTree p@(DP d _) tr = popChange (BC.split '/' (fn2ps d)) p tr + -- precondition: ``to'' does not exist yet! + applyToPopTree (Move from to) tr + = case breakP (BC.split '/' (fn2ps from)) $ + fst $ breakP (BC.split '/' $ fn2ps to) tr of + (tr',Just ins) -> + let to' = (BC.split '/' (fn2ps to)) + ins' = case ins of + PopDir i trs -> PopDir (i {nameI = last to', + modifiedByI = pi, + modifiedHowI = MovedDir (fn2fp from)}) + trs + PopFile i -> PopFile (i {nameI = last to', + modifiedByI = pi, + modifiedHowI = MovedFile (fn2fp from)}) + in insertP to' tr' ins' + _ -> tr -- ignore the move if ``from'' couldn't be found + applyToPopTree (ChangePref _ _ _) tr = tr + applyToPopTree Identity tr = tr + + -- insert snd arg into fst arg + insertP :: [B.ByteString] -> PopTree -> PopTree -> PopTree + insertP [parent,_] org@(PopDir f trs) tr + | parent == (nameI f) = PopDir f (tr:trs) + | otherwise = org + insertP (n:rest) org@(PopDir f trs) tr + | (nameI f) == n = PopDir f trs' + | otherwise = org + where trs' = map (\o -> insertP rest o tr) trs + insertP _ org _ = org + + -- change a population according to a patch + popChange :: [B.ByteString] -> Prim C(x y) -> PopTree -> PopTree + popChange [parent,path] (DP d AddDir) tr@(PopDir f trs) + | parent == (nameI f) = PopDir f (new:trs) + | otherwise = tr + where new = PopDir (Info {nameI = path, + modifiedByI = pi, + modifiedHowI = AddedDir, + createdByI = Just pi, + creationNameI = Just $ fn2ps d}) [] + -- only mark a directory (and contents) as ``deleted'' do not delete it actually + popChange [path] (DP _ RmDir) tr@(PopDir f trs) + | path == (nameI f) = PopDir (f {modifiedByI = pi, + modifiedHowI = RemovedDir}) trs' + | otherwise = tr + where trs' = map markDel trs -- recursively ``delete'' the contents + + popChange [parent,path] (FP d AddFile) tr@(PopDir f trs) + | parent == (nameI f) = PopDir f (new:trs) + | otherwise = tr + where new = PopFile (Info {nameI = path, + modifiedByI = pi, + modifiedHowI = AddedFile, + createdByI = Just pi, + creationNameI = Just $ fn2ps d}) + popChange [path] (FP _ RmFile) tr@(PopFile f) + | path == (nameI f) = PopFile (f {modifiedByI = pi, + modifiedHowI = RemovedFile}) + | otherwise = tr + popChange [path] (FP _ _) (PopFile f) + | path == (nameI f) + = PopFile (f {modifiedByI = pi, + modifiedHowI = if modifiedHowI f == AddedFile && modifiedByI f == pi + then AddedFile + else ModifiedFile}) + popChange (n:rest) p tr@(PopDir f trs) + | (nameI f) == n = PopDir f (map (popChange rest p) trs) + | otherwise = tr + popChange _ _ tr = tr + markDel (PopDir f trs) = PopDir (f {modifiedByI = pi, + modifiedHowI = RemovedDir}) trs' + where trs' = map markDel trs + markDel (PopFile f) = PopFile (f {modifiedByI = pi, + modifiedHowI = RemovedFile}) + +-- break a poptree fst: org tree with subtree removed, +-- snd: removed subtree +breakP :: [B.ByteString] -> PopTree -> (PopTree,Maybe PopTree) +breakP [parent,path] tr@(PopDir f trees) + | parent == (nameI f) = case findRem path trees of + Just (trees',tree') -> (PopDir f trees',Just tree') + _ -> (tr,Nothing) + | otherwise = (tr,Nothing) + where findRem _ [] = Nothing + findRem the_path (d:trs) + | the_path == pname d = Just (trs,d) + | otherwise = do (trs',d') <- findRem the_path trs + return (d:trs',d') +breakP (n:rest) tr@(PopDir f trs) + | (nameI f) == n = case catMaybes inss of + [ins] -> (PopDir f trs', Just ins) + [] -> (tr,Nothing) + _ -> error "breakP: more than one break" + | otherwise = (tr,Nothing) + where (trs',inss) = unzip (map (breakP rest) trs) +breakP _ tr = (tr,Nothing) + +pname :: PopTree -> B.ByteString +pname (PopDir i _) = nameI i +pname (PopFile i) = nameI i +\end{code} + diff --git a/src/Darcs/Patch/Bundle.hs b/src/Darcs/Patch/Bundle.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Bundle.hs @@ -0,0 +1,211 @@ +-- Copyright (C) 2002-2004,2007 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Patch.Bundle ( hash_bundle, make_bundle, make_bundle2, scan_bundle, + make_context, scan_context, + ) where + +import Darcs.Flags ( DarcsFlag( Unified ) ) +import Darcs.Hopefully ( PatchInfoAnd, piap, + patchInfoAndPatch, + unavailable, hopefully ) +import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch, readPatch ) +import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, human_friendly, is_tag ) +import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) +import Darcs.Ordered ( RL(..), FL(..), unsafeCoerceP, + reverseFL, (+<+), mapFL, mapFL_FL ) +import Printer ( Doc, renderPS, newline, text, ($$), + (<>), vcat, vsep, renderString ) +import Darcs.SlurpDirectory ( Slurpy ) + +import ByteStringUtils ( linesPS, unlinesPS, dropSpace, substrPS) +import qualified Data.ByteString as B (ByteString, length, null, drop, isPrefixOf) +import qualified Data.ByteString.Char8 as BC (unpack, break, pack) + +import SHA1( sha1PS ) +import Darcs.Sealed ( Sealed(Sealed), mapSeal ) + +hash_bundle :: RepoPatch p => [PatchInfo] -> FL (Named p) C(x y) -> String +hash_bundle _ to_be_sent = sha1PS $ renderPS + $ vcat (mapFL showPatch to_be_sent) <> newline + +make_bundle :: RepoPatch p => [DarcsFlag] -> Slurpy -> [PatchInfo] -> FL (Named p) C(x y) -> Doc +make_bundle opts the_s common to_be_sent = make_bundle2 opts the_s common to_be_sent to_be_sent + +-- | In make_bundle2, it is presumed that the two patch sequences are +-- identical, but that they may be lazily generated. If two different +-- patch sequences are passed, a bundle with a mismatched hash will be +-- generated, which is not the end of the world, but isn't very useful +-- either. +make_bundle2 :: RepoPatch p => [DarcsFlag] -> Slurpy -> [PatchInfo] + -> FL (Named p) C(x y) -> FL (Named p) C(x y) -> Doc +make_bundle2 opts the_s common to_be_sent to_be_sent2 = + text "" + $$ text "New patches:" + $$ text "" + $$ the_new + $$ text "" + $$ text "Context:" + $$ text "" + $$ (vcat $ map showPatchInfo common) + $$ text "Patch bundle hash:" + $$ text (hash_bundle common to_be_sent2) + $$ text "" + where the_new = if Unified `elem` opts + then showContextPatch the_s to_be_sent + else vsep $ mapFL showPatch to_be_sent + +scan_bundle :: RepoPatch p => B.ByteString -> Either String (SealedPatchSet p) +scan_bundle ps + | B.null ps = Left "Bad patch bundle!" + | otherwise = + case silly_lex ps of + ("New patches:",rest) -> + case get_patches rest of + (Sealed patches, rest') -> + case silly_lex rest' of + ("Context:", rest'') -> + case get_context rest'' of + (cont,maybe_hash) -> + case substrPS (BC.pack "Patch bundle hash:") + maybe_hash of + Just n -> + if hash_bundle cont (mapFL_FL hopefully patches) + == fst (silly_lex $ snd $ silly_lex $ + B.drop n maybe_hash) + then seal_up_patches patches cont + else Left $ + "Patch bundle failed hash!\n" ++ + "This probably means that the patch has been "++ + "corrupted by a mailer.\n"++ + "The most likely culprit is CRLF newlines." + Nothing -> seal_up_patches patches cont + (a,r) -> Left $ "Malformed patch bundle: '"++a++"' is not 'Context:'" + ++ "\n" ++ BC.unpack r + ("Context:",rest) -> + case get_context rest of + (cont, rest') -> + case silly_lex rest' of + ("New patches:", rest'') -> + case parse_patches rest'' of + Sealed ps'' -> seal_up_patches ps'' cont + (a,_) -> Left $ "Malformed patch bundle: '" ++ a ++ + "' is not 'New patches:'" + ("-----BEGIN PGP SIGNED MESSAGE-----",rest) -> + scan_bundle $ filter_gpg_dashes rest + (_,rest) -> scan_bundle rest + where seal_up_patches :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> [PatchInfo] + -> Either String (SealedPatchSet p) + seal_up_patches xxx yyy = + case reverse yyy of + (x:_) | is_tag x -> + Right $ Sealed ((reverseFL xxx +<+ unavailable_patches yyy) + :<: NilRL) + -- The above NilRL isn't quite + -- right, because ther *are* + -- earlier patches, but we + -- can't set this to undefined + -- because there are + -- situations where we look at + -- the rest. :{ + + -- bug "No more patches in patch bundle!") + _ -> Right $ Sealed ((reverseFL xxx +<+ unavailable_patches yyy) + :<: NilRL) + +-- filter_gpg_dashes is needed because clearsigned patches escape dashes: +filter_gpg_dashes :: B.ByteString -> B.ByteString +filter_gpg_dashes ps = + unlinesPS $ map drop_dashes $ + takeWhile (/= BC.pack "-----END PGP SIGNED MESSAGE-----") $ + dropWhile not_context_or_newpatches $ linesPS ps + where drop_dashes x = if B.length x < 2 then x + else if BC.pack "- " `B.isPrefixOf` x + then B.drop 2 x + else x + not_context_or_newpatches s = (s /= BC.pack "Context:") && + (s /= BC.pack "New patches:") + +unavailable_patches :: RepoPatch p => [PatchInfo] -> RL (PatchInfoAnd p) C(x y) +unavailable_patches [] = unsafeCoerceP NilRL +unavailable_patches (x:xs) = pi_unavailable x :<: unavailable_patches xs + +pi_unavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd p C(x y) +pi_unavailable i = (i `patchInfoAndPatch` + unavailable ("Patch not stored in patch bundle:\n" ++ + renderString (human_friendly i))) +get_context :: B.ByteString -> ([PatchInfo],B.ByteString) +get_context ps = + case readPatchInfo ps of + Just (pinfo,r') -> + case get_context r' of + (pis,r'') -> (pinfo:pis, r'') + Nothing -> ([],ps) +(-:-) :: a C(x y) -> (Sealed (FL a C(y)),b) -> (Sealed (FL a C(x)),b) +p -:- (Sealed ps, r) = (Sealed (p:>:ps), r) +get_patches :: RepoPatch p => B.ByteString -> (Sealed (FL (PatchInfoAnd p) C(x)), B.ByteString) +get_patches ps = + case readPatchInfo ps of + Nothing -> (Sealed NilFL, ps) + Just (pinfo,_) -> + case readPatch ps of + Nothing -> (Sealed NilFL, ps) + Just (Sealed p, r) -> (pinfo `piap` p) -:- get_patches r +parse_patches :: RepoPatch p => B.ByteString -> Sealed (FL (PatchInfoAnd p) C(x)) +parse_patches ps = + case readPatchInfo ps of + Nothing -> Sealed NilFL + Just (pinfo,_) -> + case readPatch ps of + Nothing -> Sealed NilFL + Just (Sealed p, r) -> ((pinfo `piap` p) :>:) `mapSeal` parse_patches r + +silly_lex :: B.ByteString -> (String, B.ByteString) +silly_lex ps = (BC.unpack a, b) + where + (a, b) = BC.break (== '\n') (dropSpace ps) + +{- +silly_lex ps = (BC.unpack $ BC.takeWhile (/='\n') ps', BC.dropWhile (/='\n') ps') + where + ps' = dropSpace ps +-} + +make_context :: [PatchInfo] -> Doc +make_context common = + text "" + $$ text "Context:" + $$ text "" + $$ (vcat $ map showPatchInfo $ common) + $$ text "" + +scan_context :: RepoPatch p => B.ByteString -> PatchSet p C(x) +scan_context ps + | B.null ps = error "Bad context!" + | otherwise = + case silly_lex ps of + ("Context:",rest) -> + case get_context rest of + (cont, _) -> unavailable_patches cont :<: NilRL + ("-----BEGIN PGP SIGNED MESSAGE-----",rest) -> + scan_context $ filter_gpg_dashes rest + (_,rest) -> scan_context rest diff --git a/src/Darcs/Patch/Check.hs b/src/Darcs/Patch/Check.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Check.hs @@ -0,0 +1,335 @@ +-- Copyright (C) 2002-2003 David Roundy +-- +-- 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. + +module Darcs.Patch.Check ( PatchCheck(), do_check, file_exists, dir_exists, + remove_file, remove_dir, create_file, create_dir, + insert_line, delete_line, is_valid, do_verbose_check, + file_empty, + check_move, modify_file, FileContents(..) + ) where + +import System.IO.Unsafe ( unsafePerformIO ) +import qualified Data.ByteString as B (ByteString) +import Data.List ( isPrefixOf, inits ) +import Control.Monad.State ( State, evalState, runState ) +import Control.Monad.State.Class ( get, put, modify ) +-- use Map, not IntMap, because Map has mapKeys and IntMap hasn't +import Data.Map ( Map ) +import qualified Data.Map as M ( mapKeys, delete, insert, empty, lookup, null ) +import System.FilePath ( joinPath, splitDirectories ) + +-- | File contents are represented by a map from line numbers to line contents. +-- If for a certain line number, the line contents are Nothing, that means +-- that we are sure that that line exists, but we don't know its contents. +-- We must also store the greatest line number that is known to exist in a +-- file, to be able to exclude the possibility of it being empty without +-- knowing its contents. +data FileContents = FC { fc_lines :: Map Int B.ByteString + , fc_maxline :: Int + } deriving (Eq, Show) +data Prop = FileEx String | DirEx String | NotEx String + | FileLines String FileContents + deriving (Eq) +-- | A @KnownState@ is a simulated repository state. The repository is either +-- inconsistent, or it has two lists of properties: one list with properties +-- that hold for this repo, and one with properties that do not hold for this +-- repo. These two lists may not have any common elements: if they had, the +-- repository would be inconsistent. +data KnownState = P [Prop] [Prop] + | Inconsistent + deriving (Show) +instance Show Prop where + show (FileEx f) = "FileEx "++f + show (DirEx d) = "DirEx "++d + show (NotEx f) = "NotEx"++f + show (FileLines f l) = "FileLines "++f++": "++show l + +-- | PatchCheck is a state monad with a simulated repository state +type PatchCheck = State KnownState + +-- | The @FileContents@ structure for an empty file +empty_filecontents :: FileContents +empty_filecontents = FC M.empty 0 + +-- | Returns a given value if the repository state is inconsistent, and performs +-- a given action otherwise. +handle_inconsistent :: a -- ^ The value to return if the state is inconsistent + -> PatchCheck a -- ^ The action to perform otherwise + -> PatchCheck a +handle_inconsistent v a = do state <- get + case state of + Inconsistent -> return v + _ -> a + +do_check :: PatchCheck a -> a +do_check p = evalState p (P [] []) + +-- | Run a check, and print the final repository state +do_verbose_check :: PatchCheck a -> a +do_verbose_check p = + case runState p (P [] []) of + (b, pc) -> unsafePerformIO $ do putStrLn $ show pc + return b + +-- | Returns true if the current repository state is not inconsistent +is_valid :: PatchCheck Bool +is_valid = handle_inconsistent False (return True) + +has :: Prop -> [Prop] -> Bool +has _ [] = False +has k (k':ks) = k == k' || has k ks + +modify_file :: String + -> (Maybe FileContents -> Maybe FileContents) + -> PatchCheck Bool +modify_file f change = do + file_exists f + c <- file_contents f + case change c of + Nothing -> assert_not $ FileEx f -- shorthand for "FAIL" + Just c' -> do set_contents f c' + is_valid + +insert_line :: String -> Int -> B.ByteString -> PatchCheck Bool +insert_line f n l = do + c <- file_contents f + case c of + Nothing -> assert_not $ FileEx f -- in this case, the repo is inconsistent + Just c' -> do + let lines' = M.mapKeys (\k -> if k >= n then k+1 else k) (fc_lines c') + lines'' = M.insert n l lines' + maxline' = max n (fc_maxline c') + set_contents f (FC lines'' maxline') + return True + +-- deletes a line from a hunk patch (third argument) in the given file (first +-- argument) at the given line number (second argument) +delete_line :: String -> Int -> B.ByteString -> PatchCheck Bool +delete_line f n l = do + c <- file_contents f + case c of + Nothing -> assert_not $ FileEx f + Just c' -> + let flines = fc_lines c' + flines' = M.mapKeys (\k -> if k > n then k-1 else k) + (M.delete n flines) + maxlinenum' | n <= fc_maxline c' = fc_maxline c' - 1 + | otherwise = n - 1 + c'' = FC flines' maxlinenum' + do_delete = do + set_contents f c'' + is_valid + in case M.lookup n flines of + Nothing -> do_delete + Just l' -> if l == l' + then do_delete + else assert_not $ FileEx f + +set_contents :: String -> FileContents -> PatchCheck () +set_contents f c = handle_inconsistent () $ do + P ks nots <- get + let ks' = FileLines f c : filter (not . is_file_lines_for f) ks + put (P ks' nots) + where is_file_lines_for file prop = case prop of + FileLines f' _ -> file == f' + _ -> False + +-- | Get (as much as we know about) the contents of a file in the current state. +-- Returns Nothing if the state is inconsistent. +file_contents :: String -> PatchCheck (Maybe FileContents) +file_contents f = handle_inconsistent Nothing $ do + P ks _ <- get + return (fic ks) + where fic (FileLines f' c:_) | f == f' = Just c + fic (_:ks) = fic ks + fic [] = Just empty_filecontents + +-- | Checks if a file is empty +file_empty :: String -- ^ Name of the file to check + -> PatchCheck Bool +file_empty f = do + c <- file_contents f + let empty = case c of + Just c' -> fc_maxline c' == 0 && M.null (fc_lines c') + Nothing -> True + if empty + then do set_contents f empty_filecontents + is_valid + -- Crude way to make it inconsistent and return false: + else assert_not $ FileEx f + return empty + +movedirfilename :: String -> String -> String -> String +movedirfilename d d' f = + if (d ++ "/") `isPrefixOf` f + then d'++drop (length d) f + else if f == d + then d' + else f + +-- | Replaces a filename by another in all paths. Returns True if the repository +-- is consistent, False if it is not. +do_swap :: String -> String -> PatchCheck Bool +do_swap f f' = handle_inconsistent False $ do + modify (\(P ks nots) -> P (map sw ks) (map sw nots)) + return True + where sw (FileEx a) | f `is_soe` a = FileEx $ movedirfilename f f' a + | f' `is_soe` a = FileEx $ movedirfilename f' f a + sw (DirEx a) | f `is_soe` a = DirEx $ movedirfilename f f' a + | f' `is_soe` a = DirEx $ movedirfilename f' f a + sw (FileLines a c) | f `is_soe` a = FileLines (movedirfilename f f' a) c + | f' `is_soe` a = FileLines (movedirfilename f' f a) c + sw (NotEx a) | f `is_soe` a = NotEx $ movedirfilename f f' a + | f' `is_soe` a = NotEx $ movedirfilename f' f a + sw p = p + is_soe d1 d2 = -- is_superdir_or_equal + d1 == d2 || (d1 ++ "/") `isPrefixOf` d2 + +-- | Assert a property about the repository. If the property is already present +-- in the repo state, nothing changes, and the function returns True. If it is +-- not present yet, it is added to the repo state, and the function is True. If +-- the property is already in the list of properties that do not hold for the +-- repo, the state becomes inconsistent, and the function returns false. +assert :: Prop -> PatchCheck Bool +assert p = handle_inconsistent False $ do + P ks nots <- get + if has p nots + then do + put Inconsistent + return False + else if has p ks + then return True + else do + put (P (p:ks) nots) + return True + +-- | Like @assert@, but negatively: state that some property must not hold for +-- the current repo. +assert_not :: Prop -> PatchCheck Bool +assert_not p = handle_inconsistent False $ do + P ks nots <- get + if has p ks + then do + put Inconsistent + return False + else if has p nots + then return True + else do + put (P ks (p:nots)) + return True + +-- | Remove a property from the list of properties that do not hold for this +-- repo (if it's there), and add it to the list of properties that hold. +-- Returns False if the repo is inconsistent, True otherwise. +change_to_true :: Prop -> PatchCheck Bool +change_to_true p = handle_inconsistent False $ do + modify (\(P ks nots) -> P (p:ks) (filter (p /=) nots)) + return True + +-- | Remove a property from the list of properties that hold for this repo (if +-- it's in there), and add it to the list of properties that do not hold. +-- Returns False if the repo is inconsistent, True otherwise. +change_to_false :: Prop -> PatchCheck Bool +change_to_false p = handle_inconsistent False $ do + modify (\(P ks nots) -> P (filter (p /=) ks) (p:nots)) + return True + +assert_file_exists :: String -> PatchCheck Bool +assert_file_exists f = do assert_not $ NotEx f + assert_not $ DirEx f + assert $ FileEx f +assert_dir_exists :: String -> PatchCheck Bool +assert_dir_exists d = do assert_not $ NotEx d + assert_not $ FileEx d + assert $ DirEx d +assert_exists :: String -> PatchCheck Bool +assert_exists f = assert_not $ NotEx f + +assert_no_such :: String -> PatchCheck Bool +assert_no_such f = do assert_not $ FileEx f + assert_not $ DirEx f + assert $ NotEx f + +create_file :: String -> PatchCheck Bool +create_file fn = do + superdirs_exist fn + assert_no_such fn + change_to_true (FileEx fn) + change_to_false (NotEx fn) + +create_dir :: String -> PatchCheck Bool +create_dir fn = do + substuff_dont_exist fn + superdirs_exist fn + assert_no_such fn + change_to_true (DirEx fn) + change_to_false (NotEx fn) + +remove_file :: String -> PatchCheck Bool +remove_file fn = do + superdirs_exist fn + assert_file_exists fn + file_empty fn + change_to_false (FileEx fn) + change_to_true (NotEx fn) + +remove_dir :: String -> PatchCheck Bool +remove_dir fn = do + substuff_dont_exist fn + superdirs_exist fn + assert_dir_exists fn + change_to_false (DirEx fn) + change_to_true (NotEx fn) + +check_move :: String -> String -> PatchCheck Bool +check_move f f' = do + superdirs_exist f + superdirs_exist f' + assert_exists f + assert_no_such f' + do_swap f f' + +substuff_dont_exist :: String -> PatchCheck Bool +substuff_dont_exist d = handle_inconsistent False $ do + P ks _ <- get + if all noss ks + then return True + else do + put Inconsistent + return False + where noss (FileEx f) = not (is_within_dir f) + noss (DirEx f) = not (is_within_dir f) + noss _ = True + is_within_dir f = (d ++ "/") `isPrefixOf` f + +-- the init and tail calls dump the final init (which is just the path itself +-- again), the first init (which is empty), and the initial "." from +-- splitDirectories +superdirs_exist :: String -> PatchCheck Bool +superdirs_exist fn = and `fmap` mapM assert_dir_exists superdirs + where superdirs = map (("./"++) . joinPath) + (init (tail (inits (tail (splitDirectories fn))))) + +file_exists :: String -> PatchCheck Bool +file_exists fn = do + superdirs_exist fn + assert_file_exists fn + +dir_exists :: String -> PatchCheck Bool +dir_exists fn = do + superdirs_exist fn + assert_dir_exists fn diff --git a/src/Darcs/Patch/Choices.hs b/src/Darcs/Patch/Choices.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Choices.hs @@ -0,0 +1,292 @@ +-- Copyright (C) 2002-2004 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +-- , TypeOperators, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} + +#include "gadts.h" + +-- | PatchChoices divides a sequence of patches into three sets: "first", +-- "middle" and "last", such that all patches can be applied, if you first +-- apply the first ones then the middle ones and then the last ones. +-- Obviously if there are dependencies between the patches that will put a +-- constraint on how you can choose to divide them up. The PatchChoices data +-- type and associated functions are here to deal with many of the common +-- cases that come up when choosing a subset of a group of patches. +-- +-- 'force_last' tells PatchChoices that a particular patch is required to be in +-- the "last" group, which also means that any patches that depend on it +-- must be in the "last" group. +-- +-- Internally, a PatchChoices doesn't actually reorder the patches until it is +-- asked for the final output (e.g. by 'get_first_choice'). Instead, each +-- patch is placed in a state of definitely first, definitely last and +-- undecided; undecided leans towards "middle". In case you're wondering +-- about the first-middle-last language, it's because in some cases the +-- "yes" answers will be last (as is the case for the revert command), and +-- in others first (as in record, pull and push). +module Darcs.Patch.Choices ( PatchChoices, patch_choices, patch_choices_tps, + patch_slot, + get_choices, + separate_first_middle_from_last, + separate_first_from_middle_last, + force_first, force_firsts, force_last, force_lasts, + force_matching_first, force_matching_last, + select_all_middles, + make_uncertain, make_everything_later, + TaggedPatch, Tag, tag, tp_patch, + Slot(..), + ) where + +import System.IO.Unsafe ( unsafePerformIO ) +import Data.IORef ( newIORef, writeIORef, readIORef ) +import Darcs.Patch +import Darcs.Patch.Permutations ( commuteWhatWeCanRL ) +import Darcs.Patch.Patchy ( Invert, Commute ) +import Darcs.Ordered ( FL(..), RL(..), MyEq, unsafeCompare, + (:>)(..), (:\/:)(..), (:/\:)(..), + zipWithFL, mapFL_FL, mapFL, + (+>+), reverseRL, unsafeCoerceP ) + + +newtype Tag = TG Integer deriving ( Num, Show, Eq, Ord, Enum ) +data TaggedPatch p C(x y) = TP Tag (p C(x y)) +data PatchChoice p C(x y) = PC (TaggedPatch p C(x y)) Slot +newtype PatchChoices p C(x y) = PCs (FL (PatchChoice p) C(x y)) + +data Slot = InFirst | InMiddle | InLast + +invertTag :: Slot -> Slot +invertTag InFirst = InLast +invertTag InLast = InFirst +invertTag t = t + +tag :: TaggedPatch p C(x y) -> Tag +tag (TP (TG t) _) = TG t + +tp_patch :: TaggedPatch p C(x y) -> p C(x y) +tp_patch (TP _ p) = p + +liftTP :: (p C(x y) -> p C(a b)) -> (TaggedPatch p C(x y) -> TaggedPatch p C(a b)) +liftTP f (TP t p) = TP t (f p) + +instance MyEq p => MyEq (TaggedPatch p) where + unsafeCompare (TP t1 p1) (TP t2 p2) = t1 == t2 && unsafeCompare p1 p2 + +instance Invert p => Invert (TaggedPatch p) where + invert = liftTP invert + identity = TP (-1) identity + +instance Commute p => Commute (TaggedPatch p) where + commute (TP t1 p1 :> TP t2 p2) = do p2' :> p1' <- commute (p1 :> p2) + return (TP t2 p2' :> TP t1 p1') + list_touched_files (TP _ p) = list_touched_files p + merge (TP t1 p1 :\/: TP t2 p2) = case merge (p1 :\/: p2) of + p2' :/\: p1' -> TP t2 p2' :/\: TP t1 p1' + +patch_choices :: Patchy p => FL p C(x y) -> PatchChoices p C(x y) +patch_choices = fst . patch_choices_tps + +patch_choices_tps :: Patchy p => FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y)) +patch_choices_tps ps = let tps = zipWithFL TP [1..] ps + in (PCs $ zipWithFL (flip PC) (repeat InMiddle) tps, tps) + +make_everything_later :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y) + +instance MyEq p => MyEq (PatchChoice p) where + unsafeCompare (PC tp1 _) (PC tp2 _) = unsafeCompare tp1 tp2 + +instance Invert p => Invert (PatchChoice p) where + invert (PC tp mf) = PC (invert tp) (invertTag mf) + identity = PC identity InMiddle + +instance Commute p => Commute (PatchChoice p) where + commute (PC t1 x1 :> PC t2 x2) + = do t2' :> t1' <- commute (t1 :> t2) + return (PC t2' x2 :> PC t1' x1) + merge (PC t1 x1 :\/: PC t2 x2) + = case merge (t1 :\/: t2) of + t2' :/\: t1' -> PC t2' x2 :/\: PC t1' x1 + list_touched_files (PC t _) = list_touched_files t + +invertSeq :: (Invert p, Invert q) => (p :> q) C(x y) -> (q :> p) C(y x) +invertSeq (x :> y) = (invert y :> invert x) + +separate_first_from_middle_last :: Patchy p => PatchChoices p C(x z) + -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z) +separate_first_from_middle_last (PCs e) = pull_only_firsts e + +separate_first_middle_from_last :: Patchy p => PatchChoices p C(x z) + -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z) +separate_first_middle_from_last (PCs e) = pull_firsts_middles e + +get_choices :: Patchy p => PatchChoices p C(x y) + -> (FL (TaggedPatch p) :> FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y) +get_choices (PCs e) = case pull_firsts e of + f :> ml -> case pull_firsts (invert ml) of + l :> m -> f :> mapFL_FL pc2tp (invert m) :> invert l + where pc2tp (PC tp _) = tp + +pull_firsts_middles :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z) +pull_firsts_middles easyPC = + let r = unsafePerformIO + $ newIORef (error "pull_firsts_middles called badly") + f :: Patchy p => RL (TaggedPatch p) C(a x) -> FL (PatchChoice p) C(x z) -> FL (TaggedPatch p) C(a d) + f acc NilFL = unsafePerformIO (writeIORef r (reverseRL acc)) `seq` (unsafeCoerceP NilFL) + f acc (PC tp InLast:>:e) = f (tp:<:acc) e + f acc (PC tp _:>:e) = case commuteWhatWeCanRL (acc :> tp) of + more :> tp' :> acc' -> reverseRL more+>+tp':>:f acc' e + xs = f NilRL easyPC + in (xs :> unsafePerformIO (readIORef r)) + +pull_only_firsts :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z) +pull_only_firsts easyPC = + let r = unsafePerformIO + $ newIORef (error "pull_only_firsts called badly") + f :: Patchy p => RL (TaggedPatch p) C(a x) -> FL (PatchChoice p) C(x z) -> FL (TaggedPatch p) C(a d) + f acc NilFL = unsafePerformIO (writeIORef r (reverseRL acc)) `seq` (unsafeCoerceP NilFL) + f acc (PC tp InFirst:>:e) = case commuteWhatWeCanRL (acc :> tp) of + more :> tp' :> acc' -> reverseRL more+>+tp':>:f acc' e + f acc (PC tp _:>:e) = f (tp:<:acc) e + xs = f NilRL easyPC + in (xs :> unsafePerformIO (readIORef r)) + +{- +pull_middles_lasts :: EasyPC p -> ([TaggedPatch p], [TaggedPatch p]) +pull_middles_lasts easyPC = + let r = unsafePerformIO + $ newIORef (error "pull_middles_lasts called badly") + f acc [] = unsafePerformIO (writeIORef r (reverse acc)) `seq` [] + f acc (PC tp (Just True):e) = f (tp:acc) e + f acc (PC (TP t p) _:e) = case commute_up_list p acc of + (acc', p') -> TP t p':f acc' e + xs = f [] easyPC + in (xs, unsafePerformIO (readIORef r)) +-} + +--pull_only_lasts :: EasyPC p -> ([TaggedPatch p], [TaggedPatch p]) +--pull_only_lasts easyPC = +-- let r = unsafePerformIO +-- $ newIORef (error "pull_only_lasts called badly") +-- f acc [] = unsafePerformIO (writeIORef r (reverse acc)) `seq` [] +-- f acc (PC (TP t p) (Just False):e) = case commute_up_list p acc of +-- (acc', p') -> TP t p':f acc' e +-- f acc (PC tp _:e) = f (tp:acc) e +-- xs = f [] easyPC +-- in (xs, unsafePerformIO (readIORef r)) + +pull_firsts :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (PatchChoice p)) C(x z) +pull_firsts e = case pull_first e of + Nothing -> (NilFL :> e) + Just (p:>e') -> case pull_firsts e' of + (ps:>e'') -> (p:>:ps :> e'') + +pull_lasts :: Patchy p => FL (PatchChoice p) C(x y) -> (FL (PatchChoice p) :> FL (TaggedPatch p)) C(x y) +pull_lasts e = invertSeq $ pull_firsts $ invert e + +pull_first :: Patchy p => FL (PatchChoice p) C(x z) -> Maybe ((TaggedPatch p :> FL (PatchChoice p)) C(x z)) +pull_first NilFL = Nothing +pull_first (PC tp InFirst:>:e) = Just (tp :> e) +pull_first (PC (TP t p) InLast:>:e) = + case pull_first e of + Just (TP t2 p2 :> e') -> + case commute (p:>p2) of + Just (p2':>p') -> Just (TP t2 p2' :> PC (TP t p') InLast:>:e') + Nothing -> error "Aaack fixme!" + Nothing -> Nothing +pull_first (PC tp@(TP t p) InMiddle:>:e) = + case pull_first e of + Just (TP t2 p2 :> e') -> + case commute (p:>p2) of + Just (p2':>p') -> Just (TP t2 p2' :> (PC (TP t p') InMiddle:>:e')) + Nothing -> Just (tp :> PC (TP (-t2) p2) InFirst:>:e') + Nothing -> Nothing + +patch_slot :: forall p C(a b x y). TaggedPatch p C(a b) -> PatchChoices p C(x y) -> Slot +patch_slot tp (PCs e) = ipf e + where ipf :: FL (PatchChoice p) C(u v) -> Slot + ipf (PC a mb:>:e') | tag a == tag tp = mb + | otherwise = ipf e' + -- actually, the following should be impossible, but this is a reasonable answer + ipf NilFL = InLast + +set_simplys :: [Tag] -> Bool -> FL (PatchChoice p) C(x y) -> FL (PatchChoice p) C(x y) +set_simplys ts b e = mapFL_FL ch e + where ch (PC tp@(TP t _) _) + | t `elem` ts = PC tp (if b then InFirst else InLast) + | otherwise = PC tp InMiddle + + +m2ids :: (FORALL(x y) TaggedPatch p C(x y) -> Bool) -> FL (PatchChoice p) C(a b) -> [Tag] +m2ids m (PC tp@(TP t _) _:>:e) + | m tp = t:m2ids m e + | otherwise = m2ids m e +m2ids _ NilFL = [] + +force_matching_first :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool) + -> PatchChoices p C(a b) -> PatchChoices p C(a b) +force_matching_first m (PCs e) = + let thd (PC (TP t _) _) = t + xs = m2ids m e + not_needed = case pull_firsts $ set_simplys xs True e of + _ :> rest -> mapFL thd rest + ch pc@(PC tp@(TP t _) _) + | t `elem` not_needed = pc + | otherwise = PC tp InFirst + in PCs $ mapFL_FL ch e + +force_firsts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y) +force_firsts ps pc = force_matching_first ((`elem` ps) . tag) pc + +force_first :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y) +force_first p pc = force_matching_first ((== p) . tag) pc + +select_all_middles :: Patchy p => Bool -> PatchChoices p C(x y) -> PatchChoices p C(x y) +select_all_middles b (PCs e) = PCs (mapFL_FL f e) + where f (PC tp InMiddle) = PC tp (if b then InLast else InFirst) + f pc = pc + +reverse_pc :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(y x) +reverse_pc (PCs e) = PCs $ invert e + +force_matching_last :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool) + -> PatchChoices p C(a b) -> PatchChoices p C(a b) +force_matching_last m (PCs e) = + let thd (PC (TP t _) _) = t + xs = m2ids m e + not_needed = case pull_lasts $ set_simplys xs False e of + rest :> _ -> mapFL thd rest + ch pc@(PC tp@(TP t _) _) + | t `elem` not_needed = pc + | otherwise = PC tp InLast + in PCs $ mapFL_FL ch e + +force_last :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y) +force_last p pc = reverse_pc $ force_first p $ reverse_pc pc + +force_lasts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y) +force_lasts ps pc = reverse_pc $ force_firsts ps $ reverse_pc pc + +make_uncertain :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y) +make_uncertain t (PCs e) = PCs $ mapFL_FL ch e + where ch pc@(PC x _) = if t == tag x then PC x InMiddle else pc + +make_everything_later (PCs e) = PCs $ mapFL_FL ch e + where ch (PC tp InMiddle) = PC tp InLast + ch (PC tp InFirst) = PC tp InMiddle + ch x = x diff --git a/src/Darcs/Patch/Commute.lhs b/src/Darcs/Patch/Commute.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Commute.lhs @@ -0,0 +1,879 @@ +% Copyright (C) 2002-2003 David Roundy +% +% 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. + + +\begin{code} +{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +-- , TypeOperators #-} + +#include "gadts.h" + +module Darcs.Patch.Commute ( fromPrims, + modernize_patch, +#ifndef GADT_WITNESSES + merge, elegant_merge, + merger, unravel, +#endif + public_unravel, mangle_unravelled, + CommuteFunction, Perhaps(..), + -- for other commutes: + toMaybe, + ) + where + +import Control.Monad ( MonadPlus, mplus, msum, mzero ) + +import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn ) +import Darcs.Patch.Info ( invert_name, idpatchinfo ) +import Darcs.Patch.Patchy ( Commute(..), Invert(..) ) +import Darcs.Patch.Core ( Patch(..), Named(..), +#ifndef GADT_WITNESSES + flattenFL, + is_merger, +#endif + merger_undo, + join_patchesFL ) +import Darcs.Patch.Prim ( Prim(..), FromPrims(..), + Conflict(..), Effect(..), + is_filepatch, sort_coalesceFL, +#ifndef GADT_WITNESSES + FilePatchType(..), DirPatchType(..), +#else + FilePatchType(Hunk), +#endif + is_hunk, modernizePrim ) +import qualified Data.ByteString.Char8 as BC (pack, last) +import qualified Data.ByteString as B (null, ByteString) +import Data.Maybe ( isJust ) +import Data.List ( intersperse, sort ) +#ifndef GADT_WITNESSES +import Darcs.Patch.Permutations ( head_permutationsRL, head_permutationsFL ) +import Printer ( text, vcat, ($$) ) +import Darcs.Patch.Patchy ( invertRL ) +import Darcs.Patch.Show ( showPatch_ ) +import Data.List ( nubBy ) +import Darcs.Sealed ( unsafeUnseal ) +#endif +import Darcs.Utils ( nubsort ) +#include "impossible.h" +import Darcs.Sealed ( Sealed(..), mapSeal ) +import Darcs.Ordered ( mapFL, mapFL_FL, unsafeCoerceP, + FL(..), RL(..), + (:/\:)(..), (:<)(..), (:\/:)(..), (:>)(..), +#ifndef GADT_WITNESSES + lengthFL, mapRL, +#endif + reverseFL, reverseRL, concatFL, + MyEq, unsafeCompare + ) + +--import Darcs.ColorPrinter ( traceDoc ) +--import Printer ( greenText ) +\end{code} + +\section{Commuting patches} + +\subsection{Composite patches} + +Composite patches are made up of a series of patches intended to be applied +sequentially. They are represented by a list of patches, with the first +patch in the list being applied first. + +\newcommand{\commutex}{\longleftrightarrow} +\newcommand{\commutes}{\longleftrightarrow} + +The first way (of only two) to change the context of a patch is by +commutation, which is the process of changing the order of two sequential +patches. +\begin{dfn} +The commutation of patches $P_1$ and $P_2$ is represented by +\[ P_2 P_1 \commutes {P_1}' {P_2}'. \] +Here $P_1'$ is intended to describe the same change as $P_1$, with the +only difference being that $P_1'$ is applied after $P_2'$ rather than +before $P_2$. +\end{dfn} +The above definition is obviously rather vague, the reason being that what +is the ``same change'' has not been defined, and we simply assume (and +hope) that the code's view of what is the ``same change'' will match those +of its human users. The `$\commutes$' operator should be read as something +like the $==$ operator in C, indicating that the right hand side performs +identical changes to the left hand side, but the two patches are in +reversed order. When read in this manner, it is clear that commutation +must be a reversible process, and indeed this means that commutation +\emph{can} fail, and must fail in certain cases. For example, the creation +and deletion of the same file cannot be commuted. When two patches fail to +commutex, it is said that the second patch depends on the first, meaning +that it must have the first patch in its context (remembering that the +context of a patch is a set of patches, which is how we represent a tree). +\footnote{The fact that commutation can fail makes a huge difference in the +whole patch formalism. It may be possible to create a formalism in which +commutation always succeeds, with the result of what would otherwise be a +commutation that fails being something like a virtual particle (which can +violate conservation of energy), and it may be that such a formalism would +allow strict mathematical proofs (whereas those used in the current +formalism are mostly only hand waving ``physicist'' proofs). However, I'm +not sure how you'd deal with a request to delete a file that has not yet +been created, for example. Obviously you'd need to create some kind of +antifile, which would annihilate with the file when that file finally got +created, but I'm not entirely sure how I'd go about doing this. +$\ddot\frown$ So I'm sticking with my hand waving formalism.} + +%I should add that one using the inversion relationship of sequential +%patches, one can avoid having to provide redundant definitions of +%commutation. + +% There is another interesting property which is that a commutex's results +% can't be affected by commuting another thingamabopper. + +\begin{code} +data Perhaps a = Unknown | Failed | Succeeded a + +instance Monad Perhaps where + (Succeeded x) >>= k = k x + Failed >>= _ = Failed + Unknown >>= _ = Unknown + Failed >> _ = Failed + (Succeeded _) >> k = k + Unknown >> k = k + return = Succeeded + fail _ = Unknown + +instance MonadPlus Perhaps where + mzero = Unknown + Unknown `mplus` ys = ys + Failed `mplus` _ = Failed + (Succeeded x) `mplus` _ = Succeeded x + +toMaybe :: Perhaps a -> Maybe a +toMaybe (Succeeded x) = Just x +toMaybe _ = Nothing + +toPerhaps :: Maybe a -> Perhaps a +toPerhaps (Just x) = Succeeded x +toPerhaps Nothing = Failed + +#ifndef GADT_WITNESSES +clever_commute :: CommuteFunction -> CommuteFunction +clever_commute c (p1: Succeeded x + Failed -> Failed + Unknown -> case c (invert p2 :< invert p1) of + Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1') + Failed -> Failed + Unknown -> Unknown +#endif + +speedy_commute :: CommuteFunction +speedy_commute (p1 :< p2) -- Deal with common case quickly! + | p1_modifies /= Nothing && p2_modifies /= Nothing && + p1_modifies /= p2_modifies = Succeeded (unsafeCoerceP p2 :< unsafeCoerceP p1) + | otherwise = Unknown + where p1_modifies = is_filepatch_merger p1 + p2_modifies = is_filepatch_merger p2 + +instance Commute p => Commute (Named p) where + commute (NamedP n1 d1 p1 :> NamedP n2 d2 p2) = + if n2 `elem` d1 || n1 `elem` d2 + then Nothing + else do (p2' :> p1') <- commute (p1 :> p2) + return (NamedP n2 d2 p2' :> NamedP n1 d1 p1') + merge (NamedP n1 d1 p1 :\/: NamedP n2 d2 p2) + = case merge (p1 :\/: p2) of + (p2' :/\: p1') -> NamedP n2 d2 p2' :/\: NamedP n1 d1 p1' + list_touched_files (NamedP _ _ p) = list_touched_files p + +instance Conflict p => Conflict (Named p) where + list_conflicted_files (NamedP _ _ p) = list_conflicted_files p + resolve_conflicts (NamedP _ _ p) = resolve_conflicts p + +everything_else_commute :: MaybeCommute -> CommuteFunction +everything_else_commute c x = eec x + where + eec :: CommuteFunction + eec (PP px :< PP py) = toPerhaps $ do y' :< x' <- commutex (px :< py) + return (PP y' :< PP x') + eec (ComP NilFL :< p1) = Succeeded (unsafeCoerceP p1 :< (ComP NilFL)) + eec (p2 :< ComP NilFL) = Succeeded (ComP NilFL :< unsafeCoerceP p2) + eec (ComP (p:>:ps) :< p1) = toPerhaps $ do + (p1' :< p') <- c (p :< p1) + (p1'' :< ComP ps') <- c (ComP ps :< p1') + return (p1'' :< ComP (p':>:ps')) + eec (patch2 :< ComP patches) = + toPerhaps $ do (patches' :< patch2') <- ccr (patch2 :< reverseFL patches) + return (ComP (reverseRL patches') :< patch2') + where ccr :: FORALL(x y) (Patch :< RL Patch) C(x y) -> Maybe ((RL Patch :< Patch) C(x y)) + ccr (p2 :< NilRL) = seq p2 $ return (NilRL :< p2) + ccr (p2 :< p:<:ps) = do (p' :< p2') <- c (p2 :< p) + (ps' :< p2'') <- ccr (p2' :< ps) + return (p':<:ps' :< p2'') + eec _xx = + msum [ +#ifndef GADT_WITNESSES + clever_commute commute_recursive_merger _xx + ,clever_commute other_commute_recursive_merger _xx +#endif + ] + +{- +Note that it must be true that + +commutex (A^-1 A, P) = Just (P, A'^-1 A') + +and + +if commutex (A, B) == Just (B', A') +then commutex (B^-1, A^-1) == Just (A'^-1, B'^-1) +-} + +#ifndef GADT_WITNESSES +merger_commute :: (Patch :< Patch) -> Perhaps (Patch :< Patch) +merger_commute (Merger _ _ p1 p2 :< pA) + | unsafeCompare pA p1 = Succeeded (merger "0.0" p2 p1 :< p2) + | unsafeCompare pA (invert (merger "0.0" p2 p1)) = Failed +merger_commute (Merger _ _ + (Merger _ _ c b) + (Merger _ _ c' a) :< + Merger _ _ b' c'') + | unsafeCompare b' b && unsafeCompare c c' && unsafeCompare c c'' = + Succeeded (merger "0.0" (merger "0.0" b a) (merger "0.0" b c) :< + merger "0.0" b a) +merger_commute _ = Unknown +#endif + +instance Commute Patch where + merge (y :\/: z) = +#ifndef GADT_WITNESSES + case actual_merge (y:\/:z) of + y' -> case commutex (y' :< z) of + Nothing -> bugDoc $ text "merge_patches bug" + $$ showPatch_ y + $$ showPatch_ z + $$ showPatch_ y' + Just (z' :< _) -> z' :/\: y' +#else + case elegant_merge (y:\/:z) of + Just (z' :/\: y') -> z' :/\: y' + Nothing -> undefined +#endif + commutex x = toMaybe $ msum [speedy_commute x, +#ifndef GADT_WITNESSES + clever_commute merger_commute x, +#endif + everything_else_commute commutex x + ] + -- Recurse on everything, these are potentially spoofed patches + list_touched_files (ComP ps) = nubsort $ concat $ mapFL list_touched_files ps + list_touched_files (Merger _ _ p1 p2) = nubsort $ list_touched_files p1 + ++ list_touched_files p2 + list_touched_files c@(Regrem _ _ _ _) = list_touched_files $ invert c + list_touched_files (PP p) = list_touched_files p + +commute_no_merger :: MaybeCommute +commute_no_merger x = +#ifndef GADT_WITNESSES + toMaybe $ msum [speedy_commute x, + everything_else_commute commute_no_merger x] +#else + bug "commute_no_merger undefined when compiled with GADTs" x +#endif + +is_filepatch_merger :: Patch C(x y) -> Maybe FileName +is_filepatch_merger (PP p) = is_filepatch p +is_filepatch_merger (Merger _ _ p1 p2) = do + f1 <- is_filepatch_merger p1 + f2 <- is_filepatch_merger p2 + if f1 == f2 then return f1 else Nothing +is_filepatch_merger (Regrem und unw p1 p2) + = is_filepatch_merger (Merger und unw p1 p2) +is_filepatch_merger (ComP _) = Nothing + +#ifndef GADT_WITNESSES +commute_recursive_merger :: (Patch :< Patch) -> Perhaps (Patch :< Patch) +commute_recursive_merger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $ + do (pA' :< _) <- commutex (undo :< pA) + commutex (invert undo :< pA') + (pAmid :< _) <- commutex (invert p1 :< pA) + (pAx :< p1') <- commutex (p1 :< pAmid) + assert (pAx `unsafeCompare` pA) + (_ : Perhaps (Patch :< Patch) +other_commute_recursive_merger (pA':< p_old@(Merger _ _ p1' p2')) = + toPerhaps $ + do (_ :< pA) <- commutex (pA' :< merger_undo p_old) + (p1 :< pAmid) <- commutex (pA :< p1') + (pAmido :< _) <- commutex (invert p1 :< pA) + assert (pAmido `unsafeCompare` pAmid) + (_ :< p2) <- commutex (p2' :< invert pAmid) + (_ :< p2o') <- commutex (p2 :< pAmid) + assert (p2o' `unsafeCompare` p2') + let p = if p1 `unsafeCompare` p1' && p2 `unsafeCompare` p2' + then p_old + else merger "0.0" p1 p2 + undo = merger_undo p + assert (not $ pA `unsafeCompare` p1) -- special case here... + (pAo' :< _) <- commutex (undo : Maybe () +assert False = Nothing +assert True = Just () +#endif + +type CommuteFunction = FORALL(x y) (Patch :< Patch) C(x y) -> Perhaps ((Patch :< Patch) C(x y)) +type MaybeCommute = FORALL(x y) (Patch :< Patch) C(x y) -> Maybe ((Patch :< Patch) C(x y)) +\end{code} + +\paragraph{Merge} +\newcommand{\merge}{\Longrightarrow} +The second way one can change the context of a patch is by a {\bf merge} +operation. A merge is an operation that takes two parallel patches and +gives a pair of sequential patches. The merge operation is represented by +the arrow ``\( \merge \)''. +\begin{dfn}\label{merge_dfn} +The result of a merge of two patches, $P_1$ and $P_2$ is one of two patches, +$P_1'$ and $P_2'$, which satisfy the relationship: +\[ P_2 \parallel P_1 \merge {P_2}' P_1 \commutex {P_1}' P_2. \] +\end{dfn} +Note that the sequential patches resulting from a merge are \emph{required} +to commutex. This is an important consideration, as without it most of the +manipulations we would like to perform would not be possible. The other +important fact is that a merge \emph{cannot fail}. Naively, those two +requirements seem contradictory. In reality, what it means is that the +result of a merge may be a patch which is much more complex than any we +have yet considered\footnote{Alas, I don't know how to prove that the two +constraints even \emph{can} be satisfied. The best I have been able to do +is to believe that they can be satisfied, and to be unable to find an case +in which my implementation fails to satisfy them. These two requirements +are the foundation of the entire theory of patches (have you been counting +how many foundations it has?).}. + +\subsection{How merges are actually performed} + +The constraint that any two compatible patches (patches which can +successfully be applied to the same tree) can be merged is actually quite +difficult to apply. The above merge constraints also imply that the result +of a series of merges must be independent of the order of the merges. So +I'm putting a whole section here for the interested to see what algorithms +I use to actually perform the merges (as this is pretty close to being the +most difficult part of the code). + +The first case is that in which the two merges don't actually conflict, but +don't trivially merge either (e.g.\ hunk patches on the same file, where the +line number has to be shifted as they are merged). This kind of merge can +actually be very elegantly dealt with using only commutation and inversion. + +There is a handy little theorem which is immensely useful when trying to +merge two patches. +\begin{thm}\label{merge_thm} +$ P_2' P_1 \commutex P_1' P_2 $ if and only if $ P_1'^{ -1} +P_2' \commutex P_2 P_1^{ -1} $, provided both commutations succeed. If +either commutex fails, this theorem does not apply. +\end{thm} +This can easily be proven by multiplying both sides of the first +commutation by $P_1'^{ -1}$ on the left, and by $P_1^{ -1}$ on the right. +Besides being used in merging, this theorem is also useful in the recursive +commutations of mergers. From Theorem~\ref{merge_thm}, we see that the +merge of $P_1$ and $P_2'$ is simply the commutation of $P_2$ with $P_1^{ +-1}$ (making sure to do the commutation the right way). Of course, if this +commutation fails, the patches conflict. Moreover, one must check that the +merged result actually commutes with $P_1$, as the theorem applies only +when \emph{both} commutations are successful. + +\begin{code} + +elegant_merge :: (Patch :\/: Patch) C(x y) + -> Maybe ((Patch :/\: Patch) C(x y)) +elegant_merge (p1 :\/: p2) = + case commutex (p1 :< invert p2) of + Just (ip2': case commutex (p1' :< p2) of + Nothing -> Nothing -- should be a redundant check + Just (_: if unsafeCompare p1o p1 + then Just (invert ip2' :/\: p1') + else Nothing + Nothing -> Nothing + +\end{code} + +Of course, there are patches that actually conflict, meaning a merge where +the two patches truly cannot both be applied (e.g.\ trying to create a file +and a directory with the same name). We deal with this case by creating a +special kind of patch to support the merge, which we will call a +``merger''. Basically, a merger is a patch that contains the two patches +that conflicted, and instructs darcs basically to resolve the conflict. By +construction a merger will satisfy the commutation property (see +Definition~\ref{merge_dfn}) that characterizes all merges. Moreover the +merger's properties are what makes the order of merges unimportant (which +is a rather critical property for darcs as a whole). + +The job of a merger is basically to undo the two conflicting patches, and +then apply some sort of a ``resolution'' of the two instead. In the case +of two conflicting hunks, this will look much like what CVS does, where it +inserts both versions into the file. In general, of course, the two +conflicting patches may both be mergers themselves, in which case the +situation is considerably more complicated. + +\begin{code} +#ifndef GADT_WITNESSES +actual_merge :: (Patch :\/: Patch) -> Patch +actual_merge (ComP the_p1s :\/: ComP the_p2s) = + join_patchesFL $ mc the_p1s the_p2s + where mc :: FL Patch -> FL Patch -> FL Patch + mc NilFL (_:>:_) = NilFL + mc p1s NilFL = p1s + mc p1s (p2:>:p2s) = mc (merge_patches_after_patch p1s p2) p2s +actual_merge (ComP p1s :\/: p2) = seq p2 $ + join_patchesFL $ merge_patches_after_patch p1s p2 +actual_merge (p1 :\/: ComP p2s) = seq p1 $ merge_patch_after_patches p1 p2s + +actual_merge (p1 :\/: p2) = case elegant_merge (p1:\/:p2) of + Just (_ :/\: p1') -> p1' + Nothing -> merger "0.0" p2 p1 + +merge_patch_after_patches :: Patch -> FL Patch -> Patch +merge_patch_after_patches p (p1:>:p1s) = + merge_patch_after_patches (actual_merge (p:\/:p1)) p1s +merge_patch_after_patches p NilFL = p + +merge_patches_after_patch :: FL Patch -> Patch -> FL Patch +merge_patches_after_patch p2s p = + case commutex (merge_patch_after_patches p p2s :< join_patchesFL p2s) of + Just (ComP p2s':< _) -> p2s' + _ -> impossible +#endif +\end{code} + +Much of the merger code depends on a routine which recreates from a single +merger the entire sequence of patches which led up to that merger (this is, +of course, assuming that this is the complicated general case of a merger +of mergers of mergers). This ``unwind'' procedure is rather complicated, +but absolutely critical to the merger code, as without it we wouldn't even +be able to undo the effects of the patches involved in the merger, since we +wouldn't know what patches were all involved in it. + +Basically, unwind takes a merger such as +\begin{verbatim} +M( M(A,B), M(A,M(C,D))) +\end{verbatim} +From which it recreates a merge history: +\begin{verbatim} +C +A +M(A,B) +M( M(A,B), M(A,M(C,D))) +\end{verbatim} +(For the curious, yes I can easily unwind this merger in my head [and on +paper can unwind insanely more complex mergers]---that's what comes of +working for a few months on an algorithm.) Let's start with a simple +unwinding. The merger \verb!M(A,B)! simply means that two patches +(\verb!A! and \verb!B!) conflicted, and of the two of them \verb!A! is +first in the history. The last two patches in the unwinding of any merger +are always just this easy. So this unwinds to: +\begin{verbatim} +A +M(A,B) +\end{verbatim} +What about a merger of mergers? How about \verb!M(A,M(C,D))!. In this case +we know the two most recent patches are: +\begin{verbatim} +A +M(A,M(C,D)) +\end{verbatim} +But obviously the unwinding isn't complete, since we don't yet see where +\verb!C! and \verb!D! came from. In this case we take the unwinding of +\verb!M(C,D)! and drop its latest patch (which is \verb!M(C,D)! itself) and +place that at the beginning of our patch train: +\begin{verbatim} +C +A +M(A,M(C,D)) +\end{verbatim} +As we look at \verb!M( M(A,B), M(A,M(C,D)))!, we consider the unwindings of +each of its subpatches: +\begin{verbatim} + C +A A +M(A,B) M(A,M(C,D)) +\end{verbatim} +As we did with \verb!M(A,M(C,D))!, we'll drop the first patch on the +right and insert the first patch on the left. That moves us up to the two +\verb!A!'s. Since these agree, we can use just one of them (they +``should'' agree). That leaves us with the \verb!C! which goes first. + +The catch is that things don't always turn out this easily. There is no +guarantee that the two \verb!A!'s would come out at the same time, and if +they didn't, we'd have to rearrange things until they did. Or if there was +no way to rearrange things so that they would agree, we have to go on to +plan B, which I will explain now. + +Consider the case of \verb!M( M(A,B), M(C,D))!. We can easily unwind the +two subpatches +\begin{verbatim} +A C +M(A,B) M(C,D) +\end{verbatim} +Now we need to reconcile the \verb!A! and \verb!C!. How do we do this? +Well, as usual, the solution is to use the most wonderful +Theorem~\ref{merge_thm}. In this case we have to use it in the reverse of +how we used it when merging, since we know that \verb!A! and \verb!C! could +either one be the \emph{last} patch applied before \verb!M(A,B)! or +\verb!M(C,D)!. So we can find \verb!C'! using +\[ +A^{ -1} C \commutex C' A'^{ -1} +\] +Giving an unwinding of +\begin{verbatim} +C' +A +M(A,B) +M( M(A,B), M(C,D) ) +\end{verbatim} +There is a bit more complexity to the unwinding process (mostly having to +do with cases where you have deeper nesting), but I think the general +principles that are followed are pretty much included in the above +discussion. + +\begin{code} +#ifndef GADT_WITNESSES +unwind :: Patch -> RL Patch -- Recreates a patch history in reverse. +unwind (Merger _ unwindings _ _) = unwindings +unwind p = p :<: NilRL; + +true_unwind :: Patch -> RL Patch -- Recreates a patch history in reverse. +true_unwind p@(Merger _ _ p1 p2) = + case (unwind p1, unwind p2) of + (_:<:p1s,_:<:p2s) -> p :<: p1 :<: reconcile_unwindings p p1s p2s + _ -> impossible +true_unwind _ = impossible + +reconcile_unwindings :: Patch -> RL Patch -> RL Patch -> RL Patch +reconcile_unwindings _ NilRL p2s = p2s +reconcile_unwindings _ p1s NilRL = p1s +reconcile_unwindings p (p1:<:p1s) p2s = + case [(p1s', p2s')| + p1s'@(hp1s':<:_) <- head_permutationsRL (p1:<:p1s), + p2s'@(hp2s':<:_) <- head_permutationsRL p2s, + hp1s' `unsafeCompare` hp2s'] of + ((p1':<:p1s', _:<:p2s'):_) -> + p1' :<: reconcile_unwindings p p1s' p2s' + [] -> case reverseFL `fmap` put_before p1 (reverseRL p2s) of + Just p2s' -> p1 :<: reconcile_unwindings p p1s p2s' + Nothing -> + case fmap reverseFL $ put_before (headRL p2s) $ + reverseRL (p1:<:p1s) of + Just p1s' -> case p2s of + hp2s:<:tp2s -> hp2s :<: + reconcile_unwindings p p1s' tp2s + NilRL -> impossible + Nothing -> + bugDoc $ text "in function reconcile_unwindings" + $$ text "Original patch:" + $$ showPatch_ p + _ -> bug "in reconcile_unwindings" + +put_before :: Patch -> FL Patch -> Maybe (FL Patch) +put_before p1 (p2:>:p2s) = + do p2'::) `fmap` put_before p1' p2s +put_before _ NilFL = Just NilFL +#endif +\end{code} + +\section{Conflicts} + +There are a couple of simple constraints on the routine which determines +how to resolve two conflicting patches (which is called `glump'). These +must be satisfied in order that the result of a series of merges is always +independent of their order. Firstly, the output of glump cannot change +when the order of the two conflicting patches is switched. If it did, then +commuting the merger could change the resulting patch, which would be bad. +Secondly, the result of the merge of three (or more) conflicting patches +cannot depend on the order in which the merges are performed. + +The conflict resolution code (glump) begins by ``unravelling'' the merger +into a set of sequences of patches. Each sequence of patches corresponds +to one non-conflicted patch that got merged together with the others. The +result of the unravelling of a series of merges must obviously be +independent of the order in which those merges are performed. This +unravelling code (which uses the unwind code mentioned above) uses probably +the second most complicated algorithm. Fortunately, if we can successfully +unravel the merger, almost any function of the unravelled merger satisfies +the two constraints mentioned above that the conflict resolution code must +satisfy. + +\begin{code} +instance Conflict Patch where + commute_no_conflicts (x:>y) = do x' :< y' <- commute_no_merger (y :< x) + return (y':>x') +#ifndef GADT_WITNESSES + resolve_conflicts patch = rcs NilFL $ reverseFL $ flattenFL patch + where rcs :: FL Patch C(w y) -> RL Patch C(x y) -> [[Sealed (FL Prim C(w))]] + rcs _ NilRL = [] + rcs passedby (p@(Merger _ _ _ _):<:ps) = + case commute_no_merger (join_patchesFL passedby: + (map Sealed $ nubBy unsafeCompare $ effect (glump09 p1 p2) : unravel p') + : rcs (p :>: passedby) ps + Nothing -> rcs (p :>: passedby) ps + _ -> impossible + rcs passedby (p:<:ps) = seq passedby $ + rcs (p :>: passedby) ps +#else + resolve_conflicts = bug "haven't defined resolve_conflicts with type witnesses." +#endif + +public_unravel :: Patch C(x y) -> [Sealed (FL Prim C(y))] +#ifdef GADT_WITNESSES +public_unravel = bug "Haven't implemented public_unravel with type witnesses." +#else +public_unravel p = map Sealed $ unravel p +#endif + +#ifndef GADT_WITNESSES +unravel :: Patch -> [FL Prim] +unravel p = nubBy unsafeCompare $ + map (sort_coalesceFL . concatFL . mapFL_FL effect) $ + get_supers $ map reverseRL $ new_ur p $ unwind p + +get_supers :: [FL Patch] -> [FL Patch] +get_supers (x:xs) = + case filter (not.(x `is_superpatch_of`)) xs of + xs' -> if or $ map (`is_superpatch_of` x) xs' + then get_supers xs' + else x : get_supers xs' +get_supers [] = [] +is_superpatch_of :: FL Patch -> FL Patch -> Bool +x `is_superpatch_of` y | lengthFL y > lengthFL x = False +x `is_superpatch_of` y = x `iso` y + where iso :: FL Patch -> FL Patch -> Bool + _ `iso` NilFL = True + NilFL `iso` _ = False + a `iso` (b:>:bs) = + case filter ((`unsafeCompare` b) . headFL) $ + head_permutationsFL a of + ((_:>:as):_) -> as `iso` bs + [] -> False + _ -> bug "bug in is_superpatch_of" + +headFL :: FL a -> a +headFL (x:>:_) = x +headFL NilFL = bug "bad headFL" + +merger :: String -> Patch -> Patch -> Patch +merger "0.0" p1 p2 = Merger undoit unwindings p1 p2 + where fake_p = Merger identity NilRL p1 p2 + unwindings = true_unwind fake_p + p = Merger identity unwindings p1 p2 + undoit = + case (is_merger p1, is_merger p2) of + (True ,True ) -> join_patchesFL $ invertRL $ tailRL $ unwind p + where tailRL (_:<:t) = t + tailRL _ = impossible + (False,False) -> invert p1 + (True ,False) -> join_patchesFL NilFL + (False,True ) -> join_patchesFL (invert p1 :>: merger_undo p2 :>: NilFL) +merger g _ _ = + error $ "Cannot handle mergers other than version 0.0\n"++g + ++ "\nPlease use darcs optimize --modernize with an older darcs." + +glump09 :: Patch -> Patch -> Patch +glump09 p1 p2 = fromPrims $ unsafeUnseal $ mangle_unravelled $ map Sealed $ unravel $ merger "0.0" p1 p2 + +#endif + +mangle_unravelled :: [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x)) +mangle_unravelled pss = if only_hunks pss + then (:>: NilFL) `mapSeal` mangle_unravelled_hunks pss + else head pss + +only_hunks :: [Sealed (FL Prim C(x))] -> Bool +only_hunks [] = False +only_hunks pss = fn2fp f /= "" && all oh pss + where f = get_a_filename pss + oh :: Sealed (FL Prim C(x)) -> Bool + oh (Sealed (p:>:ps)) = is_hunk p && + [fn2fp f] == list_touched_files p && + oh (Sealed ps) + oh (Sealed NilFL) = True + +apply_hunks :: [Maybe B.ByteString] -> FL Prim C(x y) -> [Maybe B.ByteString] +apply_hunks ms (FP _ (Hunk l o n):>:ps) = apply_hunks (rls l ms) ps + where rls 1 mls = map Just n ++ drop (length o) mls + rls i (ml:mls) = ml : rls (i-1) mls + rls _ [] = bug "rls in apply_hunks" +apply_hunks ms NilFL = ms +apply_hunks _ (_:>:_) = impossible + +get_old :: [Maybe B.ByteString] -> [Sealed (FL Prim C(x))] -> [Maybe B.ByteString] +get_old mls (ps:pss) = get_old (get_hunks_old mls ps) pss +get_old mls [] = mls + +get_a_filename :: [Sealed (FL Prim C(x))] -> FileName +get_a_filename ((Sealed (FP f _:>:_)):_) = f +get_a_filename _ = fp2fn "" + +get_hunks_old :: [Maybe B.ByteString] -> Sealed (FL Prim C(x)) + -> [Maybe B.ByteString] +get_hunks_old mls (Sealed ps) = + apply_hunks (apply_hunks mls ps) (invert ps) + +get_hunks_new :: [Maybe B.ByteString] -> Sealed (FL Prim C(x)) + -> [Maybe B.ByteString] +get_hunks_new mls (Sealed ps) = apply_hunks mls ps + +get_hunkline :: [[Maybe B.ByteString]] -> Int +get_hunkline = ghl 1 + where ghl :: Int -> [[Maybe B.ByteString]] -> Int + ghl n pps = + if any (isJust . head) pps + then n + else ghl (n+1) $ map tail pps + +make_chunk :: Int -> [Maybe B.ByteString] -> [B.ByteString] +make_chunk n mls = pull_chunk $ drop (n-1) mls + where pull_chunk (Just l:mls') = l : pull_chunk mls' + pull_chunk (Nothing:_) = [] + pull_chunk [] = bug "should this be [] in pull_chunk?" + +mangle_unravelled_hunks :: [Sealed (FL Prim C(x))] -> Sealed (Prim C(x)) +--mangle_unravelled_hunks [[h1],[h2]] = Deal with simple cases handily? +mangle_unravelled_hunks pss = + if null nchs then bug "mangle_unravelled_hunks" + else Sealed (FP filename (Hunk l old new)) + where oldf = get_old (repeat Nothing) pss + newfs = map (get_hunks_new oldf) pss + l = get_hunkline $ oldf : newfs + nchs = sort $ map (make_chunk l) newfs + filename = get_a_filename pss + old = make_chunk l oldf + new = [top] ++ concat (intersperse [middle] nchs) ++ [bottom] + top = BC.pack $ "v v v v v v v" ++ eol_c + middle = BC.pack $ "*************" ++ eol_c + bottom = BC.pack $ "^ ^ ^ ^ ^ ^ ^" ++ eol_c + eol_c = if any (\ps -> not (B.null ps) && BC.last ps == '\r') old + then "\r" + else "" + +instance Effect Patch where + effect p@(Merger _ _ _ _) = sort_coalesceFL $ effect $ merger_undo p + effect p@(Regrem _ _ _ _) = invert $ effect $ invert p + effect (ComP ps) = concatFL $ mapFL_FL effect ps + effect (PP p) = effect p + isHunk p = do PP p' <- return p + isHunk p' + +modernize_patch :: Patch C(x y) -> Patch C(x y) +modernize_patch p@(Merger _ _ _ _) = fromPrims $ effect p +modernize_patch p@(Regrem _ _ _ _) = fromPrims $ effect p +modernize_patch (ComP ps) = ComP $ filtermv $ mapFL_FL modernize_patch ps + where filtermv :: FL Patch C(x y) -> FL Patch C(x y) +#ifndef GADT_WITNESSES + filtermv (PP (Move _ b):>:xs) | hasadd xs = filtermv xs + where hasadd (PP (FP b' AddFile):>:_) | b' == b = True + hasadd (PP (DP b' AddDir):>:_) | b' == b = True + hasadd (PP (FP b' RmFile):>:_) | b' == b = False + hasadd (PP (DP b' RmDir):>:_) | b' == b = False + hasadd (_:>:z) = hasadd z + hasadd NilFL = False +#endif + filtermv (x:>:xs) = x :>: filtermv xs + filtermv NilFL = NilFL + +modernize_patch (PP p) = fromPrims $ modernizePrim p + +instance FromPrims Patch where + fromPrims (p :>: NilFL) = PP p + fromPrims ps = join_patchesFL $ mapFL_FL PP ps + joinPatches = join_patchesFL + +#ifndef GADT_WITNESSES +new_ur :: Patch -> RL Patch -> [RL Patch] +new_ur p (Merger _ _ p1 p2 :<: ps) = + case filter ((`unsafeCompare` p1) . headRL) $ head_permutationsRL ps of + ((_:<:ps'):_) -> new_ur p (p1:<:ps') ++ new_ur p (p2:<:ps') + _ -> bugDoc $ text "in function new_ur" + $$ text "Original patch:" + $$ showPatch_ p + $$ text "Unwound:" + $$ vcat (mapRL showPatch_ $ unwind p) + +new_ur op ps = + case filter (is_merger.headRL) $ head_permutationsRL ps of + [] -> [ps] + (ps':_) -> new_ur op ps' + +headRL :: RL a -> a +headRL (x:<:_) = x +headRL _ = bug "bad headRL" +#endif + +instance Invert p => Invert (Named p) where + invert (NamedP n d p) = NamedP (invert_name n) (map invert_name d) (invert p) + identity = NamedP idpatchinfo [] identity + +instance Invert Patch where + invert (Merger undo unwindings p1 p2) + = Regrem undo unwindings p1 p2 + invert (Regrem undo unwindings p1 p2) + = Merger undo unwindings p1 p2 + invert (PP p) = PP (invert p) + invert (ComP ps) = ComP $ invert ps + identity = ComP NilFL + +instance MyEq Patch where + unsafeCompare = eq_patches +instance MyEq p => MyEq (Named p) where + unsafeCompare (NamedP n1 d1 p1) (NamedP n2 d2 p2) = + n1 == n2 && d1 == d2 && unsafeCompare p1 p2 + +eq_patches :: Patch C(x y) -> Patch C(w z) -> Bool +eq_patches (PP p1) (PP p2) = unsafeCompare p1 p2 +eq_patches (ComP ps1) (ComP ps2) + = eq_FL eq_patches ps1 ps2 +eq_patches (ComP NilFL) (PP Identity) = True +eq_patches (PP Identity) (ComP NilFL) = True +eq_patches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b) + = eq_patches p1a p2a && + eq_patches p1b p2b +eq_patches (Regrem _ _ p1a p1b) (Regrem _ _ p2a p2b) + = eq_patches p1a p2a && + eq_patches p1b p2b +eq_patches _ _ = False + +eq_FL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Bool) + -> FL a C(x y) -> FL a C(w z) -> Bool +eq_FL _ NilFL NilFL = True +eq_FL f (x:>:xs) (y:>:ys) = f x y && eq_FL f xs ys +eq_FL _ _ _ = False + +\end{code} diff --git a/src/Darcs/Patch/Core.lhs b/src/Darcs/Patch/Core.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Core.lhs @@ -0,0 +1,173 @@ +% Copyright (C) 2002-2003 David Roundy +% +% 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. + + +\section{Patch relationships} + +\begin{code} +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +-- , GADTs, PatternGuards #-} + +#include "gadts.h" + +module Darcs.Patch.Core + ( Patch(..), Named(..), + join_patchesFL, concatFL, flattenFL, + nullP, is_null_patch, infopatch, + n_fn, + adddeps, namepatch, anonymous, + merger_undo, is_merger, + getdeps, + patch2patchinfo, patchname, patchcontents, + ) + where + +import Prelude hiding ( pi ) +import Darcs.Patch.Info ( PatchInfo, patchinfo, make_filename ) +import Darcs.Patch.Patchy ( Patchy ) +import Darcs.Ordered +import Darcs.Patch.Prim ( Prim(..), FromPrim(..), Effect(effect, effectRL), n_fn ) +#include "impossible.h" + +data Patch C(x y) where + PP :: Prim C(x y) -> Patch C(x y) + ComP :: FL Patch C(x y) -> Patch C(x y) + Merger :: Patch C(x y) + -> RL Patch C(x b) + -> Patch C(c b) + -> Patch C(c d) + -> Patch C(x y) + Regrem :: Patch C(x y) + -> RL Patch C(x b) + -> Patch C(c b) + -> Patch C(c a) + -> Patch C(y x) + +instance FromPrim Patch where + fromPrim = PP + +data Named p C(x y) where + NamedP :: !PatchInfo -> ![PatchInfo] -> !(p C(x y)) -> Named p C(x y) + +instance Effect p => Effect (Named p) where + effect (NamedP _ _ p) = effect p + effectRL (NamedP _ _ p) = effectRL p + +is_null_patch :: Patch C(x y) -> Bool +is_null_patch (ComP ps) = and $ mapFL is_null_patch ps +is_null_patch _ = False + +nullP :: Patch C(x y) -> EqCheck C(x y) +nullP (ComP NilFL) = IsEq +nullP (ComP (x:>:xs)) | IsEq <- nullP x = nullP (ComP xs) +nullP _ = NotEq + +is_merger :: Patch C(a b) -> Bool +is_merger (Merger _ _ _ _) = True +is_merger (Regrem _ _ _ _) = True +is_merger _ = False + +merger_undo :: Patch C(x y) -> Patch C(x y) +merger_undo (Merger undo _ _ _) = undo +merger_undo _ = impossible +\end{code} + +%Another nice thing to be able to do with composite patches is to `flatten' +%them, that is, turn them into a simple list of patches (appropriately +%ordered, of course), with all nested compositeness unnested. + +\begin{code} +{- INLINE flattenFL -} +flattenFL :: Patch C(x y) -> FL Patch C(x y) +flattenFL (ComP ps) = concatFL (mapFL_FL flattenFL ps) +flattenFL (PP Identity) = NilFL +flattenFL p = p :>: NilFL + +join_patchesFL :: FL Patch C(x y) -> Patch C(x y) +join_patchesFL ps = ComP $! ps + +infopatch :: Patchy p => PatchInfo -> p C(x y) -> Named p C(x y) +adddeps :: Named p C(x y) -> [PatchInfo] -> Named p C(x y) +getdeps :: Named p C(x y) -> [PatchInfo] + +namepatch :: Patchy p => String -> String -> String -> [String] -> p C(x y) -> IO (Named p C(x y)) +namepatch date name author desc p + | '\n' `elem` name = error "Patch names cannot contain newlines." + | otherwise = do pinf <- patchinfo date name author desc + return $ NamedP pinf [] p + +anonymous :: Patchy p => p C(x y) -> IO (Named p C(x y)) +anonymous p = namepatch "today" "anonymous" "unknown" ["anonymous"] p + +infopatch pi p = NamedP pi [] p +adddeps (NamedP pi _ p) ds = NamedP pi ds p +getdeps (NamedP _ ds _) = ds + +patch2patchinfo :: Named p C(x y) -> PatchInfo +patch2patchinfo (NamedP i _ _) = i + +patchname :: Named p C(x y) -> String +patchname (NamedP i _ _) = make_filename i + +patchcontents :: Named p C(x y) -> p C(x y) +patchcontents (NamedP _ _ p) = p +\end{code} + +The simplest relationship between two patches is that of ``sequential'' +patches, which means that the context of the second patch (the one on the +left) consists of the first patch (on the right) plus the context of the +first patch. The composition of two patches (which is also a patch) refers +to the patch which is formed by first applying one and then the other. The +composition of two patches, $P_1$ and $P_2$ is represented as $P_2P_1$, +where $P_1$ is to be applied first, then $P_2$\footnote{This notation is +inspired by the notation of matrix multiplication or the application of +operators upon a Hilbert space. In the algebra of patches, there is +multiplication (i.e.\ composition), which is associative but not +commutative, but no addition or subtraction.} + +There is one other very useful relationship that two patches can have, +which is to be parallel patches, which means that the two patches have an +identical context (i.e.\ their representation applies to identical trees). +This is represented by $P_1\parallel P_2$. Of course, two patches may also +have no simple relationship to one another. In that case, if you want to +do something with them, you'll have to manipulate them with respect to +other patches until they are either in sequence or in parallel. + +The most fundamental and simple property of patches is that they must be +invertible. The inverse of a patch is described by: $P^{ -1}$. In the +darcs implementation, the inverse is required to be computable from +knowledge of the patch only, without knowledge of its context, but that +(although convenient) is not required by the theory of patches. +\begin{dfn} +The inverse of patch $P$ is $P^{ -1}$, which is the ``simplest'' patch for +which the composition \( P^{ -1} P \) makes no changes to the tree. +\end{dfn} +Using this definition, it is trivial to prove the following theorem +relating to the inverse of a composition of two patches. +\begin{thm} The inverse of the composition of two patches is +\[ (P_2 P_1)^{ -1} = P_1^{ -1} P_2^{ -1}. \] +\end{thm} +Moreover, it is possible to show that the right inverse of a patch is equal +to its left inverse. In this respect, patches continue to be analogous to +square matrices, and indeed the proofs relating to these properties of the +inverse are entirely analogous to the proofs in the case of matrix +multiplication. The compositions proofs can also readily be extended to +the composition of more than two patches. +\begin{code} + +\end{code} diff --git a/src/Darcs/Patch/Depends.hs b/src/Darcs/Patch/Depends.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Depends.hs @@ -0,0 +1,498 @@ +-- Copyright (C) 2003-2004 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +-- , ScopedTypeVariables, TypeOperators #-} + +#include "gadts.h" + +module Darcs.Patch.Depends ( get_common_and_uncommon, get_tags_right, + get_common_and_uncommon_or_missing, + optimize_patchset, deep_optimize_patchset, + slightly_optimize_patchset, + get_patches_beyond_tag, get_patches_in_tag, + patchset_union, patchset_intersection, + commute_to_end, + ) where +import Data.List ( delete, intersect ) +import Control.Monad ( liftM2 ) +import Control.Monad.Error ( Error(..) ) + +import Darcs.Patch ( RepoPatch, Named, getdeps, commutex, + commuteFL, + patch2patchinfo, merge ) +import Darcs.Ordered ( (:\/:)(..), (:<)(..), (:/\:)(..), (:>)(..), + RL(..), FL(..), + (+<+), + reverseFL, mapFL_FL, mapFL, concatReverseFL, + lengthRL, concatRL, reverseRL, mapRL, + unsafeCoerceP, EqCheck(..) ) +import Darcs.Patch.Permutations ( partitionRL ) +import Darcs.Patch.Info ( PatchInfo, human_friendly, is_tag ) +import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) +import Darcs.Patch.Patchy ( sloppyIdentity ) +import Darcs.Hopefully ( PatchInfoAnd, piap, info, n2pia, + hopefully, conscientiously, hopefullyM ) +import Darcs.ProgressPatches ( progressRL ) +import Darcs.Sealed (Sealed(..), FlippedSeal(..), Sealed2(..) + , flipSeal, seal, unseal ) +import Printer ( errorDoc, renderString, ($$), text ) +#include "impossible.h" + +get_common_and_uncommon :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) -> + ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) +get_common_and_uncommon_or_missing :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) -> + Either PatchInfo ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) + +get_common_and_uncommon = + either missingPatchError id . get_common_and_uncommon_err + +get_common_and_uncommon_or_missing = + either (\(MissingPatch x _) -> Left x) Right . get_common_and_uncommon_err + +get_common_and_uncommon_err :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) -> + Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) +get_common_and_uncommon_err (ps1,ps2) = gcau (optimize_patchset ps1) ps2 + +{-| +with_partial_intersection takes two 'PatchSet's and splits them into a /common/ +intersection portion and two sets of patches. The intersection, however, +is only lazily determined, so there is no guarantee that all intersecting +patches will be included in the intersection 'PatchSet'. This is a pretty +efficient function, because it makes use of the already-broken-up nature of +'PatchSet's. + +'PatchSet's have the property that if +@ +(info $ last $ head a) == (info $ last $ head b) +@ +then @(tail a)@ and @(tail b)@ are identical repositories, and we want to take +advantage of this if possible, to avoid reading too many inventories. In +the case of --partial repositories or patch bundles, it is crucial that we +don't need to read the whole history, since it isn't available. + +TODO: + +The length equalising isn't necessarily right. We probably also be +thinking about not going past the end of a partial repository, or favour +local repository stuff over remote repository stuff. + +Also, when comparing l1 to l2, we should really be comparing the +newly discovered one to /all/ the lasts in the other patch set +that we've got so far. +-} +with_partial_intersection :: forall a p C(x y). RepoPatch p => PatchSet p C(x) -> PatchSet p C(y) + -> (FORALL(z) PatchSet p C(z) -> RL (PatchInfoAnd p) C(z x) + -> RL (PatchInfoAnd p) C(z y) -> a) + -> a +with_partial_intersection NilRL ps2 j = j (NilRL:<:NilRL) NilRL (concatRL ps2) +with_partial_intersection ps1 NilRL j = j (NilRL:<:NilRL) (concatRL ps1) NilRL +with_partial_intersection (NilRL:<:ps1) ps2 j = + with_partial_intersection ps1 ps2 j +with_partial_intersection ps1 (NilRL:<:ps2) j = + with_partial_intersection ps1 ps2 j +-- NOTE: symmetry is broken here, so we want the PatchSet with more history +-- first! +with_partial_intersection ((pi1:<:NilRL):<:common) ((pi2:<:NilRL):<:_) j +-- NOTE: Since the patchsets have the same starting but different ending +-- we can coerce them. The type system is not aware of our invariant on tags, +-- but both pi1 and pi2 should be tags, thus we check they are both identity +-- patches. + | info pi1 == info pi2 + , IsEq <- sloppyIdentity pi1 + , IsEq <- sloppyIdentity pi2 = j common NilRL (unsafeCoerceP NilRL) +with_partial_intersection (orig_ps1:<:orig_ps1s) (orig_ps2:<:orig_ps2s) j + = f (lengthRL orig_ps1) (last $ mapRL info orig_ps1) (orig_ps1:>:NilFL) orig_ps1s + (lengthRL orig_ps2) (last $ mapRL info orig_ps2) (orig_ps2:>:NilFL) orig_ps2s + where {- Invariants: nx = length $ concatReverseFL psx + lx = last $ concatReverseFL psx -} + f :: Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(r x) -> PatchSet p C(r) + -> Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(u y) -> PatchSet p C(u) + -> a + f _n1 l1 ps1 ps1s _n2 l2 ps2 _ps2s + | l1 == l2 = j ps1s (unsafeCoerceP (concatReverseFL ps1)) (unsafeCoerceP (concatReverseFL ps2)) + f n1 l1 ps1 ps1s n2 l2 ps2 ps2s + = case compare n1 n2 of + GT -> case dropWhileNilRL ps2s of + ps2':<:ps2s' -> + f n1 l1 ps1 ps1s + (n2 + lengthRL ps2') (last $ mapRL info ps2') (ps2':>:ps2) ps2s' + NilRL -> -- We keep going round f so the l1 == l2 case + -- has a chance to kick in + case dropWhileNilRL ps1s of + ps1':<:ps1s' -> + f (n1 + lengthRL ps1') (last $ mapRL info ps1') + (ps1':>:ps1) ps1s' + n2 l2 ps2 ps2s + NilRL -> j (NilRL:<:NilRL) (concatReverseFL ps1) (concatReverseFL ps2) + _ -> case dropWhileNilRL ps1s of + ps1':<:ps1s' -> + f (n1 + lengthRL ps1') (last $ mapRL info ps1') (ps1':>:ps1) ps1s' + n2 l2 ps2 ps2s + NilRL -> -- We keep going round f so the l1 == l2 case + -- has a chance to kick in + case dropWhileNilRL ps2s of + ps2':<:ps2s' -> + f n1 l1 ps1 NilRL + (n2 + lengthRL ps2') (last $ mapRL info ps2') + (ps2':>:ps2) ps2s' + NilRL -> j (NilRL:<:NilRL) (concatReverseFL ps1) (concatReverseFL ps2) + +{-| +'gcau' determines a list of /common/ patches and patches unique to each of +the two 'PatchSet's. The list of /common/ patches only needs to include all +patches that are not interspersed with the /unique/ patches, but including +more patches in the list of /common/ patches doesn't really hurt, except +for efficiency considerations. Mostly, we want to access as few elements +as possible of the 'PatchSet' list, since those can be expensive (or +unavailable). In other words, the /common/ patches need not be minimal, +whereas the 'PatchSet's should be minimal for performance reasons. + +'PatchSet's have the property that if +@ +(info $ last $ head a) == (info $ last $ head b) +@ +then @(tail a)@ and @(tail b)@ are identical repositories, and we want to take +advantage of this if possible, to avoid reading too many inventories. In +the case of --partial repositories or patch bundles, it is crucial that we +don't need to read the whole history, since it isn't available. + +TODO: + +The length equalising isn't necessarily right. We probably also be +thinking about not going past the end of a partial repository, or favour +local repository stuff over remote repo stuff. + +Also, when comparing l1 to l2, we should really be comparing the +newly discovered one to /all/ the lasts in the other patch set +that we've got so far. +-} + +gcau :: forall p C(x y). RepoPatch p => PatchSet p C(x) -> PatchSet p C(y) + -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) +gcau NilRL ps2 = return ([], NilRL:<:NilRL :\/: concatRL ps2 :<: NilRL) +gcau ps1 NilRL = return ([], concatRL ps1 :<: NilRL :\/: NilRL:<:NilRL) +gcau (NilRL:<:ps1) ps2 = gcau ps1 ps2 +gcau ps1 (NilRL:<:ps2) = gcau ps1 ps2 +gcau ((pi1:<:NilRL):<:_) ((pi2:<:NilRL):<:_) + | info pi1 == info pi2 + , IsEq <- sloppyIdentity pi1 + , IsEq <- sloppyIdentity pi2 = return ([info pi1], NilRL:<:NilRL :\/: unsafeCoerceP (NilRL:<:NilRL)) +gcau (orig_ps1:<:orig_ps1s) (orig_ps2:<:orig_ps2s) + = f (lengthRL orig_ps1) (unseal info $ lastRL orig_ps1) (orig_ps1:>:NilFL) orig_ps1s + (lengthRL orig_ps2) (unseal info $ lastRL orig_ps2) (orig_ps2:>:NilFL) orig_ps2s + where {- Invariants: nx = lengthRL $ concatReverseFL psx + lx = last $ concatReverseFL psx -} + f :: Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(r x) -> PatchSet p C(r) + -> Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(u y) -> PatchSet p C(u) + -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) + f _n1 l1 ps1 _ps1s _n2 l2 ps2 _ps2s + | l1 == l2 = gcau_simple (unsafeCoerceP (concatReverseFL ps1)) (unsafeCoerceP (concatReverseFL ps2)) + f n1 l1 ps1 ps1s n2 l2 ps2 ps2s + = case n1 `compare` n2 of + GT -> case dropWhileNilRL ps2s of + ps2':<:ps2s' -> + f n1 l1 ps1 ps1s + (n2 + lengthRL ps2') (unseal info $ lastRL ps2') (ps2':>:ps2) ps2s' + NilRL -> -- We keep going round f so the l1 == l2 case + -- has a chance to kick in + case dropWhileNilRL ps1s of + ps1':<:ps1s' -> + f (n1 + lengthRL ps1') (unseal info $ lastRL ps1') + (ps1':>:ps1) ps1s' + n2 l2 ps2 ps2s + NilRL -> gcau_simple (concatReverseFL ps1) (concatReverseFL ps2) + _ -> case dropWhileNilRL ps1s of + ps1':<:ps1s' -> + f (n1 + lengthRL ps1') (unseal info $ lastRL ps1') (ps1':>:ps1) ps1s' + n2 l2 ps2 ps2s + NilRL -> -- We keep going round f so the l1 == l2 case + -- has a chance to kick in + case dropWhileNilRL ps2s of + ps2':<:ps2s' -> + f n1 l1 ps1 NilRL + (n2 + lengthRL ps2') (unseal info $ lastRL ps2') + (ps2':>:ps2) ps2s' + NilRL -> gcau_simple (concatReverseFL ps1) (concatReverseFL ps2) + +lastRL :: RL a C(x y) -> Sealed (a C(x)) +lastRL (a:<:NilRL) = seal a +lastRL (_:<:as) = lastRL as +lastRL NilRL = bug "lastRL on empty list" + +dropWhileNilRL :: PatchSet p C(x) -> PatchSet p C(x) +dropWhileNilRL (NilRL:<:xs) = dropWhileNilRL xs +dropWhileNilRL xs = xs + +-- | Filters the common elements from @ps1@ and @ps2@ and returns the simplified sequences. +gcau_simple :: RepoPatch p => RL (PatchInfoAnd p) C(x y) -- ^ @ps1@ + -> RL (PatchInfoAnd p) C(u v) -- ^ @ps2@ + -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(y v)) +gcau_simple ps1 ps2 = do + FlippedSeal ex1 <- get_extra common ps1 + FlippedSeal ex2 <- get_extra common ps2 + let ps1' = filter (`elem` common) $ ps1_info + return (ps1', (unsafeCoerceP ex1 :<: NilRL) :\/: ex2 :<: NilRL) + where common = ps1_info `intersect` mapRL info ps2 + ps1_info = mapRL info ps1 + +data MissingPatch = MissingPatch !PatchInfo !String + +instance Error MissingPatch where + -- we don't really need those methods + noMsg = bug "MissingPatch doesn't define noMsg." + +-- | Returns a sub-sequence from @patches@, where all the elements of @common@ have +-- been removed by commuting them out. +get_extra :: RepoPatch p => [PatchInfo] -- ^ @common@ + -> RL (PatchInfoAnd p) C(u x) -- ^ @patches@ + -> Either MissingPatch (FlippedSeal (RL (PatchInfoAnd p)) C(y)) +get_extra = get_extra_aux (return $ unsafeCoerceP NilFL) + where + get_extra_aux :: RepoPatch p => Either MissingPatch (FL (Named p) C(x y)) + -> [PatchInfo] + -> RL (PatchInfoAnd p) C(u x) + -> Either MissingPatch (FlippedSeal (RL (PatchInfoAnd p)) C(y)) + get_extra_aux _ _ NilRL = return (flipSeal NilRL) + get_extra_aux skipped common (hp:<:pps) = + if info hp `elem` common && is_tag (info hp) + then case getdeps `fmap` hopefullyM hp of + Just ds -> get_extra_aux (liftM2 (:>:) ep skipped) (ds++delete (info hp) common) pps + Nothing -> get_extra_aux (liftM2 (:>:) ep skipped) (delete (info hp) common) pps + else if info hp `elem` common + then get_extra_aux (liftM2 (:>:) ep skipped) (delete (info hp) common) pps + else do + p <- ep + skpd <- skipped + case commuteFL (p :> skpd) of + Right (skipped_patch' :> p') -> do + FlippedSeal x <- get_extra_aux (return skipped_patch') common pps + return $ flipSeal (info hp `piap` p' :<: x) + -- Failure to commute indicates a bug because it means + -- that a patch was interspersed between the common + -- patches. This should only happen if that patch was + -- commuted there. This uses 2 properties: + -- 1) commute is its own inverse + -- 2) if patches commute in one adjacent context then + -- they commute in any context where they are + -- adjacent + Left (Sealed2 hpc) -> errorDoc $ text "bug in get_extra commuting patches:" + $$ text "First patch is:" + $$ human_friendly (info hp) + $$ text "Second patch is:" + $$ human_friendly (info $ n2pia hpc) + where ep = case hopefullyM hp of + Right p' -> return p' + Left e -> Left (MissingPatch (info hp) e) + +missingPatchError :: MissingPatch -> a +missingPatchError (MissingPatch pinfo e) = + errorDoc + ( text "failed to read patch in get_extra:" + $$ human_friendly pinfo $$ text e + $$ text "Perhaps this is a 'partial' repository?" ) + +get_extra_old :: RepoPatch p => [PatchInfo] + -> RL (PatchInfoAnd p) C(u x) + -> FlippedSeal (RL (PatchInfoAnd p)) C(y) +get_extra_old common pps = + either missingPatchError id (get_extra common pps) + +get_patches_beyond_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(x) +get_patches_beyond_tag t ((hp:<:NilRL):<:_) | info hp == t = flipSeal $ NilRL :<: NilRL +get_patches_beyond_tag t patchset@((hp:<:ps):<:pps) = + if info hp == t + then if get_tags_right patchset == [info hp] + then flipSeal $ NilRL :<: NilRL -- special case to avoid looking at redundant patches + else case get_extra_old [t] (concatRL patchset) of + FlippedSeal x -> flipSeal $ x :<: NilRL + else hp `prepend` get_patches_beyond_tag t (ps:<:pps) + where + prepend :: (PatchInfoAnd p) C(x y) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(x) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(y) + prepend pp (FlippedSeal NilRL) = flipSeal $ (pp:<:NilRL) :<: NilRL + prepend pp (FlippedSeal (p:<:ps')) = flipSeal $ (pp:<:p) :<: ps' +get_patches_beyond_tag t (NilRL:<:pps) = get_patches_beyond_tag t pps +get_patches_beyond_tag t NilRL = bug $ "tag\n" ++ + renderString (human_friendly t) ++ + "\nis not in the patchset in get_patches_beyond_tag." + +-- | @get_patches_in_tag t ps@ returns a 'SealedPatchSet' of all +-- patches in @ps@ which are contained in @t@. +get_patches_in_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> SealedPatchSet p +get_patches_in_tag t pps@((hp:<:NilRL):<:xs) + | info hp == t = seal pps + | otherwise = get_patches_in_tag t xs + +get_patches_in_tag t ((hp:<:ps):<:xs) + | info hp /= t = get_patches_in_tag t (ps:<:xs) + +get_patches_in_tag t ((pa:<:ps):<:xs) = gpit thepis (pa:>:NilFL) (ps:<:xs) + where thepis = getdeps $ conscientiously + (\e -> text "Couldn't read tag" + $$ human_friendly t + $$ text "" + $$ e) pa + gpit :: RepoPatch p => [PatchInfo] -> (FL (PatchInfoAnd p)) C(x y) -> PatchSet p C(x) -> SealedPatchSet p + gpit _ sofar NilRL = seal $ reverseFL sofar :<: NilRL + gpit deps sofar ((hp:<:NilRL):<:xs') + | info hp `elem` deps + , IsEq <- sloppyIdentity hp = seal $ (reverseFL $ hp :>: sofar) :<: xs' + | IsEq <- sloppyIdentity hp = gpit deps sofar xs' + gpit deps sofar (NilRL:<:xs') = gpit deps sofar xs' + gpit deps sofar ((hp:<:ps'):<:xs') + | info hp `elem` deps + = let odeps = filter (/=info hp) deps + alldeps = if is_tag $ info hp + then odeps ++ getdeps (hopefully hp) + else odeps + in gpit alldeps (hp:>:sofar) (ps':<:xs') + | otherwise + = gpit deps (commute_by sofar $ hopefully hp) (ps':<:xs') + commute_by :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> (Named p) C(w x) + -> FL (PatchInfoAnd p) C(w z) + commute_by NilFL _ = unsafeCoerceP NilFL + commute_by (hpa:>:xs') p = + case commutex (hopefully hpa :< p) of + Nothing -> bug "Failure commuting patches in commute_by called by gpit!" + Just (p': (info hpa `piap` a') :>: commute_by xs' p' + +get_patches_in_tag t _ = errorDoc $ text "Couldn't read tag" + $$ human_friendly t + +get_tags_right :: RL (RL (PatchInfoAnd p)) C(x y) -> [PatchInfo] +get_tags_right NilRL = [] +get_tags_right (ps:<:_) = get_tags_r (mapRL info_and_deps ps) + where + get_tags_r :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo] + get_tags_r [] = [] + get_tags_r (hp:pps) = case snd hp of + Just ds -> fst hp : get_tags_r (drop_tags_r ds pps) + Nothing -> fst hp : get_tags_r pps + + drop_tags_r :: [PatchInfo] + -> [(PatchInfo, Maybe [PatchInfo])] -> [(PatchInfo, Maybe [PatchInfo])] + drop_tags_r [] pps = pps + drop_tags_r _ [] = [] + drop_tags_r ds (hp:pps) + | fst hp `elem` ds = case snd hp of + Just ds' -> drop_tags_r (ds'++delete (fst hp) ds) pps + Nothing -> drop_tags_r (delete (fst hp) ds) pps + | otherwise = hp : drop_tags_r ds pps + + info_and_deps :: PatchInfoAnd p C(x y) -> (PatchInfo, Maybe [PatchInfo]) + info_and_deps p + | is_tag (info p) = (info p, getdeps `fmap` hopefullyM p) + | otherwise = (info p, Nothing) + +deep_optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x) +deep_optimize_patchset pss = optimize_patchset (concatRL pss :<: NilRL) + +optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x) +optimize_patchset NilRL = NilRL +optimize_patchset (ps:<:pss) = opsp ps +<+ pss + where + opsp :: RL (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(x y) + opsp NilRL = NilRL + opsp (hp:<:pps) + | is_tag (info hp) && get_tags_right ((hp:<:pps):<:NilRL) == [info hp] + = (hp:<:NilRL) :<: opsp pps + | otherwise = hp -:- opsp pps + +(-:-) :: (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(a x) -> RL (RL (PatchInfoAnd p)) C(a y) +pp -:- NilRL = (pp:<:NilRL) :<: NilRL +pp -:- (p:<:ps) = ((pp:<:p) :<: ps) + +slightly_optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x) +slightly_optimize_patchset NilRL = NilRL +slightly_optimize_patchset (ps:<:pss) = sops (progressRL "Optimizing inventory" ps) +<+ pss + where sops :: RL (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(x y) + sops NilRL = NilRL + sops (pinfomp :<: NilRL) = (pinfomp :<: NilRL) :<: NilRL + sops (hp:<:pps) | is_tag (info hp) = if get_tags_right ((hp:<:pps):<:NilRL) == [info hp] + then (hp:<:NilRL) :<: (pps:<: NilRL) + else hp -:- sops (progressRL "Optimizing inventory" pps) + | otherwise = hp -:- sops pps + +commute_to_end :: forall p C(x y). RepoPatch p => FL (Named p) C(x y) -> PatchSet p C(y) + -> (FL (Named p) :< RL (RL (PatchInfoAnd p))) C(() x) +commute_to_end select from = ctt (mapFL patch2patchinfo select) from NilFL + where +-- In order to preserve the structure of the original PatchSet, we commute +-- the patches we are going to throw away past the patches we plan to keep. +-- This puts them at the end of the PatchSet where it is safe to discard them. +-- We return all the patches in the PatchSet which have been commuted. + ctt :: [PatchInfo] -> PatchSet p C(v) -> FL (Named p) C(v u) + -> (FL (Named p) :< RL (RL (PatchInfoAnd p))) C(() x) + -- This unsafeCoerceP should be fine, because if we run out of + -- patches in the selection the ending context of the second param + -- should be x (because we have commute all of the selected sequence, + -- with context C(x y), past the elements of the second parameter. + -- Unfortunately this is hard to express in the type system while + -- using an accumulator to build up the return value. + ctt [] ps acc = (unsafeCoerceP acc) :< ps + ctt sel (NilRL:<:ps) acc = ctt sel ps acc + ctt sel ((hp:<:hps):<:ps) acc + | info hp `elem` sel + = case commuteFL (hopefully hp :> acc) of + Left _ -> bug "patches to commute_to_end does not commutex (1)" + Right (acc' :> _) -> ctt (delete (info hp) sel) (hps:<:ps) acc' + | otherwise + = ctt sel (hps:<:ps) (hopefully hp:>:acc) + ctt _ _ _ = bug "patches to commute_to_end does not commutex (2)" + +patchset_intersection :: RepoPatch p => [SealedPatchSet p] -> SealedPatchSet p +patchset_intersection [] = seal (NilRL :<: NilRL) +patchset_intersection [x] = x +patchset_intersection (Sealed y:ys) = + case patchset_intersection ys of + Sealed ys' -> with_partial_intersection y ys' $ + \common a b -> + case mapRL info a `intersect` mapRL info b of + morecommon -> + case partitionRL (\e -> info e `notElem` morecommon) a of + commonps :> _ -> seal $ commonps :<: common + +patchset_union :: forall p. RepoPatch p => [SealedPatchSet p] -> SealedPatchSet p +patchset_union [] = seal (NilRL :<: NilRL) +patchset_union [x] = x +patchset_union (Sealed y:ys) = + case patchset_union ys of + Sealed ys' -> with_partial_intersection y ys' f + where + f :: FORALL(z x y) PatchSet p C(z) -- ^ @common@ + -> RL (PatchInfoAnd p) C(z x) -- ^ @a@ + -> RL (PatchInfoAnd p) C(z y) -- ^ @b@ + -> SealedPatchSet p + f common a b = g_s $ gcau_simple a b + where + g_s :: Either MissingPatch + ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y)) + -> SealedPatchSet p + g_s (Left e) = missingPatchError e + g_s (Right (_, (a' :<: NilRL) :\/: (b' :<: NilRL))) = + case (merge_sets (a' :\/: b')) of + Sealed a'b' -> seal $ (a'b' +<+ b) :<: common + g_s _ = impossible + +merge_sets :: RepoPatch p => (RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y) -> Sealed (RL (PatchInfoAnd p) C(y)) +merge_sets (l :\/: r) = + let pl = mapFL_FL hopefully $ reverseRL l + pr = mapFL_FL hopefully $ reverseRL r + p2pimp p = patch2patchinfo p `piap` p + in case merge (pl:\/: pr) of + (_:/\:pl') -> seal $ reverseFL $ mapFL_FL p2pimp pl' diff --git a/src/Darcs/Patch/FileName.hs b/src/Darcs/Patch/FileName.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/FileName.hs @@ -0,0 +1,158 @@ +-- Copyright (C) 2002-2003 David Roundy +-- +-- 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. + +-- | FileName is an abstract type intended to facilitate the input and output of +-- unicode filenames. +module Darcs.Patch.FileName ( FileName( ), + fp2fn, fn2fp, + fn2ps, ps2fn, + niceps2fn, fn2niceps, + break_on_dir, norm_path, own_name, super_name, + movedirfilename, + encode_white, decode_white, + (///), + breakup + ) where + +import System.IO +import Data.Char ( isSpace, chr, ord ) +import qualified UTF8 ( encode ) +import Data.Word ( Word8( ) ) +import ByteStringUtils ( unpackPSfromUTF8 ) +import qualified Data.ByteString.Char8 as BC (unpack, pack) +import qualified Data.ByteString as B (ByteString, pack) + +newtype FileName = FN FilePath deriving ( Eq, Ord ) +encode :: [Char] -> [Word8] +encode = UTF8.encode + +instance Show FileName where + showsPrec d (FN fp) = showParen (d > app_prec) $ showString "fp2fn " . showsPrec (app_prec + 1) fp + where app_prec = 10 + +{-# INLINE fp2fn #-} +fp2fn :: FilePath -> FileName +fp2fn fp = FN fp + +{-# INLINE fn2fp #-} +fn2fp :: FileName -> FilePath +fn2fp (FN fp) = fp + +{-# INLINE niceps2fn #-} +niceps2fn :: B.ByteString -> FileName +niceps2fn = FN . decode_white . BC.unpack + +{-# INLINE fn2niceps #-} +fn2niceps :: FileName -> B.ByteString +fn2niceps (FN fp) = BC.pack $ encode_white fp + +{-# INLINE fn2ps #-} +fn2ps :: FileName -> B.ByteString +fn2ps (FN fp) = B.pack $ encode $ encode_white fp + +{-# INLINE ps2fn #-} +ps2fn :: B.ByteString -> FileName +ps2fn ps = FN $ decode_white $ unpackPSfromUTF8 ps + +-- | 'encode_white' translates whitespace in filenames to a darcs-specific +-- format (backslash followed by numerical representation according to 'ord'). +-- Note that backslashes are also escaped since they are used in the encoding. +-- +-- > encode_white "hello there" == "hello\32there" +-- > encode_white "hello\there" == "hello\\there" +encode_white :: FilePath -> String +encode_white (c:cs) | isSpace c || c == '\\' = + '\\' : (show $ ord c) ++ "\\" ++ encode_white cs +encode_white (c:cs) = c : encode_white cs +encode_white [] = [] + +-- | 'decode_white' interprets the Darcs-specific \"encoded\" filenames +-- produced by 'encode_white' +-- +-- > decode_white "hello\32there" == "hello there" +-- > decode_white "hello\\there" == "hello\there" +-- > decode_white "hello\there" == error "malformed filename" +decode_white :: String -> FilePath +decode_white ('\\':cs) = + case break (=='\\') cs of + (theord, '\\':rest) -> + chr (read theord) : decode_white rest + _ -> error "malformed filename" +decode_white (c:cs) = c: decode_white cs +decode_white "" = "" + +own_name :: FileName -> FileName +own_name (FN f) = case breakLast '/' f of Nothing -> FN f + Just (_,f') -> FN f' +super_name :: FileName -> FileName +super_name fn = case norm_path fn of + FN f -> case breakLast '/' f of + Nothing -> FN "." + Just (d,_) -> FN d +break_on_dir :: FileName -> Maybe (FileName,FileName) +break_on_dir (FN p) = case breakFirst '/' p of + Nothing -> Nothing + Just (d,f) | d == "." -> break_on_dir $ FN f + | otherwise -> Just (FN d, FN f) +norm_path :: FileName -> FileName -- remove "./" +norm_path (FN p) = FN $ repath $ drop_dotdot $ breakup p + +repath :: [String] -> String +repath [] = "" +repath [f] = f +repath (d:p) = d ++ "/" ++ repath p + +drop_dotdot :: [String] -> [String] +drop_dotdot ("":p) = drop_dotdot p +drop_dotdot (".":p) = drop_dotdot p +drop_dotdot ("..":p) = ".." : (drop_dotdot p) +drop_dotdot (_:"..":p) = drop_dotdot p +drop_dotdot (d:p) = case drop_dotdot p of + ("..":p') -> p' + p' -> d : p' +drop_dotdot [] = [] + +-- | Split a file path at the slashes +breakup :: String -> [String] +breakup p = case break (=='/') p of + (d,"") -> [d] + (d,p') -> d : breakup (tail p') + +breakFirst :: Char -> String -> Maybe (String,String) +breakFirst c l = bf [] l + where bf a (r:rs) | r == c = Just (reverse a,rs) + | otherwise = bf (r:a) rs + bf _ [] = Nothing +breakLast :: Char -> String -> Maybe (String,String) +breakLast c l = case breakFirst c (reverse l) of + Nothing -> Nothing + Just (a,b) -> Just (reverse b, reverse a) + +(///) :: FileName -> FileName -> FileName +(FN "")///b = norm_path b +a///b = norm_path $ fp2fn $ fn2fp a ++ "/" ++ fn2fp b + +movedirfilename :: FileName -> FileName -> FileName -> FileName +movedirfilename old new name = + if name' == old' then new + else if length name' > length old' && + take (length old'+1) name' == old'++"/" + then fp2fn ("./"++new'++drop (length old') name') + else name + where old' = fn2fp $ norm_path old + new' = fn2fp $ norm_path new + name' = fn2fp $ norm_path name diff --git a/src/Darcs/Patch/Info.hs b/src/Darcs/Patch/Info.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Info.hs @@ -0,0 +1,331 @@ +-- Copyright (C) 2002-2003 David Roundy +-- +-- 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. + +module Darcs.Patch.Info ( PatchInfo, patchinfo, invert_name, is_inverted, + idpatchinfo, add_junk, + make_filename, make_alt_filename, readPatchInfo, + just_name, just_author, repopatchinfo, RepoPatchInfo, + human_friendly, to_xml, pi_date, set_pi_date, + pi_name, pi_rename, pi_author, pi_tag, pi_log, + showPatchInfo, is_tag + ) where +import Text.Html hiding (name, text) +import System.Random ( randomRIO ) +import Numeric ( showHex ) +import Control.Monad ( when ) + +import ByteStringUtils +import qualified Data.ByteString as B (length, splitAt, null, drop + ,isPrefixOf, tail, concat, ByteString ) +import qualified Data.ByteString.Char8 as BC (index, head, unpack, pack, break) + +import Printer ( renderString, Doc, packedString, + empty, ($$), (<>), (<+>), vcat, text, blueText, prefix ) +import OldDate ( readUTCDate, showIsoDateTime ) +import System.Time ( CalendarTime(ctTZ), calendarTimeToString, toClockTime, + toCalendarTime ) +import System.IO.Unsafe ( unsafePerformIO ) +import SHA1 ( sha1PS ) +import Darcs.Utils ( promptYorn ) +import Prelude hiding (pi, log) + +data RepoPatchInfo = RPI String PatchInfo + +repopatchinfo :: String -> PatchInfo -> RepoPatchInfo +repopatchinfo r pi = RPI r pi + +data PatchInfo = PatchInfo { _pi_date :: !B.ByteString + , _pi_name :: !B.ByteString + , _pi_author :: !B.ByteString + , _pi_log :: ![B.ByteString] + , is_inverted :: !Bool + } + deriving (Eq,Ord) + +idpatchinfo :: PatchInfo +idpatchinfo = PatchInfo myid myid myid [] False + where myid = BC.pack "identity" + +patchinfo :: String -> String -> String -> [String] -> IO PatchInfo +patchinfo date name author log = + add_junk $ PatchInfo { _pi_date = BC.pack date + , _pi_name = BC.pack name + , _pi_author = BC.pack author + , _pi_log = map BC.pack log + , is_inverted = False } + +add_junk :: PatchInfo -> IO PatchInfo +add_junk pinf = + do x <- randomRIO (0,2^(128 ::Integer) :: Integer) + when (_pi_log pinf /= ignore_junk (_pi_log pinf)) $ + do yorn <- promptYorn "Lines beginning with 'Ignore-this: ' will be ignored.\nProceed? " + when (yorn == 'n') $ fail "User cancelled because of Ignore-this." + return $ pinf { _pi_log = BC.pack (head ignored++showHex x ""): + _pi_log pinf } + +ignored :: [String] -- this is a [String] so we can change the junk header. +ignored = ["Ignore-this: "] + +ignore_junk :: [B.ByteString] -> [B.ByteString] +ignore_junk = filter isnt_ignored + where isnt_ignored x = doesnt_start_with x (map BC.pack ignored) -- TODO + doesnt_start_with x ys = not $ any (`B.isPrefixOf` x) ys + + +-- * Patch info formatting +invert_name :: PatchInfo -> PatchInfo +invert_name pi = pi { is_inverted = not (is_inverted pi) } + +just_name :: PatchInfo -> String +just_name pinf = if is_inverted pinf then "UNDO: " ++ BC.unpack (_pi_name pinf) + else BC.unpack (_pi_name pinf) + +just_author :: PatchInfo -> String +just_author = BC.unpack . _pi_author + +human_friendly :: PatchInfo -> Doc +human_friendly pi = + text (friendly_d $ _pi_date pi) <> text " " <> packedString (_pi_author pi) + $$ hfn (_pi_name pi) + $$ vcat (map ((text " " <>) . packedString) (ignore_junk $ _pi_log pi)) + where hfn x = case pi_tag pi of + Nothing -> inverted <+> packedString x + Just t -> text " tagged" <+> text t + inverted = if is_inverted pi then text " UNDO:" else text " *" + +-- note the difference with just_name +pi_name :: PatchInfo -> String +pi_name = BC.unpack . _pi_name + +pi_rename :: PatchInfo -> String -> PatchInfo +pi_rename x n = x { _pi_name = BC.pack n } + +pi_author :: PatchInfo -> String +pi_author = BC.unpack . _pi_author + +is_tag :: PatchInfo -> Bool +is_tag pinfo = take 4 (just_name pinfo) == "TAG " + + +-- | Note: we ignore timezone information in the date string, +-- systematically treating a time as UTC. So if the patch +-- tells me it's 17:00 EST, we're actually treating it as +-- 17:00 UTC, in other words 11:00 EST. This is for +-- backwards compatibility to darcs prior to 2003-11, sometime +-- before 1.0. Fortunately, newer patch dates are written in +-- UTC, so this timezone truncation is harmless for them. +readPatchDate :: B.ByteString -> CalendarTime +readPatchDate = ignoreTz . readUTCDate . BC.unpack + where ignoreTz ct = ct { ctTZ = 0 } + +pi_date :: PatchInfo -> CalendarTime +pi_date = readPatchDate . _pi_date + +set_pi_date :: String -> PatchInfo -> PatchInfo +set_pi_date date pi = pi { _pi_date = BC.pack date } + +pi_log :: PatchInfo -> [String] +pi_log = map BC.unpack . ignore_junk . _pi_log + +pi_tag :: PatchInfo -> Maybe String +pi_tag pinf = + if l == t + then Just $ BC.unpack r + else Nothing + where (l, r) = B.splitAt (B.length t) (_pi_name pinf) + t = BC.pack "TAG " + +friendly_d :: B.ByteString -> String +--friendly_d d = calendarTimeToString . readPatchDate . d +friendly_d d = unsafePerformIO $ do + ct <- toCalendarTime $ toClockTime $ readPatchDate d + return $ calendarTimeToString ct + +to_xml :: PatchInfo -> Doc +to_xml pi = + text " text "author='" <> escapeXML (just_author pi) <> text "'" + <+> text "date='" <> escapeXML (BC.unpack $ _pi_date pi) <> text "'" + <+> text "local_date='" <> escapeXML (friendly_d $ _pi_date pi) <> text "'" + <+> text "inverted='" <> text (show $ is_inverted pi) <> text "'" + <+> text "hash='" <> text (make_filename pi) <> text "'>" + $$ prefix "\t" ( + text "" <> escapeXML (pi_name pi) <> text "" + $$ comments_as_xml (_pi_log pi)) + $$ text "" + +comments_as_xml :: [B.ByteString] -> Doc +comments_as_xml comments + | B.length comments' > 0 = text "" + <> escapeXML (BC.unpack comments') + <> text "" + | otherwise = empty + where comments' = unlinesPS comments + +-- escapeXML is duplicated in Patch.lhs and Annotate.lhs +-- It should probably be refactored to exist in one place. +escapeXML :: String -> Doc +escapeXML = text . strReplace '\'' "'" . strReplace '"' """ . + strReplace '>' ">" . strReplace '<' "<" . strReplace '&' "&" + + +strReplace :: Char -> String -> String -> String +strReplace _ _ [] = [] +strReplace x y (z:zs) + | x == z = y ++ (strReplace x y zs) + | otherwise = z : (strReplace x y zs) + +make_alt_filename :: PatchInfo -> String +make_alt_filename pi@(PatchInfo { is_inverted = False }) = + fix_up_fname (midtrunc (pi_name pi)++"-"++just_author pi++"-"++BC.unpack (_pi_date pi)) +make_alt_filename pi@(PatchInfo { is_inverted = True}) = + make_alt_filename (pi { is_inverted = False }) ++ "-inverted" + +-- This makes darcs-1 (non-hashed repos) filenames, and is also generally used in both in +-- hashed and non-hashed repo code for making patch "hashes" +make_filename :: PatchInfo -> String +make_filename pi = + showIsoDateTime d++"-"++sha1_a++"-"++sha1PS sha1_me++".gz" + where b2ps True = BC.pack "t" + b2ps False = BC.pack "f" + sha1_me = B.concat [_pi_name pi, + _pi_author pi, + _pi_date pi, + B.concat $ _pi_log pi, + b2ps $ is_inverted pi] + d = readPatchDate $ _pi_date pi + sha1_a = take 5 $ sha1PS $ _pi_author pi + +midtrunc :: String -> String +midtrunc s + | length s < 73 = s + | otherwise = (take 40 s)++"..."++(reverse $ take 30 $ reverse s) +fix_up_fname :: String -> String +fix_up_fname = map munge_char + +munge_char :: Char -> Char +munge_char '*' = '+' +munge_char '?' = '2' +munge_char '>' = '7' +munge_char '<' = '2' +munge_char ' ' = '_' +munge_char '"' = '~' +munge_char '`' = '.' +munge_char '\'' = '.' +munge_char '/' = '1' +munge_char '\\' = '1' +munge_char '!' = '1' +munge_char ':' = '.' +munge_char ';' = ',' +munge_char '{' = '~' +munge_char '}' = '~' +munge_char '(' = '~' +munge_char ')' = '~' +munge_char '[' = '~' +munge_char ']' = '~' +munge_char '=' = '+' +munge_char '#' = '+' +munge_char '%' = '8' +munge_char '&' = '6' +munge_char '@' = '9' +munge_char '|' = '1' +munge_char c = c + +instance HTML RepoPatchInfo where + toHtml = htmlPatchInfo +instance Show PatchInfo where + show pi = renderString (showPatchInfo pi) + +-- |Patch is stored between square brackets. +-- +-- > [ +-- > * +-- > (indented one) +-- > +-- > +-- > +-- > ] +-- +-- note that below I assume the name has no newline in it. +showPatchInfo :: PatchInfo -> Doc +showPatchInfo pi = + blueText "[" <> packedString (_pi_name pi) + $$ packedString (_pi_author pi) <> text inverted <> packedString (_pi_date pi) + <> myunlines (_pi_log pi) <> blueText "] " + where inverted = if is_inverted pi then "*-" else "**" + myunlines [] = empty + myunlines xs = mul xs + where mul [] = text "\n" + mul (s:ss) = text "\n " <> packedString s <> mul ss + +-- +-- Note, Data.ByteString rewrites break ((==) x) into the memchr-based +-- breakByte. For this rule to fire, we keep it in prefix application form +-- + +readPatchInfo :: B.ByteString -> Maybe (PatchInfo, B.ByteString) +readPatchInfo s | B.null (dropSpace s) = Nothing +readPatchInfo s = + if BC.head (dropSpace s) /= '[' -- ] + then Nothing + else case BC.break ((==) '\n') $ B.tail $ dropSpace s of + (name,s') -> + case BC.break ((==) '*') $ B.tail s' of + (author,s2) -> + case BC.break (\c->c==']'||c=='\n') $ B.drop 2 s2 of + (ct,s''') -> + do (log, s4) <- lines_starting_with_ending_with ' ' ']' $ dn s''' + return $ (PatchInfo { _pi_date = ct + , _pi_name = name + , _pi_author = author + , _pi_log = log + , is_inverted = BC.index s2 1 /= '*' + }, s4) + where dn x = if B.null x || BC.head x /= '\n' then x else B.tail x + +lines_starting_with_ending_with :: Char -> Char -> B.ByteString + -> Maybe ([B.ByteString],B.ByteString) +lines_starting_with_ending_with st en s = lswew s + where + lswew x | B.null x = Nothing + lswew x = + if BC.head x == en + then Just ([], B.tail x) + else if BC.head x /= st + then Nothing + else case BC.break ((==) '\n') $ B.tail x of + (l,r) -> case lswew $ B.tail r of + Just (ls,r') -> Just (l:ls,r') + Nothing -> + case breakLastPS en l of + Just (l2,_) -> + Just ([l2], B.drop (B.length l2+2) x) + Nothing -> Nothing + +htmlPatchInfo :: RepoPatchInfo -> Html +htmlPatchInfo (RPI r pi) = + toHtml $ (td << patch_link r pi) `above` + ((td ! [align "right"] << mail_link (just_author pi)) `beside` + (td << (friendly_d $ _pi_date pi))) + +patch_link :: String -> PatchInfo -> Html +patch_link r pi = + toHtml $ hotlink + ("darcs?"++r++"**"++make_filename pi) + [toHtml $ pi_name pi] +mail_link :: String -> Html +mail_link email = toHtml $ hotlink ("mailto:"++email) [toHtml email] diff --git a/src/Darcs/Patch/Match.lhs b/src/Darcs/Patch/Match.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Match.lhs @@ -0,0 +1,346 @@ +% Copyright (C) 2004 David Roundy +% +% 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. + +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Patch.Match ( PatchMatch, Matcher, MatchFun, + patch_match, match_pattern, + apply_matcher, make_matcher, + parseMatch, + match_parser, helpOnMatchers, + ) where + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr +import Text.Regex ( mkRegex, matchRegex ) +import Data.Maybe ( isJust ) +import System.IO.Unsafe ( unsafePerformIO ) + +import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) +import Darcs.Patch ( Patch, Patchy, list_touched_files, patchcontents ) +import Darcs.Patch.Info ( just_name, just_author, make_filename, + pi_date ) +import Darcs.Sealed ( Sealed2(..), seal2 ) +import DateMatcher ( parseDateMatcher ) + +import Darcs.Patch.MatchData ( PatchMatch(..), patch_match ) + +-- | A type for predicates over patches which do not care about +-- contexts +type MatchFun p = Sealed2 (PatchInfoAnd p) -> Bool + +-- | A @Matcher@ is made of a 'MatchFun' which we will use to match +-- patches and a @String@ representing it. +data Matcher p = MATCH String (MatchFun p) + +instance Show (Matcher p) where + show (MATCH s _) = '"':s ++ "\"" + +make_matcher :: String -> (Sealed2 (PatchInfoAnd p) -> Bool) -> Matcher p +make_matcher s m = MATCH s m + +-- | @apply_matcher@ applies a matcher to a patch. +apply_matcher :: Matcher p -> PatchInfoAnd p C(x y) -> Bool +apply_matcher (MATCH _ m) = m . seal2 + +parseMatch :: Patchy p => PatchMatch -> Either String (MatchFun p) +parseMatch (PatternMatch s) = + case parse match_parser "match" s of + Left err -> Left $ "Invalid -"++"-match pattern '"++s++ + "'.\n"++ unlines (map (" "++) $ lines $ show err) -- indent + Right m -> Right m + +match_pattern :: Patchy p => PatchMatch -> Matcher p +match_pattern p@(PatternMatch s) = + case parseMatch p of + Left err -> error err + Right m -> make_matcher s m + +trivial :: Patchy p => MatchFun p +trivial = const True +\end{code} + +\paragraph{Match} + +Currently \verb!--match! accepts six primitive match types, although +there are plans to expand it to match more patterns. Also, note that the +syntax is still preliminary and subject to change. + +The first match type accepts a literal string which is checked against +the patch name. The syntax is +\begin{verbatim} +darcs annotate --summary --match 'exact foo+bar' +\end{verbatim} +This is useful for situations where a patch name contains characters that +could be considered special for regular expressions. + +In this and the other match types, the argument must be enclosed in double +quotes if it contains spaces. You can escape a quote in the argument with a +backslash; backslash escapes itself, but it is treated literally if followed +by a character other than a double quote or backslash, so it is typically not +necessary to escape a backslash. No such escaping is necessary unless the +argument is enclosed in double quotes. + +The second match type accepts a regular expression which is checked against +the patch name. The syntax is +\begin{verbatim} +darcs annotate --summary --match 'name foo' +\end{verbatim} +Note that to match regexp metacharacters, such as \verb|(|, literally, they +must be escaped with backslash along with any embedded double quotes. To +match a literal backslash it must be written quadrupled in general, but often +it need not be escaped, since backslash is only special in regexps when +followed by a metacharacter. In the following example pairs, the first +literal is matched by the second sequence in the match name: +``\verb|"|'':``\verb|\"|'', ``\verb|\|'':``\verb|\\\\|'', +``\verb|\x|'':``\verb|\x|'', ``\verb|(|'':``\verb|\(|''. + +The third match type matches the darcs hash for each patch: +\begin{verbatim} +darcs annotate --summary --match \ + 'hash 20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef' +\end{verbatim} +Note you need to provide the full hash string as above. +This is intended to be used, for example, by programs allowing you to view +darcs repositories (e.g.\ CGI scripts like viewCVS). + +The fourth match type accepts a regular expression which is checked against +the patch author. The syntax is +\begin{verbatim} +darcs annotate --summary --match 'author foo' +\end{verbatim} + +There is also support for matching by date. This is done using commands such as +\begin{verbatim} +darcs annotate --summary --match 'date "last week"' +darcs annotate --summary --match 'date yesterday' +darcs annotate --summary --match 'date "today 14:00"' +darcs annotate --summary --match 'date "tea time yesterday"' +darcs annotate --summary --match 'date "3 days before last year at 17:00"' +darcs changes --from-match 'date "Sat Jun 30 11:31:30 EDT 2004"' +\end{verbatim} + +Only English date specifications are supported---specifically you must use +English day and month names. Also, only a limited set of time zones is +supported (compatible with GNU coreutils' date parsing). Unrecognized zones +are treated as UTC, which may result in the timestamps printed in change +entries not being recognized by the date matching. You can avoid this problem +on a POSIX-like system by running darcs in the UTC zone to get the times +initially, e.g.: +\begin{verbatim} +TZ=UTC darcs changes +\end{verbatim} + +When matching on the ISO format, a partial date is treated as a range. +English dates can either refer to a specific day (``6 months ago',``day before +yesterday''), or to an interval +from some past date (``last month'') to the present. Putting this all +together, if today is ``2004-07-24'' then the following matches should work: + +\begin{tabular}{|ll|} +\hline +\textbf{date} & \textbf{patches selected} \\ +\hline +2004 & from 2004-01-01 up to and including 2004-12-31 \\ +2004-01 & from 2004-01-01 up to and including 2004-01-31 \\ +2004-01-01 & during 2004-01-01 \\ +\hline +today & during 2004-07-24 (starting midnight in your timezone) \\ +yesterday & during 2004-07-23 \\ +6 months ago & during 2004-01-23 \\ +\hline +last 6 months & since 2004-01-23 \\ +last month & since 2004-06-23 (not 2004-06-01!) \\ +last week & since 2004-07-16 \\ +\hline +\end{tabular} + +For more precise control, you may specify an interval, either +in a small subset of English or +of \htmladdnormallinkfoot{the ISO 8601 format}{http://www.w3.org/TR/NOTE-datetime}. +If you use the ISO format, note that durations, when +specified alone, are interpreted as being relative to the current date and time. +\begin{verbatim} +darcs annotate --summary --match 'date "between 2004-03-12 and last week"' +darcs annotate --summary --match 'date "after 2005"' +darcs annotate --summary --match 'date "in the last 3 weeks"' +darcs annotate --summary --match 'date "P3M/2006-03-17"' +darcs annotate --summary --match 'date "2004-01-02/2006-03-17"' +darcs annotate --summary --match 'date "P2M6D"' +\end{verbatim} + +You may also prefer to combine date matching with a more specific pattern. +\begin{verbatim} +darcs annotate --summary --match 'date "last week" && name foo' +\end{verbatim} + +The sixth match type accepts a regular expression which is checked against +file paths that the patch touches. The syntax is +\begin{verbatim} +darcs annotate --summary --match 'touch foo/bar.c' +\end{verbatim} + +The \verb!--match! pattern can include the logical operators \verb!&&!, +\verb!||! and \verb!not!, as well as grouping of patterns with parentheses. +For example +\begin{verbatim} +darcs annotate --summary --match 'name record && not name overrode' +\end{verbatim} + +\begin{code} +match_parser :: Patchy p => CharParser st (MatchFun p) +match_parser = do m <- option trivial submatch + eof + return m + +submatch :: Patchy p => CharParser st (MatchFun p) +submatch = buildExpressionParser table match "match rule" + +table :: OperatorTable Char st (MatchFun p) +table = [ [prefix "not" negate_match, + prefix "!" negate_match ] + , [binary "||" or_match, + binary "or" or_match, + binary "&&" and_match, + binary "and" and_match ] + ] + where binary name fun = + Infix (do trystring name + spaces + return fun) AssocLeft + prefix name fun = Prefix $ do trystring name + spaces + return fun + negate_match a p = not (a p) + or_match m1 m2 p = (m1 p) || (m2 p) + and_match m1 m2 p = (m1 p) && (m2 p) + +trystring :: String -> CharParser st String +trystring s = try $ string s + +match :: Patchy p => CharParser st (MatchFun p) +match = between spaces spaces + (parens submatch + <|> choice matchers_ + "simple match") + where matchers_ = map createMatchHelper primitiveMatchers + + +createMatchHelper :: (String, String, [String], String -> MatchFun p) + -> CharParser st (MatchFun p) +createMatchHelper (key,_,_,matcher) = + do trystring key + spaces + q <- quoted + return $ matcher q + +-- FIXME: would this be better defined in Darcs.Commands.Help? +-- | The string that is emitted when the user runs @darcs help --match@. +helpOnMatchers :: String +helpOnMatchers = unlines $ + ["Selecting Patches:", + "", + "The --patches option yields patches with names matching an `extended'", + "regular expression. See regex(7) for details. The --matches option", + "yields patches that match a logical (Boolean) expression: one or more", + "primitive expressions combined by grouping (parentheses) and the", + "complement (not), conjunction (and) and disjunction (or) operators.", + "The C notation for logic operators (!, && and ||) can also be used.", + "", + " --patches=regex is a synonym for --matches='name regex'", + " --from-patch and --to-patch are synonyms for --from-match='name... and --to-match='name...", + " --from-patch and --to-match can be unproblematically combined:", + " darcs changes --from-patch='html.*documentation' --to-match='date 20040212'", + "", + "The following primitive Boolean expressions are supported:"] + ++ keywords + ++ ["", "Here are some examples:"] + ++ examples + where -- This type signature exists to appease GHC. + ps :: [(String, String, [String], String -> MatchFun Patch)] + ps = primitiveMatchers + keywords = [showKeyword k d | (k,d,_,_) <- ps] + examples = [showExample k e | (k,_,es,_) <- ps, e <- es] + showKeyword keyword description = + -- FIXME: it would be nice to have a variable name here: + -- "author REGEX - match against author (email address)" + -- or "exact STRING - match against exact patch name". + " " ++ keyword ++ " - " ++ description ++ "." + showExample keyword example = + -- FIXME: this string is long, and its not a use case I've + -- ever seen in practice. Can we use something else, + -- like "darcs changes --matches"? --twb, 2008-12-28 + " darcs annotate --summary --match " + ++ "'" ++ keyword ++ " " ++ example ++ "'" + +primitiveMatchers :: Patchy p => [(String, String, [String], String -> MatchFun p)] + -- ^ keyword (operator), help description, list + -- of examples, matcher function +primitiveMatchers = + [ ("exact", "check a literal string against the patch name" + , ["\"Resolve issue17: use dynamic memory allocation.\""] + , exactmatch ) + , ("name", "check a regular expression against the patch name" + , ["issue17", "\"^[Rr]esolve issue17\\>\""] + , mymatch ) + , ("author", "check a regular expression against the author name" + , ["\"David Roundy\"", "droundy", "droundy@darcs.net"] + , authormatch ) + , ("hash", "match the darcs hash for a patch" + , ["20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef"] + , hashmatch ) + , ("date", "match the patch date" + , ["\"2006-04-02 22:41\"", "\"tea time yesterday\""] + , datematch ) + , ("touch", "match file paths for a patch" + , ["src/foo.c", "src/", "\"src/*.(c|h)\""] + , touchmatch ) ] + +parens :: CharParser st (MatchFun p) + -> CharParser st (MatchFun p) +parens p = between (string "(") (string ")") p + +quoted :: CharParser st String +quoted = between (char '"') (char '"') + (many $ do { char '\\' -- allow escapes + ; try (oneOf ['\\', '"']) <|> return '\\' + } + <|> noneOf ['"']) + <|> between spaces spaces (many $ noneOf " ()") + "string" + +mymatch, exactmatch, authormatch, hashmatch, datematch, touchmatch :: Patchy p => String -> MatchFun p + +mymatch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ just_name (info hp) + +exactmatch r (Sealed2 hp) = r == (just_name (info hp)) + +authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ just_author (info hp) + +hashmatch h (Sealed2 hp) = let rh = make_filename (info hp) in + (rh == h) || (rh == h++".gz") + +datematch d (Sealed2 hp) = let dm = unsafePerformIO $ parseDateMatcher d + in dm $ pi_date (info hp) + +touchmatch r (Sealed2 hp) = let files = list_touched_files $ patchcontents $ hopefully hp + in or $ map (isJust . matchRegex (mkRegex r)) files +\end{code} diff --git a/src/Darcs/Patch/MatchData.hs b/src/Darcs/Patch/MatchData.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/MatchData.hs @@ -0,0 +1,28 @@ +-- Copyright (C) 2004 David Roundy +-- +-- 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. + +module Darcs.Patch.MatchData ( PatchMatch(..), patch_match, + ) where + +data PatchMatch = PatternMatch String + deriving ( Eq ) + +instance Show PatchMatch where + show (PatternMatch m) = "pattern " ++ show m + +patch_match :: String -> PatchMatch +patch_match s = PatternMatch s diff --git a/src/Darcs/Patch/Non.hs b/src/Darcs/Patch/Non.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Non.hs @@ -0,0 +1,187 @@ +-- Copyright (C) 2007 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +-- , TypeOperators, GADTs, FlexibleContexts #-} + +#include "gadts.h" + +-- |'NonPatch' and 'Non' patches are patches that store a context as a +-- sequence of patches. See "Darcs.Patch.Real" for example usage. +module Darcs.Patch.Non + ( NonPatch, Non(..), Nonable(..), unNon, + showNon, readNon, showNons, readNons, + add, rem, addP, remP, addPs, remPs, remAddP, remAddPs, remNons, + (*>), (>*), (*>>), (>>*), + prop_adjust_twice ) where + +import Prelude hiding ( rem ) +import Data.List ( delete ) +import Control.Monad ( liftM ) +import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Effect(..), + showPrim, FileNameFormat(..), sort_coalesceFL ) +import Darcs.Patch.Patchy +import Darcs.Patch.ReadMonads ( ParserM, lex_char ) +import Darcs.Ordered +import Darcs.Patch.Read ( readPrim ) +import Darcs.Patch.Viewing () +import Darcs.Patch.Permutations ( removeFL, commuteWhatWeCanFL ) +import Darcs.Show +import Darcs.Sealed ( Sealed(Sealed) ) +import Printer ( Doc, empty, vcat, hiddenPrefix, blueText, redText, ($$) ) + +--import Darcs.ColorPrinter ( traceDoc ) +--import Printer ( greenText ) + +showNons :: ShowPatch (FL p) => [Non p C(x)] -> Doc +showNons [] = empty +showNons xs = blueText "{{" $$ vcat (map showNon xs) $$ blueText "}}" + +showNon :: ShowPatch (FL p) => Non p C(x) -> Doc +showNon (Non c p) = hiddenPrefix "|" (showPatch c) + $$ hiddenPrefix "|" (blueText ":") + $$ showPrim NewFormat p + +readNons :: (ReadPatch p, ParserM m) => m [Non p C(x)] +readNons = peekfor "{{" rns (return []) + where rns = peekfor "}}" (return []) $ + do Just (Sealed ps) <- readPatch' False + lex_char ':' + Just (Sealed p) <- readPrim NewFormat False + (Non ps p :) `liftM` rns + +readNon :: (ReadPatch p, ParserM m) => m (Maybe (Non p C(x))) +readNon = do Just (Sealed ps) <- readPatch' False + peekfor ":" (do Just (Sealed p) <- readPatch' False + return $ Just $ Non ps p) + (return Nothing) + +instance (Commute p, MyEq p) => Eq (Non p C(x)) where + (Non cx x) == (Non cy y) | IsEq <- cx =\/= cy, + IsEq <- x =\/= y = True + | otherwise = False + +-- | 'Non' stores a context with a 'Prim' patch. +data Non p C(x) where + Non :: FL p C(a x) -> Prim C(x y) -> Non p C(a) + +-- | Convenience type for non primitive patches +type NonPatch C(x) = Non Prim C(x) + +-- | Return as a list the context followed by the primitive patch. +unNon :: FromPrim p => Non p C(x) -> Sealed (FL p C(x)) +unNon (Non c x) = Sealed (c +>+ fromPrim x :>: NilFL) + +class Nonable p where + non :: p C(x y) -> Non p C(x) + +addP :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Non p C(x) +addP p n | Just n' <- p >* n = n' +addP p (Non c x) = Non (p:>:c) x + +addPs :: (Patchy p, ToFromPrim p) => RL p C(x y) -> Non p C(y) -> Non p C(x) +addPs NilRL n = n +addPs (p:<:ps) n = addPs ps $ addP p n + +add :: (Effect q, Patchy p, ToFromPrim p) => q C(x y) -> Non p C(y) -> Non p C(x) +add q = addPs (mapRL_RL fromPrim $ effectRL q) + +-- remNons really only works right if the relevant nons are conflicting... +remNons :: (Nonable p, Effect p, Patchy p, ToFromPrim p, ShowPatch p) => [Non p C(x)] -> Non p C(x) -> Non p C(x) +remNons ns (Non c x) = case remNonHelper ns c of + NilFL :> c' -> Non c' x + _ -> Non c x + +remNonHelper :: (Nonable p, Effect p, Patchy p, ToFromPrim p) => [Non p C(x)] -> FL p C(x y) + -> (FL Prim :> FL p) C(x y) +remNonHelper [] x = NilFL :> x +remNonHelper ns (c:>:cs) + | non c `elem` ns = case remNonHelper (map (addP $ invert c) $ delete (non c) ns) cs of + a :> z -> sort_coalesceFL (effect c+>+a) :> z + | otherwise = case commuteWhatWeCanFL (c :> cs) of + b :> c' :> d -> + case remNonHelper ns b of + a :> b' -> a :> (b'+>+c':>:d) +remNonHelper _ NilFL = NilFL :> NilFL + +remP :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(x) -> Maybe (Non p C(y)) +remP p n | Just n' <- n *> p = Just n' +remP p (Non pc x) = do c <- removeFL p pc + return (Non c x) + +remPs :: (Patchy p, ToFromPrim p) => FL p C(x y) -> Non p C(x) -> Maybe (Non p C(y)) +remPs NilFL n = Just n +remPs (p:>:ps) n = remP p n >>= remPs ps + +rem :: (Effect q, Patchy p, ToFromPrim p) => q C(x y) -> Non p C(x) -> Maybe (Non p C(y)) +rem q = remPs (mapFL_FL fromPrim $ effect q) + +remAddP :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Non p C(x) +remAddP p n = maybe (addP p n) id $ remP (invert p) n + +remAddPs :: (Patchy p, ToFromPrim p) => RL p C(x y) -> Non p C(y) -> Non p C(x) +remAddPs NilRL n = n +remAddPs (x:<:xs) n = remAddPs xs $ remAddP x n + +(*>) :: (Patchy p, ToFromPrim p) => Non p C(x) -> p C(x y) -> Maybe (Non p C(y)) +n *> p = invert p >* n + +(>*) :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Maybe (Non p C(x)) +y >* (Non c x) = case commuteFL (y :> c) of + Right (c' :> y') -> do + px' :> _ <- commute (y' :> fromPrim x) + x' <- toPrim px' + return (Non c' x') + _ -> Nothing + +(*>>) :: (Effect q, Patchy q, Patchy p, ToFromPrim p) => Non p C(x) -> q C(x y) -> Maybe (Non p C(y)) +n *>> p = invert p >>* n + +(>>*) :: (Effect q, Patchy p, ToFromPrim p) => q C(x y) -> Non p C(y) -> Maybe (Non p C(x)) +q >>* nn = adj (effectRL q) nn + where adj :: (Patchy p, ToFromPrim p) => RL Prim C(x y) -> Non p C(y) -> Maybe (Non p C(x)) + adj NilRL n = Just n + adj (x:<:xs) n = fromPrim x >* n >>= adj xs + +prop_adjust_twice :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Maybe Doc +prop_adjust_twice p n = + do n' <- p >* n + case n' *> p of + Nothing -> Just (redText "prop_adjust_inverse 1") + Just n'' | n'' /= n -> Just (redText "prop_adjust_inverse 2") + _ -> case n *> invert p of + Nothing -> Just (redText "prop_adjust_inverse 3") + Just n'' | n'' /= n' -> Just (redText "prop_adjust_inverse 4") + _ -> case invert p >* n' of + Nothing -> Just (redText "prop_adjust_inverse 5") + Just n'' | n'' /= n -> Just (redText "prop_adjust_inverse 6") + _ -> Nothing + + +instance Nonable Prim where + non = Non NilFL + +instance Show2 p => Show (Non p C(x)) where + showsPrec = showsPrec1 + +instance Show2 p => Show1 (Non p) where + showsPrec1 d (Non cs p) = showParen (d > app_prec) $ showString "Non " . + showsPrec2 (app_prec + 1) cs . showString " " . + showsPrec (app_prec + 1) p + +instance Patchy Prim diff --git a/src/Darcs/Patch/Patchy.hs b/src/Darcs/Patch/Patchy.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Patchy.hs @@ -0,0 +1,230 @@ +-- Copyright (C) 2007 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +-- , TypeOperators, GADTs #-} + +#include "gadts.h" + +module Darcs.Patch.Patchy ( Patchy, + Apply, apply, applyAndTryToFix, applyAndTryToFixFL, + mapMaybeSnd, + Commute(..), commuteFL, commuteRL, commuteRLFL, + mergeFL, + ShowPatch(..), + ReadPatch, readPatch', bracketedFL, peekfor, + Invert(..), invertFL, invertRL ) where + +import Control.Monad ( liftM ) +import Data.Maybe ( fromJust ) +import Data.Word ( Word8 ) +import Data.List ( nub ) + +import Darcs.SlurpDirectory ( Slurpy ) +import Darcs.Sealed ( Sealed(..), Sealed2(..), seal2 ) +import Darcs.Patch.ReadMonads ( ParserM, lex_eof, peek_input, my_lex, work, alter_input ) +import Darcs.Ordered +import Printer ( Doc, (<>), text ) +import Darcs.Lock ( writeDocBinFile, gzWriteDocFile ) +import Darcs.IO ( WriteableDirectory ) +import Darcs.Flags ( DarcsFlag ) +import English ( plural, Noun(Noun) ) + +import ByteStringUtils ( ifHeadThenTail, dropSpace ) +import qualified Data.ByteString.Char8 as BC (pack, ByteString) + +--import Darcs.ColorPrinter ( traceDoc ) +--import Printer ( greenText, ($$) ) + +class (Apply p, Commute p, ShowPatch p, ReadPatch p, Invert p) => Patchy p where +-- instance (ShowPatch p, Invert p) => Patchy p where + +class Apply p where + apply :: WriteableDirectory m => [DarcsFlag] -> p C(x y) -> m () + apply _ p = do mp' <- applyAndTryToFix p + case mp' of + Nothing -> return () + Just (e, _) -> fail $ "Unable to apply a patch: " ++ e + applyAndTryToFix :: WriteableDirectory m => p C(x y) -> m (Maybe (String, p C(x y))) + applyAndTryToFix p = do apply [] p; return Nothing + applyAndTryToFixFL :: WriteableDirectory m => p C(x y) -> m (Maybe (String, FL p C(x y))) + applyAndTryToFixFL p = mapMaybeSnd (:>:NilFL) `liftM` applyAndTryToFix p + +mapMaybeSnd :: (a -> b) -> Maybe (c, a) -> Maybe (c, b) +mapMaybeSnd f (Just (a,b)) = Just (a,f b) +mapMaybeSnd _ Nothing = Nothing + +class Commute p where + commute :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y)) + commutex :: (p :< p) C(x y) -> Maybe ((p :< p) C(x y)) + commute (x :> y) = do x' :< y' <- commutex (y :< x) + return (y' :> x') + commutex (x :< y) = do x' :> y' <- commute (y :> x) + return (y' :< x') + merge :: (p :\/: p) C(x y) -> (p :/\: p) C(x y) + list_touched_files :: p C(x y) -> [FilePath] + +class Commute p => ShowPatch p where + showPatch :: p C(x y) -> Doc + showNicely :: p C(x y) -> Doc + showNicely = showPatch + showContextPatch :: Slurpy -> p C(x y) -> Doc + showContextPatch _ p = showPatch p + description :: p C(x y) -> Doc + description = showPatch + summary :: p C(x y) -> Doc + summary = showPatch + writePatch :: FilePath -> p C(x y) -> IO () + writePatch f p = writeDocBinFile f $ showPatch p <> text "\n" + gzWritePatch :: FilePath -> p C(x y) -> IO () + gzWritePatch f p = gzWriteDocFile f $ showPatch p <> text "\n" + thing :: p C(x y) -> String + thing _ = "patch" + things :: p C(x y) -> String + things x = plural (Noun $ thing x) "" + +class ReadPatch p where + readPatch' + :: ParserM m => Bool -> m (Maybe (Sealed (p C(x )))) + +class MyEq p => Invert p where + invert :: p C(x y) -> p C(y x) + identity :: p C(x x) + sloppyIdentity :: p C(x y) -> EqCheck C(x y) + sloppyIdentity p = identity =\/= p + +instance Apply p => Apply (FL p) where + apply _ NilFL = return () + apply opts (p:>:ps) = apply opts p >> apply opts ps + applyAndTryToFix NilFL = return Nothing + applyAndTryToFix (p:>:ps) = do mp <- applyAndTryToFixFL p + mps <- applyAndTryToFix ps + return $ case (mp,mps) of + (Nothing, Nothing) -> Nothing + (Just (e,p'),Nothing) -> Just (e,p'+>+ps) + (Nothing, Just (e,ps')) -> Just (e,p:>:ps') + (Just (e,p'), Just (es,ps')) -> + Just (unlines [e,es], p'+>+ps') + +instance Commute p => Commute (FL p) where + commute (NilFL :> x) = Just (x :> NilFL) + commute (x :> NilFL) = Just (NilFL :> x) + commute (xs :> ys) = do ys' :> rxs' <- commuteRLFL (reverseFL xs :> ys) + return $ ys' :> reverseRL rxs' + merge (NilFL :\/: x) = x :/\: NilFL + merge (x :\/: NilFL) = NilFL :/\: x + merge ((x:>:xs) :\/: ys) = fromJust $ do ys' :/\: x' <- return $ mergeFL (x :\/: ys) + xs' :/\: ys'' <- return $ merge (ys' :\/: xs) + return (ys'' :/\: (x' :>: xs')) + list_touched_files xs = nub $ concat $ mapFL list_touched_files xs + +mergeFL :: Commute p => (p :\/: FL p) C(x y) -> (FL p :/\: p) C(x y) +mergeFL (p :\/: NilFL) = NilFL :/\: p +mergeFL (p :\/: (x :>: xs)) = fromJust $ do x' :/\: p' <- return $ merge (p :\/: x) + xs' :/\: p'' <- return $ mergeFL (p' :\/: xs) + return ((x' :>: xs') :/\: p'') + +commuteRLFL :: Commute p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y)) +commuteRLFL (NilRL :> ys) = Just (ys :> NilRL) +commuteRLFL (xs :> NilFL) = Just (NilFL :> xs) +commuteRLFL (xs :> y :>: ys) = do y' :> xs' <- commuteRL (xs :> y) + ys' :> xs'' <- commuteRLFL (xs' :> ys) + return (y' :>: ys' :> xs'') + +commuteRL :: Commute p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y)) +commuteRL (z :<: zs :> w) = do w' :> z' <- commute (z :> w) + w'' :> zs' <- commuteRL (zs :> w') + return (w'' :> z' :<: zs') +commuteRL (NilRL :> w) = Just (w :> NilRL) + +commuteFL :: Commute p => (p :> FL p) C(x y) -> Either (Sealed2 p) ((FL p :> p) C(x y)) +commuteFL (p :> NilFL) = Right (NilFL :> p) +commuteFL (q :> p :>: ps) = case commute (q :> p) of + Just (p' :> q') -> + case commuteFL (q' :> ps) of + Right (ps' :> q'') -> Right (p' :>: ps' :> q'') + Left l -> Left l + Nothing -> Left $ seal2 p + +instance ReadPatch p => ReadPatch (FL p) where + readPatch' want_eof = Just `liftM` read_patches + where read_patches :: ParserM m => m (Sealed (FL p C(x ))) + read_patches = do --tracePeek "starting FL read" + mp <- readPatch' False + case mp of + Just (Sealed p) -> do --tracePeek "found one patch" + Sealed ps <- read_patches + return $ Sealed (p:>:ps) + Nothing -> if want_eof + then do --tracePeek "no more patches" + unit' <- lex_eof + case unit' of + () -> return $ Sealed NilFL + else do --tracePeek "no more patches" + return $ Sealed NilFL +-- tracePeek x = do y <- peek_input +-- traceDoc (greenText x $$ greenText (show $ sal_to_string y)) return () + +{-# INLINE bracketedFL #-} +bracketedFL :: (ReadPatch p, ParserM m) => + Word8 -> Word8 -> m (Maybe (Sealed (FL p C(x)))) +bracketedFL pre post = + peekforw pre bfl (return Nothing) + where bfl :: (ReadPatch p, ParserM m) => m (Maybe (Sealed (FL p C(x)))) + bfl = peekforw post (return $ Just $ Sealed NilFL) + (do Just (Sealed p) <- readPatch' False + Just (Sealed ps) <- bfl + return $ Just $ Sealed (p:>:ps)) + +{-# INLINE peekforw #-} +peekforw :: ParserM m => Word8 -> m a -> m a -> m a +peekforw w ifstr ifnot = do s <- peek_input + case ifHeadThenTail w $ dropSpace s of + Just s' -> alter_input (const s') >> ifstr + Nothing -> ifnot + +peekforPS :: ParserM m => BC.ByteString -> m a -> m a -> m a +peekforPS ps ifstr ifnot = do s <- peek_input + case ((ps ==) . fst) `fmap` my_lex s of + Just True -> work my_lex >> ifstr + _ -> ifnot + +{-# INLINE peekfor #-} +peekfor :: ParserM m => String -> m a -> m a -> m a +peekfor = peekforPS . BC.pack + +instance Apply p => Apply (RL p) where + apply _ NilRL = return () + apply opts (p:<:ps) = apply opts ps >> apply opts p +instance Commute p => Commute (RL p) where + commute (xs :> ys) = do fys' :> xs' <- commuteRLFL (xs :> reverseRL ys) + return (reverseFL fys' :> xs') + merge (x :\/: y) = case merge (reverseRL x :\/: reverseRL y) of + (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx' + list_touched_files = list_touched_files . reverseRL +instance ReadPatch p => ReadPatch (RL p) where + readPatch' want_eof = do Just (Sealed fl) <- readPatch' want_eof + return $ Just $ Sealed $ reverseFL fl + +invertFL :: Invert p => FL p C(x y) -> RL p C(y x) +invertFL NilFL = NilRL +invertFL (x:>:xs) = invert x :<: invertFL xs + +invertRL :: Invert p => RL p C(x y) -> FL p C(y x) +invertRL NilRL = NilFL +invertRL (x:<:xs) = invert x :>: invertRL xs diff --git a/src/Darcs/Patch/Permutations.hs b/src/Darcs/Patch/Permutations.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Permutations.hs @@ -0,0 +1,232 @@ +-- Copyright (C) 2002-2003 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +-- , TypeOperators, PatternGuards #-} + +#include "gadts.h" + +module Darcs.Patch.Permutations ( removeFL, removeRL, removeCommon, + commuteWhatWeCanFL, commuteWhatWeCanRL, + genCommuteWhatWeCanRL, + partitionFL, partitionRL, + head_permutationsFL, head_permutationsRL, + headPermutationsFL, + remove_subsequenceFL, remove_subsequenceRL ) where + +import Data.Maybe ( catMaybes ) +import Darcs.Patch.Patchy ( Commute, commute, commuteFL, commuteRL, Invert(..), invertFL, invertRL ) +import Darcs.Ordered +#include "impossible.h" + +-- |split an 'FL' into "left" and "right" lists according to a predicate, using commutation as necessary. +-- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy +-- the predicate, it goes in the "right" list. +partitionFL :: Commute p + => (FORALL(u v) p C(u v) -> Bool) -- ^predicate; if true we would like the patch in the "left" list + -> FL p C(x y) -- ^input 'FL' + -> (FL p :> FL p) C(x y) -- ^"left" and "right" results + +-- optimise by using an accumulating parameter to track all the "right" patches that we've found so far +partitionFL' :: Commute p + => (FORALL(u v) p C(u v) -> Bool) + -> RL p C(x z) -- the "right" patches found so far + -> FL p C(z y) + -> (FL p :> FL p) C(x y) + +partitionFL keepleft ps = partitionFL' keepleft NilRL ps + +partitionFL' _ qs NilFL = NilFL :> reverseRL qs +partitionFL' keepleft qs (p :>: ps) + | keepleft p, + Just (p' :> qs') <- commuteRL (qs :> p) + = case partitionFL' keepleft qs' ps of + a :> b -> p' :>: a :> b + | otherwise = partitionFL' keepleft (p :<: qs) ps + +-- |split an 'RL' into "left" and "right" lists according to a predicate, using commutation as necessary. +-- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy +-- the predicate, it goes in the "left" list. +partitionRL :: Commute p + => (FORALL(u v) p C(u v) -> Bool) -- ^predicate; if true we would like the patch in the "right" list + -> RL p C(x y) -- ^input 'RL' + -> (RL p :> RL p) C(x y) -- ^"left" and "right" results + +-- optimise by using an accumulating parameter to track all the "left" patches that we've found so far +partitionRL' :: Commute p + => (FORALL(u v) p C(u v) -> Bool) + -> RL p C(x z) + -> FL p C(z y) -- the "left" patches found so far + -> (RL p :> RL p) C(x y) + +partitionRL keepright ps = partitionRL' keepright ps NilFL + +partitionRL' _ NilRL qs = reverseFL qs :> NilRL + +partitionRL' keepright (p :<: ps) qs + | keepright p, + Right (qs' :> p') <- commuteFL (p :> qs) + = case partitionRL' keepright ps qs' of + a :> b -> a :> p' :<: b + | otherwise = partitionRL' keepright ps (p :>: qs) + +commuteWhatWeCanFL :: Commute p => (p :> FL p) C(x y) -> (FL p :> p :> FL p) C(x y) +commuteWhatWeCanFL (p :> x :>: xs) = + case commute (p :> x) of + Nothing -> case commuteWhatWeCanFL (x :> xs) of + xs1 :> x' :> xs2 -> case commuteWhatWeCanFL (p :> xs1) of + xs1' :> p' :> xs2' -> xs1' :> p' :> xs2' +>+ x' :>: xs2 + Just (x' :> p') -> case commuteWhatWeCanFL (p' :> xs) of + a :> p'' :> c -> x' :>: a :> p'' :> c +commuteWhatWeCanFL (y :> NilFL) = NilFL :> y :> NilFL + +commuteWhatWeCanRL :: Commute p => (RL p :> p) C(x y) -> (RL p :> p :> RL p) C(x y) +commuteWhatWeCanRL = genCommuteWhatWeCanRL commute + +genCommuteWhatWeCanRL :: (FORALL(a b) ((p :> p) C(a b) -> Maybe ((p :> p) C(a b)))) + -> (RL p :> p) C(x y) -> (RL p :> p :> RL p) C(x y) +genCommuteWhatWeCanRL com (x :<: xs :> p) = + case com (x :> p) of + Nothing -> case genCommuteWhatWeCanRL com (xs :> x) of + xs1 :> x' :> xs2 -> case genCommuteWhatWeCanRL com (xs2 :> p) of + xs1' :> p' :> xs2' -> xs1' +<+ x' :<: xs1 :> p' :> xs2' + Just (p' :> x') -> case genCommuteWhatWeCanRL com (xs :> p') of + a :> p'' :> c -> a :> p'' :> x' :<: c +genCommuteWhatWeCanRL _ (NilRL :> y) = NilRL :> y :> NilRL + + +removeCommon :: (MyEq p, Commute p) => (FL p :\/: FL p) C(x y) -> (FL p :\/: FL p) C(x y) +removeCommon (xs :\/: NilFL) = xs :\/: NilFL +removeCommon (NilFL :\/: xs) = NilFL :\/: xs +removeCommon (xs :\/: ys) = rc xs (headPermutationsFL ys) + where rc :: (MyEq p, Commute p) => FL p C(x y) -> [(p:>FL p) C(x z)] -> (FL p :\/: FL p) C(y z) + rc nms ((n:>ns):_) | Just ms <- removeFL n nms = removeCommon (ms :\/: ns) + rc ms [n:>ns] = ms :\/: n:>:ns + rc ms (_:nss) = rc ms nss + rc _ [] = impossible -- because we already checked for NilFL case + +-- | 'removeFL' @x xs@ removes @x@ from @xs@ if @x@ can be commuted to its head. +-- Otherwise it returns 'Nothing' +removeFL :: (MyEq p, Commute p) => p C(x y) -> FL p C(x z) -> Maybe (FL p C(y z)) +removeFL x xs = r x $ headPermutationsFL xs + where r :: (MyEq p, Commute p) => p C(x y) -> [(p:>FL p) C(x z)] -> Maybe (FL p C(y z)) + r _ [] = Nothing + r z ((z':>zs):zss) | IsEq <- z =\/= z' = Just zs + | otherwise = r z zss + +-- | 'removeRL' is like 'removeFL' except with 'RL' +removeRL :: (MyEq p, Commute p) => p C(y z) -> RL p C(x z) -> Maybe (RL p C(x y)) +removeRL x xs = r x $ head_permutationsRL xs + where r :: (MyEq p, Commute p) => p C(y z) -> [RL p C(x z)] -> Maybe (RL p C(x y)) + r z ((z':<:zs):zss) | IsEq <- z =/\= z' = Just zs + | otherwise = r z zss + r _ _ = Nothing + +-- | 'remove_subsequenceFL' @ab abc@ returns @Just c'@ where all the patches in +-- @ab@ have been commuted out of it, if possible. If this is not possible +-- for any reason (the set of patches @ab@ is not actually a subset of @abc@, +-- or they can't be commuted out) we return 'Nothing'. +remove_subsequenceFL :: (MyEq p, Commute p) => FL p C(a b) + -> FL p C(a c) -> Maybe (FL p C(b c)) +remove_subsequenceFL a b | lengthFL a > lengthFL b = Nothing + | otherwise = rsFL a b + where rsFL :: (MyEq p, Commute p) => FL p C(a b) -> FL p C(a c) -> Maybe (FL p C(b c)) + rsFL NilFL ys = Just ys + rsFL (x:>:xs) yys = removeFL x yys >>= remove_subsequenceFL xs + +-- | 'remove_subsequenceRL' is like @remove_subsequenceFL@ except that it works +-- on 'RL' +remove_subsequenceRL :: (MyEq p, Commute p) => RL p C(ab abc) + -> RL p C(a abc) -> Maybe (RL p C(a ab)) +remove_subsequenceRL a b | lengthRL a > lengthRL b = Nothing + | otherwise = rsRL a b + where rsRL :: (MyEq p, Commute p) => RL p C(ab abc) -> RL p C(a abc) -> Maybe (RL p C(a ab)) + rsRL NilRL ys = Just ys + rsRL (x:<:xs) yys = removeRL x yys >>= remove_subsequenceRL xs + +-- | This is a minor variant of 'headPermutationsFL' with each permutation +-- is simply returned as a 'FL' +head_permutationsFL :: Commute p => FL p C(x y) -> [FL p C(x y)] +head_permutationsFL ps = map (\ (x:>xs) -> x:>:xs) $ headPermutationsFL ps + +-- | 'headPermutationsFL' @p:>:ps@ returns all the permutations of the list +-- in which one element of @ps@ is commuted past @p@ +-- +-- Suppose we have a sequence of patches +-- +-- > X h a y s-t-c k +-- +-- Suppose furthermore that the patch @c@ depends on @t@, which in turn +-- depends on @s@. This function will return +-- +-- > X :> h a y s t c k +-- > h :> X a y s t c k +-- > a :> X h y s t c k +-- > y :> X h a s t c k +-- > s :> X h a y t c k +-- > k :> X h a y s t c +headPermutationsFL :: Commute p => FL p C(x y) -> [(p :> FL p) C(x y)] +headPermutationsFL NilFL = [] +headPermutationsFL (p:>:ps) = + (p:>ps) : catMaybes (map (swapfirstFL.(p:>)) $ headPermutationsFL ps) + where swapfirstFL (p1:>p2:>xs) = do p2':>p1' <- commute (p1:>p2) + Just $ p2':>p1':>:xs + +-- | 'head_permutationsRL' is like 'headPermutationsFL', except that we +-- operate on an 'RL' (in other words, we are pushing things to the end of a +-- patch sequence instead of to the beginning). +head_permutationsRL :: Commute p => RL p C(x y) -> [RL p C(x y)] +head_permutationsRL NilRL = [] +head_permutationsRL (p:<:ps) = + (p:<:ps) : catMaybes (map (swapfirstRL.(p:<:)) $ head_permutationsRL ps) + where swapfirstRL (p1:<:p2:<:xs) = do p1':>p2' <- commute (p2:>p1) + Just $ p2':<:p1':<:xs + swapfirstRL _ = Nothing + +instance (MyEq p, Commute p) => MyEq (FL p) where + a =\/= b | lengthFL a /= lengthFL b = NotEq + | otherwise = cmpSameLength a b + where cmpSameLength :: FL p C(x y) -> FL p C(x z) -> EqCheck C(y z) + cmpSameLength (x:>:xs) xys | Just ys <- removeFL x xys = cmpSameLength xs ys + cmpSameLength NilFL NilFL = IsEq + cmpSameLength _ _ = NotEq + xs =/\= ys = reverseFL xs =/\= reverseFL ys + +instance (Invert p, Commute p) => Invert (FL p) where + invert = reverseRL . invertFL + identity = NilFL + sloppyIdentity NilFL = IsEq + sloppyIdentity (x:>:xs) | IsEq <- sloppyIdentity x = sloppyIdentity xs + sloppyIdentity _ = NotEq + +instance (MyEq p, Commute p) => MyEq (RL p) where + unsafeCompare = bug "Buggy use of unsafeCompare on RL" + a =/\= b | lengthRL a /= lengthRL b = NotEq + | otherwise = cmpSameLength a b + where cmpSameLength :: RL p C(x y) -> RL p C(w y) -> EqCheck C(x w) + cmpSameLength (x:<:xs) xys | Just ys <- removeRL x xys = cmpSameLength xs ys + cmpSameLength NilRL NilRL = IsEq + cmpSameLength _ _ = NotEq + xs =\/= ys = reverseRL xs =\/= reverseRL ys + +instance (Commute p, Invert p) => Invert (RL p) where + invert = reverseFL . invertRL + identity = NilRL + sloppyIdentity NilRL = IsEq + sloppyIdentity (x:<:xs) | IsEq <- sloppyIdentity x = sloppyIdentity xs + sloppyIdentity _ = NotEq diff --git a/src/Darcs/Patch/Prim.lhs b/src/Darcs/Patch/Prim.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Prim.lhs @@ -0,0 +1,1130 @@ +% Copyright (C) 2002-2003,2007 David Roundy +% +% 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. + +\begin{code} +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +-- , MagicHash, TypeOperators, GADTs, PatternGuards #-} + +#include "gadts.h" + +module Darcs.Patch.Prim + ( Prim(..), IsConflictedPrim(IsC), ConflictState(..), showPrim, + DirPatchType(..), FilePatchType(..), + CommuteFunction, Perhaps(..), + null_patch, nullP, is_null_patch, + is_identity, + formatFileName, FileNameFormat(..), + adddir, addfile, binary, changepref, + hunk, move, rmdir, rmfile, tokreplace, + is_addfile, is_hunk, is_binary, is_setpref, + is_similar, is_adddir, is_filepatch, + canonize, try_to_shrink, modernizePrim, + subcommutes, sort_coalesceFL, join, + try_tok_internal, + try_shrinking_inverse, + n_fn, + FromPrim(..), FromPrims(..), ToFromPrim(..), + Conflict(..), Effect(..), commute_no_conflictsFL, commute_no_conflictsRL + ) + where + +import Prelude hiding ( pi ) +import Control.Monad ( MonadPlus, msum, mzero, mplus ) +import Data.Maybe ( isNothing ) +#ifndef GADT_WITNESSES +import Data.Map ( elems, fromListWith, mapWithKey ) +#endif + +import ByteStringUtils ( substrPS, fromPS2Hex) +import qualified Data.ByteString as B (ByteString, length, null, head, take, concat, drop) +import qualified Data.ByteString.Char8 as BC (break, pack) + +import Darcs.Patch.FileName ( FileName, fn2ps, fn2fp, fp2fn, norm_path, + movedirfilename, encode_white ) +import Darcs.Ordered +import Darcs.Sealed ( Sealed, unseal ) +import Darcs.Patch.Patchy ( Invert(..), Commute(..) ) +import Darcs.Patch.Permutations () -- for Invert instance of FL +import Darcs.Show +import Darcs.Utils ( nubsort ) +import Lcs ( getChanges ) +import RegChars ( regChars ) +import Printer ( Doc, vcat, packedString, Color(Cyan,Magenta), lineColor, + text, userchunk, invisibleText, invisiblePS, blueText, + ($$), (<+>), (<>), prefix, userchunkPS, + ) +import GHC.Base (unsafeCoerce#) +#include "impossible.h" + +data Prim C(x y) where + Move :: !FileName -> !FileName -> Prim C(x y) + DP :: !FileName -> !(DirPatchType C(x y)) -> Prim C(x y) + FP :: !FileName -> !(FilePatchType C(x y)) -> Prim C(x y) + Split :: FL Prim C(x y) -> Prim C(x y) + Identity :: Prim C(x x) + ChangePref :: !String -> !String -> !String -> Prim C(x y) + +data FilePatchType C(x y) = RmFile | AddFile + | Hunk !Int [B.ByteString] [B.ByteString] + | TokReplace !String !String !String + | Binary B.ByteString B.ByteString + deriving (Eq,Ord) + +data DirPatchType C(x y) = RmDir | AddDir + deriving (Eq,Ord) + +instance MyEq FilePatchType where + unsafeCompare a b = a == unsafeCoerce# b + +instance MyEq DirPatchType where + unsafeCompare a b = a == unsafeCoerce# b + +null_patch :: Prim C(x x) +null_patch = Identity + +is_null_patch :: Prim C(x y) -> Bool +is_null_patch (FP _ (Binary x y)) = B.null x && B.null y +is_null_patch (FP _ (Hunk _ [] [])) = True +is_null_patch Identity = True +is_null_patch _ = False + +nullP :: Prim C(x y) -> EqCheck C(x y) +nullP = sloppyIdentity + +is_identity :: Prim C(x y) -> EqCheck C(x y) +is_identity (FP _ (Binary old new)) | old == new = unsafeCoerce# IsEq +is_identity (FP _ (Hunk _ old new)) | old == new = unsafeCoerce# IsEq +is_identity (FP _ (TokReplace _ old new)) | old == new = unsafeCoerce# IsEq +is_identity (Move old new) | old == new = unsafeCoerce# IsEq +is_identity Identity = IsEq +is_identity _ = NotEq + +-- FIXME: The following code needs to be moved. + +-- | Tells you if two patches are in the same category, human-wise. +-- Currently just returns true if they are filepatches on the same +-- file. +is_similar :: Prim C(x y) -> Prim C(a b) -> Bool +is_similar (FP f _) (FP f' _) = f == f' +is_similar (DP f _) (DP f' _) = f == f' +is_similar _ _ = False + +is_addfile :: Prim C(x y) -> Bool +is_addfile (FP _ AddFile) = True +is_addfile _ = False + +is_adddir :: Prim C(x y) -> Bool +is_adddir (DP _ AddDir) = True +is_adddir _ = False + +is_hunk :: Prim C(x y) -> Bool +is_hunk (FP _ (Hunk _ _ _)) = True +is_hunk _ = False + +is_binary :: Prim C(x y) -> Bool +is_binary (FP _ (Binary _ _)) = True +is_binary _ = False + +is_setpref :: Prim C(x y) -> Bool +is_setpref (ChangePref _ _ _) = True +is_setpref _ = False + +addfile :: FilePath -> Prim C(x y) +rmfile :: FilePath -> Prim C(x y) +adddir :: FilePath -> Prim C(x y) +rmdir :: FilePath -> Prim C(x y) +move :: FilePath -> FilePath -> Prim C(x y) +changepref :: String -> String -> String -> Prim C(x y) +hunk :: FilePath -> Int -> [B.ByteString] -> [B.ByteString] -> Prim C(x y) +tokreplace :: FilePath -> String -> String -> String -> Prim C(x y) +binary :: FilePath -> B.ByteString -> B.ByteString -> Prim C(x y) + +evalargs :: (a -> b -> c) -> a -> b -> c +evalargs f x y = (f $! x) $! y + +addfile f = FP (fp2fn $ n_fn f) AddFile +rmfile f = FP (fp2fn $ n_fn f) RmFile +adddir d = DP (fp2fn $ n_fn d) AddDir +rmdir d = DP (fp2fn $ n_fn d) RmDir +move f f' = Move (fp2fn $ n_fn f) (fp2fn $ n_fn f') +changepref p f t = ChangePref p f t +hunk f line old new = evalargs FP (fp2fn $ n_fn f) (Hunk line old new) +tokreplace f tokchars old new = + evalargs FP (fp2fn $ n_fn f) (TokReplace tokchars old new) +binary f old new = FP (fp2fn $! n_fn f) $ Binary old new + +n_fn :: FilePath -> FilePath +n_fn f = "./"++(fn2fp $ norm_path $ fp2fn f) + +instance Invert Prim where + invert Identity = Identity + invert (FP f RmFile) = FP f AddFile + invert (FP f AddFile) = FP f RmFile + invert (FP f (Hunk line old new)) = FP f $ Hunk line new old + invert (FP f (TokReplace t o n)) = FP f $ TokReplace t n o + invert (FP f (Binary o n)) = FP f $ Binary n o + invert (DP d RmDir) = DP d AddDir + invert (DP d AddDir) = DP d RmDir + invert (Move f f') = Move f' f + invert (ChangePref p f t) = ChangePref p t f + invert (Split ps) = Split $ invert ps + identity = Identity + sloppyIdentity Identity = IsEq + sloppyIdentity _ = NotEq + +instance Show (Prim C(x y)) where + showsPrec d (Move fn1 fn2) = showParen (d > app_prec) $ showString "Move " . + showsPrec (app_prec + 1) fn1 . showString " " . + showsPrec (app_prec + 1) fn2 + showsPrec d (DP fn dp) = showParen (d > app_prec) $ showString "DP " . + showsPrec (app_prec + 1) fn . showString " " . + showsPrec (app_prec + 1) dp + showsPrec d (FP fn fp) = showParen (d > app_prec) $ showString "FP " . + showsPrec (app_prec + 1) fn . showString " " . + showsPrec (app_prec + 1) fp + showsPrec d (Split l) = showParen (d > app_prec) $ showString "Split " . + showsPrec (app_prec + 1) l + showsPrec _ Identity = showString "Identity" + showsPrec d (ChangePref p f t) = showParen (d > app_prec) $ showString "ChangePref " . + showsPrec (app_prec + 1) p . showString " " . + showsPrec (app_prec + 1) f . showString " " . + showsPrec (app_prec + 1) t + +instance Show2 Prim where + showsPrec2 = showsPrec + +instance Show (FilePatchType C(x y)) where + showsPrec _ RmFile = showString "RmFile" + showsPrec _ AddFile = showString "AddFile" + showsPrec d (Hunk line old new) | all ((==1) . B.length) old && all ((==1) . B.length) new + = showParen (d > app_prec) $ showString "Hunk " . + showsPrec (app_prec + 1) line . showString " " . + showsPrecC old . showString " " . + showsPrecC new + where showsPrecC [] = showString "[]" + showsPrecC ss = showParen True $ showString "packStringLetters " . showsPrec (app_prec + 1) (map B.head ss) + showsPrec d (Hunk line old new) = showParen (d > app_prec) $ showString "Hunk " . + showsPrec (app_prec + 1) line . showString " " . + showsPrec (app_prec + 1) old . showString " " . + showsPrec (app_prec + 1) new + showsPrec d (TokReplace t old new) = showParen (d > app_prec) $ showString "TokReplace " . + showsPrec (app_prec + 1) t . showString " " . + showsPrec (app_prec + 1) old . showString " " . + showsPrec (app_prec + 1) new + -- this case may not work usefully + showsPrec d (Binary old new) = showParen (d > app_prec) $ showString "Binary " . + showsPrec (app_prec + 1) old . showString " " . + showsPrec (app_prec + 1) new + +instance Show (DirPatchType C(x y)) where + showsPrec _ RmDir = showString "RmDir" + showsPrec _ AddDir = showString "AddDir" + +{- +instance Show (Prim C(x y)) where + show p = renderString (showPrim p) ++ "\n" +-} + +data FileNameFormat = OldFormat | NewFormat +formatFileName :: FileNameFormat -> FileName -> Doc +formatFileName OldFormat = packedString . fn2ps +formatFileName NewFormat = text . encode_white . fn2fp + +showPrim :: FileNameFormat -> Prim C(a b) -> Doc +showPrim x (FP f AddFile) = showAddFile x f +showPrim x (FP f RmFile) = showRmFile x f +showPrim x (FP f (Hunk line old new)) = showHunk x f line old new +showPrim x (FP f (TokReplace t old new)) = showTok x f t old new +showPrim x (FP f (Binary old new)) = showBinary x f old new +showPrim x (DP d AddDir) = showAddDir x d +showPrim x (DP d RmDir) = showRmDir x d +showPrim x (Move f f') = showMove x f f' +showPrim _ (ChangePref p f t) = showChangePref p f t +showPrim x (Split ps) = showSplit x ps +showPrim _ Identity = blueText "{}" + +\end{code} + + +\paragraph{Add file} +Add an empty file to the tree. + +\verb!addfile filename! +\begin{code} +showAddFile :: FileNameFormat -> FileName -> Doc +showAddFile x f = blueText "addfile" <+> formatFileName x f +\end{code} + +\paragraph{Remove file} +Delete a file from the tree. + +\verb!rmfile filename! +\begin{code} +showRmFile :: FileNameFormat -> FileName -> Doc +showRmFile x f = blueText "rmfile" <+> formatFileName x f +\end{code} + +\paragraph{Move} +Rename a file or directory. + +\verb!move oldname newname! +\begin{code} +showMove :: FileNameFormat -> FileName -> FileName -> Doc +showMove x d d' = blueText "move" <+> formatFileName x d <+> formatFileName x d' +\end{code} + +\paragraph{Change Pref} +Change one of the preference settings. Darcs stores a number of simple +string settings. Among these are the name of the test script and the name +of the script that must be called prior to packing in a make dist. +\begin{verbatim} +changepref prefname +oldval +newval +\end{verbatim} +\begin{code} +showChangePref :: String -> String -> String -> Doc +showChangePref p f t = blueText "changepref" <+> text p + $$ userchunk f + $$ userchunk t +\end{code} + +\paragraph{Add dir} +Add an empty directory to the tree. + +\verb!adddir filename! +\begin{code} +showAddDir :: FileNameFormat -> FileName -> Doc +showAddDir x d = blueText "adddir" <+> formatFileName x d +\end{code} + +\paragraph{Remove dir} +Delete a directory from the tree. + +\verb!rmdir filename! +\begin{code} +showRmDir :: FileNameFormat -> FileName -> Doc +showRmDir x d = blueText "rmdir" <+> formatFileName x d +\end{code} + + +\paragraph{Hunk} +Replace a hunk (set of contiguous lines) of text with a new +hunk. +\begin{verbatim} +hunk FILE LINE# +-LINE +... ++LINE +... +\end{verbatim} +\begin{code} +showHunk :: FileNameFormat -> FileName -> Int -> [B.ByteString] -> [B.ByteString] -> Doc +showHunk x f line old new = + blueText "hunk" <+> formatFileName x f <+> text (show line) + $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS old)) + $$ lineColor Cyan (prefix "+" (vcat $ map userchunkPS new)) +\end{code} + +\paragraph{Token replace} + +Replace a token with a new token. Note that this format means that +whitespace must not be allowed within a token. If you know of a practical +application of whitespace within a token, let me know and I may change +this. +\begin{verbatim} +replace FILENAME [REGEX] OLD NEW +\end{verbatim} +\begin{code} +showTok :: FileNameFormat -> FileName -> String -> String -> String -> Doc +showTok x f t o n = blueText "replace" <+> formatFileName x f + <+> text "[" <> userchunk t <> text "]" + <+> userchunk o + <+> userchunk n +\end{code} + +\paragraph{Binary file modification} + +Modify a binary file +\begin{verbatim} +binary FILENAME +oldhex +*HEXHEXHEX +... +newhex +*HEXHEXHEX +... +\end{verbatim} +\begin{code} +showBinary :: FileNameFormat -> FileName -> B.ByteString -> B.ByteString -> Doc +showBinary x f o n = + blueText "binary" <+> formatFileName x f + $$ invisibleText "oldhex" + $$ (vcat $ map makeprintable $ break_every 78 $ fromPS2Hex o) + $$ invisibleText "newhex" + $$ (vcat $ map makeprintable $ break_every 78 $ fromPS2Hex n) + where makeprintable ps = invisibleText "*" <> invisiblePS ps + +break_every :: Int -> B.ByteString -> [B.ByteString] +break_every n ps | B.length ps < n = [ps] + | otherwise = B.take n ps : break_every n (B.drop n ps) +\end{code} + +\paragraph{Split patch [OBSOLETE!]} +A split patch is similar to a composite patch but rather than being +composed of several patches grouped together, it is created from one +patch that has been split apart, typically through a merge or +commutation. +\begin{verbatim} +( + (indented two) +) +\end{verbatim} +\begin{code} +showSplit :: FileNameFormat -> FL Prim C(x y) -> Doc +showSplit x ps = blueText "(" + $$ vcat (mapFL (showPrim x) ps) + $$ blueText ")" + +commute_split :: CommuteFunction +commute_split (Split patches :< patch) = + toPerhaps $ cs (patches :< patch) >>= sc + where cs :: ((FL Prim) :< Prim) C(x y) -> Maybe ((Prim :< (FL Prim)) C(x y)) + cs (NilFL :< p1) = return (p1 :< NilFL) + cs (p:>:ps :< p1) = do p1' :< p' <- commutex (p :< p1) + p1'' :< ps' <- cs (ps :< p1') + return (p1'' :< p':>:ps') + sc :: (Prim :< (FL Prim)) C(x y) -> Maybe ((Prim :< Prim) C(x y)) + sc (p1 :< ps) = scFL $ p1 :< (sort_coalesceFL ps) + where scFL :: (Prim :< (FL Prim)) C(x y) + -> Maybe ((Prim :< Prim) C(x y)) + scFL (p1' :< (p :>: NilFL)) = return (p1' :< p) + scFL (p1' :< ps') = return (p1' :< Split ps') +commute_split _ = Unknown + +try_to_shrink :: FL Prim C(x y) -> FL Prim C(x y) +try_to_shrink = mapPrimFL try_harder_to_shrink + +mapPrimFL :: (FORALL(x y) FL Prim C(x y) -> FL Prim C(x y)) + -> FL Prim C(w z) -> FL Prim C(w z) +mapPrimFL f x = +#ifdef GADT_WITNESSES + f x +#else +-- an optimisation; break the list up into independent sublists +-- and apply f to each of them + case mapM toSimple $ mapFL id x of + Just sx -> foldr (+>+) NilFL $ elems $ + mapWithKey (\ k p -> f (fromSimples k (p NilFL))) $ + fromListWith (flip (.)) $ + map (\ (a,b) -> (a,(b:>:))) sx + Nothing -> f x + +data Simple C(x y) = SFP !(FilePatchType C(x y)) | SDP !(DirPatchType C(x y)) + | SCP String String String + deriving ( Show ) + +toSimple :: Prim C(x y) -> Maybe (FileName, Simple C(x y)) +toSimple (FP a b) = Just (a, SFP b) +toSimple (DP a AddDir) = Just (a, SDP AddDir) +toSimple (DP _ RmDir) = Nothing -- ordering is trickier with rmdir present +toSimple (Move _ _) = Nothing +toSimple (Split _) = Nothing +toSimple Identity = Nothing +toSimple (ChangePref a b c) = Just (fp2fn "_darcs/prefs/prefs", SCP a b c) + +fromSimple :: FileName -> Simple C(x y) -> Prim C(x y) +fromSimple a (SFP b) = FP a b +fromSimple a (SDP b) = DP a b +fromSimple _ (SCP a b c) = ChangePref a b c + +fromSimples :: FileName -> FL Simple C(x y) -> FL Prim C(x y) +fromSimples a bs = mapFL_FL (fromSimple a) bs +#endif + +try_harder_to_shrink :: FL Prim C(x y) -> FL Prim C(x y) +try_harder_to_shrink x = try_to_shrink2 $ maybe x id (try_shrinking_inverse x) + +try_to_shrink2 :: FL Prim C(x y) -> FL Prim C(x y) +try_to_shrink2 psold = + let ps = sort_coalesceFL psold + ps_shrunk = shrink_a_bit ps + in + if lengthFL ps_shrunk < lengthFL ps + then try_to_shrink2 ps_shrunk + else ps_shrunk + +try_shrinking_inverse :: FL Prim C(x y) -> Maybe (FL Prim C(x y)) +try_shrinking_inverse (x:>:y:>:z) + | IsEq <- invert x =\/= y = Just z + | otherwise = case try_shrinking_inverse (y:>:z) of + Nothing -> Nothing + Just yz' -> Just $ case try_shrinking_inverse (x:>:yz') of + Nothing -> x:>:yz' + Just xyz' -> xyz' +try_shrinking_inverse _ = Nothing + +shrink_a_bit :: FL Prim C(x y) -> FL Prim C(x y) +shrink_a_bit NilFL = NilFL +shrink_a_bit (p:>:ps) = + case try_one NilRL p ps of + Nothing -> p :>: shrink_a_bit ps + Just ps' -> ps' + +try_one :: RL Prim C(w x) -> Prim C(x y) -> FL Prim C(y z) + -> Maybe (FL Prim C(w z)) +try_one _ _ NilFL = Nothing +try_one sofar p (p1:>:ps) = + case coalesce (p1 :< p) of + Just p' -> Just (reverseRL sofar +>+ p':>:NilFL +>+ ps) + Nothing -> case commutex (p1 :< p) of + Nothing -> Nothing + Just (p' :< p1') -> try_one (p1':<:sofar) p' ps + +-- | 'sort_coalesceFL' @ps@ coalesces as many patches in @ps@ as +-- possible, sorting the results according to the scheme defined +-- in 'comparePrim' +sort_coalesceFL :: FL Prim C(x y) -> FL Prim C(x y) +sort_coalesceFL = mapPrimFL sort_coalesceFL2 + +-- | The heart of "sort_coalesceFL" +sort_coalesceFL2 :: FL Prim C(x y) -> FL Prim C(x y) +sort_coalesceFL2 NilFL = NilFL +sort_coalesceFL2 (x:>:xs) | IsEq <- nullP x = sort_coalesceFL2 xs +sort_coalesceFL2 (x:>:xs) | IsEq <- is_identity x = sort_coalesceFL2 xs +sort_coalesceFL2 (x:>:xs) = either id id $ push_coalesce_patch x $ sort_coalesceFL2 xs + +-- | 'push_coalesce_patch' @new ps@ is almost like @new :>: ps@ except +-- as an alternative to consing, we first try to coalesce @new@ with +-- the head of @ps@. If this fails, we try again, using commutation +-- to push @new@ down the list until we find a place where either +-- (a) @new@ is @LT@ the next member of the list [see 'comparePrim'] +-- (b) commutation fails or +-- (c) coalescing succeeds. +-- The basic principle is to coalesce if we can and cons otherwise. +-- +-- As an additional optimization, push_coalesce_patch outputs a Left +-- value if it wasn't able to shrink the patch sequence at all, and +-- a Right value if it was indeed able to shrink the patch sequence. +-- This avoids the O(N) calls to lengthFL that were in the older +-- code. +-- +-- Also note that push_coalesce_patch is only ever used (and should +-- only ever be used) as an internal function in in +-- sort_coalesceFL2. +push_coalesce_patch :: Prim C(x y) -> FL Prim C(y z) + -> Either (FL Prim C(x z)) (FL Prim C(x z)) +push_coalesce_patch new NilFL = Left (new:>:NilFL) +push_coalesce_patch new ps@(p:>:ps') + = case coalesce (p :< new) of + Just new' | IsEq <- nullP new' -> Right ps' + | otherwise -> Right $ either id id $ push_coalesce_patch new' ps' + Nothing -> if comparePrim new p == LT then Left (new:>:ps) + else case commutex (p :< new) of + Just (new' :< p') -> + case push_coalesce_patch new' ps' of + Right r -> Right $ either id id $ + push_coalesce_patch p' r + Left r -> Left (p' :>: r) + Nothing -> Left (new:>:ps) + +is_in_directory :: FileName -> FileName -> Bool +is_in_directory d f = iid (fn2fp d) (fn2fp f) + where iid (cd:cds) (cf:cfs) + | cd /= cf = False + | otherwise = iid cds cfs + iid [] ('/':_) = True + iid [] [] = True -- Count directory itself as being in directory... + iid _ _ = False + +data Perhaps a = Unknown | Failed | Succeeded a + +instance Monad Perhaps where + (Succeeded x) >>= k = k x + Failed >>= _ = Failed + Unknown >>= _ = Unknown + Failed >> _ = Failed + (Succeeded _) >> k = k + Unknown >> k = k + return = Succeeded + fail _ = Unknown + +instance MonadPlus Perhaps where + mzero = Unknown + Unknown `mplus` ys = ys + Failed `mplus` _ = Failed + (Succeeded x) `mplus` _ = Succeeded x + +toMaybe :: Perhaps a -> Maybe a +toMaybe (Succeeded x) = Just x +toMaybe _ = Nothing + +toPerhaps :: Maybe a -> Perhaps a +toPerhaps (Just x) = Succeeded x +toPerhaps Nothing = Failed + +clever_commute :: CommuteFunction -> CommuteFunction +clever_commute c (p1: Succeeded x + Failed -> Failed + Unknown -> case c (invert p2 :< invert p1) of + Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1') + Failed -> Failed + Unknown -> Unknown +--clever_commute c (p1,p2) = c (p1,p2) `mplus` +-- (case c (invert p2,invert p1) of +-- Succeeded (p1', p2') -> Succeeded (invert p2', invert p1') +-- Failed -> Failed +-- Unknown -> Unknown) + +speedy_commute :: CommuteFunction +speedy_commute (p1 :< p2) -- Deal with common case quickly! + | p1_modifies /= Nothing && p2_modifies /= Nothing && + p1_modifies /= p2_modifies = Succeeded (unsafeCoerce# p2 :< unsafeCoerce# p1) + | otherwise = Unknown + where p1_modifies = is_filepatch p1 + p2_modifies = is_filepatch p2 + +everything_else_commute :: CommuteFunction +everything_else_commute x = eec x + where + eec :: CommuteFunction + eec (ChangePref p f t : z' :/\: y' + Nothing -> error "Commute Prim merge" + commutex x = toMaybe $ msum [speedy_commute x, + everything_else_commute x + ] + -- Recurse on everything, these are potentially spoofed patches + list_touched_files (Move f1 f2) = map fn2fp [f1, f2] + list_touched_files (Split ps) = nubsort $ concat $ mapFL list_touched_files ps + list_touched_files (FP f _) = [fn2fp f] + list_touched_files (DP d _) = [fn2fp d] + list_touched_files (ChangePref _ _ _) = [] + list_touched_files Identity = [] + +is_filepatch :: Prim C(x y) -> Maybe FileName +is_filepatch (FP f _) = Just f +is_filepatch _ = Nothing + +is_superdir :: FileName -> FileName -> Bool +is_superdir d1 d2 = isd (fn2fp d1) (fn2fp d2) + where isd s1 s2 = + length s2 >= length s1 + 1 && take (length s1 + 1) s2 == s1 ++ "/" + +commute_filedir :: CommuteFunction +commute_filedir (FP f1 p1 :< FP f2 p2) = + if f1 /= f2 then Succeeded ( FP f2 (unsafeCoerce# p2) :< FP f1 (unsafeCoerce# p1) ) + else commuteFP f1 (p1 :< p2) +commute_filedir (DP d1 p1 :< DP d2 p2) = + if (not $ is_in_directory d1 d2) && (not $ is_in_directory d2 d1) && + d1 /= d2 + then Succeeded ( DP d2 (unsafeCoerce# p2) :< DP d1 (unsafeCoerce# p1) ) + else Failed +commute_filedir (DP d dp :< FP f fp) = + if not $ is_in_directory d f + then Succeeded (FP f (unsafeCoerce# fp) :< DP d (unsafeCoerce# dp)) + else Failed + +commute_filedir (Move d d' :< FP f2 p2) + | f2 == d' = Failed + | (p2 == AddFile || p2 == RmFile) && d == f2 = Failed + | otherwise = Succeeded (FP (movedirfilename d d' f2) (unsafeCoerce# p2) :< Move d d') +commute_filedir (Move d d' :< DP d2 p2) + | is_superdir d2 d' || is_superdir d2 d = Failed + | (p2 == AddDir || p2 == RmDir) && d == d2 = Failed + | d2 == d' = Failed + | otherwise = Succeeded (DP (movedirfilename d d' d2) (unsafeCoerce# p2) :< Move d d') +commute_filedir (Move d d' :< Move f f') + | f == d' || f' == d = Failed + | f == d || f' == d' = Failed + | d `is_superdir` f && f' `is_superdir` d' = Failed + | otherwise = + Succeeded (Move (movedirfilename d d' f) (movedirfilename d d' f') :< + Move (movedirfilename f' f d) (movedirfilename f' f d')) + +commute_filedir _ = Unknown + +type CommuteFunction = FORALL(x y) (Prim :< Prim) C(x y) -> Perhaps ((Prim :< Prim) C(x y)) +subcommutes :: [(String, CommuteFunction)] +subcommutes = + [("speedy_commute", speedy_commute), + ("commute_filedir", clever_commute commute_filedir), + ("commute_filepatches", clever_commute commute_filepatches), + ("commutex", toPerhaps . commutex) + ] + +elegant_merge :: (Prim :\/: Prim) C(x y) + -> Maybe ((Prim :/\: Prim) C(x y)) +elegant_merge (p1 :\/: p2) = + do p1':>ip2' <- commute (invert p2 :> p1) + -- The following should be a redundant check + p1o:>_ <- commute (p2 :> p1') + IsEq <- return $ p1o =\/= p1 + return (invert ip2' :/\: p1') +\end{code} + +It can sometimes be handy to have a canonical representation of a given +patch. We achieve this by defining a canonical form for each patch type, +and a function ``{\tt canonize}'' which takes a patch and puts it into +canonical form. This routine is used by the diff function to create an +optimal patch (based on an LCS algorithm) from a simple hunk describing the +old and new version of a file. +\begin{code} +canonize :: Prim C(x y) -> FL Prim C(x y) +canonize (Split ps) = sort_coalesceFL ps +canonize p | IsEq <- is_identity p = NilFL +canonize (FP f (Hunk line old new)) = canonizeHunk f line old new +canonize p = p :>: NilFL +\end{code} + +A simpler, faster (and more generally useful) cousin of canonize is the +coalescing function. This takes two sequential patches, and tries to turn +them into one patch. This function is used to deal with ``split'' patches, +which are created when the commutation of a primitive patch can only be +represented by a composite patch. In this case the resulting composite +patch must return to the original primitive patch when the commutation is +reversed, which a split patch accomplishes by trying to coalesce its +contents each time it is commuted. + +\begin{code} +-- | 'coalesce' @p2 :< p1@ tries to combine @p1@ and @p2@ into a single +-- patch without intermediary changes. For example, two hunk patches +-- modifying adjacent lines can be coalesced into a bigger hunk patch. +-- Or a patch which moves file A to file B can be coalesced with a +-- patch that moves file B into file C, yielding a patch that moves +-- file A to file C. +coalesce :: (Prim :< Prim) C(x y) -> Maybe (Prim C(x y)) +coalesce (FP f1 _ :< FP f2 _) | f1 /= f2 = Nothing +coalesce (p2 :< p1) | IsEq <- p2 =\/= invert p1 = Just null_patch +coalesce (FP f1 p1 :< FP _ p2) = coalesceFilePrim f1 (p1 :< p2) -- f1 = f2 +coalesce (Identity :< p) = Just p +coalesce (p :< Identity) = Just p +coalesce (Split NilFL :< p) = Just p +coalesce (p :< Split NilFL) = Just p +coalesce (Move a b :< Move b' a') | a == a' = Just $ Move b' b +coalesce (Move a b :< FP f AddFile) | f == a = Just $ FP b AddFile +coalesce (Move a b :< DP f AddDir) | f == a = Just $ DP b AddDir +coalesce (FP f RmFile :< Move a b) | b == f = Just $ FP a RmFile +coalesce (DP f RmDir :< Move a b) | b == f = Just $ DP a RmDir +coalesce (ChangePref p f1 t1 :< ChangePref p2 f2 t2) | p == p2 && t2 == f1 = Just $ ChangePref p f2 t1 +coalesce _ = Nothing + +join :: (Prim :> Prim) C(x y) -> Maybe (Prim C(x y)) +join (x :> y) = coalesce (y :< x) +\end{code} + +\subsection{File patches} + +A file patch is a patch which only modifies a single +file. There are some rules which can be made about file patches in +general, which makes them a handy class. +For example, commutation of two filepatches is trivial if they modify +different files. If they happen to +modify the same file, we'll have to check whether or not they commutex. +\begin{code} +commute_filepatches :: CommuteFunction +commute_filepatches (FP f1 p1 :< FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :< p2) +commute_filepatches _ = Unknown + +commuteFP :: FileName -> (FilePatchType :< FilePatchType) C(x y) + -> Perhaps ((Prim :< Prim) C(x y)) +commuteFP f (Hunk line1 [] [] :< p2) = + seq f $ Succeeded (FP f (unsafeCoerceP p2) :< FP f (Hunk line1 [] [])) +commuteFP f (p2 :< Hunk line1 [] []) = + seq f $ Succeeded (FP f (Hunk line1 [] []) :< FP f (unsafeCoerceP p2)) +commuteFP f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) = seq f $ + toPerhaps $ commuteHunk f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) +commuteFP f (TokReplace t o n :< Hunk line2 old2 new2) = seq f $ + case try_tok_replace t o n old2 of + Nothing -> Failed + Just old2' -> + case try_tok_replace t o n new2 of + Nothing -> Failed + Just new2' -> Succeeded (FP f (Hunk line2 old2' new2') :< + FP f (TokReplace t o n)) +commuteFP f (TokReplace t o n :< TokReplace t2 o2 n2) + | seq f $ t /= t2 = Failed + | o == o2 = Failed + | n == o2 = Failed + | o == n2 = Failed + | n == n2 = Failed + | otherwise = Succeeded (FP f (TokReplace t2 o2 n2) :< + FP f (TokReplace t o n)) +commuteFP _ _ = Unknown + +coalesceFilePrim :: FileName -> (FilePatchType :< FilePatchType) C(x y) + -> Maybe (Prim C(x y)) +coalesceFilePrim f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) + = coalesceHunk f line1 old1 new1 line2 old2 new2 +-- Token replace patches operating right after (or before) AddFile (RmFile) +-- is an identity patch, as far as coalescing is concerned. +coalesceFilePrim f (TokReplace _ _ _ :< AddFile) = Just $ FP f AddFile +coalesceFilePrim f (RmFile :< TokReplace _ _ _) = Just $ FP f RmFile +coalesceFilePrim f (TokReplace t1 o1 n1 :< TokReplace t2 o2 n2) + | t1 == t2 && n2 == o1 = Just $ FP f $ TokReplace t1 o2 n1 +coalesceFilePrim f (Binary m n :< Binary o m') + | m == m' = Just $ FP f $ Binary o n +coalesceFilePrim _ _ = Nothing +\end{code} + +\subsection{Hunks} + +The hunk is the simplest patch that has a commuting pattern in which the +commuted patches differ from the originals (rather than simple success or +failure). This makes commuting or merging two hunks a tad tedious. +\begin{code} +commuteHunk :: FileName -> (FilePatchType :< FilePatchType) C(x y) + -> Maybe ((Prim :< Prim) C(x y)) +commuteHunk f (Hunk line2 old2 new2 :< Hunk line1 old1 new1) + | seq f $ line1 + lengthnew1 < line2 = + Just (FP f (Hunk line1 old1 new1) :< + FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2)) + | line2 + lengthold2 < line1 = + Just (FP f (Hunk (line1+ lengthnew2 - lengthold2) old1 new1) :< + FP f (Hunk line2 old2 new2)) + | line1 + lengthnew1 == line2 && + lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = + Just (FP f (Hunk line1 old1 new1) :< + FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2)) + | line2 + lengthold2 == line1 && + lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = + Just (FP f (Hunk (line1 + lengthnew2 - lengthold2) old1 new1) :< + FP f (Hunk line2 old2 new2)) + | otherwise = seq f Nothing + where lengthnew1 = length new1 + lengthnew2 = length new2 + lengthold1 = length old1 + lengthold2 = length old2 +commuteHunk _ _ = impossible +\end{code} +Hunks, of course, can be coalesced if they have any overlap. Note that +coalesce code doesn't check if the two patches are conflicting. If you are +coalescing two conflicting hunks, you've already got a bug somewhere. + +\begin{code} +coalesceHunk :: FileName + -> Int -> [B.ByteString] -> [B.ByteString] + -> Int -> [B.ByteString] -> [B.ByteString] + -> Maybe (Prim C(x y)) +coalesceHunk f line1 old1 new1 line2 old2 new2 + | line1 == line2 && lengthold1 < lengthnew2 = + if take lengthold1 new2 /= old1 + then Nothing + else case drop lengthold1 new2 of + extranew -> Just (FP f (Hunk line1 old2 (new1 ++ extranew))) + | line1 == line2 && lengthold1 > lengthnew2 = + if take lengthnew2 old1 /= new2 + then Nothing + else case drop lengthnew2 old1 of + extraold -> Just (FP f (Hunk line1 (old2 ++ extraold) new1)) + | line1 == line2 = if new2 == old1 then Just (FP f (Hunk line1 old2 new1)) + else Nothing + | line1 < line2 && lengthold1 >= line2 - line1 = + case take (line2 - line1) old1 of + extra-> coalesceHunk f line1 old1 new1 line1 (extra ++ old2) (extra ++ new2) + | line1 > line2 && lengthnew2 >= line1 - line2 = + case take (line1 - line2) new2 of + extra-> coalesceHunk f line2 (extra ++ old1) (extra ++ new1) line2 old2 new2 + | otherwise = Nothing + where lengthold1 = length old1 + lengthnew2 = length new2 +\end{code} + +One of the most important pieces of code is the canonization of a hunk, +which is where the ``diff'' algorithm is performed. This algorithm begins +with chopping off the identical beginnings and endings of the old and new +hunks. This isn't strictly necessary, but is a good idea, since this +process is $O(n)$, while the primary diff algorithm is something +considerably more painful than that\ldots\ actually the head would be dealt +with all right, but with more space complexity. I think it's more +efficient to just chop the head and tail off first. + +\begin{code} +canonizeHunk :: FileName -> Int + -> [B.ByteString] -> [B.ByteString] -> FL Prim C(x y) +canonizeHunk f line old new + | null old || null new + = FP f (Hunk line old new) :>: NilFL +canonizeHunk f line old new = make_holey f line $ getChanges old new + +make_holey :: FileName -> Int -> [(Int,[B.ByteString], [B.ByteString])] + -> FL Prim C(x y) +make_holey f line changes = + unsafeMap_l2f (\ (l,o,n) -> FP f (Hunk (l+line) o n)) changes + +try_tok_replace :: String -> String -> String + -> [B.ByteString] -> Maybe [B.ByteString] +try_tok_replace t o n mss = + mapM (fmap B.concat . try_tok_internal t (BC.pack o) (BC.pack n)) mss + + +try_tok_internal :: String -> B.ByteString -> B.ByteString + -> B.ByteString -> Maybe [B.ByteString] +try_tok_internal _ o n s | isNothing (substrPS o s) && + isNothing (substrPS n s) = Just [s] +try_tok_internal t o n s = + case BC.break (regChars t) s of + (before,s') -> + case BC.break (not . regChars t) s' of + (tok,after) -> + case try_tok_internal t o n after of + Nothing -> Nothing + Just rest -> + if tok == o + then Just $ before : n : rest + else if tok == n + then Nothing + else Just $ before : tok : rest + +modernizePrim :: Prim C(x y) -> FL Prim C(x y) +modernizePrim (Split ps) = concatFL $ mapFL_FL modernizePrim ps +modernizePrim p = p :>: NilFL + +instance MyEq Prim where + unsafeCompare (Move a b) (Move c d) = a == c && b == d + unsafeCompare (DP d1 p1) (DP d2 p2) + = d1 == d2 && p1 `unsafeCompare` p2 + unsafeCompare (FP f1 fp1) (FP f2 fp2) + = f1 == f2 && fp1 `unsafeCompare` fp2 + unsafeCompare (Split ps1) (Split ps2) + = eq_FL unsafeCompare ps1 ps2 + unsafeCompare (ChangePref a1 b1 c1) (ChangePref a2 b2 c2) + = c1 == c2 && b1 == b2 && a1 == a2 + unsafeCompare Identity Identity = True + unsafeCompare _ _ = False + +merge_orders :: Ordering -> Ordering -> Ordering +merge_orders EQ x = x +merge_orders LT _ = LT +merge_orders GT _ = GT + +-- | 'comparePrim' @p1 p2@ is used to provide an arbitrary ordering between +-- @p1@ and @p2@. Basically, identical patches are equal and +-- @Move < DP < FP < Split < Identity < ChangePref@. +-- Everything else is compared in dictionary order of its arguments. +comparePrim :: Prim C(x y) -> Prim C(w z) -> Ordering +comparePrim (Move a b) (Move c d) = compare (a, b) (c, d) +comparePrim (Move _ _) _ = LT +comparePrim _ (Move _ _) = GT +comparePrim (DP d1 p1) (DP d2 p2) = compare (d1, p1) $ unsafeCoerceP (d2, p2) +comparePrim (DP _ _) _ = LT +comparePrim _ (DP _ _) = GT +comparePrim (FP f1 fp1) (FP f2 fp2) = compare (f1, fp1) $ unsafeCoerceP (f2, fp2) +comparePrim (FP _ _) _ = LT +comparePrim _ (FP _ _) = GT +comparePrim (Split ps1) (Split ps2) = compare_FL comparePrim ps1 $ unsafeCoerceP ps2 +comparePrim (Split _) _ = LT +comparePrim _ (Split _) = GT +comparePrim Identity Identity = EQ +comparePrim Identity _ = LT +comparePrim _ Identity = GT +comparePrim (ChangePref a1 b1 c1) (ChangePref a2 b2 c2) + = compare (c1, b1, a1) (c2, b2, a2) + +eq_FL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Bool) + -> FL a C(x y) -> FL a C(w z) -> Bool +eq_FL _ NilFL NilFL = True +eq_FL f (x:>:xs) (y:>:ys) = f x y && eq_FL f xs ys +eq_FL _ _ _ = False + +compare_FL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Ordering) + -> FL a C(x y) -> FL a C(w z) -> Ordering +compare_FL _ NilFL NilFL = EQ +compare_FL _ NilFL _ = LT +compare_FL _ _ NilFL = GT +compare_FL f (x:>:xs) (y:>:ys) = f x y `merge_orders` compare_FL f xs ys + + +class FromPrim p where + fromPrim :: Prim C(x y) -> p C(x y) + +class FromPrim p => ToFromPrim p where + toPrim :: p C(x y) -> Maybe (Prim C(x y)) + +class FromPrims p where + fromPrims :: FL Prim C(x y) -> p C(x y) + joinPatches :: FL p C(x y) -> p C(x y) + +instance FromPrim Prim where + fromPrim = id +instance ToFromPrim Prim where + toPrim = Just . id + +instance FromPrim p => FromPrims (FL p) where + fromPrims = mapFL_FL fromPrim + joinPatches = concatFL +instance FromPrim p => FromPrims (RL p) where + fromPrims = reverseFL . mapFL_FL fromPrim + joinPatches = concatRL . reverseFL + +class (Invert p, Commute p, Effect p) => Conflict p where + list_conflicted_files :: p C(x y) -> [FilePath] + list_conflicted_files p = + nubsort $ concatMap (unseal list_touched_files) $ concat $ resolve_conflicts p + resolve_conflicts :: p C(x y) -> [[Sealed (FL Prim C(y))]] + resolve_conflicts _ = [] + -- | If 'commute_no_conflicts' @x :> y@ succeeds, we know that that @x@ commutes + -- past @y@ without any conflicts. This function is useful for patch types + -- for which 'commute' is defined to always succeed; so we need some way to + -- pick out the specific cases where commutation succeeds without any conflicts. + -- + -- Consider the commute square with patch names written in capital letters and + -- repository states written in small letters. + -- + -- @ + -- X + -- o-->--a + -- | | + -- Y' v v Y + -- | | + -- z-->--b + -- X' + -- @ + -- + -- The default definition of this function checks that we can mirror the + -- commutation with patch inverses (written with the negative sign) + -- + -- @ + -- -X X + -- a-->--o-->--a + -- | | | + -- Y'' v Y' v v Y + -- | | | + -- b-->--z-->--b + -- (-X)' X' + -- @ + -- + -- + -- We check that commuting @X@ and @Y@ succeeds, as does commuting @-X@ and @Y'@. + -- It also checks that @Y'' == Y@ and that @-(X')@ is the same as @(-X)'@ + commute_no_conflicts :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y)) + commute_no_conflicts (x:>y) = + do y':>x' <- commute (x:>y) + y'':>ix'' <- commute (invert x :> y') + IsEq <- return $ y'' =\/= y + IsEq <- return $ ix'' =\/= invert x' + return (y':>x') + conflictedEffect :: p C(x y) -> [IsConflictedPrim] + conflictedEffect x = case list_conflicted_files x of + [] -> mapFL (IsC Okay) $ effect x + _ -> mapFL (IsC Conflicted) $ effect x + +instance Conflict p => Conflict (FL p) where + list_conflicted_files = nubsort . concat . mapFL list_conflicted_files + resolve_conflicts NilFL = [] + resolve_conflicts x = resolve_conflicts $ reverseFL x + commute_no_conflicts (NilFL :> x) = Just (x :> NilFL) + commute_no_conflicts (x :> NilFL) = Just (NilFL :> x) + commute_no_conflicts (xs :> ys) = do ys' :> rxs' <- commute_no_conflictsRLFL (reverseFL xs :> ys) + return $ ys' :> reverseRL rxs' + conflictedEffect = concat . mapFL conflictedEffect + +instance Conflict p => Conflict (RL p) where + list_conflicted_files = nubsort . concat . mapRL list_conflicted_files + resolve_conflicts x = rcs x NilFL + where rcs :: RL p C(x y) -> FL p C(y w) -> [[Sealed (FL Prim C(w))]] + rcs NilRL _ = [] + rcs (p:<:ps) passedby | (_:_) <- resolve_conflicts p = + case commute_no_conflictsFL (p:>passedby) of + Just (_:> p') -> resolve_conflicts p' ++ rcs ps (p:>:passedby) + Nothing -> rcs ps (p:>:passedby) + rcs (p:<:ps) passedby = seq passedby $ rcs ps (p:>:passedby) + commute_no_conflicts (NilRL :> x) = Just (x :> NilRL) + commute_no_conflicts (x :> NilRL) = Just (NilRL :> x) + commute_no_conflicts (xs :> ys) = do ys' :> rxs' <- commute_no_conflictsRLFL (xs :> reverseRL ys) + return $ reverseFL ys' :> rxs' + conflictedEffect = concat . reverse . mapRL conflictedEffect + +data IsConflictedPrim where + IsC :: !ConflictState -> !(Prim C(x y)) -> IsConflictedPrim +data ConflictState = Okay | Conflicted | Duplicated deriving ( Eq, Ord, Show, Read) + +-- | Patches whose concrete effect which can be expressed as a list of +-- primitive patches. +-- +-- A minimal definition would be either of @effect@ or @effectRL@. +class Effect p where + effect :: p C(x y) -> FL Prim C(x y) + effect = reverseRL . effectRL + effectRL :: p C(x y) -> RL Prim C(x y) + effectRL = reverseFL . effect + isHunk :: p C(x y) -> Maybe (Prim C(x y)) + isHunk _ = Nothing + +instance Effect Prim where + effect p | IsEq <- sloppyIdentity p = NilFL + | otherwise = p :>: NilFL + effectRL p | IsEq <- sloppyIdentity p = NilRL + | otherwise = p :<: NilRL + isHunk p = if is_hunk p then Just p else Nothing + +instance Conflict Prim + +instance Effect p => Effect (FL p) where + effect p = concatFL $ mapFL_FL effect p + effectRL p = concatRL $ mapRL_RL effectRL $ reverseFL p + +instance Effect p => Effect (RL p) where + effect p = concatFL $ mapFL_FL effect $ reverseRL p + effectRL p = concatRL $ mapRL_RL effectRL p + +commute_no_conflictsFL :: Conflict p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y)) +commute_no_conflictsFL (p :> NilFL) = Just (NilFL :> p) +commute_no_conflictsFL (q :> p :>: ps) = do p' :> q' <- commute_no_conflicts (q :> p) + ps' :> q'' <- commute_no_conflictsFL (q' :> ps) + return (p' :>: ps' :> q'') + +commute_no_conflictsRL :: Conflict p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y)) +commute_no_conflictsRL (NilRL :> p) = Just (p :> NilRL) +commute_no_conflictsRL (p :<: ps :> q) = do q' :> p' <- commute_no_conflicts (p :> q) + q'' :> ps' <- commute_no_conflictsRL (ps :> q') + return (q'' :> p' :<: ps') + +commute_no_conflictsRLFL :: Conflict p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y)) +commute_no_conflictsRLFL (NilRL :> ys) = Just (ys :> NilRL) +commute_no_conflictsRLFL (xs :> NilFL) = Just (NilFL :> xs) +commute_no_conflictsRLFL (xs :> y :>: ys) = do y' :> xs' <- commute_no_conflictsRL (xs :> y) + ys' :> xs'' <- commute_no_conflictsRLFL (xs' :> ys) + return (y' :>: ys' :> xs'') + +\end{code} diff --git a/src/Darcs/Patch/Properties.lhs b/src/Darcs/Patch/Properties.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Properties.lhs @@ -0,0 +1,357 @@ +% Copyright (C) 2007 David Roundy +% +% 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. + +\documentclass{article} +%\usepackage{color} + +\usepackage{verbatim} +\usepackage{html} +\usepackage{fancyvrb} +\newenvironment{code}{\comment}{\endcomment} +% \newenvironment{code}{\color{blue}\verbatim}{\endverbatim} + +\newcommand{\commutes}{\longleftrightarrow} + +\begin{document} + +\begin{code} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp -fno-warn-deprecations -fno-warn-orphans -fglasgow-exts #-} + +#include "gadts.h" + +module Darcs.Patch.Properties ( recommute, commute_inverses, permutivity, partial_permutivity, + identity_commutes, inverse_doesnt_commute, + patch_and_inverse_commute, merge_either_way, + show_read, + merge_commute, merge_consistent, merge_arguments_consistent, + join_inverses, join_commute ) where + +import Control.Monad ( msum, mplus ) +import Darcs.Show ( Show2(..) ) +import Darcs.Patch.Patchy +import Darcs.Patch.Prim +import Darcs.Patch () +import Darcs.Patch.Read ( readPatch ) +import Darcs.Ordered +import Darcs.Sealed ( Sealed(Sealed) ) +import Printer ( Doc, renderPS, redText, greenText, ($$) ) +--import Darcs.ColorPrinter ( traceDoc ) +\end{code} + +\section{Patch properties} + +Darcs is built on a hierarchy of patch types. At the lowest level are +``primitive'' patches, and from these building blocks, a whole hierarchy of +patch types are built. Each of these patch types must support a number of +functions, which must obey a number of laws. + +\subsection{Properties of identity} + +\newtheorem{prp}{Property} + +\begin{prp}[Identity commutes trivially] + The identity patch must commute with any patch without modifying said patch. +\end{prp} + +\begin{code} +identity_commutes :: forall p C(x y). Patchy p => p C(x y) -> Maybe Doc +identity_commutes p = case commute (p :> identity) of + Nothing -> Just $ redText "identity_commutes failed:" $$ showPatch p + Just (i :> p') | IsEq <- i =\/= identity, + IsEq <- p' =\/= p -> + checkRightIdentity $ commute $ identity :> p + Just _ -> Just $ greenText "identity_commutes" + where checkRightIdentity :: Maybe ((p :> p) C(x y)) -> Maybe Doc + checkRightIdentity Nothing = Just $ redText "identity_commutes failed 2:" $$ showPatch p + checkRightIdentity (Just (p2 :> i2)) | IsEq <- i2 =\/= identity, + IsEq <- p2 =\/= p = Nothing + checkRightIdentity (Just _) = Just $ greenText "identity_commutes 2" +\end{code} + +\begin{prp}[Inverse doesn't commute] + A patch and its inverse will always commute, unless that patch is an + identity patch (or an identity-like patch that has no effect). +\end{prp} + +\begin{code} +inverse_doesnt_commute :: Patchy p => p C(a b) -> Maybe Doc +inverse_doesnt_commute p | IsEq <- sloppyIdentity p = Nothing + | otherwise = do p' :> _ <- commute (invert p :> p) + Just $ redText "inverse_doesnt_commute" $$ showPatch p' +\end{code} + +\subsection{Commute properties} + +\begin{prp}[Recommute] + $AB \commutes B'A'$ if and only if $B'A' \commutes AB$ +\end{prp} + +\begin{code} +recommute :: Patchy p => (FORALL(x y) ((p :> p) C(x y) -> Maybe ((p :> p) C(x y)))) + -> (p :> p) C(a b) -> Maybe Doc +recommute c (x :> y) = + case c (x :> y) of + Nothing -> Nothing + Just (y' :> x') -> + case c (y' :> x') of + Nothing -> Just (redText "failed" $$ showPatch y' $$ redText ":>" $$ showPatch x') + Just (x'' :> y'') -> + case y'' =/\= y of + NotEq -> Just (redText "y'' =/\\= y failed, where x" $$ showPatch x $$ + redText ":> y" $$ showPatch y $$ + redText "y'" $$ showPatch y' $$ + redText ":> x'" $$ showPatch x' $$ + redText "x''" $$ showPatch x'' $$ + redText ":> y''" $$ showPatch y'') + IsEq -> case x'' =/\= x of + NotEq -> Just (redText "x'' /= x" $$ showPatch x'' $$ redText ":>" $$ showPatch y'') + IsEq -> Nothing +\end{code} + +\begin{prp}[Commute inverses] + $AB \commutes B'A'$ if and only if $B^{-1}A^{-1} \commutes A'^{-1}B'^{-1}$ +\end{prp} + +\begin{code} +commute_inverses :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y))) + -> (p :> p) C(a b) -> Maybe Doc +commute_inverses c (x :> y) = + case c (x :> y) of + Nothing -> Nothing + Just (y' :> x') -> + case c (invert y :> invert x) of + Nothing -> Just $ redText "second commute failed" $$ + redText "x" $$ showPatch x $$ redText "y" $$ showPatch y $$ + redText "y'" $$ showPatch y' $$ redText "x'" $$ showPatch x' + Just (ix' :> iy') -> + case invert ix' =/\= x' of + NotEq -> Just $ redText "invert ix' /= x'" $$ + redText "x" $$ showPatch x $$ + redText "y" $$ showPatch y $$ + redText "y'" $$ showPatch y' $$ + redText "x'" $$ showPatch x' $$ + redText "ix'" $$ showPatch ix' $$ + redText "iy'" $$ showPatch iy' $$ + redText "invert ix'" $$ showPatch (invert ix') $$ + redText "invert iy'" $$ showPatch (invert iy') + IsEq -> case y' =\/= invert iy' of + NotEq -> Just $ redText "y' /= invert iy'" $$ showPatch iy' $$ showPatch y' + IsEq -> Nothing +\end{code} + +\begin{prp}[Patch and inverse] + If $AB \commutes B'A'$ then $A^{-1}B' \commutes BA'^{-1}$ +\end{prp} + +This property is only true of primitive patches. + +\begin{code} +patch_and_inverse_commute :: Patchy p => + (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y))) + -> (p :> p) C(a b) -> Maybe Doc +patch_and_inverse_commute c (x :> y) = + do y' :> x' <- c (x :> y) + case c (invert x :> y') of + Nothing -> Just (redText "failure in patch_and_inverse_commute") + Just (y'' :> ix') -> + case y'' =\/= y of + NotEq -> Just (redText "y'' /= y" $$ + redText "x" $$ showPatch x $$ + redText "y" $$ showPatch y $$ + redText "x'" $$ showPatch x' $$ + redText "y'" $$ showPatch y' $$ + redText "y''" $$ showPatch y'' $$ + redText ":> x'" $$ showPatch x') + IsEq -> case x' =\/= invert ix' of + NotEq -> Just (redText "x' /= invert ix'" $$ + redText "y''" $$ showPatch y'' $$ + redText ":> x'" $$ showPatch x' $$ + redText "invert x" $$ showPatch (invert x) $$ + redText ":> y" $$ showPatch y $$ + redText "y'" $$ showPatch y' $$ + redText "ix'" $$ showPatch ix') + IsEq -> Nothing +\end{code} + +\begin{prp}[Permutivity] + (to be added...) +\end{prp} + +\begin{code} +permutivity :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y))) + -> (p :> p :> p) C(a b) -> Maybe Doc +permutivity c (x:>y:>z) = + do y1 :> x1 <- c (x :> y) + z2 :> y2 <- --traceDoc (greenText "first commuted") $ + c (y :> z) + z3 :> x3 <- --traceDoc (greenText "second commuted") $ + c (x :> z2) + case c (x1 :> z) of + Nothing -> Just $ redText "permutivity1" + Just (z4 :> x4) -> + --traceDoc (greenText "third commuted" $$ + -- greenText "about to commute" $$ + -- greenText "y1" $$ showPatch y1 $$ + -- greenText "z4" $$ showPatch z4) $ + case c (y1 :> z4) of + Nothing -> Just $ redText "permutivity2" + Just (z3_ :> y4) + | IsEq <- z3_ =\/= z3 -> + --traceDoc (greenText "passed z3") $ error "foobar test" $ + case c (y4 :> x4) of + Nothing -> Just $ redText "permutivity5: input was" $$ + redText "x" $$ showPatch x $$ + redText "y" $$ showPatch y $$ + redText "z" $$ showPatch z $$ + redText "z3" $$ showPatch z3 $$ + redText "failed commute of" $$ + redText "y4" $$ showPatch y4 $$ + redText "x4" $$ showPatch x4 $$ + redText "whereas commute of x and y give" $$ + redText "y1" $$ showPatch y1 $$ + redText "x1" $$ showPatch x1 + Just (x3_ :> y2_) + | NotEq <- x3_ =\/= x3 -> Just $ redText "permutivity6" + | NotEq <- y2_ =/\= y2 -> Just $ redText "permutivity7" + | otherwise -> Nothing + | otherwise -> + Just $ redText "permutivity failed" $$ + redText "z3" $$ showPatch z3 $$ + redText "z3_" $$ showPatch z3_ + +partial_permutivity :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y))) + -> (p :> p :> p) C(a b) -> Maybe Doc +partial_permutivity c (xx:>yy:>zz) = pp (xx:>yy:>zz) `mplus` pp (invert zz:>invert yy:>invert xx) + where pp (x:>y:>z) = do z1 :> y1 <- c (y :> z) + _ :> x1 <- c (x :> z1) + case c (x :> y) of + Just _ -> Nothing -- this is covered by full permutivity test above + Nothing -> + case c (x1 :> y1) of + Nothing -> Nothing + Just _ -> Just $ greenText "partial_permutivity error" $$ + greenText "x" $$ showPatch x $$ + greenText "y" $$ showPatch y $$ + greenText "z" $$ showPatch z + +merge_arguments_consistent :: Patchy p => + (FORALL(x y) p C(x y) -> Maybe Doc) + -> (p :\/: p) C(a b) -> Maybe Doc +merge_arguments_consistent is_consistent (x :\/: y) = + msum [(\z -> redText "merge_arguments_consistent x" $$ showPatch x $$ z) `fmap` is_consistent x, + (\z -> redText "merge_arguments_consistent y" $$ showPatch y $$ z) `fmap` is_consistent y] + +merge_consistent :: Patchy p => + (FORALL(x y) p C(x y) -> Maybe Doc) + -> (p :\/: p) C(a b) -> Maybe Doc +merge_consistent is_consistent (x :\/: y) = + case merge (x :\/: y) of + y' :/\: x' -> + msum [(\z -> redText "merge_consistent x" $$ showPatch x $$ z) `fmap` is_consistent x, + (\z -> redText "merge_consistent y" $$ showPatch y $$ z) `fmap` is_consistent y, + (\z -> redText "merge_consistent x'" $$ showPatch x' $$ z $$ + redText "where x' comes from x" $$ showPatch x $$ + redText "and y" $$ showPatch y) `fmap` is_consistent x', + (\z -> redText "merge_consistent y'" $$ showPatch y' $$ z) `fmap` is_consistent y'] + +merge_either_way :: Patchy p => (p :\/: p) C(x y) -> Maybe Doc +merge_either_way (x :\/: y) = + case merge (x :\/: y) of + y' :/\: x' -> case merge (y :\/: x) of + x'' :/\: y'' | IsEq <- x'' =\/= x', + IsEq <- y'' =\/= y' -> Nothing + | otherwise -> Just $ redText "merge_either_way bug" + +merge_commute :: Patchy p => (p :\/: p) C(x y) -> Maybe Doc +merge_commute (x :\/: y) = + case merge (x :\/: y) of + y' :/\: x' -> + case commute (x :> y') of + Nothing -> Just $ redText "merge_commute 1" $$ + redText "x" $$ showPatch x $$ + redText "y" $$ showPatch y $$ + redText "x'" $$ showPatch x' $$ + redText "y'" $$ showPatch y' + Just (y_ :> x'_) + | IsEq <- y_ =\/= y, + IsEq <- x'_ =\/= x' -> + case commute (y :> x') of + Nothing -> Just $ redText "merge_commute 2 failed" $$ + redText "x" $$ showPatch x $$ + redText "y" $$ showPatch y $$ + redText "x'" $$ showPatch x' $$ + redText "y'" $$ showPatch y' + Just (x_ :> y'_) + | IsEq <- x_ =\/= x, + IsEq <- y'_ =\/= y' -> Nothing + | otherwise -> Just $ redText "merge_commute 3" $$ + redText "x" $$ showPatch x $$ + redText "y" $$ showPatch y $$ + redText "x'" $$ showPatch x' $$ + redText "y'" $$ showPatch y' $$ + redText "x_" $$ showPatch x_ $$ + redText "y'_" $$ showPatch y'_ + | otherwise -> Just $ redText "merge_commute 4" $$ + redText "x" $$ showPatch x $$ + redText "y" $$ showPatch y $$ + redText "x'" $$ showPatch x' $$ + redText "y'" $$ showPatch y' $$ + redText "x'_" $$ showPatch x'_ $$ + redText "y_" $$ showPatch y_ + +join_inverses :: (FORALL(x y) (Prim :> Prim) C(x y) -> Maybe (Prim C(x y))) + -> Prim C(a b) -> Maybe Doc +join_inverses j p = case j (invert p :> p) of + Just Identity -> Nothing + Just p' -> Just $ redText "join_inverses gave just" $$ showPatch p' + Nothing -> Just $ redText "join_inverses failed" + +join_commute :: (FORALL(x y) (Prim :> Prim) C(x y) -> Maybe (Prim C(x y))) + -> (Prim :> Prim :> Prim) C(a b) -> Maybe Doc +join_commute j (a :> b :> c) = + do x <- j (b :> c) + case commuteFL (a :> b :>: c :>: NilFL) of + Right (b' :>: c' :>: NilFL :> a') -> + case commute (a :> x) of + Nothing -> Just $ greenText "join_commute 1" + Just (x' :> a'') -> + case a'' =/\= a' of + NotEq -> Just $ greenText "join_commute 3" + IsEq -> case j (b' :> c') of + Nothing -> Just $ greenText "join_commute 4" + Just x'' -> case x' =\/= x'' of + NotEq -> Just $ greenText "join_commute 5" + IsEq -> Nothing + _ -> Nothing + +show_read :: (Show2 p, Patchy p) => p C(a b) -> Maybe Doc +show_read p = let ps = renderPS (showPatch p) + in case readPatch ps of + Nothing -> Just (redText "unable to read " $$ showPatch p) + Just (Sealed p',_) | IsEq <- p' =\/= p -> Nothing + | otherwise -> Just $ redText "trouble reading patch p" $$ + showPatch p $$ + redText "reads as p'" $$ + showPatch p' $$ + redText "aka" $$ + greenText (show2 p) $$ + redText "and" $$ + greenText (show2 p') +\end{code} + +\end{document} diff --git a/src/Darcs/Patch/Read.hs b/src/Darcs/Patch/Read.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Read.hs @@ -0,0 +1,255 @@ +-- Copyright (C) 2002-2003 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} + +module Darcs.Patch.Read ( readPrim, readPatch ) + where + +import Prelude hiding ( pi ) +import Control.Monad ( liftM ) + +#include "gadts.h" + +import ByteStringUtils ( breakFirstPS, fromHex2PS, readIntPS, dropSpace ) +import qualified Data.ByteString.Char8 as BC (head, unpack, dropWhile, break) +import qualified Data.ByteString as B (ByteString, null, init, tail, empty, concat) + +import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, ps2fn, decode_white ) +import Darcs.Patch.Core ( Patch(..), Named(..) ) +import Darcs.Patch.Prim ( Prim(..), FileNameFormat(..), + DirPatchType(..), FilePatchType(..), + hunk, binary ) +#ifndef GADT_WITNESSES +import Darcs.Patch.Commute ( merger ) +import Darcs.Patch.Patchy ( invert ) +#endif +import Darcs.Patch.Info ( PatchInfo, readPatchInfo ) +import Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input, + parse_strictly, peek_input, lex_string, lex_eof, my_lex) +#include "impossible.h" +import Darcs.Patch.Patchy ( ReadPatch, readPatch', bracketedFL ) +import Darcs.Ordered ( FL(..) ) +import Darcs.Sealed ( Sealed(..), seal, mapSeal ) + +readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString) +readPatch ps = case parse_strictly (readPatch' False) ps of + Just (Just p, ps') -> Just (p, ps') + _ -> Nothing + +instance ReadPatch p => ReadPatch (Named p) where + readPatch' want_eof + = do s <- peek_input + case liftM (BC.unpack . fst) $ my_lex s of + Just ('[':_) -> liftM Just $ readNamed want_eof -- ] + _ -> return Nothing + +instance ReadPatch Prim where + readPatch' w = readPrim OldFormat w + +readPrim :: ParserM m => FileNameFormat -> Bool -> m (Maybe (Sealed (Prim C(x )))) +readPrim x _ + = do s <- peek_input + case liftM (BC.unpack . fst) $ my_lex s of + Just "{}" -> do work my_lex + return $ Just $ seal Identity + Just "(" -> liftM Just $ readSplit x -- ) + Just "hunk" -> liftM (Just . seal) $ readHunk x + Just "replace" -> liftM (Just . seal) $ readTok x + Just "binary" -> liftM (Just . seal) $ readBinary x + Just "addfile" -> liftM (Just . seal) $ readAddFile x + Just "adddir" -> liftM (Just . seal) $ readAddDir x + Just "rmfile" -> liftM (Just . seal) $ readRmFile x + Just "rmdir" -> liftM (Just . seal) $ readRmDir x + Just "move" -> liftM (Just . seal) $ readMove x + Just "changepref" -> liftM (Just . seal) $ readChangePref + _ -> return Nothing + +instance ReadPatch Patch where + readPatch' want_eof + = do mps <- bracketedFL (fromIntegral $ fromEnum '{') (fromIntegral $ fromEnum '}') + case mps of + Just (Sealed ps) -> return $ Just $ Sealed $ ComP ps + Nothing -> do s <- peek_input + case liftM (BC.unpack . fst) $ my_lex s of +#ifndef GADT_WITNESSES + Just "merger" -> liftM (Just . seal) $ readMerger True + Just "regrem" -> liftM (Just . seal) $ readMerger False +#endif + _ -> liftM (fmap (mapSeal PP)) $ readPatch' want_eof + +read_patches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x ))) +read_patches x str want_eof + = do mp <- readPrim x False + case mp of + Nothing -> do unit <- lex_string str + case unit of + () -> if want_eof then do unit' <- lex_eof + case unit' of + () -> return $ seal NilFL + else return $ seal NilFL + Just (Sealed p) -> do Sealed ps <- read_patches x str want_eof + return $ seal (p:>:ps) + +readSplit :: ParserM m => FileNameFormat -> m (Sealed (Prim C(x ))) +readSplit x = do + work my_lex + ps <- read_patches x ")" False + return $ Split `mapSeal` ps + +readFileName :: FileNameFormat -> B.ByteString -> FileName +readFileName OldFormat = ps2fn +readFileName NewFormat = fp2fn . decode_white . BC.unpack + +readHunk :: ParserM m => FileNameFormat -> m (Prim C(x y)) +readHunk x = do + work my_lex + fi <- work my_lex + l <- work readIntPS + have_nl <- skip_newline + if have_nl + then do work $ lines_starting_with ' ' -- skipping context + old <- work $ lines_starting_with '-' + new <- work $ lines_starting_with '+' + work $ lines_starting_with ' ' -- skipping context + return $ hunk (fn2fp $ readFileName x fi) l old new + else return $ hunk (fn2fp $ readFileName x fi) l [] [] + +skip_newline :: ParserM m => m Bool +skip_newline = do s <- peek_input + if B.null s + then return False + else if BC.head s /= '\n' + then return False + else alter_input B.tail >> return True + +readTok :: ParserM m => FileNameFormat -> m (Prim C(x y)) +readTok x = do + work my_lex + f <- work my_lex + regstr <- work my_lex + o <- work my_lex + n <- work my_lex + return $ FP (readFileName x f) $ TokReplace (BC.unpack (drop_brackets regstr)) + (BC.unpack o) (BC.unpack n) + where drop_brackets = B.init . B.tail + + +-- * Binary file modification +-- +-- | Modify a binary file +-- +-- > binary FILENAME +-- > oldhex +-- > *HEXHEXHEX +-- > ... +-- > newhex +-- > *HEXHEXHEX +-- > ... +readBinary :: ParserM m => FileNameFormat -> m (Prim C(x y)) +readBinary x = do + work my_lex + fi <- work my_lex + work my_lex + alter_input dropSpace + old <- work $ lines_starting_with '*' + work my_lex + alter_input dropSpace + new <- work $ lines_starting_with '*' + return $ binary (fn2fp $ readFileName x fi) + (fromHex2PS $ B.concat old) + (fromHex2PS $ B.concat new) + +readAddFile :: ParserM m => FileNameFormat -> m (Prim C(x y)) +readAddFile x = do work my_lex + f <- work my_lex + return $ FP (readFileName x f) AddFile + +readRmFile :: ParserM m => FileNameFormat -> m (Prim C(x y)) +readRmFile x = do work my_lex + f <- work my_lex + return $ FP (readFileName x f) RmFile + +readMove :: ParserM m => FileNameFormat -> m (Prim C(x y)) +readMove x = do work my_lex + d <- work my_lex + d' <- work my_lex + return $ Move (readFileName x d) (readFileName x d') + +readChangePref :: ParserM m => m (Prim C(x y)) +readChangePref + = do work my_lex + p <- work my_lex + f <- work (Just . BC.break ((==)'\n') . B.tail . BC.dropWhile (== ' ')) + t <- work (Just . BC.break ((==)'\n') . B.tail) + return $ ChangePref (BC.unpack p) (BC.unpack f) (BC.unpack t) + +readAddDir :: ParserM m => FileNameFormat -> m (Prim C(x y)) +readAddDir x = do work my_lex + f <- work my_lex + return $ DP (readFileName x f) AddDir + +readRmDir :: ParserM m => FileNameFormat -> m (Prim C(x y)) +readRmDir x = do work my_lex + f <- work my_lex + return $ DP (readFileName x f) RmDir + +#ifndef GADT_WITNESSES +readMerger :: ParserM m => Bool -> m (Patch C(x y)) +readMerger b = do work my_lex + g <- work my_lex + lex_string "(" + Just (Sealed p1) <- readPatch' False + Just (Sealed p2) <- readPatch' False + lex_string ")" + let m = merger (BC.unpack g) p1 p2 + return $ if b then m else invert m +#endif + +readNamed :: (ReadPatch p, ParserM m) => Bool -> m (Sealed (Named p C(x ))) +readNamed want_eof + = do mn <- maybe_work readPatchInfo + case mn of + Nothing -> bug "readNamed 1" + Just n -> + do d <- read_depends + Just p <- readPatch' want_eof + return $ (NamedP n d) `mapSeal` p +read_depends :: ParserM m => m [PatchInfo] +read_depends = do s <- peek_input + case my_lex s of + Just (xs, _) | BC.unpack xs == "<" -> + do work my_lex + read_pis + _ -> return [] +read_pis :: ParserM m => m [PatchInfo] +read_pis = do mpi <- maybe_work readPatchInfo + case mpi of + Just pi -> do pis <- read_pis + return (pi:pis) + Nothing -> do alter_input (B.tail . BC.dropWhile (/= '>')) + return [] + +lines_starting_with :: Char -> B.ByteString -> Maybe ([B.ByteString], B.ByteString) +lines_starting_with c thes = + Just (lsw [] thes) + where lsw acc s | B.null s || BC.head s /= c = (reverse acc, s) + lsw acc s = let s' = B.tail s + in case breakFirstPS '\n' s' of + Just (l, r) -> lsw (l:acc) r + Nothing -> (reverse (s':acc), B.empty) diff --git a/src/Darcs/Patch/ReadMonads.hs b/src/Darcs/Patch/ReadMonads.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/ReadMonads.hs @@ -0,0 +1,91 @@ + +module Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input, + parse_strictly, parse_lazily, + peek_input, + lex_char, lex_string, lex_strings, lex_eof, + my_lex) where + +import ByteStringUtils ( dropSpace, breakSpace ) +import qualified Data.ByteString as B (null, empty, ByteString) +import qualified Data.ByteString.Char8 as BC (unpack, pack) + +lex_char :: ParserM m => Char -> m () +lex_char c = lex_string [c] + +lex_string :: ParserM m => String -> m () +lex_string str = work + $ \s -> case my_lex s of + Just (xs, ys) | xs == BC.pack str -> Just ((), ys) + _ -> Nothing + +lex_eof :: ParserM m => m () +lex_eof = work + $ \s -> if B.null (dropSpace s) + then Just ((), B.empty) + else Nothing + +lex_strings :: ParserM m => [String] -> m String +lex_strings str = + work $ \s -> + case my_lex s of + Just (xs, ys) | xs' `elem` str -> Just (xs', ys) + where xs' = BC.unpack xs + _ -> Nothing + +my_lex :: B.ByteString -> Maybe (B.ByteString, B.ByteString) +my_lex s = let s' = dropSpace s + in if B.null s' + then Nothing + else Just $ breakSpace s' + +alter_input :: ParserM m + => (B.ByteString -> B.ByteString) -> m () +alter_input f = work (\s -> Just ((), f s)) + +class Monad m => ParserM m where + work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m a + maybe_work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m (Maybe a) + peek_input :: m B.ByteString + +----- Strict Monad ----- +parse_strictly :: SM a -> B.ByteString -> Maybe (a, B.ByteString) +parse_strictly (SM f) s = f s + +newtype SM a = SM (B.ByteString -> Maybe (a, B.ByteString)) +instance Monad SM where + SM m >>= k = SM $ \s -> case m s of + Nothing -> Nothing + Just (x, s') -> + case k x of + SM y -> y s' + return x = SM (\s -> Just (x,s)) + fail _ = SM (\_ -> Nothing) + +instance ParserM SM where + work f = SM f + maybe_work f = SM $ \s -> case f s of + Just (x, s') -> Just (Just x, s') + Nothing -> Just (Nothing, s) + peek_input = SM $ \s -> Just (s, s) + +----- Lazy Monad ----- +parse_lazily :: LM a -> B.ByteString -> (a, B.ByteString) +parse_lazily (LM f) s = f s + +newtype LM a = LM (B.ByteString -> (a, B.ByteString)) +instance Monad LM where + LM m >>= k = LM $ \s -> let (x, s') = m s + LM y = k x + in y s' + return x = LM (\s -> (x,s)) + fail s = error s + +instance ParserM LM where + work f = LM $ \s -> case f s of + Nothing -> error "parser error" + Just x -> x + maybe_work f = LM $ \s -> case f s of + Nothing -> (Nothing, s) + Just (x, s') -> (Just x, s') + peek_input = LM $ \s -> (s, s) + diff --git a/src/Darcs/Patch/Real.hs b/src/Darcs/Patch/Real.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Real.hs @@ -0,0 +1,777 @@ +-- Copyright (C) 2007 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +-- , TypeOperators, GADTs, PatternGuards #-} + +#include "gadts.h" + +-- | Conflictor patches +module Darcs.Patch.Real + ( RealPatch(..), prim2real, is_consistent, is_forward, is_duplicate, + pullCommon, mergeUnravelled ) where + +import Control.Monad ( mplus, liftM ) +import Data.List ( partition, nub ) +import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Conflict(..), Effect(..), + showPrim, FileNameFormat(NewFormat), + IsConflictedPrim(..), ConflictState(..) ) +import Darcs.Patch.Read ( readPrim ) +import Darcs.Patch.Patchy +import Darcs.Ordered +--import Darcs.Patch.Read () +--import Darcs.Patch.Viewing () +--import Darcs.Patch.Apply () +import Darcs.Patch.Commute ( mangle_unravelled ) +import Darcs.Patch.Non ( Non(..), Nonable(..), unNon, + showNons, showNon, readNons, readNon, + add, addP, addPs, remP, remPs, remNons, + (*>), (>*), (*>>), (>>*) ) +import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL, + genCommuteWhatWeCanRL, + removeRL, removeFL, remove_subsequenceFL ) +import qualified Data.ByteString.Char8 as BC ( unpack ) +import Darcs.Patch.ReadMonads (work, peek_input, my_lex ) +import Darcs.Utils ( nubsort ) +import Darcs.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal ) +import Darcs.Show +import Printer ( Doc, renderString, blueText, redText, (<+>), ($$) ) +import Darcs.ColorPrinter ( errorDoc, assertDoc ) +--import Printer ( greenText ) +--import Darcs.ColorPrinter ( traceDoc ) +#include "impossible.h" + +-- | +-- @Duplicate x@: This patch has no effect since @x@ is already present in the repository +-- +-- @Etacilpud x: invert (Duplicate x)@ +-- +-- @Normal prim@: A primitive patch +-- +-- @Conflictor ix xx x@: +-- @ix@ is the set of patches: +-- +-- * that conflict with @x@ and also conflict with another patch in the repository +-- +-- * that conflict with a patch that conflict with @x@ +-- +-- @xx@ is the sequence of patches that conflict *only* with @x@ +-- +-- @x@ is the current patch +-- +-- @ix@ and @x@ are stored as @Non@ objects, which include any necessary +-- context to uniquely define the patch that is referred to. +-- +-- @InvConflictor ix xx x@: like @invert (Conflictor ix xx x)@ +data RealPatch C(x y) where + Duplicate :: Non RealPatch C(x) -> RealPatch C(x x) + Etacilpud :: Non RealPatch C(x) -> RealPatch C(x x) + Normal :: Prim C(x y) -> RealPatch C(x y) + Conflictor :: [Non RealPatch C(x)] -> FL Prim C(x y) -> Non RealPatch C(x) -> RealPatch C(y x) + InvConflictor :: [Non RealPatch C(x)] -> FL Prim C(x y) -> Non RealPatch C(x) -> RealPatch C(x y) + +-- | 'is_duplicate' @p@ is ' @True@ if @p@ is either a 'Duplicate' or 'Etacilpud' patch +is_duplicate :: RealPatch C(s y) -> Bool +is_duplicate (Duplicate _) = True +is_duplicate (Etacilpud _) = True +is_duplicate _ = False + +-- | This is only used for unit testing +is_forward :: RealPatch C(s y) -> Maybe Doc +is_forward p@(InvConflictor _ _ _) = + Just $ redText "An inverse conflictor" $$ showPatch p +is_forward p@(Etacilpud _) = + Just $ redText "An inverse duplicate" $$ showPatch p +is_forward _ = Nothing + +mergeUnravelled :: [Sealed ((FL Prim) C(x))] -> Maybe (FlippedSeal RealPatch C(x)) +mergeUnravelled [] = Nothing +mergeUnravelled [_] = Nothing +mergeUnravelled ws = case mergeUnravelled_private ws of + Nothing -> Nothing + Just NilRL -> bug "found no patches in mergeUnravelled" + Just (z:<:_) -> Just $ FlippedSeal z + where notNullS :: Sealed ((FL Prim) C(x)) -> Bool + notNullS (Sealed NilFL) = False + notNullS _ = True + mergeUnravelled_private :: [Sealed (FL Prim C(x))] -> Maybe (RL RealPatch C(x x)) + mergeUnravelled_private xs = reverseFL `fmap` mergeConflictingNons + (map sealed2non $ filter notNullS xs) + +-- | 'sealed2non' @(Sealed xs)@ converts @xs@ to a 'Non'. +-- @xs@ must be non-empty since we split this list at the last patch +sealed2non :: Sealed ((FL Prim) C(x)) -> Non RealPatch C(x) +sealed2non (Sealed xs) = case reverseFL xs of + y:<:ys -> Non (mapFL_FL fromPrim $ reverseRL ys) y + NilRL -> bug "NilFL encountered in sealed2non" + +mergeConflictingNons :: [Non RealPatch C(x)] -> Maybe (FL RealPatch C(x x)) +mergeConflictingNons ns = mcn $ map unNon ns + where mcn :: [Sealed (FL RealPatch C(x))] -> Maybe (FL RealPatch C(x x)) + mcn [] = Just NilFL + mcn [Sealed p] = case join_effects p of -- this is just a safety check, and could + NilFL -> Just p -- be removed when we're sure of the code. + _ -> Nothing + mcn (Sealed p1:Sealed p2:zs) = case pullCommon p1 p2 of + Common c ps qs -> + case merge (ps :\/: qs) of + qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs) + +join_effects :: Effect p => p C(x y) -> FL Prim C(x y) +join_effects = join_inverses . effect + where join_inverses :: FL Prim C(x y) -> FL Prim C(x y) + join_inverses NilFL = NilFL + join_inverses (p:>:ps) = case removeFL (invert p) ps' of + Just ps'' -> ps'' + Nothing -> p :>: ps' + where ps' = join_inverses ps + +assertConsistent :: RealPatch C(x y) -> RealPatch C(x y) +assertConsistent x = assertDoc (do e <- is_consistent x + Just (redText "Inconsistent patch:" $$ showPatch x $$ e)) x + +-- | @mergeAfterConflicting@ takes as input a sequence of conflicting +-- patches @xxx@ (which therefore have no effect) and a sequence of +-- primitive patches @yyy@ that follow said sequence of conflicting +-- patches, and may depend upon some of the conflicting patches (as a +-- resolution). + +-- The output is two sequences of patches the first consisting of a +-- set of mutually-conflicting patches, and the second having the same +-- effect as the original primitive patch sequence in the input. + +-- So far as I can tell, the second output is always identical to +-- @mapFL Normal yyy@ + +-- The first output is the set of patches from @xxx@ that are depended +-- upon by @yyy@. + +mergeAfterConflicting :: FL RealPatch C(x x) -> FL Prim C(x y) + -> Maybe (FL RealPatch C(x x), FL RealPatch C(x y)) +mergeAfterConflicting xxx yyy = --traceDoc (greenText "mergeAfterConflicting xxx" $$ showPatch xxx $$ + -- greenText "and yyy" $$ showPatch yyy) $ + mac (reverseFL xxx) yyy NilFL + where mac :: RL RealPatch C(x y) -> FL Prim C(y z) -> FL RealPatch C(z a) + -> Maybe (FL RealPatch C(x x), FL RealPatch C(x a)) + mac NilRL xs goneby = case join_effects goneby of + NilFL -> Just (NilFL, mapFL_FL Normal xs) + _z -> --traceDoc (greenText "mac1 z" $$ showPatch _z) $ + Nothing + mac (p:<:ps) xs goneby = --traceDoc (greenText "mac ps" $$ showPatch ps $$ + -- greenText "p" $$ showPatch p $$ + -- greenText "xs" $$ showPatch xs $$ + -- greenText "goneby" $$ showPatch goneby) $ + case commuteFL (p :> mapFL_FL Normal xs) of + Left _ -> case genCommuteWhatWeCanRL commute_no_conflicts (ps :> p) of + a:>p':>b -> + do (b',xs') <- mac b xs goneby + let pa = join_effects $ p':<:a + --traceDoc (greenText "foo1" $$ + -- showPatch pa) $ Just () + NilFL <- return pa + return (reverseRL (p':<:a)+>+b', xs') + `mplus` do NilFL <- return goneby + NilFL <- return $ join_effects (p:<:ps) + return (reverseRL (p:<:ps), + mapFL_FL Normal xs) + Right (l:>p'') -> + case allNormal l of + Just xs'' -> mac ps xs'' (p'':>:goneby) + Nothing -> + case genCommuteWhatWeCanRL commute_no_conflicts (ps :> p) of + a:>p':>b -> + do (b',xs') <- mac b xs goneby + let pa = join_effects $ p':<:a + --traceDoc (greenText "foo2" $$ + -- showPatch pa) $ Just () + NilFL <- return pa + return $ (reverseRL (p':<:a)+>+b', xs') + +geteff :: [Non RealPatch C(x)] -> FL Prim C(x y) -> ([Non RealPatch C(x)], FL RealPatch C(x y)) +geteff _ NilFL = ([],NilFL) +geteff ix (x:>:xs) | Just ix' <- mapM (remP (Normal x)) ix + = --traceDoc (greenText "I got rid of x" $$ showPatch x) $ + case geteff ix' xs of + (ns,xs') -> (non (Normal x) : map (addP (Normal x)) ns, + Normal x :>: xs') +geteff ix xx = case mergeConflictingNons ix of + Nothing -> errorDoc $ redText "mergeConflictingNons failed in geteff with ix" $$ + showNons ix $$ redText "xx" $$ showPatch xx + Just rix -> case mergeAfterConflicting rix xx of + Just (a,x) -> (map (addPs (reverseFL a)) $ toNons x, + a +>+ x) + Nothing -> errorDoc $ redText "mergeAfterConflicting failed in geteff"$$ + redText "where ix" $$ showNons ix $$ + redText "and xx" $$ showPatch xx $$ + redText "and rix" $$ showPatch rix + +xx2nons :: [Non RealPatch C(x)] -> FL Prim C(x y) -> [Non RealPatch C(x)] +xx2nons ix xx = fst $ geteff ix xx + +xx2patches :: [Non RealPatch C(x)] -> FL Prim C(x y) -> FL RealPatch C(x y) +xx2patches ix xx = snd $ geteff ix xx + +-- | If @xs@ consists only of 'Normal' patches, 'allNormal' @xs@ returns +-- @Just pxs@ those patches (so @lengthFL pxs == lengthFL xs@). +-- Otherwise, it returns 'Nothing'. +allNormal :: FL RealPatch C(x y) -> Maybe (FL Prim C(x y)) +allNormal (Normal x:>:xs) = (x :>:) `fmap` allNormal xs +allNormal NilFL = Just NilFL +allNormal _ = Nothing + +-- | This is used for unit-testing and for internal sanity checks +is_consistent :: RealPatch C(x y) -> Maybe Doc +is_consistent (Normal _) = Nothing +is_consistent (Duplicate _) = Nothing +is_consistent (Etacilpud _) = Nothing +is_consistent (Conflictor im mm m@(Non deps _)) + | not $ everyone_conflicts im = Just $ redText "Someone doesn't conflict in im in is_consistent" + | Just _ <- remPs rmm m, _:>:_ <- mm = Just $ redText "m doesn't conflict with mm in is_consistent" + | any (\x -> any (x `conflicts_with`) nmm) im + = Just $ redText "mm conflicts with im in is_consistent where nmm is" $$ + showNons nmm + | Nothing <- (nmm ++ im) `minus` toNons deps = Just $ redText "dependencies not in conflict:" $$ + showNons (toNons deps) $$ + redText "compared with deps itself:" $$ + showPatch deps + | otherwise = case all_conflicts_with m im of + (im1,[]) | im1 `eqSet` im -> Nothing + (_,imnc) -> Just $ redText "m doesn't conflict with im in is_consistent. unconflicting:" + $$ showNons imnc + where (nmm, rmm) = geteff im mm +is_consistent c@(InvConflictor _ _ _) = is_consistent (invert c) + +everyone_conflicts :: [Non RealPatch C(x)] -> Bool +everyone_conflicts [] = True +everyone_conflicts (x:xs) = case all_conflicts_with x xs of + ([],_) -> False + (_,xs') -> everyone_conflicts xs' + +prim2real :: Prim C(x y) -> RealPatch C(x y) +prim2real = Normal + +instance Patchy RealPatch + +instance MyEq p => Eq (Sealed (p C(x))) where + (Sealed x) == (Sealed y) | IsEq <- x =\/= y = True + | otherwise = False + +merge_with :: Non RealPatch C(x) -> [Non RealPatch C(x)] -> Sealed (FL Prim C(x)) +merge_with p [] = effect `mapSeal` unNon p +merge_with p xs = mergeall $ map unNon $ (p:) $ unconflicting_of $ + filter (\x -> not (p `depends_upon` x) && not (p `conflicts_with` x)) xs + where mergeall :: [Sealed (FL RealPatch C(x))] -> Sealed (FL Prim C(x)) + mergeall [Sealed x] = Sealed $ effect x + mergeall [] = Sealed NilFL + mergeall (Sealed x:Sealed y:rest) = case merge (x :\/: y) of + y' :/\: _ -> mergeall (Sealed (x+>+y'):rest) + unconflicting_of [] = [] + unconflicting_of (q:qs) = case all_conflicts_with q qs of + ([],_) -> q:qs + (_,nc) -> unconflicting_of nc + +instance Conflict RealPatch where + conflictedEffect (Duplicate (Non _ x)) = [IsC Duplicated x] + conflictedEffect (Etacilpud _) = impossible + conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x] + conflictedEffect (InvConflictor _ _ _) = impossible + conflictedEffect (Normal x) = [IsC Okay x] + resolve_conflicts (Conflictor ix xx x) = [mangle_unravelled unravelled : unravelled] + where unravelled = nub $ filter isn $ map (`merge_with` (x:ix++nonxx)) (x:ix++nonxx) + nonxx = nonxx_ (nonxx_aux ix xx) + nonxx_aux :: [Non RealPatch C(x)] -> FL Prim C(x y) -> RL RealPatch C(x y) + nonxx_aux a b = reverseFL $ xx2patches a b + nonxx_ :: RL RealPatch C(x y) -> [Non RealPatch C(x)] + nonxx_ NilRL = [] + nonxx_ ((Normal q) :<: qs) = [Non (reverseRL qs) q] + nonxx_ _ = [] + isn :: Sealed (FL p C(x)) -> Bool + isn (Sealed NilFL) = False + isn _ = True + resolve_conflicts _ = [] + + -- cA + commute_no_conflicts (Duplicate x :> Duplicate y) = Just (Duplicate y :> Duplicate x) + commute_no_conflicts (Etacilpud x :> Duplicate y) = Just (Duplicate y :> Etacilpud x) + commute_no_conflicts (Duplicate x :> Etacilpud y) = Just (Etacilpud y :> Duplicate x) + commute_no_conflicts (Etacilpud x :> Etacilpud y) = Just (Etacilpud y :> Etacilpud x) + -- cB + commute_no_conflicts (x :> Duplicate d) = if d == addP (invert x) (non x) + then Just (x :> Duplicate d) + else do d' <- remP (invert x) d + return (Duplicate d' :> x) + commute_no_conflicts (Duplicate d' :> x) = Just (x :> Duplicate (addP (invert x) d')) + commute_no_conflicts c@(Etacilpud _ :> _) = invertCommuteNC c + commute_no_conflicts c@(_ :> Etacilpud _) = invertCommuteNC c + -- cE + commute_no_conflicts (Normal x :> Normal y) = do y' :> x' <- commute (x :> y) + return (Normal y' :> Normal x') + -- cF -- involves a conflict + -- cG + commute_no_conflicts (Normal x :> Conflictor iy yy y) = + case commuteFL (x :> invert yy) of + Right (iyy' :> x') -> do + y':iy' <- mapM (Normal x' >*) (y:iy) + return (Conflictor iy' (invert iyy') y' :> Normal x') + _ -> Nothing + -- cFi+cGi -- handle with previous two pattern matches + commute_no_conflicts c@(InvConflictor _ _ _ :> Normal _) = invertCommuteNC c + -- icG FIXME: where is icF? + commute_no_conflicts (Conflictor iy' yy' y' :> Normal x') = + do x :> iyy <- commuteRL (invertFL yy' :> x') + y:iy <- mapM (*> Normal x') (y':iy') + return (Normal x :> Conflictor iy (invertRL iyy) y) + -- icGi -- handle with previous pattern match + commute_no_conflicts c@(Normal _ :> InvConflictor _ _ _) = invertCommuteNC c + -- cH -- this involves a conflict commute + -- cI + commute_no_conflicts (Conflictor ix xx x :> Conflictor iy yy y) = + do xx' :> yy' <- commute (yy :> xx) + x':ix' <- mapM (yy >>*) (x:ix) + y':iy' <- mapM (*>> xx') (y:iy) + False <- return $ any (conflicts_with y) (x':ix') + False <- return $ any (conflicts_with x') iy + return (Conflictor iy' yy' y' :> Conflictor ix' xx' x') + -- cHi+cIi uses previous two matches + commute_no_conflicts c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommuteNC c + -- cJ + commute_no_conflicts (InvConflictor ix xx x :> Conflictor iy yy y) = + do iyy' :> xx' <- commute (xx :> invert yy) + y':iy' <- mapM (xx' >>*) (y:iy) + x':ix' <- mapM (invertFL iyy' >>*) (x:ix) + False <- return $ any (conflicts_with y') (x':ix') + False <- return $ any (conflicts_with x') iy' + return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x') + -- icJ + commute_no_conflicts (Conflictor iy' yy' y' :> InvConflictor ix' xx' x') = + do xx :> iyy <- commute (invert yy' :> xx') + y:iy <- mapM (*>> xx') (y':iy') + x:ix <- mapM (*>> yy') (x':ix') + False <- return $ any (conflicts_with y') (x':ix') + False <- return $ any (conflicts_with x') iy' + return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y) + +instance FromPrim RealPatch where + fromPrim = prim2real +instance ToFromPrim RealPatch where + toPrim (Normal p) = Just p + toPrim _ = Nothing + +instance MyEq RealPatch where + (Duplicate x) =\/= (Duplicate y) | x == y = IsEq + (Etacilpud x) =\/= (Etacilpud y) | x == y = IsEq + (Normal x) =\/= (Normal y) = x =\/= y + (Conflictor cx xx x) =\/= (Conflictor cy yy y) + | map (add $ invertFL xx) cx `eqSet` + map (add $ invertFL yy) cy && + add (invert xx) x == add (invert yy) y = xx =/\= yy + (InvConflictor cx xx x) =\/= (InvConflictor cy yy y) + | cx `eqSet` cy && x == y = xx =\/= yy + _ =\/= _ = NotEq + +eqSet :: Eq a => [a] -> [a] -> Bool +eqSet [] [] = True +eqSet (x:xs) xys | Just ys <- remove1 x xys = eqSet xs ys +eqSet _ _ = False + +remove1 :: Eq a => a -> [a] -> Maybe [a] +remove1 x (y:ys) | x == y = Just ys + | otherwise = (y :) `fmap` remove1 x ys +remove1 _ [] = Nothing + +minus :: Eq a => [a] -> [a] -> Maybe [a] +minus xs [] = Just xs +minus xs (y:ys) = do xs' <- remove1 y xs + xs' `minus` ys + +invertNon :: Non RealPatch C(x) -> Non RealPatch C(x) +invertNon (Non c x) + | Just rc' <- removeRL nix (reverseFL c) = Non (reverseRL rc') (invert x) + | otherwise = addPs (Normal x :<: reverseFL c) $ non nix + where nix = Normal $ invert x + +nonTouches :: Non RealPatch C(x) -> [FilePath] +nonTouches (Non c x) = list_touched_files (c +>+ fromPrim x :>: NilFL) + +toNons :: (Conflict p, Patchy p, ToFromPrim p, Nonable p) => FL p C(x y) -> [Non p C(x)] +toNons xs = map lastNon $ initsFL xs + where lastNon :: (Conflict p, Patchy p, Nonable p) => Sealed ((p :> FL p) C(x)) -> Non p C(x) + lastNon (Sealed xxx) = case lastNon_aux xxx of + deps :> p :> _ -> case non p of + Non NilFL pp -> Non (reverseRL deps) pp + Non ds pp -> errorDoc $ redText "Weird case in toNons" $$ + redText "please report this bug!" $$ + (case xxx of + z:>zs -> showPatch (z:>:zs)) $$ + redText "ds are" $$ showPatch ds $$ + redText "pp is" $$ showPatch pp + reverseFoo :: (p :> FL p) C(x y) -> (RL p :> p) C(x y) + reverseFoo (p :> ps) = rf NilRL p ps + where rf :: RL p C(a b) -> p C(b c) -> FL p C(c d) -> (RL p :> p) C(a d) + rf rs l NilFL = rs :> l + rf rs x (y:>:ys) = rf (x:<:rs) y ys + lastNon_aux :: Commute p => (p :> FL p) C(x y) -> (RL p :> p :> RL p) C(x y) + lastNon_aux = commuteWhatWeCanRL . reverseFoo + +initsFL :: Patchy p => FL p C(x y) -> [Sealed ((p :> FL p) C(x))] +initsFL NilFL = [] +initsFL (x:>:xs) = Sealed (x:>NilFL) : map (\ (Sealed (y:>xs')) -> Sealed (x:>y:>:xs')) (initsFL xs) + +fromNons :: [Non RealPatch C(x)] -> Maybe (Sealed (FL Prim C(x))) +fromNons [] = Just $ Sealed $ NilFL +fromNons ns = do (Sealed p, ns') <- pullInContext ns + ns'' <- mapM (remP $ fromPrim p) ns' + Sealed ps <- fromNons ns'' + return $ Sealed $ p :>: ps + +pullInContext :: [Non RealPatch C(x)] -> Maybe (Sealed (Prim C(x)), [Non RealPatch C(x)]) +pullInContext (Non NilFL p:ns) = Just (Sealed p, ns) +pullInContext (n:ns) = do (sp,ns') <- pullInContext ns + return (sp, n:ns') +pullInContext [] = Nothing + +filterConflictsFL :: Non RealPatch C(x) -> FL Prim C(x y) -> (FL Prim :> FL Prim) C(x y) +filterConflictsFL _ NilFL = NilFL :> NilFL +filterConflictsFL n (p:>:ps) + | Just n' <- remP (fromPrim p) n = case filterConflictsFL n' ps of + p1 :> p2 -> p:>:p1 :> p2 + | otherwise = case commuteWhatWeCanFL (p :> ps) of + p1 :> p' :> p2 -> case filterConflictsFL n p1 of + p1a :> p1b -> p1a :> p1b +>+ p' :>: p2 + +instance Invert RealPatch where + invert (Duplicate d) = Etacilpud d + invert (Etacilpud d) = Duplicate d + invert (Normal p) = Normal (invert p) + invert (Conflictor x c p) = InvConflictor x c p + invert (InvConflictor x c p) = Conflictor x c p + identity = Normal identity + +instance Commute RealPatch where +-- commute (x :> y) | traceDoc (greenText "commuting x" $$ showPatch x $$ +-- greenText "with y" $$ showPatch y) False = undefined + commute (x :> y) | Just (y' :> x') <- commute_no_conflicts (assertConsistent x :> assertConsistent y) = Just (y' :> x') + -- cF + commute (Normal x :> Conflictor a1'nop2 n1'x p1') -- these patches conflicted + | Just rn1' <- removeRL x (reverseFL n1'x) = + do let p2:n1nons = reverse $ xx2nons a1'nop2 $ reverseRL (x:<:rn1') + a2 = p1':a1'nop2++n1nons + case (a1'nop2, reverseRL rn1', p1') of + ([], NilFL, Non c y) | NilFL <- join_effects c -> + Just (Normal y :> Conflictor a1'nop2 (y:>:NilFL) p2) + (a1,n1,_) -> Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2) + -- cFi -- handle with previous pattern match + commute c@(InvConflictor _ _ _ :> Normal _) = invertCommute c + -- cH + commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2) + | Just a2_minus_p1 <- remove1 p1' a2, + not (p2 `depends_upon` p1') = + do let n1nons = map (add n2) $ xx2nons a1 n1 + n2nons = xx2nons a2 n2 + Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons + n2n1 = n2 +>+ n1 + a1' = map (add n2) a1 + p2ooo = remNons a1' p2 + n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1 + let n1'n2'nons = xx2nons a2_minus_p1n1 (n1'+>+n2') + n1'nons = take (lengthFL n1') n1'n2'nons + n2'nons = drop (lengthFL n1') n1'n2'nons + Just a1'nop2 = (a2++n2nons) `minus` (p1':n1'nons) + Just a2'o = --traceDoc (greenText "\n\nConflictor a1 n1 p1 is" $$ + -- showPatch (assertConsistent $ Conflictor a1 n1 p1) $$ + -- greenText "and Conflictor a2 n2 p2 is" $$ + -- showPatch (assertConsistent $ Conflictor a2 n2 p2) $$ + -- greenText "where n2'nons is" $$ showNons n2'nons $$ + -- greenText "and others are" $$ + -- showNons (fst $ all_conflicts_with p2 $ a2_minus_p1++n2nons) $$ + -- greenText "These came from" $$ + -- showNons (a2_minus_p1++n2nons) $$ + -- greenText "n1'n2'nons" $$ showNons n1'n2'nons $$ + -- greenText "from n1' :> n2'" $$ + -- showPatch n1' $$ greenText ":>" $$ showPatch n2' $$ + -- greenText "p2" $$ showNon p2 $$ + -- greenText "p2 fixed" $$ showNon p2ooo $$ + -- -- greenText "pren1" $$ showPatch pren1 $$ + -- greenText "n1'" $$ showPatch n1' $$ + -- greenText "p2" $$ showNon p2 + -- ) + (fst $ all_conflicts_with p2 $ a2_minus_p1++n2nons) `minus` n2'nons + Just a2' = mapM (remPs (xx2patches a1'nop2 n1')) $ + a2'o + Just p2' = remPs (xx2patches a1'nop2 n1') p2 + case (a2', n2', p2') of + ([], NilFL, Non c x) | NilFL <- join_effects c -> + Just (Normal x :> Conflictor a1'nop2 (n1'+>+x:>:NilFL) p1') + | otherwise -> impossible + _ -> Just (Conflictor a2' n2' p2' :> Conflictor (p2:a1'nop2) n1' p1') + where (_,rpn2) = geteff a2 n2 + p1' = addPs (reverseFL rpn2) p1 + -- cHi -- uses previous match + commute c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommute c + commute _ = Nothing + + merge (InvConflictor _ _ _ :\/: _) = impossible + merge (_ :\/: InvConflictor _ _ _) = impossible + merge (Etacilpud _ :\/: _) = impossible + merge (_ :\/: Etacilpud _) = impossible +-- merge (x :\/: y) | traceDoc (greenText "merging x" $$ showPatch x $$ +-- greenText "with y" $$ showPatch y) False = impossible + -- mA + merge (Duplicate a :\/: Duplicate b) = Duplicate b :/\: Duplicate a + -- mB + merge (Duplicate a :\/: b) = b :/\: Duplicate (addP (invert b) a) -- FIXME ??? + -- smB + merge m@(_ :\/: Duplicate _) = swapMerge m + -- mC +-- merge _ | traceDoc (greenText "about to look for conflictingness") False = impossible + merge (x :\/: y) | Just (y' :> ix') <- commute (invert (assertConsistent x) :> assertConsistent y), + Just (y'' :> _) <- commute (x :> y'), + IsEq <- y'' =\/= y = --traceDoc (greenText "These didn't conflict") $ + assertConsistent y' :/\: invert (assertConsistent ix') + | IsEq <- x =\/= y, + n <- addP (invert x) $ non x = + --traceDoc (greenText "Found duplicate") $ + Duplicate n :/\: Duplicate n +-- merge (x :\/: y) | traceDoc (greenText "trying to merging x" $$ showPatch x $$ +-- greenText "which conflicts with y" $$ showPatch y) False = impossible + -- mD + merge (Normal x :\/: Normal y) = + Conflictor [] (x:>:NilFL) (non $ Normal y) :/\: Conflictor [] (y:>:NilFL) (non $ Normal x) + -- mG + merge (Normal x :\/: Conflictor iy yy y) = + --traceDoc (greenText "merging Normal x" $$ showPatch x $$ + -- greenText "and Conflictor iy yy y" $$ showPatch (Conflictor iy yy y)) $ + Conflictor iy yyx y :/\: Conflictor (y:iy++nyy) NilFL x' + where yyx = yy +>+ x:>:NilFL + (x':nyy) = reverse $ xx2nons iy yyx + -- smE+smG + merge m@(Conflictor _ _ _ :\/: Normal _) = swapMerge m +-- merge (x :\/: y) | traceDoc (greenText "still trying to merge x" $$ showPatch x $$ +-- greenText "with y" $$ showPatch y) False = impossible + -- mH see also cH + merge (Conflictor ix xx x :\/: Conflictor iy yy y) = + case pullCommonRL (reverseFL xx) (reverseFL yy) of + CommonRL rxx1 ryy1 c -> + case commuteRLFL (ryy1 :> invertRL rxx1) of + Just (ixx' :> ryy') -> + let xx' = invert ixx' + yy' = reverseRL ryy' + y':iy' = map (add $ invertFL ixx') (y:iy) + x':ix' = map (add ryy') (x:ix) + nyy' = xx2nons iy' yy' + nxx' = xx2nons ix' xx' + icx = drop (lengthRL rxx1) $ xx2nons ix (reverseRL $ c+<+rxx1) + ic' = map (add ryy') icx + ixy' = ic' ++ (iy'+++ix') + -- +++ above is a more efficient version of nub + -- (iy'++ix') given that we know each element shows up + -- only once in either list. + in --traceDoc (greenText "here I am! and so is ixy'" $$ showNons ixy' $$ + -- greenText "and iy" $$ showNons iy $$ greenText (show $ length iy) $$ + -- greenText "and ix" $$ showNons ix $$ + -- greenText "and iy'" $$ showNons iy' $$ + -- greenText "and ix'" $$ showNons ix' $$ + -- greenText "and ic'" $$ showNons ic' + -- ) $ + Conflictor (x':ixy'++nxx') yy' y' :/\: Conflictor (y':ixy'++nyy') xx' x' + Nothing -> impossible pullInContext fromNons +-- merge _ = error "haven't finished fixing merge" + + list_touched_files (Duplicate p) = nonTouches p + list_touched_files (Etacilpud p) = nonTouches p + list_touched_files (Normal p) = list_touched_files p + list_touched_files (Conflictor x c p) = + nubsort $ concatMap nonTouches x ++ list_touched_files c ++ nonTouches p + list_touched_files (InvConflictor x c p) = + nubsort $ concatMap nonTouches x ++ list_touched_files c ++ nonTouches p + +{- +all_conflicts_withFL :: FL Prim C(x y) -> [Non RealPatch C(x)] + -> ([Non RealPatch C(x)], [Non RealPatch C(x)]) +all_conflicts_withFL xx ns = case partition f ns of + ([],nc) -> ([],nc) + (c,nc) -> case acw c nc of + (c',nc') -> (c++c',nc') + where acw (y:ys) zs = case all_conflicts_with y zs of + (c,nc) -> case acw ys nc of + (c',nc') -> (c++c',nc') + acw [] zs = ([],zs) + f (Non c p) = case commuteRLFL (invertFL c :> mapFL_FL Normal xx) of + Nothing -> True + Just (xx' :> _) -> case commuteFL (Normal (invert p) :> xx') of + Nothing -> True + Just _ -> False +-} +all_conflicts_with :: Non RealPatch C(x) -> [Non RealPatch C(x)] + -> ([Non RealPatch C(x)], [Non RealPatch C(x)]) +all_conflicts_with x ys = acw $ partition (conflicts_with x) ys + where acw ([],nc) = ([],nc) + acw (c:cs, nc) = case all_conflicts_with c nc of + (c1,nc1) -> case acw (cs, nc1) of + (xs',nc') -> (c:c1++xs',nc') + +conflicts_with :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool +conflicts_with x y | x `depends_upon` y || y `depends_upon` x = False +conflicts_with x (Non cy y) = + case remPs cy x of + Just (Non cx' x') -> case commuteFL (fromPrim (invert y) :> cx' +>+ fromPrim x' :>: NilFL) of + Right _ -> False + Left _ -> True + Nothing -> True + +depends_upon :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool +depends_upon (Non xs _) (Non ys y) = + case remove_subsequenceFL (ys +>+ fromPrim y :>: NilFL) xs of + Just _ -> True + Nothing -> False + +(+++) :: Eq a => [a] -> [a] -> [a] +[] +++ x = x +x +++ [] = x +(x:xs) +++ xys | Just ys <- remove1 x xys = x : (xs +++ ys) + | otherwise = x : (xs +++ xys) + +swapMerge :: (RealPatch :\/: RealPatch) C(x y) -> (RealPatch :/\: RealPatch) C(x y) +swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x' + +invertCommute :: (RealPatch :> RealPatch) C(x y) -> Maybe ((RealPatch :> RealPatch) C(x y)) +invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x) + return (invert iy' :> invert ix') + +invertCommuteNC :: (RealPatch :> RealPatch) C(x y) -> Maybe ((RealPatch :> RealPatch) C(x y)) +invertCommuteNC (x :> y) = do ix' :> iy' <- commute_no_conflicts (invert y :> invert x) + return (invert iy' :> invert ix') + +-- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted +-- out of both @xs@ and @ys@ along with the remnants of both lists +pullCommon :: Patchy p => FL p C(o x) -> FL p C(o y) -> Common p C(o x y) +pullCommon NilFL ys = Common NilFL NilFL ys +pullCommon xs NilFL = Common NilFL xs NilFL +pullCommon (x:>:xs) xys | Just ys <- removeFL x xys = case pullCommon xs ys of + Common c xs' ys' -> Common (x:>:c) xs' ys' +pullCommon (x:>:xs) ys = case commuteWhatWeCanFL (x :> xs) of + xs1:>x':>xs2 -> case pullCommon xs1 ys of + Common c xs1' ys' -> Common c (xs1'+>+x':>:xs2) ys' + +-- | 'Common' @cs xs ys@ represents two sequences of patches that have @cs@ in common, +-- in other words @cs +>+ xs@ and @cs +>+ ys@ +data Common p C(o x y) where + Common :: FL p C(o i) -> FL p C(i x) -> FL p C(i y) -> Common p C(o x y) + +-- | 'pullCommonRL' @xs ys@ returns the set of patches that can be commuted +-- out of both @xs@ and @ys@ along with the remnants of both lists +pullCommonRL :: Patchy p => RL p C(x o) -> RL p C(y o) -> CommonRL p C(x y o) +pullCommonRL NilRL ys = CommonRL NilRL ys NilRL +pullCommonRL xs NilRL = CommonRL xs NilRL NilRL +pullCommonRL (x:<:xs) xys + | Just ys <- removeRL x xys = case pullCommonRL xs ys of + CommonRL xs' ys' c -> CommonRL xs' ys' (x:<:c) +pullCommonRL (x:<:xs) ys = + case commuteWhatWeCanRL (xs :> x) of + xs1:>x':>xs2 -> case pullCommonRL xs2 ys of + CommonRL xs2' ys' c -> CommonRL (xs2'+<+x':<:xs1) ys' c + +-- | 'CommonRL' @xs ys cs@' represents two sequences of patches that have @cs@ in common, +-- in other words @xs +<+ cs@ and @ys +<+ cs@ +data CommonRL p C(x y f) where + CommonRL :: RL p C(x i) -> RL p C(y i) -> RL p C(i f) -> CommonRL p C(x y f) + +instance Apply RealPatch where + apply opts p = apply opts (effect p) + applyAndTryToFixFL (Normal p) = mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p + applyAndTryToFixFL x = do apply [] x; return Nothing + +instance ShowPatch RealPatch where + showPatch (Duplicate d) = blueText "duplicate" $$ showNon d + showPatch (Etacilpud d) = blueText "etacilpud" $$ showNon d + showPatch (Normal p) = showPrim NewFormat p + showPatch (Conflictor i NilFL p) = + blueText "conflictor" <+> showNons i <+> blueText "[]" $$ showNon p + showPatch (Conflictor i cs p) = + blueText "conflictor" <+> showNons i <+> blueText "[" $$ + showPatch cs $$ + blueText "]" $$ + showNon p + showPatch (InvConflictor i NilFL p) = + blueText "rotcilfnoc" <+> showNons i <+> blueText "[]" $$ showNon p + showPatch (InvConflictor i cs p) = + blueText "rotcilfnoc" <+> showNons i <+> blueText "[" $$ + showPatch cs $$ + blueText "]" $$ + showNon p + showContextPatch s (Normal p) = showContextPatch s p + showContextPatch _ c = showPatch c + +instance ReadPatch RealPatch where + readPatch' want_eof = + do s <- peek_input + case fmap (BC.unpack . fst) $ my_lex s of + Just "duplicate" -> + do work my_lex + p <- readNon + return $ (Sealed . Duplicate) `fmap` p + Just "etacilpud" -> + do work my_lex + p <- readNon + return $ (Sealed . Etacilpud) `fmap` p + Just "conflictor" -> + do work my_lex + --let tracePeek x = do y <- peek_input + -- traceDoc (greenText x $$ greenText (show $ BC.unpack y)) return () + i <- readNons + Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']') + + Just p <- readNon + return $ Just $ Sealed $ Conflictor i (unsafeCoerceP ps) p + Just "rotcilfnoc" -> + do work my_lex + i <- readNons + Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']') + Just p <- readNon + return $ Just $ Sealed $ InvConflictor i ps p + _ -> do mp <- readPrim NewFormat want_eof + case mp of + Just p -> return $ Just $ Normal `mapSeal` p + Nothing -> return Nothing + +instance Show (RealPatch C(x y)) where + show p = renderString $ showPatch p + +instance Show2 RealPatch where + show2 = show + +instance Nonable RealPatch where + non (Duplicate d) = d + non (Etacilpud d) = invertNon d -- FIXME !!! ??? + non (Normal p) = Non NilFL p + non (Conflictor _ xx x) = add (invertFL xx) x + non (InvConflictor _ _ n) = invertNon n + +instance Effect RealPatch where + effect (Duplicate _) = NilFL + effect (Etacilpud _) = NilFL + effect (Normal p) = effect p + effect (Conflictor _ e _) = invert e + effect (InvConflictor _ e _) = e + effectRL (Duplicate _) = NilRL + effectRL (Etacilpud _) = NilRL + effectRL (Normal p) = effectRL p + effectRL (Conflictor _ e _) = invertFL e + effectRL (InvConflictor _ e _) = reverseFL e + isHunk rp = do Normal p <- return rp + isHunk p diff --git a/src/Darcs/Patch/Set.hs b/src/Darcs/Patch/Set.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Set.hs @@ -0,0 +1,50 @@ +-- Copyright (C) 2003 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Patch.Set ( PatchSet, SealedPatchSet ) where + +import Darcs.Hopefully ( PatchInfoAnd ) +import Darcs.Ordered ( RL ) +import Darcs.Sealed ( Sealed ) + +-- | A PatchSet is in reverse order, plus has information about which +-- tags are clean, meaning all patches applied prior to them are in +-- the tag itself, so we can stop reading at that point. Just to +-- clarify, the first patch in a PatchSet is the one most recently +-- applied to the repo. +-- +-- 'PatchSet's have the property that if +-- @ +-- (info $ last $ head a) == (info $ last $ head b) +-- @ +-- then @(tail a)@ and @(tail b)@ are identical repositories +-- +-- Questions: +-- +-- Does this mean that in a patch set such as @[[a b t1 c d e t2][f g +-- t3] [h i]]@, t1, t2 and t3 are tags, and t2 and t3 are clean? +-- +-- Can we have PatchSet with length at least 3? +-- Florent +type PatchSet p C(x) = RL (RL (PatchInfoAnd p)) C(() x) + +type SealedPatchSet p = Sealed (RL (RL (PatchInfoAnd p)) C(())) diff --git a/src/Darcs/Patch/Show.lhs b/src/Darcs/Patch/Show.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Show.lhs @@ -0,0 +1,89 @@ +% Copyright (C) 2002-2005 David Roundy +% +% 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. + + +\begin{code} +{-# OPTIONS_GHC -cpp -fno-warn-orphans -fglasgow-exts #-} +{-# LANGUAGE CPP #-} + +module Darcs.Patch.Show ( showPatch_, showNamedPrefix ) + where + +import Prelude hiding ( pi ) + +import Printer ( Doc, renderString, vcat, + text, blueText, + ($$), (<+>) ) +import Darcs.Patch.Core ( Patch(..) ) +import Darcs.Patch.Prim ( showPrim, FileNameFormat(..) ) +import Darcs.Patch.Info ( PatchInfo, showPatchInfo ) +import Darcs.Ordered ( FL(NilFL), mapFL ) +#include "gadts.h" +\end{code} + +\section{Patch string formatting} + +Of course, in order to store our patches in a file, we'll have to save them +as some sort of strings. The convention is that each patch string will end +with a newline, but on parsing we skip any amount of whitespace between +patches. +\begin{code} +instance Show (Patch C(x y)) where + show p = renderString (showPatch_ p) ++ "\n" + +showPatch_ :: Patch C(a b) -> Doc +showPatch_ (PP p) = showPrim OldFormat p +showPatch_ (ComP NilFL) = blueText "{" $$ blueText "}" +showPatch_ (ComP ps) = blueText "{" + $$ vcat (mapFL showPatch_ ps) + $$ blueText "}" +showPatch_ (Merger _ _ p1 p2) = showMerger "merger" p1 p2 +showPatch_ (Regrem _ _ p1 p2) = showMerger "regrem" p1 p2 +\end{code} + +\paragraph{Merger patches} +Merge two patches. The MERGERVERSION is included to allow some degree of +backwards compatibility if the merger algorithm needs to be changed. +\begin{verbatim} +merger MERGERVERSION + + +\end{verbatim} +\begin{code} +showMerger :: String -> Patch C(a b) -> Patch C(d e) -> Doc +showMerger merger_name p1 p2 = + blueText merger_name <+> text "0.0" <+> blueText "(" + $$ showPatch_ p1 + $$ showPatch_ p2 + $$ blueText ")" +\end{code} + +\paragraph{Named patches} + +Named patches are displayed as a ``patch id'' which is in square brackets, +followed by a patch. Optionally, after the patch id (but before the patch +itself) can come a list of dependencies surrounded by angle brackets. Each +dependency consists of a patch id. + +\begin{code} +showNamedPrefix :: PatchInfo -> [PatchInfo] -> Doc +showNamedPrefix n d = showPatchInfo n + $$ blueText "<" + $$ vcat (map showPatchInfo d) + $$ blueText ">" + +\end{code} diff --git a/src/Darcs/Patch/TouchesFiles.hs b/src/Darcs/Patch/TouchesFiles.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/TouchesFiles.hs @@ -0,0 +1,90 @@ +-- Copyright (C) 2002-2004 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Patch.TouchesFiles ( look_touch, choose_touching, + select_touching, + deselect_not_touching, select_not_touching, + ) where +import Data.List ( sort ) + +import Darcs.Patch.Choices ( PatchChoices, Tag, TaggedPatch, + patch_choices, tag, get_choices, + force_firsts, force_lasts, tp_patch, + ) +import Darcs.Patch ( Patchy, apply_to_filepaths, list_touched_files ) +import Darcs.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) ) +import Darcs.Sealed ( Sealed, seal ) + +select_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) +select_touching [] pc = pc +select_touching files pc = force_firsts xs pc + where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag] + ct _ NilFL = [] + ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of + (True, fs') -> tag tp:ct fs' tps + (False, fs') -> ct fs' tps + xs = case get_choices pc of + _ :> mc :> lc -> ct (map fix files) (mc +>+ lc) + +deselect_not_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) +deselect_not_touching [] pc = pc +deselect_not_touching files pc = force_lasts xs pc + where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag] + ct _ NilFL = [] + ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of + (True, fs') -> ct fs' tps + (False, fs') -> tag tp:ct fs' tps + xs = case get_choices pc of + fc :> mc :> _ -> ct (map fix files) (fc +>+ mc) + +select_not_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y) +select_not_touching [] pc = pc +select_not_touching files pc = force_firsts xs pc + where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag] + ct _ NilFL = [] + ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of + (True, fs') -> ct fs' tps + (False, fs') -> tag tp:ct fs' tps + xs = case get_choices pc of + fc :> mc :> _ -> ct (map fix files) (fc +>+ mc) + +fix :: FilePath -> FilePath +fix f | take 1 (reverse f) == "/" = fix $ reverse $ drop 1 $ reverse f +fix "" = "." +fix "." = "." +fix f = "./" ++ f + +choose_touching :: Patchy p => [FilePath] -> FL p C(x y) -> Sealed (FL p C(x)) +choose_touching [] p = seal p +choose_touching files p = case get_choices $ select_touching files $ patch_choices p of + fc :> _ :> _ -> seal $ mapFL_FL tp_patch fc + +look_touch :: Patchy p => [FilePath] -> p C(x y) -> (Bool, [FilePath]) +look_touch fs p = (any (\tf -> any (affects tf) fs) (list_touched_files p) + || fs' /= fs, fs') + where affects touched f | touched == f = True + affects t f = case splitAt (length f) t of + (t', '/':_) -> t' == f + _ -> case splitAt (length t) f of + (f', '/':_) -> f' == t + _ -> False + fs' = sort $ apply_to_filepaths p fs diff --git a/src/Darcs/Patch/Viewing.hs b/src/Darcs/Patch/Viewing.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Patch/Viewing.hs @@ -0,0 +1,333 @@ +-- Copyright (C) 2002-2004 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} + +module Darcs.Patch.Viewing ( xml_summary, summarize ) + where + +import Prelude hiding ( pi ) +import Control.Monad ( liftM ) +import Data.List ( sort ) + +import Darcs.SlurpDirectory ( Slurpy, get_slurp, get_filecontents ) +import ByteStringUtils (linesPS ) +import qualified Data.ByteString as B (null) +import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp ) +import Printer ( Doc, empty, vcat, + text, blueText, Color(Cyan,Magenta), lineColor, + minus, plus, ($$), (<+>), (<>), + prefix, renderString, + userchunkPS, + ) +import Darcs.Patch.Core ( Patch(..), Named(..), + patchcontents ) +import Darcs.Patch.Prim ( Prim(..), is_hunk, isHunk, formatFileName, showPrim, FileNameFormat(..), Conflict(..), + Effect, IsConflictedPrim(IsC), ConflictState(..), + DirPatchType(..), FilePatchType(..) ) +import Darcs.Patch.Patchy ( Patchy, Apply, ShowPatch(..), identity ) +import Darcs.Patch.Show ( showPatch_, showNamedPrefix ) +import Darcs.Patch.Info ( showPatchInfo, human_friendly ) +import Darcs.Patch.Apply ( apply_to_slurpy ) +#include "impossible.h" +#include "gadts.h" +import Darcs.Ordered ( RL(..), FL(..), + mapFL, mapFL_FL, reverseRL ) + +instance ShowPatch Prim where + showPatch = showPrim OldFormat + showContextPatch s p@(FP _ (Hunk _ _ _)) = showContextHunk s (PP p) + showContextPatch s (Split ps) = + blueText "(" $$ showContextSeries s (mapFL_FL PP ps) + <> blueText ")" + showContextPatch _ p = showPatch p + summary = gen_summary False . (:[]) . IsC Okay + thing _ = "change" + +summarize :: (Conflict e, Effect e) => e C(x y) -> Doc +summarize = gen_summary False . conflictedEffect + +instance ShowPatch Patch where + showPatch = showPatch_ + showContextPatch s (PP x) | is_hunk x = showContextHunk s (PP x) + showContextPatch _ (ComP NilFL) = blueText "{" $$ blueText "}" + showContextPatch s (ComP ps) = blueText "{" $$ showContextSeries s ps + $$ blueText "}" + showContextPatch _ p = showPatch p + summary = summarize + thing _ = "change" + +showContextSeries :: (Apply p, ShowPatch p, Effect p) => Slurpy -> FL p C(x y) -> Doc +showContextSeries slur patches = scs slur identity patches + where scs :: (Apply p, ShowPatch p, Effect p) => Slurpy -> Prim C(w x) -> FL p C(x y) -> Doc + scs s pold (p:>:ps) = + case isHunk p of + Nothing -> showContextPatch s p $$ scs s' identity ps + Just hp -> + case ps of + NilFL -> coolContextHunk s pold hp identity + (p2:>:_) -> + case isHunk p2 of + Nothing -> coolContextHunk s pold hp identity $$ scs s' hp ps + Just hp2 -> coolContextHunk s pold hp hp2 $$ + scs s' hp ps + where s' = + fromJust $ apply_to_slurpy p s + scs _ _ NilFL = empty + +showContextHunk :: (Apply p, ShowPatch p, Effect p) => Slurpy -> p C(x y) -> Doc +showContextHunk s p = case isHunk p of + Just h -> coolContextHunk s identity h identity + Nothing -> showPatch p + +coolContextHunk :: Slurpy -> Prim C(a b) -> Prim C(b c) + -> Prim C(c d) -> Doc +coolContextHunk s prev p@(FP f (Hunk l o n)) next = + case (linesPS . get_filecontents) `liftM` get_slurp f s of + Nothing -> showPatch p -- This is a weird error... + Just ls -> + let numpre = case prev of + (FP f' (Hunk lprev _ nprev)) + | f' == f && + l - (lprev + length nprev + 3) < 3 && + lprev < l -> + max 0 $ l - (lprev + length nprev + 3) + _ -> if l >= 4 then 3 else l - 1 + pre = take numpre $ drop (l - numpre - 1) ls + numpost = case next of + (FP f' (Hunk lnext _ _)) + | f' == f && lnext < l+length n+4 && + lnext > l -> + lnext - (l+length n) + _ -> 3 + cleanedls = case reverse ls of + (x:xs) | B.null x -> reverse xs + _ -> ls + post = take numpost $ drop (max 0 $ l+length o-1) cleanedls + in blueText "hunk" <+> formatFileName OldFormat f <+> text (show l) + $$ prefix " " (vcat $ map userchunkPS pre) + $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS o)) + $$ lineColor Cyan (prefix "+" (vcat $ map userchunkPS n)) + $$ prefix " " (vcat $ map userchunkPS post) +coolContextHunk _ _ _ _ = impossible + +xml_summary :: (Effect p, Patchy p, Conflict p) => Named p C(x y) -> Doc +xml_summary p = text "" + $$ gen_summary True (conflictedEffect $ patchcontents p) + $$ text "" + +-- Yuck duplicated code below... +escapeXML :: String -> Doc +escapeXML = text . strReplace '\'' "'" . strReplace '"' """ . + strReplace '>' ">" . strReplace '<' "<" . strReplace '&' "&" + +strReplace :: Char -> String -> String -> String +strReplace _ _ [] = [] +strReplace x y (z:zs) + | x == z = y ++ (strReplace x y zs) + | otherwise = z : (strReplace x y zs) +-- end yuck duplicated code. + +gen_summary :: Bool -> [IsConflictedPrim] -> Doc +gen_summary use_xml p + = vcat themoves + $$ vcat themods + where themods = map summ $ combine $ sort $ concatMap s2 p + s2 :: IsConflictedPrim -> [(FileName, Int, Int, Int, Bool, ConflictState)] + s2 (IsC c x) = map (append56 c) $ s x + s :: Prim C(x y) -> [(FileName, Int, Int, Int, Bool)] + s (FP f (Hunk _ o n)) = [(f, length o, length n, 0, False)] + s (FP f (Binary _ _)) = [(f, 0, 0, 0, False)] + s (FP f AddFile) = [(f, -1, 0, 0, False)] + s (FP f RmFile) = [(f, 0, -1, 0, False)] + s (FP f (TokReplace _ _ _)) = [(f, 0, 0, 1, False)] + s (DP d AddDir) = [(d, -1, 0, 0, True)] + s (DP d RmDir) = [(d, 0, -1, 0, True)] + s (Split xs) = concat $ mapFL s xs + s (Move _ _) = [(fp2fn "", 0, 0, 0, False)] + s (ChangePref _ _ _) = [(fp2fn "", 0, 0, 0, False)] + s Identity = [(fp2fn "", 0, 0, 0, False)] + append56 f (a,b,c,d,e) = (a,b,c,d,e,f) + (-1) .+ _ = -1 + _ .+ (-1) = -1 + a .+ b = a + b + combine ((f,a,b,r,isd,c):(f',a',b',r',_,c'):ss) + -- Don't combine AddFile and RmFile: (maybe an old revision of) darcs + -- allows a single patch to add and remove the same file, see issue 185 + | f == f' && (a /= -1 || b' /= -1) && (a' /= -1 || b /= -1) = + combine ((f,a.+a',b.+b',r+r',isd,combineConflitStates c c'):ss) + combine ((f,a,b,r,isd,c):ss) = (f,a,b,r,isd,c) : combine ss + combine [] = [] + combineConflitStates Conflicted _ = Conflicted + combineConflitStates _ Conflicted = Conflicted + combineConflitStates Duplicated _ = Duplicated + combineConflitStates _ Duplicated = Duplicated + combineConflitStates Okay Okay = Okay + + summ (f,_,-1,_,False,Okay) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + $$ text "" + else text "R" <+> text (fn2fp f) + summ (f,_,-1,_,False,Conflicted) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + $$ text "" + else text "R!" <+> text (fn2fp f) + summ (f,_,-1,_,False,Duplicated) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + $$ text "" + else text "R" <+> text (fn2fp f) <+> text "(duplicate)" + summ (f,-1,_,_,False,Okay) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + $$ text "" + else text "A" <+> text (fn2fp f) + summ (f,-1,_,_,False,Conflicted) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + $$ text "" + else text "A!" <+> text (fn2fp f) + summ (f,-1,_,_,False,Duplicated) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + $$ text "" + else text "A" <+> text (fn2fp f) <+> text "(duplicate)" + summ (f,0,0,0,False,Okay) | f == fp2fn "" = empty + summ (f,0,0,0,False,Conflicted) | f == fp2fn "" + = if use_xml then empty -- don't know what to do here... + else text "!" <+> text (fn2fp f) + summ (f,0,0,0,False,Duplicated) | f == fp2fn "" + = if use_xml then empty -- don't know what to do here... + else text (fn2fp f) <+> text "(duplicate)" + summ (f,a,b,r,False,Okay) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + <> xrm a <> xad b <> xrp r + $$ text "" + else text "M" <+> text (fn2fp f) + <+> rm a <+> ad b <+> rp r + summ (f,a,b,r,False,Conflicted) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + <> xrm a <> xad b <> xrp r + $$ text "" + else text "M!" <+> text (fn2fp f) + <+> rm a <+> ad b <+> rp r + summ (f,a,b,r,False,Duplicated) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + <> xrm a <> xad b <> xrp r + $$ text "" + else text "M" <+> text (fn2fp f) + <+> rm a <+> ad b <+> rp r <+> text "(duplicate)" + summ (f,_,-1,_,True,Okay) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + $$ text "" + else text "R" <+> text (fn2fp f) <> text "/" + summ (f,_,-1,_,True,Conflicted) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + $$ text "" + else text "R!" <+> text (fn2fp f) <> text "/" + summ (f,_,-1,_,True,Duplicated) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + $$ text "" + else text "R" <+> text (fn2fp f) <> text "/ (duplicate)" + summ (f,-1,_,_,True,Okay) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + $$ text "" + else text "A" <+> text (fn2fp f) <> text "/" + summ (f,-1,_,_,True,Conflicted) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + $$ text "" + else text "A!" <+> text (fn2fp f) <> text "/" + summ (f,-1,_,_,True,Duplicated) + = if use_xml then text "" + $$ escapeXML (drop_dotslash $ fn2fp f) + $$ text "" + else text "A!" <+> text (fn2fp f) <> text "/ (duplicate)" + summ _ = empty + ad 0 = empty + ad a = plus <> text (show a) + xad 0 = empty + xad a = text "" + rm 0 = empty + rm a = minus <> text (show a) + xrm 0 = empty + xrm a = text "" + rp 0 = empty + rp a = text "r" <> text (show a) + xrp 0 = empty + xrp a = text "" + drop_dotslash ('.':'/':str) = drop_dotslash str + drop_dotslash str = str + themoves :: [Doc] + themoves = map showmoves p + showmoves :: IsConflictedPrim -> Doc + showmoves (IsC _ (Move a b)) + = if use_xml + then text " escapeXML (drop_dotslash $ fn2fp a) <> text "\" to=\"" + <> escapeXML (drop_dotslash $ fn2fp b) <> text"\"/>" + else text " " <> text (fn2fp a) + <> text " -> " <> text (fn2fp b) + showmoves _ = empty + +instance (Conflict p, ShowPatch p) => ShowPatch (Named p) where + showPatch (NamedP n [] p) = showPatchInfo n <> showPatch p + showPatch (NamedP n d p) = showNamedPrefix n d <+> showPatch p + showContextPatch s (NamedP n [] p) = showPatchInfo n <> showContextPatch s p + showContextPatch s (NamedP n d p) = showNamedPrefix n d <+> showContextPatch s p + description (NamedP n _ _) = human_friendly n + summary p = description p $$ text "" $$ + prefix " " (summarize p) -- this isn't summary because summary does the + -- wrong thing with (Named (FL p)) so that it can + -- get the summary of a sequence of named patches + -- right. + showNicely p@(NamedP _ _ pt) = description p $$ + prefix " " (showNicely pt) + +instance (Conflict p, ShowPatch p) => Show (Named p C(x y)) where + show = renderString . showPatch + +instance (Conflict p, Apply p, Effect p, ShowPatch p) => ShowPatch (FL p) where + showPatch xs = vcat (mapFL showPatch xs) + showContextPatch = showContextSeries + description = vcat . mapFL description + summary = vcat . mapFL summary + thing x = thing (helperx x) ++ "s" + where helperx :: FL a C(x y) -> a C(x y) + helperx _ = undefined + things = thing + +instance (Conflict p, Apply p, ShowPatch p) => ShowPatch (RL p) where + showPatch = showPatch . reverseRL + showContextPatch s = showContextPatch s . reverseRL + description = description . reverseRL + summary = summary . reverseRL + thing = thing . reverseRL + things = things . reverseRL + +instance (Conflict p, Patchy p) => Patchy (FL p) +instance (Conflict p, Patchy p) => Patchy (RL p) diff --git a/src/Darcs/Population.hs b/src/Darcs/Population.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Population.hs @@ -0,0 +1,144 @@ +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +-- Copyright (C) 2003-2004 Jan Scheffczyk and David Roundy +-- +-- 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. + +#include "gadts.h" + +module Darcs.Population ( Population, patchChanges, applyToPop, + getPopFrom, + setPopState, + DirMark(..), + getRepoPop, getRepoPopVersion, + modified_to_xml, + lookup_pop, lookup_creation_pop, + ) where + +import qualified Data.ByteString.Char8 as BC ( unpack, singleton, pack ) +import Data.Maybe ( catMaybes ) +import Darcs.Utils ( withCurrentDirectory ) + +import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) +import Darcs.Patch.FileName ( fn2fp, fp2fn, fn2ps, norm_path ) +import Darcs.Patch ( RepoPatch, applyToPop, patchcontents, patchChanges, + Effect, effect ) +import Darcs.Ordered ( FL(..), RL(..), reverseRL, concatRL, mapRL ) +import Darcs.Patch.Info ( PatchInfo, idpatchinfo, to_xml ) +import Darcs.Patch.Set ( PatchSet ) +import Darcs.Sealed ( Sealed(..), seal, unseal ) +import Darcs.Repository ( withRepositoryDirectory, ($-), read_repo ) +import Darcs.Repository.Pristine ( identifyPristine, getPristinePop ) +import Darcs.PopulationData ( Population(..), PopTree(..), Info(..), DirMark(..), + setPopState, getPopFrom ) +import Printer ( empty, text, ($$), (<>), Doc ) +import Control.Monad ( liftM ) + +#include "impossible.h" + +-- | population of an empty repository +initPop :: Population +initPop = Pop idpatchinfo (PopDir i []) + where i = Info {nameI = BC.singleton '.', + modifiedByI = idpatchinfo, + modifiedHowI = DullDir, + createdByI = Nothing, + creationNameI = Just (BC.singleton '.')} + +-- | apply a patchset to a population +applyPatchSetPop :: RepoPatch p => PatchSet p C(x) -> Population -> Population +applyPatchSetPop ps pop = applyPatchesPop (reverseRL $ concatRL ps) pop + +-- | apply Patches to a population +applyPatchesPop :: Effect p => FL (PatchInfoAnd p) C(x y) -> Population -> Population +applyPatchesPop NilFL = id +applyPatchesPop (hp:>:hps) = applyPatchesPop hps . + applyToPop (info hp) (effect $ patchcontents $ hopefully hp) +-- | get the pristine population from a repo +getRepoPop :: FilePath -> IO Population +getRepoPop repobasedir + = withRepositoryDirectory [] repobasedir $- \repository -> do + pinfo <- (head . mapRL info . concatRL) `liftM` read_repo repository + -- pinfo is the latest patchinfo + mp <- withCurrentDirectory repobasedir $ + identifyPristine >>= getPristinePop pinfo + case mp of + (Just pop) -> return pop + (Nothing) -> getRepoPopVersion repobasedir pinfo + +getRepoPopVersion :: FilePath -> PatchInfo -> IO Population +getRepoPopVersion repobasedir pinfo = withRepositoryDirectory [] repobasedir $- \repository -> + do pips <- concatRL `liftM` read_repo repository + return $ (unseal applyPatchSetPop) (mkPatchSet $ dropWhileRL ((/=pinfo).info) pips) initPop + where mkPatchSet (Sealed xs) = seal $ xs :<: NilRL + dropWhileRL :: (FORALL(x y) a C(x y) -> Bool) -> RL a C(r v) -> Sealed (RL a C(r)) + dropWhileRL _ NilRL = seal NilRL + dropWhileRL p xs@(x:<:xs') + | p x = dropWhileRL p xs' + | otherwise = seal xs + +-- Routines for pulling data conveniently out of a Population + +lookup_pop :: FilePath -> Population -> Maybe Population +lookup_pop f p = lookup_pop' (BC.unpack $ fn2ps $ fp2fn f) p + +lookup_pop' :: String -> Population -> Maybe Population +lookup_pop' f p@(Pop _ (PopFile i)) + | BC.unpack (nameI i) == f = Just p + | otherwise = Nothing +lookup_pop' d p@(Pop pinfo (PopDir i c)) + | BC.unpack (nameI i) == "." = + case catMaybes $ map (lookup_pop' (dropDS d).(Pop pinfo)) c of + [apop] -> Just apop + [] -> Nothing + _ -> impossible + | BC.unpack (nameI i) == takeWhile (/='/') d = + case dropWhile (=='/') $ dropWhile (/='/') d of + "" -> Just p + d' -> case catMaybes $ map (lookup_pop' d'.(Pop pinfo)) c of + [apop] -> Just apop + [] -> Nothing + _ -> impossible + | otherwise = Nothing + where dropDS ('.':'/':f) = dropDS f + dropDS f = f + +lookup_creation_pop :: PatchInfo -> FilePath -> Population -> Maybe Population +lookup_creation_pop pinfo f p = lookup_creation_pop' pinfo (BC.unpack $ fn2ps $ fp2fn f) p + +lookup_creation_pop' :: PatchInfo -> String -> Population -> Maybe Population +lookup_creation_pop' b a (Pop pinfo pp) = (Pop pinfo) `fmap` lcp pp + where lcp p@(PopFile i) + | fixname `fmap` creationNameI i == f && createdByI i == who = Just p + | otherwise = Nothing + lcp p@(PopDir i c) + | fixname `fmap` creationNameI i == f && createdByI i == who = Just p + | otherwise = case catMaybes $ map lcp c of + [apop] -> Just apop + _ -> Nothing + fixname = BC.pack . fn2fp . norm_path . fp2fn . BC.unpack + f = Just $ BC.pack $ fn2fp $ norm_path $ fp2fn a + who = Just b + +modified_to_xml :: Info -> Doc +modified_to_xml i | modifiedHowI i == DullDir = empty + | modifiedHowI i == DullFile = empty +modified_to_xml i = text "" + $$ text "" <> text (show (modifiedHowI i)) <> + text "" + $$ to_xml (modifiedByI i) + $$ text "" diff --git a/src/Darcs/PopulationData.hs b/src/Darcs/PopulationData.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/PopulationData.hs @@ -0,0 +1,123 @@ +-- Copyright (C) 2003-2004 Jan Scheffczyk and David Roundy +-- +-- 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. + +module Darcs.PopulationData ( Population(..), PopTree(..), Info(..), + setPopState, notModified, setState, + DirMark(..), getPopFrom + ) where +import Darcs.Patch.Info +import Darcs.Utils ( withCurrentDirectory ) +import System.Directory ( doesDirectoryExist, getDirectoryContents ) +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString as B (ByteString) + +-- | the population of a darcs repository (simpler Slurpy) +data Population = Pop { popState :: PatchInfo -- ^ the state when last modified + , popTree :: PopTree -- ^ the directory listing + } + deriving (Show, Eq) + +setPopState :: PatchInfo -> Population -> Population +setPopState i (Pop _ tr) = Pop i tr + +-- | directory listing +data PopTree = PopDir !Info ![PopTree] + | PopFile !Info + deriving ( Ord, Eq ) + +-- | info of a directory member +data DirMark = AddedFile | RemovedFile | MovedFile String + | ModifiedFile | DullFile + | AddedDir | RemovedDir | MovedDir !String | DullDir + deriving ( Ord, Eq ) +data Info = Info {nameI :: !B.ByteString, -- ^ name of the element + modifiedByI :: !PatchInfo, -- ^ last patch modifying this element + modifiedHowI :: !DirMark, -- ^ how was it modified + createdByI :: !(Maybe PatchInfo), -- ^ this can be unknown when restored backwards! + creationNameI :: !(Maybe B.ByteString) -- ^ the original name of the element + } + deriving ( Ord, Eq ) + +-- | was an Info record not modified? +notModified :: Info -> Bool +notModified i = (modifiedHowI i == DullFile) || (modifiedHowI i == DullDir) + +-- | set the modifier for an Info record +setState :: Info -> PatchInfo -> Info +setState i pinfo = i { modifiedByI = pinfo } + +instance Show PopTree where + show s = showPop "" s + +showPop :: String -> PopTree -> String +showPop indent (PopDir i fs) + = indent ++ show i ++ "\n" ++ + unlines (map (showPop (' ':indent)) fs) +showPop indent (PopFile i) + = indent ++ show i + +instance Show Info where + show i = show (nameI i) ++ " " ++ show (modifiedHowI i) ++ + " at state " ++ show (modifiedByI i) + +instance Show DirMark where + show AddedFile = "File added" + show RemovedFile = "File removed" + show (MovedFile s) = "File moved to " ++ s + show ModifiedFile = "File modified" + show DullFile = "File old" + show AddedDir = "Dir added" + show RemovedDir = "Dir removed" + show (MovedDir s) = "Dir moved from " ++ s + show DullDir = "Dir old" + +-- | read the population from a given directory @dirname@ +-- all folders and documents get the given time @t@ +-- +-- This needs to be here in order to avoid a circular dependency +-- between Population and Pristine. +getPopFrom :: FilePath -> PatchInfo -> IO Population +getPopFrom the_directory pinfo = + withCurrentDirectory the_directory $ + do popT <- getPopFrom_helper "." + return (Pop pinfo popT) + where getPopFrom_helper :: FilePath -> IO PopTree + getPopFrom_helper dirname = do + isdir <- doesDirectoryExist dirname + let n = BC.pack dirname + if isdir + then do + fnames <- getDirectoryContents dirname + sl <- withCurrentDirectory dirname + (sequence $ map getPopFrom_helper $ filter not_hidden fnames) + let i = Info {nameI = n, + modifiedByI = pinfo, + modifiedHowI = DullDir, + createdByI = Just pinfo, + creationNameI = Just n} + return $ PopDir i sl + else do let i = Info {nameI = n, + modifiedByI = pinfo, + modifiedHowI = DullFile, + createdByI = Just pinfo, + creationNameI = Just n} + return $ PopFile i + +not_hidden :: FilePath -> Bool +not_hidden ('.':_) = False +not_hidden ('_':_) = False +not_hidden _ = True diff --git a/src/Darcs/PrintPatch.hs b/src/Darcs/PrintPatch.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/PrintPatch.hs @@ -0,0 +1,50 @@ +-- Copyright (C) 2003 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.PrintPatch ( printPatch, contextualPrintPatch, + printPatchPager, printFriendly ) where + +import Darcs.Patch ( Patchy, showContextPatch, showPatch ) +import Darcs.SlurpDirectory ( Slurpy ) +import Darcs.Arguments ( DarcsFlag, showFriendly ) +import Printer ( putDocLnWith ) +import Darcs.ColorPrinter ( fancyPrinters ) +import Darcs.External ( viewDocWith ) + +-- | @'printFriendly' opts patch@ prints @patch@ in accordance with the +-- flags in opts, ie, whether @--verbose@ or @--summary@ were passed at +-- the command-line. +printFriendly :: Patchy p => [DarcsFlag] -> p C(x y) -> IO () +printFriendly opts p = putDocLnWith fancyPrinters $ showFriendly opts p + +-- | 'printPatch' prints a patch on standard output. +printPatch :: Patchy p => p C(x y) -> IO () +printPatch p = putDocLnWith fancyPrinters $ showPatch p + +-- | 'printPatchPager' runs '$PAGER' and shows a patch in it. +printPatchPager :: Patchy p => p C(x y) -> IO () +printPatchPager p = viewDocWith fancyPrinters $ showPatch p + +-- | 'contextualPrintPatch' prints a patch, together with its context, +-- on standard output. +contextualPrintPatch :: Patchy p => Slurpy -> p C(x y) -> IO () +contextualPrintPatch s p = putDocLnWith fancyPrinters $ showContextPatch s p diff --git a/src/Darcs/ProgressPatches.hs b/src/Darcs/ProgressPatches.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/ProgressPatches.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} + +#include "gadts.h" +module Darcs.ProgressPatches (progressRL, progressFL, progressRLShowTags) +where +import Darcs.Ordered ( FL(..), RL(..), lengthRL, lengthFL ) +import Darcs.Hopefully (PatchInfoAnd,info) +import System.IO.Unsafe ( unsafePerformIO ) +import Progress (minlist, beginTedious, + endTedious, progress, progressKeepLatest, + tediousSize, finishedOne) +import Darcs.Patch.Info (just_name, is_tag) + + +-- | Evaluate an 'FL' list and report progress. +progressFL :: String -> FL a C(x y) -> FL a C(x y) +progressFL _ NilFL = NilFL +progressFL k (x:>:xs) = if l < minlist then x:>:xs + else startit x :>: pl xs + where l = lengthFL (x:>:xs) + startit y = unsafePerformIO $ do beginTedious k + tediousSize k l + return y + pl :: FL a C(x y) -> FL a C(x y) + pl NilFL = NilFL + pl (y:>:NilFL) = unsafePerformIO $ do endTedious k + return (y:>:NilFL) + pl (y:>:ys) = progress k y :>: pl ys + +-- | Evaluate an 'RL' list and report progress. +progressRL :: String -> RL a C(x y) -> RL a C(x y) +progressRL _ NilRL = NilRL +progressRL k (x:<:xs) = if l < minlist then x:<:xs + else startit x :<: pl xs + where l = lengthRL (x:<:xs) + startit y = unsafePerformIO $ do beginTedious k + tediousSize k l + return y + pl :: RL a C(x y) -> RL a C(x y) + pl NilRL = NilRL + pl (y:<:NilRL) = unsafePerformIO $ do endTedious k + return (y:<:NilRL) + pl (y:<:ys) = progress k y :<: pl ys + +-- | Evaluate an 'RL' list and report progress. In addition to printing +-- the number of patches we got, show the name of the last tag we got. +progressRLShowTags :: String -> RL (PatchInfoAnd p) C(x y) + -> RL (PatchInfoAnd p) C(x y) +progressRLShowTags _ NilRL = NilRL +progressRLShowTags k (x:<:xs) = if l < minlist then x:<:xs + else startit x :<: pl xs + where l = lengthRL (x:<:xs) + startit y = unsafePerformIO $ do beginTedious k + tediousSize k l + return y + pl :: RL (PatchInfoAnd p) C(x y) -> RL (PatchInfoAnd p) C(x y) + pl NilRL = NilRL + pl (y:<:NilRL) = unsafePerformIO $ do endTedious k + return (y:<:NilRL) + pl (y:<:ys) = + if is_tag iy + then finishedOne k ("back to "++ just_name iy) y :<: pl ys + else progressKeepLatest k y :<: pl ys + where + iy = info y diff --git a/src/Darcs/RemoteApply.hs b/src/Darcs/RemoteApply.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/RemoteApply.hs @@ -0,0 +1,58 @@ +-- | This module is used by the push and put commands to apply the a bundle to a +-- remote repository. By remote I do not necessarily mean a repository on another +-- machine, it is just not the repository we're located in. +module Darcs.RemoteApply ( remote_apply, apply_as ) where + +import System.Exit ( ExitCode ) + +import Darcs.Flags ( DarcsFlag( ApplyAs, Debug ) ) +import Darcs.Utils ( breakCommand ) +import Darcs.URL ( is_url, is_ssh ) +import Darcs.External +import Printer + +remote_apply :: [DarcsFlag] -> String -> Doc -> IO ExitCode +remote_apply opts repodir bundle + = case apply_as opts of + Nothing -> if is_ssh repodir + then apply_via_ssh opts repodir bundle + else if is_url repodir + then apply_via_url opts repodir bundle + else apply_via_local opts repodir bundle + Just un -> if is_ssh repodir + then apply_via_ssh_and_sudo repodir un bundle + else apply_via_sudo un repodir bundle + +apply_as :: [DarcsFlag] -> Maybe String +apply_as (ApplyAs user:_) = Just user +apply_as (_:fs) = apply_as fs +apply_as [] = Nothing +apply_via_sudo :: String -> String -> Doc -> IO ExitCode +apply_via_sudo user repo bundle = + pipeDoc "sudo" ["-u",user,"darcs","apply","--all","--repodir",repo] bundle +apply_via_local :: [DarcsFlag] -> String -> Doc -> IO ExitCode +apply_via_local opts repo bundle = + pipeDoc "darcs" ("apply":"--all":"--repodir":repo:applyopts opts) bundle + +apply_via_url :: [DarcsFlag] -> String -> Doc -> IO ExitCode +apply_via_url opts repo bundle = + do maybeapply <- maybeURLCmd "APPLY" repo + case maybeapply of + Nothing -> apply_via_local opts repo bundle + Just apply -> + do let (cmd, args) = breakCommand apply + pipeDoc cmd (args ++ [repo]) bundle + +apply_via_ssh :: [DarcsFlag] -> String -> Doc -> IO ExitCode +apply_via_ssh opts repo bundle = + pipeDocSSH addr ["darcs apply --all "++unwords (applyopts opts)++" --repodir '"++path++"'"] bundle + where (addr,':':path) = break (==':') repo + +apply_via_ssh_and_sudo :: String -> String -> Doc -> IO ExitCode +apply_via_ssh_and_sudo repo username bundle = + pipeDocSSH addr ["sudo -u "++username++ + " darcs apply --all --repodir '"++path++"'"] bundle + where (addr,':':path) = break (==':') repo + +applyopts :: [DarcsFlag] -> [String] +applyopts opts = if Debug `elem` opts then ["--debug"] else [] diff --git a/src/Darcs/RepoPath.hs b/src/Darcs/RepoPath.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/RepoPath.hs @@ -0,0 +1,251 @@ +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +-- Copyright (C) 2007 Eric Kow +-- +-- 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. + +-- | Various abstractions for dealing with paths. +module Darcs.RepoPath ( + -- * AbsolutePath + AbsolutePath, + makeAbsolute, + ioAbsolute, + rootDirectory, + -- * AbsolutePathOrStd + AbsolutePathOrStd, + makeAbsoluteOrStd, + ioAbsoluteOrStd, + useAbsoluteOrStd, + -- * AbsoluteOrRemotePath + AbsoluteOrRemotePath, + ioAbsoluteOrRemote, + isRemote, + -- * SubPath + SubPath, + makeSubPathOf, + simpleSubPath, + -- * Miscellaneous + sp2fn, + FilePathOrURL(..), + FilePathLike(toFilePath), + getCurrentDirectory, + setCurrentDirectory +) where + +import Data.List ( isPrefixOf, isSuffixOf ) +import Control.Exception ( bracket ) + +import Darcs.URL ( is_absolute, is_relative, is_ssh_nopath ) +import qualified Workaround ( getCurrentDirectory ) +import qualified System.Directory ( setCurrentDirectory ) +import System.Directory ( doesDirectoryExist ) +import qualified System.FilePath.Posix as FilePath ( normalise ) +import qualified System.FilePath as NativeFilePath ( takeFileName, takeDirectory ) +import qualified Darcs.Patch.FileName as PatchFileName ( FileName, fp2fn, fn2fp ) +#include "impossible.h" + +class FilePathOrURL a where + {-# INLINE toPath #-} + toPath :: a -> String + +class FilePathOrURL a => FilePathLike a where + {-# INLINE toFilePath #-} + toFilePath :: a -> FilePath + +-- | Paths which are relative to the local darcs repository and normalized. +-- Note: These are understood not to have the dot in front. +newtype SubPath = SubPath FilePath deriving (Eq, Ord) + +newtype AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord) + +-- | This is for situations where a string (e.g. a command line argument) +-- may take the value \"-\" to mean stdin or stdout (which one depends on +-- context) instead of a normal file path. +data AbsolutePathOrStd = AP AbsolutePath | APStd deriving (Eq, Ord) +data AbsoluteOrRemotePath = AbsP AbsolutePath | RmtP String deriving (Eq, Ord) + +instance FilePathOrURL AbsolutePath where + toPath (AbsolutePath x) = x +instance FilePathOrURL SubPath where + toPath (SubPath x) = x +instance CharLike c => FilePathOrURL [c] where + toPath = toFilePath + +instance FilePathOrURL AbsoluteOrRemotePath where + toPath (AbsP a) = toPath a + toPath (RmtP r) = r + +instance FilePathOrURL PatchFileName.FileName where + toPath = PatchFileName.fn2fp +instance FilePathLike PatchFileName.FileName where + toFilePath = PatchFileName.fn2fp + +instance FilePathLike AbsolutePath where + toFilePath (AbsolutePath x) = x +instance FilePathLike SubPath where + toFilePath (SubPath x) = x + +class CharLike c where + toChar :: c -> Char + fromChar :: Char -> c +instance CharLike Char where + toChar = id + fromChar = id + +instance CharLike c => FilePathLike [c] where + toFilePath = map toChar + +-- | Make the second path relative to the first, if possible +makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath +makeSubPathOf (AbsolutePath p1) (AbsolutePath p2) = + -- The slash prevents "foobar" from being treated as relative to "foo" + if p1 == p2 || (p1 ++ "/") `isPrefixOf` p2 + then Just $ SubPath $ drop (length p1 + 1) p2 + else Nothing + +simpleSubPath :: FilePath -> Maybe SubPath +simpleSubPath x | null x = bug "simpleSubPath called with empty path" + | is_relative x = Just $ SubPath $ FilePath.normalise $ pathToPosix x + | otherwise = Nothing + +-- | Interpret a possibly relative path wrt the current working directory. +ioAbsolute :: FilePath -> IO AbsolutePath +ioAbsolute dir = + do isdir <- doesDirectoryExist dir + here <- getCurrentDirectory + if isdir + then bracket (setCurrentDirectory dir) + (const $ setCurrentDirectory $ toFilePath here) + (const getCurrentDirectory) + else let super_dir = case NativeFilePath.takeDirectory dir of + "" -> "." + d -> d + file = NativeFilePath.takeFileName dir + in do abs_dir <- if dir == super_dir + then return $ AbsolutePath dir + else ioAbsolute super_dir + return $ makeAbsolute abs_dir file + +-- | Take an absolute path and a string representing a (possibly relative) +-- path and combine them into an absolute path. If the second argument is +-- already absolute, then the first argument gets ignored. This function also +-- takes care that the result is converted to Posix convention and +-- normalized. Also, parent directories (\"..\") at the front of the string +-- argument get canceled out against trailing directory parts of the +-- absolute path argument. +-- +-- Regarding the last point, someone more familiar with how these functions +-- are used should verify that this is indeed necessary or at least useful. +makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath +makeAbsolute a dir = if not (null dir) && is_absolute dir + then AbsolutePath (norm_slashes dir') + else ma a dir' + where + dir' = FilePath.normalise $ pathToPosix dir + -- Why do we care to reduce ".." here? + -- Why not do this throughout the whole path, i.e. "x/y/../z" -> "x/z" ? + ma here ('.':'.':'/':r) = ma (takeDirectory here) r + ma here ".." = takeDirectory here + ma here "." = here + ma here "" = here + ma here r = here /- ('/':r) + +(/-) :: AbsolutePath -> String -> AbsolutePath +x /- ('/':r) = x /- r +(AbsolutePath "/") /- r = AbsolutePath ('/':simpleClean r) +(AbsolutePath x) /- r = AbsolutePath (x++'/':simpleClean r) + +-- | Convert to posix, remove trailing slashes, and (under Posix) +-- reduce multiple leading slashes to one. +simpleClean :: String -> String +simpleClean = norm_slashes . reverse . dropWhile (=='/') . reverse . pathToPosix + +-- | The root directory as an absolute path. +rootDirectory :: AbsolutePath +rootDirectory = AbsolutePath "/" + +makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd +makeAbsoluteOrStd _ "-" = APStd +makeAbsoluteOrStd a p = AP $ makeAbsolute a p + +ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd +ioAbsoluteOrStd "-" = return APStd +ioAbsoluteOrStd p = AP `fmap` ioAbsolute p + +-- | Execute either the first or the second argument action, depending on +-- whether the given path is an 'AbsolutePath' or stdin/stdout. +useAbsoluteOrStd :: (AbsolutePath -> IO a) -> IO a -> AbsolutePathOrStd -> IO a +useAbsoluteOrStd _ f APStd = f +useAbsoluteOrStd f _ (AP x) = f x + +ioAbsoluteOrRemote :: String -> IO AbsoluteOrRemotePath +ioAbsoluteOrRemote p = do + isdir <- doesDirectoryExist p + if not isdir + then return $ RmtP $ + case () of _ | is_ssh_nopath p -> p++"." + | "/" `isSuffixOf` p -> init p + | otherwise -> p + else AbsP `fmap` ioAbsolute p + +isRemote :: AbsoluteOrRemotePath -> Bool +isRemote (RmtP _) = True +isRemote _ = False + +takeDirectory :: AbsolutePath -> AbsolutePath +takeDirectory (AbsolutePath x) = + case reverse $ drop 1 $ dropWhile (/='/') $ reverse x of + "" -> AbsolutePath "/" + x' -> AbsolutePath x' + +instance Show AbsolutePath where + show = show . toFilePath +instance Show SubPath where + show = show . toFilePath +instance Show AbsolutePathOrStd where + show (AP a) = show a + show APStd = "standard input/output" +instance Show AbsoluteOrRemotePath where + show (AbsP a) = show a + show (RmtP r) = show r + +-- | Normalize the path separator to Posix style (slash, not backslash). +-- This only affects Windows systems. +pathToPosix :: FilePath -> FilePath +pathToPosix = map convert where +#ifdef WIN32 + convert '\\' = '/' +#endif + convert c = c + +-- | Reduce multiple leading slashes to one. This only affects Posix systems. +norm_slashes :: FilePath -> FilePath +#ifndef WIN32 +-- multiple slashes in front are ignored under Posix +norm_slashes ('/':p) = '/' : dropWhile (== '/') p +#endif +norm_slashes p = p + +getCurrentDirectory :: IO AbsolutePath +getCurrentDirectory = AbsolutePath `fmap` Workaround.getCurrentDirectory + +setCurrentDirectory :: FilePathLike p => p -> IO () +setCurrentDirectory = System.Directory.setCurrentDirectory . toFilePath + +{-# INLINE sp2fn #-} +sp2fn :: SubPath -> PatchFileName.FileName +sp2fn = PatchFileName.fp2fn . toFilePath diff --git a/src/Darcs/Repository.hs b/src/Darcs/Repository.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository.hs @@ -0,0 +1,302 @@ +-- Copyright (C) 2002-2004 David Roundy +-- Copyright (C) 2005 Juliusz Chroboczek +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +#include "gadts.h" + +module Darcs.Repository ( Repository, ($-), maybeIdentifyRepository, + identifyRepositoryFor, + withRepoLock, withRepoReadLock, + withRepository, withRepositoryDirectory, withGutsOf, + makePatchLazy, writePatchSet, + findRepository, amInRepository, amNotInRepository, + slurp_pending, replacePristineFromSlurpy, + slurp_recorded, slurp_recorded_and_unrecorded, + withRecorded, + get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds, + get_unrecorded_in_files, get_unrecorded_in_files_unsorted, + read_repo, sync_repo, + prefsUrl, + add_to_pending, + tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending, + tentativelyReplacePatches, + tentativelyMergePatches, considerMergeToWorking, + revertRepositoryChanges, finalizeRepositoryChanges, + createRepository, copyRepository, copy_oldrepo_patches, + patchSetToRepository, + unrevertUrl, + applyToWorking, patchSetToPatches, + createPristineDirectoryTree, createPartialsPristineDirectoryTree, + optimizeInventory, cleanRepository, + checkPristineAgainstSlurpy, getMarkedupFile, + PatchSet, SealedPatchSet, PatchInfoAnd, + setScriptsExecutable, + checkUnrelatedRepos, + testTentative, testRecorded + ) where + +import System.Exit ( ExitCode(..), exitWith ) + +import Darcs.Repository.Internal + (Repository(..), RepoType(..), ($-), pristineFromWorking, + maybeIdentifyRepository, identifyRepositoryFor, + findRepository, amInRepository, amNotInRepository, + makePatchLazy, + slurp_pending, replacePristineFromSlurpy, + slurp_recorded, slurp_recorded_and_unrecorded, + withRecorded, + get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds, + get_unrecorded_in_files, get_unrecorded_in_files_unsorted, + read_repo, sync_repo, + prefsUrl, checkPristineAgainstSlurpy, + add_to_pending, + withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf, + tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending, + tentativelyReplacePatches, + tentativelyMergePatches, considerMergeToWorking, + revertRepositoryChanges, finalizeRepositoryChanges, + unrevertUrl, + applyToWorking, patchSetToPatches, + createPristineDirectoryTree, createPartialsPristineDirectoryTree, + optimizeInventory, cleanRepository, + getMarkedupFile, + setScriptsExecutable, + testTentative, testRecorded + ) +import Darcs.Repository.Cache ( unionCaches, fetchFileUsingCache, HashedDir(..) ) +import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) + +import Control.Monad ( unless, when ) +import Data.Either(Either(..)) +import System.Directory ( createDirectory ) +import System.IO.Error ( isAlreadyExistsError ) + +import qualified Darcs.Repository.DarcsRepo as DarcsRepo +import qualified Darcs.Repository.HashedRepo as HashedRepo + +import Darcs.Hopefully ( PatchInfoAnd, info, extractHash ) +import Darcs.Repository.Checkpoint ( identify_checkpoint, write_checkpoint_patch, get_checkpoint ) +import Darcs.Repository.ApplyPatches ( apply_patches ) +import Darcs.Repository.HashedRepo ( apply_to_tentative_pristine ) +import Darcs.Patch ( RepoPatch, Named, Patch, patch2patchinfo, apply ) +import Darcs.Ordered ( RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL, reverseRL, + concatRL, lengthRL, isShorterThanRL ) +import Darcs.Patch.Info ( PatchInfo ) +import Darcs.Repository.Format ( RepoProperty ( HashedInventory ), + create_repo_format, format_has, writeRepoFormat ) +import Darcs.Repository.Prefs ( write_default_prefs ) +import Darcs.Repository.Pristine ( createPristine, flagsToPristine ) +import Darcs.Patch.Depends ( get_patches_beyond_tag ) +import Darcs.SlurpDirectory ( empty_slurpy ) +import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn, prettyError ) +import Darcs.External ( copyFileOrUrl, Cachable(..) ) +import Progress ( debugMessage, tediousSize, + beginTedious, endTedious, progress ) +import Darcs.ProgressPatches (progressRLShowTags, progressFL) +import Darcs.Lock ( writeBinFile ) +import Darcs.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped ) + +import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral, + AllowUnrelatedRepos + ), + compression ) +import Darcs.Global ( darcsdir ) +#include "impossible.h" + +createRepository :: [DarcsFlag] -> IO () +createRepository opts = do + createDirectory darcsdir `catch` + (\e-> if isAlreadyExistsError e + then fail "Tree has already been initialized!" + else fail $ "Error creating directory `"++darcsdir++"'.") + let rf = create_repo_format opts + createPristine $ flagsToPristine opts rf + createDirectory $ darcsdir ++ "/patches" + createDirectory $ darcsdir ++ "/prefs" + write_default_prefs + writeRepoFormat rf (darcsdir++"/format") + if format_has HashedInventory rf + then writeBinFile (darcsdir++"/hashed_inventory") "" + else DarcsRepo.write_inventory "." ((NilRL:<:NilRL) :: PatchSet Patch C(())) -- YUCK! + +copyRepository :: RepoPatch p => Repository p C(r u t) -> IO () +copyRepository fromrepository@(Repo _ opts rf _) + | Partial `elem` opts && not (format_has HashedInventory rf) = + do isPartial <- copyPartialRepository fromrepository + unless (isPartial == IsPartial) $ copyFullRepository fromrepository + | otherwise = copyFullRepository fromrepository + +data PorNP = NotPartial | IsPartial + deriving ( Eq ) + +data RepoSort = Hashed | Old + +copyInventory :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO () +copyInventory fromrepo@(Repo fromdir opts rf (DarcsRepository _ cremote)) = do + repo@(Repo todir xx rf2 (DarcsRepository yy c)) <- identifyRepositoryFor fromrepo "." + let newrepo :: Repository p C(r u t) + newrepo = Repo todir xx rf2 (DarcsRepository yy (c `unionCaches` cremote)) + copyHashedHashed = HashedRepo.copy_repo newrepo opts fromdir + copyAnythingToOld r = withCurrentDirectory todir $ read_repo r >>= + DarcsRepo.write_inventory_and_patches opts + repoSort rfx | format_has HashedInventory rfx = Hashed + | otherwise = Old + case repoSort rf2 of + Hashed -> + if format_has HashedInventory rf + then copyHashedHashed + else withCurrentDirectory todir $ + do HashedRepo.revert_tentative_changes + patches <- read_repo fromrepo + let k = "Copying patch" + beginTedious k + tediousSize k (lengthRL $ concatRL patches) + let patches' = mapRL_RL (mapRL_RL (progress k)) patches + HashedRepo.write_tentative_inventory c (compression opts) patches' + endTedious k + HashedRepo.finalize_tentative_changes repo (compression opts) + Old -> case repoSort rf of + Hashed -> copyAnythingToOld fromrepo + _ -> copy_oldrepo_patches opts fromrepo todir + +copy_oldrepo_patches :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> FilePath -> IO () +copy_oldrepo_patches opts repository@(Repo dir _ _ _) out = do + Sealed patches <- DarcsRepo.read_repo opts "." :: IO (SealedPatchSet Patch) + mpi <- if Partial `elem` opts + -- FIXME this should get last pinfo *before* + -- desired tag... + then identify_checkpoint repository + else return Nothing + FlippedSeal scp <- return $ since_checkpoint mpi $ concatRL patches + DarcsRepo.copy_patches opts dir out $ mapRL info $ scp + where since_checkpoint :: Maybe PatchInfo + -> RL (PatchInfoAnd p) C(x y) -> FlippedSeal (RL (PatchInfoAnd p)) C(y) + since_checkpoint Nothing ps = flipSeal ps + since_checkpoint (Just ch) (hp:<:ps) + | ch == info hp = flipSeal $ hp :<: NilRL + | otherwise = (hp :<:) `mapFlipped` since_checkpoint (Just ch) ps + since_checkpoint _ NilRL = flipSeal NilRL + +copyPartialRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO PorNP +copyPartialRepository fromrepository@(Repo _ opts _ _) = do + mch <- get_checkpoint fromrepository :: IO (Maybe (Sealed (Named p C(x)))) + case mch of + Nothing -> do putStrLn "No checkpoint." + return NotPartial + Just (Sealed ch) -> + do copyInventory fromrepository + withRepoLock opts $- \torepository -> do + write_checkpoint_patch ch + local_patches <- read_repo torepository + let pi_ch = patch2patchinfo ch + FlippedSeal ps <- return $ get_patches_beyond_tag pi_ch local_patches + let needed_patches = reverseRL $ concatRL ps + apply opts ch `catch` + \e -> fail ("Bad checkpoint!\n" ++ prettyError e) + apply_patches opts needed_patches + debugMessage "Writing the pristine" + pristineFromWorking torepository + return IsPartial + +copyFullRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO () +copyFullRepository fromrepository@(Repo fromdir opts rffrom _) = do + copyInventory fromrepository + debugMessage "Copying prefs" + copyFileOrUrl opts (fromdir++"/"++darcsdir++"/prefs/prefs") (darcsdir++"/prefs/prefs") (MaxAge 600) + `catchall` return () + debugMessage "Grabbing lock in new repository..." + withRepoLock opts $- \torepository@(Repo _ _ rfto (DarcsRepository _ c)) -> + if format_has HashedInventory rffrom && format_has HashedInventory rfto + then do debugMessage "Writing working directory contents..." + createPristineDirectoryTree torepository "." + fetch_patches_if_necessary opts torepository + when (Partial `elem` opts) $ putStrLn $ + "--partial: hashed or darcs-2 repository detected, using --lazy instead" + else if format_has HashedInventory rfto + then do local_patches <- read_repo torepository + replacePristineFromSlurpy torepository empty_slurpy + let patchesToApply = progressFL "Applying patch" $ concatFL $ reverseRL $ + mapRL_RL reverseRL local_patches + sequence_ $ mapFL (apply_to_tentative_pristine c opts) $ bunchFL 100 patchesToApply + finalizeRepositoryChanges torepository + debugMessage "Writing working directory contents..." + createPristineDirectoryTree torepository "." + else do read_repo torepository >>= (apply_patches opts . reverseRL . concatRL) + debugMessage "Writing the pristine" + pristineFromWorking torepository + +-- | writePatchSet is like patchSetToRepository, except that it doesn't +-- touch the working directory or pristine cache. +writePatchSet :: RepoPatch p => PatchSet p C(x) -> [DarcsFlag] -> IO (Repository p C(r u t)) +writePatchSet patchset opts = do + maybeRepo <- maybeIdentifyRepository opts "." + let repo@(Repo _ _ rf2 (DarcsRepository _ c)) = + case maybeRepo of + Right r -> r + Left e -> bug ("Current directory not repository in writePatchSet: " ++ e) + debugMessage "Writing inventory" + if format_has HashedInventory rf2 + then do HashedRepo.write_tentative_inventory c (compression opts) patchset + HashedRepo.finalize_tentative_changes repo (compression opts) + else DarcsRepo.write_inventory_and_patches opts patchset + return repo + +-- | patchSetToRepository takes a patch set, and writes a new repository in the current directory +-- that contains all the patches in the patch set. This function is used when 'darcs get'ing a +-- repository with the --to-match flag and the new repository is not in hashed format. +-- This function does not (yet) work for hashed repositories. If the passed @DarcsFlag@s tell +-- darcs to create a hashed repository, this function will call @error@. +patchSetToRepository :: RepoPatch p => Repository p C(r1 u1 r1) -> PatchSet p C(x) + -> [DarcsFlag] -> IO (Repository p C(r u t)) +patchSetToRepository (Repo fromrepo _ rf _) patchset opts = do + when (format_has HashedInventory rf) $ -- set up sources and all that + do writeFile "_darcs/tentative_pristine" "" -- this is hokey + repox <- writePatchSet patchset opts + HashedRepo.copy_repo repox opts fromrepo + repo <- writePatchSet patchset opts + read_repo repo >>= (apply_patches opts . reverseRL . concatRL) + debugMessage "Writing the pristine" + pristineFromWorking repo + return repo + +checkUnrelatedRepos :: [DarcsFlag] -> [PatchInfo] -> PatchSet p C(x) -> PatchSet p C(x) -> IO () +checkUnrelatedRepos opts common us them + | AllowUnrelatedRepos `elem` opts || not (null common) + || concatRL us `isShorterThanRL` 5 || concatRL them `isShorterThanRL` 5 + = return () + | otherwise + = do yorn <- promptYorn ("Repositories seem to be unrelated. Proceed?") + when (yorn /= 'y') $ do putStrLn "Cancelled." + exitWith ExitSuccess + +-- | Unless a flag has been given in the first argument that tells darcs not to do so (--lazy, +-- --partial or --ephemeral), this function fetches all patches that the given repository has +-- with fetchFileUsingCache. This is used as a helper in copyFullRepository. +fetch_patches_if_necessary :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO () +fetch_patches_if_necessary opts torepository@(Repo _ _ _ (DarcsRepository _ c)) = + unless (Partial `elem` opts || Lazy `elem` opts || Ephemeral `elem` opts) $ + do putInfo "Copying patches, to get lazy repository hit ctrl-C..." + r <- read_repo torepository + let peekaboo :: PatchInfoAnd p C(x y) -> IO () + peekaboo x = case extractHash x of + Left _ -> return () + Right h -> fetchFileUsingCache c HashedPatchesDir h >> return () + sequence_ $ mapRL peekaboo $ progressRLShowTags "Copying patches" $ concatRL r + where putInfo = when (not $ Quiet `elem` opts) . putStrLn diff --git a/src/Darcs/Repository/ApplyPatches.hs b/src/Darcs/Repository/ApplyPatches.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/ApplyPatches.hs @@ -0,0 +1,50 @@ +-- Copyright (C) 2002-2005,2007 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Repository.ApplyPatches ( apply_patches, apply_patches_with_feedback ) where + +import Darcs.Patch ( Patchy, apply ) +import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) +import Darcs.Patch.Info ( human_friendly ) +import Darcs.Ordered ( FL(..), lengthFL, mapFL ) +import Darcs.Flags ( DarcsFlag ) +import Darcs.Utils ( putDocLnError ) +import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) +import Printer ( text ) + +apply_patches_with_feedback :: Patchy p => [DarcsFlag] -> String -> FL (PatchInfoAnd p) C(x y) -> IO () +apply_patches_with_feedback _ _ NilFL = return () +apply_patches_with_feedback opts k patches = + do beginTedious k + tediousSize k (lengthFL patches) + sequence_ $ mapFL apply_cautiously patches + endTedious k + where apply_cautiously :: Patchy p => PatchInfoAnd p C(a b) -> IO () + apply_cautiously hp = + do finishedOneIO k (show $ human_friendly $ info hp) + apply opts (hopefully hp) `catch` \e -> + do putDocLnError $ text "Unapplicable patch:" + putDocLnError $ human_friendly (info hp) + ioError e + +apply_patches :: Patchy p => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO () +apply_patches opts ps = apply_patches_with_feedback opts "Applying patch" ps diff --git a/src/Darcs/Repository/Cache.hs b/src/Darcs/Repository/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Cache.hs @@ -0,0 +1,276 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Repository.Cache ( + cacheHash, okayHash, takeHash, + Cache(..), CacheType(..), CacheLoc(..), WritableOrNot(..), + HashedDir(..), hashedDir, + unionCaches, cleanCaches, cleanCachesWithHint, + fetchFileUsingCache, speculateFileUsingCache, writeFileUsingCache, + findFileMtimeUsingCache, setFileMtimeUsingCache, peekInCache, + repo2cache, + writable, hashedFilePath, allHashedDirs + ) where + +import Control.Monad ( liftM, when, guard ) +import Data.List ( nub ) +import Data.Maybe ( listToMaybe ) +import System.Directory ( removeFile, doesFileExist, getDirectoryContents ) +import System.Posix ( setFileTimes ) +import System.Posix.Files ( linkCount, modificationTime, getSymbolicLinkStatus ) +import System.Posix.Types ( EpochTime ) +import System.IO ( hPutStrLn, stderr ) + +import Crypt.SHA256 ( sha256sum ) + +import ByteStringUtils ( gzWriteFilePS, linesPS ) +import qualified Data.ByteString as B (length, drop, ByteString ) +import qualified Data.ByteString.Char8 as BC (unpack) + +import SHA1 ( sha1PS ) +import System.Posix.Files ( createLink ) +import System.Directory ( createDirectoryIfMissing ) + +import Darcs.External ( gzFetchFilePS, fetchFilePS, speculateFileOrUrl, copyFileOrUrl, + Cachable( Cachable ) ) +import Darcs.Flags ( Compression( .. ) ) +import Darcs.Global ( darcsdir ) +import Darcs.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS ) +import Progress ( progressList, debugMessage, debugFail ) +import Darcs.SlurpDirectory ( undefined_time ) +import Darcs.URL ( is_file ) +import Darcs.Utils ( withCurrentDirectory, catchall ) + +data HashedDir = HashedPristineDir | HashedPatchesDir | HashedInventoriesDir +hashedDir :: HashedDir -> String +hashedDir HashedPristineDir = "pristine.hashed" +hashedDir HashedPatchesDir = "patches" +hashedDir HashedInventoriesDir = "inventories" + +allHashedDirs :: [HashedDir] +allHashedDirs = [HashedPristineDir, HashedPatchesDir, HashedInventoriesDir] + +data WritableOrNot = Writable | NotWritable deriving ( Show ) +data CacheType = Repo | Directory deriving ( Eq, Show ) +data CacheLoc = Cache !CacheType !WritableOrNot !String +newtype Cache = Ca [CacheLoc] -- abstract type for hiding cache + +instance Eq CacheLoc where + (Cache Repo _ a) == (Cache Repo _ b) = a == b + (Cache Directory _ a) == (Cache Directory _ b) = a == b + _ == _ = False +instance Show CacheLoc where + show (Cache Repo Writable a) = "thisrepo:" ++ a + show (Cache Repo NotWritable a) = "repo:" ++ a + show (Cache Directory Writable a) = "cache:" ++ a + show (Cache Directory NotWritable a) = "readonly:" ++ a +instance Show Cache where + show (Ca cs) = unlines $ map show cs + +unionCaches :: Cache -> Cache -> Cache +unionCaches (Ca a) (Ca b) = Ca (nub (a++b)) + +repo2cache :: String -> Cache +repo2cache r = Ca [Cache Repo NotWritable r] + +-- | 'cacheHash' computes the cache hash (i.e. filename) of a packed string. +cacheHash :: B.ByteString -> String +cacheHash ps = case show (B.length ps) of + x | l > 10 -> sha256sum ps + | otherwise -> take (10-l) (repeat '0') ++ x ++'-':sha256sum ps + where l = length x + +okayHash :: String -> Bool +okayHash s = length s == 40 || length s == 64 || length s == 75 + +takeHash :: B.ByteString -> Maybe (String, B.ByteString) +takeHash ps = do h <- listToMaybe $ linesPS ps + let v = BC.unpack h + guard $ okayHash v + Just (v, B.drop (B.length h) ps) + +checkHash :: String -> B.ByteString -> Bool +checkHash h s | length h == 40 = sha1PS s == h + | length h == 64 = sha256sum s == h + | length h == 75 = B.length s == read (take 10 h) && sha256sum s == drop 11 h + | otherwise = False + + +findFileMtimeUsingCache :: Cache -> HashedDir -> String -> IO EpochTime +findFileMtimeUsingCache (Ca cache) subdir f = mt cache + where mt [] = return undefined_time + mt (Cache Repo Writable r:_) = (modificationTime `fmap` + getSymbolicLinkStatus (r++"/"++darcsdir++"/"++(hashedDir subdir)++"/"++f)) + `catchall` return undefined_time + mt (_:cs) = mt cs + +setFileMtimeUsingCache :: Cache -> HashedDir -> String -> EpochTime -> IO () +setFileMtimeUsingCache (Ca cache) subdir f t = st cache + where st [] = return () + st (Cache Repo Writable r:_) = setFileTimes (r++"/"++darcsdir++"/"++(hashedDir subdir)++"/"++f) t t + `catchall` return () + st (_:cs) = st cs + +fetchFileUsingCache :: Cache -> HashedDir -> String -> IO (String, B.ByteString) +fetchFileUsingCache = fetchFileUsingCachePrivate Anywhere + +writable :: CacheLoc -> Bool +writable (Cache _ NotWritable _) = False +writable (Cache _ Writable _) = True + +-- | @hashedFilePath cachelocation subdir hash@ returns the physical filename of +-- hash @hash@ in the @subdir@ section of @cachelocation@. +hashedFilePath :: CacheLoc -> HashedDir -> String -> String +hashedFilePath (Cache Directory _ d) s f = d ++ "/" ++ (hashedDir s) ++ "/" ++ f +hashedFilePath (Cache Repo _ r) s f = + r ++ "/"++darcsdir++"/" ++ (hashedDir s) ++ "/" ++ f + +-- | @peekInCache cache subdir hash@ tells whether @cache@ and +-- contains an object with hash @hash@ in a writable position. +-- Florent: why do we want it to be in a writable position? +peekInCache :: Cache -> HashedDir -> String -> IO Bool +peekInCache (Ca cache) subdir f = cacheHasIt cache `catchall` return False + where cacheHasIt [] = return False + cacheHasIt (c:cs) | not $ writable c = cacheHasIt cs + | otherwise = do ex <- doesFileExist $ fn c + if ex then return True + else cacheHasIt cs + fn c = hashedFilePath c subdir f + +-- | @speculateFileUsingCache cache subdirectory name@ takes note that +-- the file @name@ is likely to be useful soon: pipelined downloads +-- will add it to the (low-priority) queue, for the rest it is a noop. +speculateFileUsingCache :: Cache -> HashedDir -> String -> IO () +speculateFileUsingCache c sd h = do debugMessage $ "Speculating on "++h + copyFileUsingCache OnlySpeculate c sd h + +data OrOnlySpeculate = ActuallyCopy | OnlySpeculate deriving ( Eq ) + +copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> String -> IO () +copyFileUsingCache oos (Ca cache) subdir f = + do debugMessage $ "I'm doing copyFileUsingCache on "++(hashedDir subdir)++"/"++f + Just stickItHere <- cacheLoc cache + createDirectoryIfMissing False (reverse $ dropWhile (/='/') $ reverse stickItHere) + sfuc cache stickItHere + `catchall` return () + where cacheLoc [] = return Nothing + cacheLoc (c:cs) | not $ writable c = cacheLoc cs + | otherwise = + do ex <- doesFileExist $ fn c + if ex then fail "Bug in darcs: This exception should be caught in speculateFileUsingCache" + else do othercache <- cacheLoc cs + case othercache of Just x -> return $ Just x + Nothing -> return $ Just (fn c) + sfuc [] _ = return () + sfuc (c:cs) out | not $ writable c = + if oos == OnlySpeculate + then speculateFileOrUrl (fn c) out + else copyFileOrUrl [] (fn c) out Cachable + | otherwise = sfuc cs out + fn c = hashedFilePath c subdir f + + +data FromWhere = LocalOnly | Anywhere deriving ( Eq ) + +fetchFileUsingCachePrivate :: FromWhere -> Cache -> HashedDir -> String -> IO (String, B.ByteString) +fetchFileUsingCachePrivate fromWhere (Ca cache) subdir f = + do when (fromWhere == Anywhere) $ copyFileUsingCache ActuallyCopy (Ca cache) subdir f + ffuc cache + `catchall` debugFail ("Couldn't fetch `"++f++"'\nin subdir "++(hashedDir subdir)++ + " from sources:\n\n"++show (Ca cache)) + where ffuc (c:cs) + | not (writable c) && (Anywhere == fromWhere || is_file (fn c)) = + do debugMessage $ "In fetchFileUsingCachePrivate I'm going manually" + debugMessage $ " getting "++f + debugMessage $ " from " ++ fn c + x <- gzFetchFilePS (fn c) Cachable + if not $ checkHash f x + then do x' <- fetchFilePS (fn c) Cachable + when (not $ checkHash f x') $ + do hPutStrLn stderr $ "Hash failure in " ++ fn c + fail $ "Hash failure in " ++ fn c + return (fn c, x') + else return (fn c, x) -- FIXME: create links in caches + `catchall` ffuc cs + + | writable c = + do x1 <- gzFetchFilePS (fn c) Cachable + x <- if not $ checkHash f x1 + then do x2 <- fetchFilePS (fn c) Cachable + when (not $ checkHash f x2) $ + do hPutStrLn stderr $ "Hash failure in " ++ fn c + removeFile $ fn c + fail $ "Hash failure in " ++ fn c + return x2 + else return x1 + mapM_ (tryLinking (fn c)) cs + return (fn c, x) + `catchall` do (fname,x) <- ffuc cs + do createCache c subdir + createLink fname (fn c) + return (fn c, x) + `catchall` + do gzWriteFilePS (fn c) x `catchall` return () + return (fname,x) + | otherwise = ffuc cs + + ffuc [] = debugFail $ "No sources from which to fetch file `"++f++"'\n"++ show (Ca cache) + + tryLinking ff c@(Cache Directory Writable d) = + do createDirectoryIfMissing False (d++"/"++(hashedDir subdir)) + createLink ff (fn c) + `catchall` return () + tryLinking _ _ = return () + fn c = hashedFilePath c subdir f + +createCache :: CacheLoc -> HashedDir -> IO () +createCache (Cache Directory _ d) subdir = + createDirectoryIfMissing True (d ++ "/" ++ (hashedDir subdir)) +createCache _ _ = return () + +-- | @write compression filename content@ writes @content@ to the file @filename@ according +-- to the policy given by @compression@. +write :: Compression -> String -> B.ByteString -> IO () +write NoCompression = writeAtomicFilePS +write GzipCompression = gzWriteAtomicFilePS + +-- | @writeFileUsingCache cache compression subdir contents@ write the string @contents@ to +-- the directory subdir, except if it is already in the cache, in which case it is a noop. +-- Warning (?) this means that in case of a hash collision, writing using writeFileUsingCache is +-- a noop. The returned value is the filename that was given to the string. +writeFileUsingCache :: Cache -> Compression -> HashedDir -> B.ByteString -> IO String +writeFileUsingCache (Ca cache) compr subdir ps = + (fetchFileUsingCachePrivate LocalOnly (Ca cache) subdir hash >> return hash) `catchall` + wfuc cache `catchall` + debugFail ("Couldn't write `"++hash++"'\nin subdir "++(hashedDir subdir)++" to sources:\n\n"++ + show (Ca cache)) + where hash = cacheHash ps + wfuc (c:cs) | not $ writable c = wfuc cs + | otherwise = do createCache c subdir + write compr (fn c) ps -- FIXME: create links in caches + return hash + wfuc [] = debugFail $ "No location to write file `" ++ (hashedDir subdir) ++"/"++hash ++ "'" + fn c = hashedFilePath c subdir hash + +cleanCaches :: Cache -> HashedDir -> IO () +cleanCaches c d = cleanCachesWithHint' c d Nothing + +cleanCachesWithHint :: Cache -> HashedDir -> [String] -> IO () +cleanCachesWithHint c d h = cleanCachesWithHint' c d (Just h) + +cleanCachesWithHint' :: Cache -> HashedDir -> Maybe [String] -> IO () +cleanCachesWithHint' (Ca cs) subdir hint = mapM_ cleanCache cs + where cleanCache (Cache Directory Writable d) = + (withCurrentDirectory (d++"/"++(hashedDir subdir)) $ + do fs' <- getDirectoryContents "." + let fs = case hint of + Just h -> h + Nothing -> fs' + mapM_ clean $ progressList ("Cleaning cache "++d++"/"++(hashedDir subdir)) $ + filter okayHash fs) `catchall` return () + cleanCache _ = return () + clean f = do lc <- linkCount `liftM` getSymbolicLinkStatus f + when (lc < 2) $ removeFile f + `catchall` return () diff --git a/src/Darcs/Repository/Checkpoint.hs b/src/Darcs/Repository/Checkpoint.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Checkpoint.hs @@ -0,0 +1,174 @@ +-- Copyright (C) 2002-2005 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Repository.Checkpoint ( get_checkpoint, get_checkpoint_by_default, + identify_checkpoint, + write_checkpoint, write_recorded_checkpoint, + write_checkpoint_patch, + ) where + +import System.Directory ( setCurrentDirectory, createDirectoryIfMissing ) +import Workaround ( getCurrentDirectory ) +import System.IO.Unsafe ( unsafeInterleaveIO ) +import Data.Maybe ( listToMaybe, catMaybes ) +import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) +import qualified Data.ByteString as B ( null, empty, ByteString ) + +import Darcs.Lock ( withTempDir, writeDocBinFile ) +import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, mmap_slurp, ) +import Darcs.Patch ( RepoPatch, Patch, Named, Prim, invertRL, patch2patchinfo, + apply_to_slurpy, patchcontents, + effect, fromPrims, + is_setpref, infopatch, + readPatch, + gzWritePatch + ) +import Darcs.Ordered ( RL(..), FL(..), EqCheck(IsEq,NotEq), + (+>+), filterFL, unsafeCoerceP, + mapRL, mapFL_FL, mapRL_RL, reverseRL, concatRL, concatFL ) +import Darcs.Repository.Internal ( Repository(..), read_repo, slurp_recorded, withRecorded ) +import Darcs.Repository.ApplyPatches ( apply_patches ) +import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo, + showPatchInfo + ) +import Darcs.Diff ( unsafeDiff ) +import Darcs.External ( gzFetchFilePS, fetchFilePS, Cachable(..) ) +import Darcs.Flags ( DarcsFlag(LookForAdds, Partial, Complete ) ) +import Darcs.Patch.Depends ( get_patches_beyond_tag, get_patches_in_tag ) +import Darcs.Repository.Prefs ( filetype_function ) +import Darcs.Utils ( catchall ) +import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) +import Darcs.Global ( darcsdir ) +import Printer ( Doc, ($$), empty ) +#include "impossible.h" +import Darcs.Sealed ( Sealed(Sealed), FlippedSeal(..), Sealed2(Sealed2), seal, seal2 ) +import Control.Monad ( liftM ) + +read_patch_ids :: B.ByteString -> [PatchInfo] +read_patch_ids inv | B.null inv = [] +read_patch_ids inv = case readPatchInfo inv of + Just (pinfo,r) -> pinfo : read_patch_ids r + Nothing -> [] + +read_checkpoints :: String -> IO [(PatchInfo, Maybe Slurpy)] +read_checkpoints d = do + realdir <- toPath `fmap` ioAbsoluteOrRemote d + pistr <- fetchFilePS (realdir++"/"++darcsdir++"/checkpoints/inventory") Uncachable + `catchall` return B.empty + pis <- return $ reverse $ read_patch_ids pistr + slurpies <- sequence $ map (fetch_checkpoint realdir) pis + return $ zip pis slurpies + where fetch_checkpoint r pinfo = + unsafeInterleaveIO $ do + pstr <- gzFetchFilePS + (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable + case fst `fmap` (readPatch pstr :: Maybe (Sealed (Named Patch C(x)), B.ByteString)) of + Nothing -> return Nothing + Just (Sealed p) -> return $ apply_to_slurpy p empty_slurpy + +get_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x)))) +get_checkpoint repository@(Repo _ opts _ _) = if Partial `elem` opts + then get_check_internal repository + else return Nothing + +get_checkpoint_by_default :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x)))) +get_checkpoint_by_default repository@(Repo _ opts _ _) = if Complete `elem` opts + then return Nothing + else get_check_internal repository + +identify_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe PatchInfo) +identify_checkpoint repository@(Repo r _ _ _) = do + pis <- (map sp2i . catMaybes . mapRL lastRL) `liftM` read_repo repository + pistr <- fetchFilePS (r++"/"++darcsdir++"/checkpoints/inventory") Uncachable + `catchall` return B.empty + return $ listToMaybe $ filter (`elem` pis) $ reverse $ read_patch_ids pistr + where lastRL :: RL a C(x y) -> Maybe (Sealed2 a) + lastRL as = do Sealed ps <- headFL (reverseRL as) + return $ seal2 ps + headFL :: FL a C(x y) -> Maybe (Sealed (a C(x))) + headFL (x:>:_) = Just $ seal x + headFL NilFL = Nothing + sp2i :: Sealed2 (PatchInfoAnd p) -> PatchInfo + sp2i (Sealed2 p) = info p + +get_check_internal :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x)))) +get_check_internal repository@(Repo r _ _ _) = do + mc <- identify_checkpoint repository + case mc of + Nothing -> return Nothing + Just pinfo -> do ps <- gzFetchFilePS + (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable + return $ case readPatch ps of + Just (p, _) -> Just p + Nothing -> Nothing + +format_inv :: [PatchInfo] -> Doc +format_inv [] = empty +format_inv (pinfo:ps) = showPatchInfo pinfo + $$ format_inv ps + +write_recorded_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO () +write_recorded_checkpoint r@(Repo _ _ _ _) pinfo = do + Sealed ps <- (seal . mapFL_FL hopefully.reverseRL.concatRL) `liftM` read_repo r + ftf <- filetype_function + s <- slurp_recorded r + write_checkpoint_patch $ infopatch pinfo + (fromPrims $ changepps ps +>+ unsafeDiff [LookForAdds] ftf empty_slurpy s :: Patch C(() y)) + where changeps = filterFL is_setprefFL . + effect . patchcontents + changepps = concatFL . mapFL_FL changeps + +is_setprefFL :: Prim C(x y) -> EqCheck C(x y) +is_setprefFL p | is_setpref p = NotEq + | otherwise = unsafeCoerceP IsEq + +write_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO () +write_checkpoint repo@(Repo _ _ _ _) pinfo = do + repodir <- getCurrentDirectory + Sealed pit <- get_patches_in_tag pinfo `liftM` read_repo repo + let ps = (reverseRL.mapRL_RL hopefully.concatRL) pit + ftf <- filetype_function + with_tag repo pinfo $ do + s <- mmap_slurp "." + setCurrentDirectory repodir + write_checkpoint_patch $ infopatch pinfo $ + (fromPrims $ changepps ps +>+ unsafeDiff [LookForAdds] ftf empty_slurpy s :: Patch C(() y)) + where changeps = filterFL is_setprefFL . + effect . patchcontents + changepps = concatFL . mapFL_FL changeps + +write_checkpoint_patch :: RepoPatch p => Named p C(x y) -> IO () +write_checkpoint_patch p = + do createDirectoryIfMissing False (darcsdir++"/checkpoints") + gzWritePatch (darcsdir++"/checkpoints/"++make_filename (patch2patchinfo p)) p + cpi <- (map fst) `fmap` read_checkpoints "." + writeDocBinFile (darcsdir++"/checkpoints/inventory") + $ format_inv $ reverse $ patch2patchinfo p:cpi + +with_tag :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> (IO ()) -> IO () +with_tag r pinfo job = do + ps <- read_repo r + case get_patches_beyond_tag pinfo ps of + FlippedSeal (extras :<: NilRL) -> withRecorded r (withTempDir "checkpoint") $ \_ -> do + apply_patches [] $ invertRL extras + job + _ -> bug "with_tag" diff --git a/src/Darcs/Repository/DarcsRepo.lhs b/src/Darcs/Repository/DarcsRepo.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/DarcsRepo.lhs @@ -0,0 +1,344 @@ +% Copyright (C) 2002-2005,2007-2008 David Roundy +% +% 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. + +\chapter{DarcsRepo format} + +A repository consists of a working directory, which has within it a +directory called \verb!_darcs!. There must also be a subdirectory within +\verb!_darcs! named \verb!patches!. The \verb!patches! directory contains +the actual patches which are in the repository. There must also be a +\emph{pristine tree}, which may either be a directory containing a cache of +the version of the tree which has been recorded, or a stub, and may be +named either ``current'' or ``pristine''. + +\emph{WARNING!} Viewing files in the pristine cache is perfectly +acceptable, but if you view them with an editor (e.g.\ vi or Emacs), that +editor may create temporary files in the pristine tree +(\verb|_darcs/pristine/| or \verb|_darcs/current/|), which will temporarily +cause your repository to be inconsistent. So \emph{don't record any +patches while viewing files in \_darcs/current with an editor!} A better +plan would be to restrict yourself to viewing these files with a pager such +as more or less. + +Also within \verb!_darcs! is the \verb!inventory! file, which lists all the +patches that are in the repository. Moreover, it also gives the order of the +representation of the patches as they are stored. Given a source of patches, +i.e.\ any other set of repositories which have between them all the patches +contained in a given repository, that repository can be reproduced based on only the +information in the \verb!inventory! file. Under those circumstances, the +order of the patches specified in the \verb!inventory! file would be +unimportant, as this order is only needed to provide context for the +interpretation of the stored patches in this repository. + +\begin{code} +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +#include "gadts.h" + +module Darcs.Repository.DarcsRepo ( write_inventory, write_inventory_and_patches, + add_to_inventory, add_to_tentative_pristine, + add_to_tentative_inventory, remove_from_tentative_inventory, + finalize_tentative_changes, finalize_pristine_changes, + revert_tentative_changes, + read_repo, read_tentative_repo, write_and_read_patch, + copy_patches + ) where + +import System.Directory ( doesDirectoryExist, createDirectoryIfMissing ) +import Workaround ( renameFile ) +import Darcs.Utils ( clarify_errors ) +import Progress ( debugMessage, beginTedious, endTedious, finishedOneIO ) +import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) +import System.IO ( hPutStrLn, stderr ) +import System.IO.Unsafe ( unsafeInterleaveIO ) +import Control.Monad ( liftM, when, unless ) +import Darcs.Hopefully ( Hopefully, PatchInfoAnd, + patchInfoAndPatch, info, + actually, hopefully, unavailable, n2pia ) +import Darcs.SignalHandler ( withSignalsBlocked ) + +import ByteStringUtils ( gzReadFilePS ) +import qualified Data.ByteString as B (ByteString, null, readFile, empty) +import qualified Data.ByteString.Char8 as BC (break, pack) + +import Darcs.SlurpDirectory ( Slurpy, empty_slurpy ) +import Darcs.Patch ( RepoPatch, Effect, Prim, Named, Patch, invert, + effect, + patch2patchinfo, + apply_to_slurpy, + readPatch, + writePatch, gzWritePatch, showPatch ) +import Darcs.Ordered ( FL(..), RL(..), (:<)(..), + reverseFL, mapFL, unsafeCoerceP, + reverseRL, concatRL, mapRL, mapRL_RL ) +import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo, + showPatchInfo, is_tag + ) +import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) +import Darcs.External ( gzFetchFilePS, fetchFilePS, copyFilesOrUrls, Cachable(..), + cloneFile ) +import Darcs.Lock ( writeBinFile, writeDocBinFile, appendDocBinFile, appendBinFile ) +import Darcs.Flags ( DarcsFlag( NoCompress ) ) +import Darcs.Patch.Depends ( slightly_optimize_patchset, commute_to_end, deep_optimize_patchset ) +import Darcs.Repository.Pristine ( identifyPristine, applyPristine ) +import Darcs.Global ( darcsdir ) +import Darcs.Utils ( catchall ) +import Darcs.ProgressPatches ( progressFL ) +import Printer ( text, (<>), Doc, ($$), empty ) +import Darcs.Sealed ( Sealed(Sealed), seal, unseal ) +\end{code} + +There is a very special patch which may be stored in \verb!patches! which +is called `pending'. This patch describes any changes which have not yet +been recorded, and cannot be determined by a simple diff. For example, file +additions or renames are placed in pending until they are recorded. +Similarly, token replaces are stored in pending until they are recorded. + +\begin{code} +write_patch :: RepoPatch p => [DarcsFlag] -> Named p C(x y) -> IO FilePath +write_patch opts p = + do let writeFun = if NoCompress `elem` opts + then writePatch + else gzWritePatch + pname = darcsdir++"/patches/"++make_filename (patch2patchinfo p) + writeFun pname p + return pname + +write_and_read_patch :: RepoPatch p => [DarcsFlag] -> PatchInfoAnd p C(x y) + -> IO (PatchInfoAnd p C(x y)) +write_and_read_patch opts p = do fn <- write_patch opts $ hopefully p + unsafeInterleaveIO $ parse fn + where parse fn = do debugMessage ("Reading patch file: "++ fn) + ps <- gzReadFilePS fn + Sealed pp <- case readPatch ps of + Just (x,_) -> return x + Nothing -> fail ("Couldn't parse patch file "++fn) + return $ n2pia $ unsafeCoerceP pp + +--format_inventory is not exported for use outside of the DarcsRepo module +--itself. +format_inventory :: [PatchInfo] -> Doc +format_inventory [] = empty +format_inventory (pinfo:ps) = showPatchInfo pinfo $$ format_inventory ps + +write_inventory :: RepoPatch p => FilePath -> PatchSet p C(x) -> IO () +-- Note that write_inventory optimizes the inventory it writes out by +-- checking on tag dependencies. +-- FIXME: There is also a problem that write_inventory always writes +-- out the entire inventory, including the parts that you haven't +-- changed... +write_inventory dir ps = withSignalsBlocked $ do + createDirectoryIfMissing False (dir++"/"++darcsdir++"/inventories") + simply_write_inventory "inventory" dir $ slightly_optimize_patchset ps + +simply_write_inventory :: RepoPatch p => String -> FilePath -> PatchSet p C(x) -> IO () +simply_write_inventory name dir NilRL = + writeBinFile (dir++"/"++darcsdir++"/"++name) "" +simply_write_inventory name dir (ps:<:NilRL) = do + writeDocBinFile (dir++"/"++darcsdir++"/"++name) $ format_inventory $ mapFL info $ reverseRL ps +simply_write_inventory _ _ (NilRL:<:_) = + fail $ "Bug in simply_write_inventory, please report!" +simply_write_inventory name dir (ps:<:pss) = do + tagname <- return $ make_filename $ last $ mapRL info ps + simply_write_inventory ("inventories/"++tagname) dir pss + writeDocBinFile (dir++"/"++darcsdir++"/"++name) $ text "Starting with tag:" + $$ format_inventory (mapFL info $ reverseRL ps) + +write_inventory_and_patches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> IO () +write_inventory_and_patches opts ps = do write_inventory "." ps + sequence_ $ mapRL (write_patch opts . hopefully) $ concatRL ps + +add_to_inventory :: FilePath -> [PatchInfo] -> IO () +add_to_inventory dir pinfos = + appendDocBinFile (dir++"/"++darcsdir++"/inventory") $ text "\n" <> pidocs pinfos + where + pidocs [] = text "" + pidocs (p:ps) = showPatchInfo p $$ pidocs ps + +add_to_tentative_inventory :: forall p C(x y). RepoPatch p => [DarcsFlag] -> Named p C(x y) -> IO FilePath +add_to_tentative_inventory opts p = + do appendDocBinFile (darcsdir++"/tentative_inventory") $ text "\n" + <> showPatchInfo (patch2patchinfo p) + when (is_tag $ patch2patchinfo p) $ + do debugMessage "Optimizing the tentative inventory, since we're adding a tag." + realdir <- toPath `fmap` ioAbsoluteOrRemote "." + let k = "Reading tentative inventory" + beginTedious k + Sealed ps <- read_repo_private k opts realdir "tentative_inventory" + :: IO (SealedPatchSet p) + simply_write_inventory "tentative_inventory" "." $ slightly_optimize_patchset ps + write_patch opts p + +add_to_tentative_pristine :: Effect p => p C(x y) -> IO () +add_to_tentative_pristine p = + do -- Sealed p <- (fst . fromJust . readPatchCarefully) `fmap` gzReadFilePS fp + appendDocBinFile (darcsdir++"/tentative_pristine") $ showPatch (effect p) -- FIXME: this is inefficient! + appendBinFile (darcsdir++"/tentative_pristine") "\n" + +remove_from_tentative_inventory :: RepoPatch p => Bool -> [DarcsFlag] -> FL (Named p) C(x y) -> IO () +remove_from_tentative_inventory update_pristine opts to_remove = + do finalize_tentative_changes + Sealed allpatches <- read_repo opts "." + skipped :< unmodified <- return $ commute_to_end (unsafeCoerceP to_remove) allpatches + sequence_ $ mapFL (write_patch opts) skipped + write_inventory "." $ deep_optimize_patchset + $ mapRL_RL n2pia (reverseFL skipped) :<: unmodified + remove_from_checkpoint_inventory to_remove + when update_pristine $ + do pris <- identifyPristine + repairable $ applyPristine pris + $ progressFL "Applying inverse to pristine" $ invert to_remove + revert_tentative_changes + +finalize_tentative_changes :: IO () +finalize_tentative_changes = renameFile (darcsdir++"/tentative_inventory") (darcsdir++"/inventory") + +finalize_pristine_changes :: IO () +finalize_pristine_changes = + do Sealed ps <- read_patches $ darcsdir++"/tentative_pristine" + pris <- identifyPristine + repairable $ applyPristine pris ps + where + read_patches :: String -> IO (Sealed (FL Prim C(x))) + read_patches f = do ps <- B.readFile f + return $ case readPatch ps of + Just (x, _) -> x + Nothing -> seal $ NilFL + +repairable :: IO a -> IO a +repairable x = x `clarify_errors` unlines + ["Your repository is now in an inconsistent state.", + "This must be fixed by running darcs repair."] + +revert_tentative_changes :: IO () +revert_tentative_changes = + do cloneFile (darcsdir++"/inventory") (darcsdir++"/tentative_inventory") + writeBinFile (darcsdir++"/tentative_pristine") "" + +copy_patches :: [DarcsFlag] -> FilePath -> FilePath -> [PatchInfo] -> IO () +copy_patches opts dir out patches = do + realdir <- toPath `fmap` ioAbsoluteOrRemote dir + copyFilesOrUrls opts (realdir++"/"++darcsdir++"/patches") (map make_filename patches) + (out++"/"++darcsdir++"/patches") Cachable + +read_repo :: RepoPatch p => [DarcsFlag] -> String -> IO (SealedPatchSet p) +read_repo opts d = do + realdir <- toPath `fmap` ioAbsoluteOrRemote d + let k = "Reading inventory of repository "++d + beginTedious k + read_repo_private k opts realdir "inventory" `catch` + (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) + ioError e) + +read_tentative_repo :: RepoPatch p => [DarcsFlag] -> String -> IO (SealedPatchSet p) +read_tentative_repo opts d = do + realdir <- toPath `fmap` ioAbsoluteOrRemote d + let k = "Reading tentative inventory of repository "++d + beginTedious k + read_repo_private k opts realdir "tentative_inventory" `catch` + (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) + ioError e) + +read_repo_private :: RepoPatch p => String -> [DarcsFlag] -> FilePath -> FilePath -> IO (SealedPatchSet p) +read_repo_private k opts d iname = do + i <- gzFetchFilePS (d++"/"++darcsdir++"/"++iname) Uncachable + finishedOneIO k iname + (rest,str) <- case BC.break ((==) '\n') i of + (swt,pistr) | swt == BC.pack "Starting with tag:" -> + do r <- rr $ head $ read_patch_ids pistr + return (r,pistr) + _ -> do endTedious k + return (seal NilRL,i) + pis <- return $ reverse $ read_patch_ids str + isdir <- doesDirectoryExist d + let parse f = let fn = d ++ "/"++darcsdir++"/patches/" ++ make_filename f + in if isdir then parse_local fn + else parse_remote fn + lift2Sealed (:<:) (return rest) (read_patches parse pis) + where rr pinfo = unsafeInterleaveIO $ read_repo_private k opts d $ + "inventories/"++make_filename pinfo + -- parse_remote should really download to a temporary file removed + -- at exit + parse_remote, parse_local :: RepoPatch p => String -> IO (Sealed (Hopefully (Named p) C(x))) + parse_remote fn = do ps <- gzFetchFilePS fn Cachable + return $ hopefullyNoParseError fn (readPatch ps) + parse_local fn = do ps <- gzReadFilePS fn + return $ hopefullyNoParseError fn (readPatch ps) + hopefullyNoParseError :: String -> Maybe (Sealed (a C(x)), b) -> Sealed (Hopefully a C(x)) + hopefullyNoParseError _ (Just (Sealed x, _)) = seal $ actually x + hopefullyNoParseError s Nothing = seal $ unavailable $ "Couldn't parse file "++s + read_patches :: RepoPatch p => (FORALL(b) PatchInfo -> IO (Sealed (Hopefully (Named p) C(b)))) + -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd p) C(x))) + read_patches _ [] = return $ seal NilRL + read_patches parse (i:is) = + lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest) + (read_patches parse is) + (parse i `catch` \e -> return $ seal $ unavailable $ show e) + lift2Sealed :: (FORALL(y z) q C(y z) -> p C(x y) -> r C(x z)) + -> IO (Sealed (p C(x))) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed (r C(x))) + lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap` unsafeInterleaveIO iox + Sealed y <- unseal seal `fmap` unsafeInterleaveIO ioy + return $ seal $ f y x + +read_patch_ids :: B.ByteString -> [PatchInfo] +read_patch_ids inv | B.null inv = [] +read_patch_ids inv = case readPatchInfo inv of + Just (pinfo,r) -> pinfo : read_patch_ids r + Nothing -> [] + +read_checkpoints :: String -> IO [(PatchInfo, Maybe Slurpy)] +read_checkpoints d = do + realdir <- toPath `fmap` ioAbsoluteOrRemote d + pistr <- fetchFilePS (realdir++"/"++darcsdir++"/checkpoints/inventory") Uncachable + `catchall` return B.empty + pis <- return $ reverse $ read_patch_ids pistr + slurpies <- sequence $ map (fetch_checkpoint realdir) pis + return $ zip pis slurpies + where fetch_checkpoint r pinfo = + unsafeInterleaveIO $ do + pstr <- gzFetchFilePS + (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable + case fst `liftM` readPatch_ pstr of + Nothing -> return Nothing + Just (Sealed p) -> return $ apply_to_slurpy p empty_slurpy + readPatch_ :: B.ByteString -> Maybe (Sealed (Named Patch C(x)), B.ByteString) + readPatch_ = readPatch + +remove_from_checkpoint_inventory :: RepoPatch p => FL (Named p) C(x y) -> IO () +remove_from_checkpoint_inventory ps = do + -- only tags can be checkpoints + let pinfos = filter is_tag $ mapFL patch2patchinfo ps + unless (null pinfos) $ do + createDirectoryIfMissing False (darcsdir++"/checkpoints") + cpi <- (map fst) `liftM` read_checkpoints "." + writeDocBinFile (darcsdir++"/checkpoints/inventory") $ + format_inventory $ reverse $ filter (`notElem` pinfos) cpi +\end{code} + +The \verb!_darcs! directory also contains a directory called +``\verb!prefs!'', which is described in Chapter~\ref{configuring}. + +\begin{comment} +\section{Getting interesting info on change history} + +One can query the repository for the entire markup history of a file. This +provides a data structure which contains a history of \emph{all} the +revisions ever made on a given file. + +\end{comment} + diff --git a/src/Darcs/Repository/Format.hs b/src/Darcs/Repository/Format.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Format.hs @@ -0,0 +1,153 @@ +-- Copyright (C) 2005 David Roundy +-- +-- This file is licensed under the GPL, version two or later. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Repository.Format ( RepoFormat(..), RepoProperty(..), identifyRepoFormat, + create_repo_format, writeRepoFormat, + write_problem, read_problem, readfrom_and_writeto_problem, + format_has, format_has_together, + ) where + +import Data.List ( sort ) +import Data.Maybe ( isJust, catMaybes ) +import Control.Monad ( msum ) + +import Darcs.SignalHandler ( catchNonSignal ) +import Darcs.External ( fetchFilePS, Cachable( Cachable ) ) +import Darcs.Flags ( DarcsFlag ( UseFormat2, UseHashedInventory, + UseOldFashionedInventory ) ) +import Darcs.Lock ( writeBinFile ) +import Darcs.Utils ( catchall, prettyException ) +import Progress ( beginTedious, endTedious, finishedOneIO ) +import Darcs.Global ( darcsdir ) + +import ByteStringUtils ( linesPS ) +import qualified Data.ByteString.Char8 as BC (split, unpack, singleton, elemIndex, pack) +import qualified Data.ByteString as B (ByteString, null, empty) +import qualified ByteStringUtils as BU ( intercalate ) + +#include "impossible.h" + +data RepoProperty = Darcs1_0 | Darcs2 | HashedInventory + +-- | @RepoFormat@ is the representation of the format of a +-- repository. Each sublist corresponds to a line in the format +-- file. Each line is decomposed into words. +newtype RepoFormat = RF [[B.ByteString]] deriving ( Show ) + +-- | The file where the format information should be. +df :: FilePath +df = darcsdir++"/format" + +-- | @identifyRepoFormat URL@ identifies the format of the repository +-- at the given address. Return @Left reason@ if it fails, where +-- @reason@ explains why we weren't able to identify the format. +identifyRepoFormat :: String -> IO (Either String RepoFormat) +identifyRepoFormat repo = + do let k = "Identifying repository "++repo + beginTedious k + finishedOneIO k "format" + dff <- fetchFilePS (repo ++ "/" ++ df) Cachable `catchall` return B.empty + -- below is a workaround for servers that don't return a 404 on nonexistent files + rf <- if B.null dff || isJust (BC.elemIndex '<' dff) + then do finishedOneIO k "inventory" + have_inventory <- doesRemoteFileExist (repo++"/"++darcsdir++"/inventory") + case have_inventory of + Right _ -> return $ Right default_repo_format + Left e -> return $ Left $ "Not a repository: "++repo++" ("++e++")" + else return $ Right $ parse_repo_format dff + endTedious k + return rf + where drfe x = fetchFilePS x Cachable >> return True + doesRemoteFileExist x = (fmap Right) (drfe x) `catchNonSignal` + (\e -> return (Left (prettyException e))) + +-- | @writeRepoFormat@ writes the repo format to the given file. +writeRepoFormat :: RepoFormat -> FilePath -> IO () +writeRepoFormat (RF rf) loc = writeBinFile loc $ unlines $ + map (BC.unpack . BU.intercalate (BC.singleton '|')) rf + +parse_repo_format :: B.ByteString -> RepoFormat +parse_repo_format ps = + RF $ map (BC.split '|') $ filter (not . B.null) $ linesPS ps + +-- | The repo format we assume if we do not find a format file. +default_repo_format :: RepoFormat +default_repo_format = RF [[rp2ps Darcs1_0]] + +create_repo_format :: [DarcsFlag] -> RepoFormat +create_repo_format fs = RF ([map rp2ps flags2inv] ++ maybe2) + where flags2inv | UseFormat2 `elem` fs = [HashedInventory] + | UseHashedInventory `elem` fs = [HashedInventory] + | UseOldFashionedInventory `elem` fs = [Darcs1_0] + | otherwise = [HashedInventory] + maybe2 = if UseFormat2 `notElem` fs && + (UseOldFashionedInventory `elem` fs || + UseHashedInventory `elem` fs) + then [] + else [[rp2ps Darcs2]] + +-- | @write_problem from@ tells if we can write to a repo in format @form@. +-- it returns @Nothing@ if there's no problem writing to such a repository. +write_problem :: RepoFormat -> Maybe String +write_problem rf | isJust $ read_problem rf = read_problem rf +write_problem (RF ks) = unlines `fmap` justsOrNothing (map wp ks) + where wp x | all is_known x = Nothing + wp [] = impossible + wp x = Just $ unwords $ "Can't write repository format: " : + map BC.unpack (filter (not . is_known) x) + + +-- | @write_problem from@ tells if we can read and write to a repo in +-- format @form@. it returns @Nothing@ if there's no problem reading +-- and writing to such a repository. +readfrom_and_writeto_problem :: RepoFormat -> RepoFormat -> Maybe String +readfrom_and_writeto_problem inrf outrf + | format_has Darcs2 inrf /= format_has Darcs2 outrf + = Just "Cannot mix darcs-2 repositories with older formats" + | otherwise = msum [read_problem inrf, write_problem outrf] + + +-- | @read_problem from@ tells if we can write to a repo in format @form@. +-- it returns @Nothing@ if there's no problem reading from such a repository. +read_problem :: RepoFormat -> Maybe String +read_problem rf | format_has Darcs1_0 rf && format_has Darcs2 rf + = Just "Invalid repositoryformat: format 2 is incompatible with format 1" +read_problem (RF ks) = unlines `fmap` justsOrNothing (map rp ks) + where rp x | any is_known x = Nothing + rp [] = impossible + rp x = Just $ unwords $ + "Can't understand repository format:" : map BC.unpack x + + +-- | Does this version of darcs know how to handle this property? +is_known :: B.ByteString -> Bool +is_known p = p `elem` map rp2ps known_properties + +-- | This is the list of properties which this version of darcs knows +-- how to handle. +known_properties :: [RepoProperty] +known_properties = [Darcs1_0, Darcs2, HashedInventory] + +justsOrNothing :: [Maybe x] -> Maybe [x] +justsOrNothing mxs = + case catMaybes mxs of + [] -> Nothing + xs -> Just xs + +format_has :: RepoProperty -> RepoFormat -> Bool +format_has f (RF ks) = rp2ps f `elem` concat ks + +format_has_together :: [RepoProperty] -> RepoFormat -> Bool +format_has_together fs (RF ks) = fht (sort $ map rp2ps fs) ks + where fht _ [] = False + fht x (y:ys) | x == sort y = True + | otherwise = fht x ys + +rp2ps :: RepoProperty -> B.ByteString +rp2ps Darcs1_0 = BC.pack "darcs-1.0" +rp2ps Darcs2 = BC.pack "darcs-2" +rp2ps HashedInventory = BC.pack "hashed" diff --git a/src/Darcs/Repository/HashedIO.hs b/src/Darcs/Repository/HashedIO.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/HashedIO.hs @@ -0,0 +1,417 @@ +-- Copyright (C) 2007 David Roundy +-- +-- 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; if not, write to the Free Software Foundation, +-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-} + +#include "gadts.h" + +module Darcs.Repository.HashedIO ( HashedIO, applyHashed, + copyHashed, syncHashedPristine, copyPartialsHashed, listHashedContents, + slurpHashedPristine, writeHashedPristine, + clean_hashdir ) where + +import Darcs.Global ( darcsdir ) +import Data.List ( (\\) ) +import qualified Data.Map as Map +import System.Directory ( getDirectoryContents, createDirectoryIfMissing ) +import System.Posix.Types ( EpochTime ) +import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift ) +import Control.Monad ( when ) +import Data.Maybe ( isJust ) +import System.IO.Unsafe ( unsafeInterleaveIO ) + +import Darcs.SlurpDirectory.Internal ( Slurpy(..), SlurpyContents(..), map_to_slurpies, slurpies_to_map ) +import Darcs.SlurpDirectory ( withSlurpy, undefined_time, undefined_size ) +import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, writeFileUsingCache, + peekInCache, speculateFileUsingCache, + findFileMtimeUsingCache, setFileMtimeUsingCache, + okayHash, cleanCachesWithHint, HashedDir(..), hashedDir ) +import Darcs.Patch ( Patchy, apply ) +import Darcs.RepoPath ( FilePathLike, toFilePath ) +import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) ) +import Darcs.Flags ( DarcsFlag, Compression( .. ), compression ) +import Darcs.Lock ( writeAtomicFilePS, removeFileMayNotExist ) +import Darcs.Utils ( withCurrentDirectory ) +import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO, progress ) +import Darcs.Patch.FileName ( FileName, norm_path, fp2fn, fn2fp, fn2niceps, niceps2fn, + break_on_dir, own_name, super_name ) + +import ByteStringUtils ( linesPS, unlinesPS ) +import qualified Data.ByteString as B (ByteString, length, empty) +import qualified Data.ByteString.Char8 as BC (unpack, pack) + +import SHA1 ( sha1PS ) + +-- | @readHashFile c subdir hash@ reads the file with hash @hash@ in dir subdir, +-- fetching it from 'Cache' @c@ if needed. +readHashFile :: Cache -> HashedDir -> String -> IO (String,B.ByteString) +readHashFile c subdir hash = + do debugMessage $ "Reading hash file "++hash++" from "++(hashedDir subdir)++"/" + fetchFileUsingCache c subdir hash + +applyHashed :: Patchy q => Cache -> [DarcsFlag] -> String -> q C(x y) -> IO String +applyHashed c fs h p = do s <- slurpHashedPristine c (compression fs) h + let ms = withSlurpy s $ apply fs p + case ms of + Left e -> fail e + Right (s', ()) -> writeHashedPristine c (compression fs) s' +{- +applyHashed c fs h p = do (_,hd) <- runStateT (apply fs p) $ + HashDir { permissions = RW, cache = c, + options = fs, rootHash = h } + return $ rootHash hd +-} + +data HashDir r p = HashDir { permissions :: !r, cache :: !Cache, + compress :: !Compression, rootHash :: !String } +type HashedIO r p = StateT (HashDir r p) IO + +data RO = RO +data RW = RW +{- +class Readable r where + isRO :: r -> Bool + isRO = const False +instance Readable RW +instance Readable RO where + isRO RO = True +-} + +instance ReadableDirectory (HashedIO r p) where + mDoesDirectoryExist fn = do thing <- identifyThing fn + case thing of Just (D,_) -> return True + _ -> return False + mDoesFileExist fn = do thing <- identifyThing fn + case thing of Just (F,_) -> return True + _ -> return False + mInCurrentDirectory fn j | fn' == fp2fn "" = j + | otherwise = + case break_on_dir fn' of + Nothing -> do c <- readroot + case geta D fn' c of + Nothing -> fail "dir doesn't exist mInCurrentDirectory..." + Just h -> inh h j + Just (d,fn'') -> do c <- readroot + case geta D d c of + Nothing -> fail "dir doesn't exist..." + Just h -> inh h $ mInCurrentDirectory fn'' j + where fn' = norm_path fn + mGetDirectoryContents = map (\ (_,f,_) -> f) `fmap` readroot + mReadFilePS fn = mInCurrentDirectory (super_name fn) $ do + c <- readroot + case geta F (own_name fn) c of + Nothing -> fail $ " file don't exist... "++ fn2fp fn + Just h -> readhash h + +instance WriteableDirectory (HashedIO RW p) where + mWithCurrentDirectory fn j + | fn' == fp2fn "" = j + | otherwise = + case break_on_dir fn' of + Nothing -> do c <- readroot + case geta D fn' c of + Nothing -> fail "dir doesn't exist in mWithCurrentDirectory..." + Just h -> do (h',x) <- withh h j + writeroot $ seta D fn' h' c + return x + Just (d,fn'') -> do c <- readroot + case geta D d c of + Nothing -> fail "dir doesn't exist..." + Just h -> do (h',x) <- withh h $ mWithCurrentDirectory fn'' j + writeroot $ seta D d h' c + return x + where fn' = norm_path fn + mSetFileExecutable _ _ = return () + mWriteFilePS fn ps = do mexists <- identifyThing fn + case mexists of + Just (D,_) -> fail "can't write file over directory" + _ -> do h <- writeHashFile ps + makeThing fn (F,h) + mCreateDirectory fn = do h <- writeHashFile B.empty + exists <- isJust `fmap` identifyThing fn + when exists $ fail "can't mCreateDirectory over an existing object." + makeThing fn (D,h) + mRename o n = do nexists <- isJust `fmap` identifyThing n + when nexists $ fail "mRename failed..." + mx <- identifyThing o + -- for backwards compatibility accept rename of nonexistent files. + case mx of Nothing -> return () + Just x -> do rmThing o + makeThing n x + mRemoveDirectory = rmThing + mRemoveFile f = do x <- mReadFilePS f + when (B.length x /= 0) $ + fail $ "Cannot remove non-empty file "++fn2fp f + rmThing f + +identifyThing :: FileName -> HashedIO r p (Maybe (ObjType,String)) +identifyThing fn | fn' == fp2fn "" = do h <- gets rootHash + return $ Just (D, h) + | otherwise = case break_on_dir fn' of + Nothing -> getany fn' `fmap` readroot + Just (d,fn'') -> do c <- readroot + case geta D d c of + Nothing -> return Nothing + Just h -> inh h $ identifyThing fn'' + where fn' = norm_path fn + +makeThing :: FileName -> (ObjType,String) -> HashedIO RW p () +makeThing fn (o,h) = mWithCurrentDirectory (super_name $ norm_path fn) $ + seta o (own_name $ norm_path fn) h `fmap` readroot >>= writeroot + +rmThing :: FileName -> HashedIO RW p () +rmThing fn = mWithCurrentDirectory (super_name $ norm_path fn) $ + do c <- readroot + let c' = filter (\(_,x,_)->x/= own_name (norm_path fn)) c + if length c' == length c - 1 + then writeroot c' + else fail "obj doesn't exist in rmThing" + +readhash :: String -> HashedIO r p B.ByteString +readhash h = do c <- gets cache + z <- lift $ unsafeInterleaveIO $ readHashFile c HashedPristineDir h + let (_,out) = z + return out + +readTediousHash :: String -> String -> HashedIO r p B.ByteString +readTediousHash k h = do lift $ finishedOneIO k h + readhash h + +gethashmtime :: String -> HashedIO r p EpochTime +gethashmtime h = do HashDir _ c _ _ <- get + lift $ unsafeInterleaveIO $ findFileMtimeUsingCache c HashedPristineDir h + +withh :: String -> HashedIO RW p a -> HashedIO RW p (String,a) +withh h j = do hd <- get + put $ hd { rootHash = h } + x <- j + h' <- gets rootHash + put hd + return (h',x) + +inh :: String -> HashedIO r p a -> HashedIO r p a +inh h j = do hd <- get + put $ hd { rootHash = h } + x <- j + put hd + return x + +safeInterleave :: HashedIO RO p a -> HashedIO r p a +safeInterleave job = do HashDir _ c compr h <- get + z <- lift $ unsafeInterleaveIO $ runStateT job + (HashDir { permissions = RO, cache = c, compress = compr, rootHash = h }) + let (x,_) = z + return x + +readroot :: HashedIO r p [(ObjType, FileName, String)] +readroot = do haveitalready <- peekroot + cc <- gets rootHash >>= readdir + when (not haveitalready) $ speculate cc + return cc + where speculate :: [(a,b,String)] -> HashedIO r q () + speculate c = do cac <- gets cache + mapM_ (\(_,_,z) -> lift $ speculateFileUsingCache cac HashedPristineDir z) c + peekroot :: HashedIO r p Bool + peekroot = do HashDir _ c _ h <- get + lift $ peekInCache c HashedPristineDir h + +writeroot :: [(ObjType, FileName, String)] -> HashedIO r p () +writeroot c = do h <- writedir c + modify $ \hd -> hd { rootHash = h } + +data ObjType = F | D deriving Eq + +-- | @geta objtype name stuff@ tries to get an object of type @objtype@ named @name@ +-- in @stuff@. +geta :: ObjType -> FileName -> [(ObjType, FileName, String)] -> Maybe String +geta o f c = do (o',h) <- getany f c + if o == o' then Just h else Nothing + +getany :: FileName -> [(ObjType, FileName, String)] -> Maybe (ObjType,String) +getany _ [] = Nothing +getany f ((o,f',h):_) | f == f' = Just (o,h) +getany f (_:r) = getany f r + +seta :: ObjType -> FileName -> String -> [(ObjType, FileName, String)] -> [(ObjType, FileName, String)] +seta o f h [] = [(o,f,h)] +seta o f h ((_,f',_):r) | f == f' = (o,f,h):r +seta o f h (x:xs) = x : seta o f h xs + +readdir :: String -> HashedIO r p [(ObjType, FileName, String)] +readdir hash = (parsed . linesPS) `fmap` readhash hash + where parsed (t:n:h:rest) | t == dir = (D, niceps2fn n, BC.unpack h) : parsed rest + | t == file = (F, niceps2fn n, BC.unpack h) : parsed rest + parsed _ = [] +dir :: B.ByteString +dir = BC.pack "directory:" +file :: B.ByteString +file = BC.pack "file:" + + +writedir :: [(ObjType, FileName, String)] -> HashedIO r p String +writedir c = writeHashFile cps + where cps = unlinesPS $ concatMap (\ (o,d,h) -> [showO o,fn2niceps d,BC.pack h]) c++[B.empty] + showO D = dir + showO F = file + +writeHashFile :: B.ByteString -> HashedIO r p String +writeHashFile ps = do c <- gets cache + compr <- gets compress + lift $ writeFileUsingCache c compr HashedPristineDir ps + +-- |Create a Slurpy representing the pristine content determined by the +-- supplied root hash (which uniquely determines the pristine tree) +slurpHashedPristine :: Cache -> Compression -> String -> IO Slurpy +slurpHashedPristine c compr h = fst `fmap` runStateT slh + (HashDir { permissions = RO, cache = c, + compress = compr, rootHash = h }) + +slh :: HashedIO r p Slurpy +slh = do c <- readroot + hroot <- gets rootHash + lift $ beginTedious k + safeInterleave $ (Slurpy rootdir . SlurpDir (Just hroot) . slurpies_to_map) `fmap` mapM sl c + where sl (F,n,h) = do ps <- safeInterleave $ readTediousHash k h + t <- gethashmtime h + let len = if length h == 75 then read (take 10 h) + else undefined_size + return $ Slurpy n $ SlurpFile (Just h, t, len) ps + sl (D,n,h) = inh h $ do c <- readroot + lift $ tediousSize k (length c) + lift $ finishedOneIO k h + (Slurpy n . SlurpDir (Just h) . slurpies_to_map) `fmap` mapM sl c + k = "Reading pristine" + +rootdir :: FileName +rootdir = fp2fn "." + +-- |Write contents of a Slurpy into hashed pristine. Only files that have not +-- not yet been hashed (that is, the hash corresponding to their content is +-- already present in hashed pristine) will be written out, so it is efficient +-- to use this function to update existing pristine cache. Note that the +-- pristine root hash will *not* be updated. You need to do that manually. +writeHashedPristine :: Cache -> Compression -> Slurpy -> IO String +writeHashedPristine c compr sl = + do beginTedious k + h <- fst `fmap` runStateT (hsl sl) + (HashDir { permissions = RW, cache = c, + compress = compr, rootHash = sha1PS B.empty }) + endTedious k + return h + where hsl (Slurpy _ (SlurpDir (Just h) _)) = return h + hsl (Slurpy _ (SlurpDir Nothing ss)) = do lift $ tediousSize k (Map.size ss) + mapM hs (map_to_slurpies ss) >>= writedir + hsl (Slurpy _ (SlurpFile (Just h,_,_) _)) = return h + hsl (Slurpy _ (SlurpFile _ x)) = writeHashFile x + hs (Slurpy d (SlurpDir (Just h) _)) = progress k $ return (D, d, h) + hs s@(Slurpy d (SlurpDir Nothing _)) = do h <- hsl s + lift $ finishedOneIO k h + return (D, d, h) + hs (Slurpy f (SlurpFile (Just h,_,_) _)) = progress k $ return (F, f, h) + hs s@(Slurpy f (SlurpFile _ _)) = do h <- hsl s + lift $ finishedOneIO k h + return (F, f, h) + k = "Writing pristine" + +grab :: FileName -> Slurpy -> Maybe Slurpy +grab _ (Slurpy _ (SlurpFile _ _)) = Nothing +grab fn (Slurpy _ (SlurpDir _ ss)) = fmap (Slurpy fn) $ Map.lookup fn ss + +-- | Update timestamps on pristine files to match those in the working directory +-- (which is passed to this function in form of a Slurpy). It needed for the +-- mtime-based unsafeDiff optimisation to work efficiently. +syncHashedPristine :: Cache -> Slurpy -> String -> IO () +syncHashedPristine c s r = do runStateT sh $ HashDir { permissions=RW, cache=c, + compress=compression [], rootHash=r } + return () + where sh = do cc <- readroot + lift $ tediousSize k (length cc) + mapM_ sh' cc + sh' (D,n,h) = case progress k $ grab n s of + Just s' -> lift $ syncHashedPristine c s' h + Nothing -> return () + sh' (F,n,h) = case progress k $ grab n s of + Just (Slurpy _ (SlurpFile (_,t',l) x)) -> + do t <- lift $ findFileMtimeUsingCache c HashedPristineDir h + when (t' /= undefined_time && t' /= t) $ + do ps <- readhash h + when (B.length ps == fromIntegral l && ps == x) $ + lift $ setFileMtimeUsingCache c HashedPristineDir h t' + _ -> return () + k = "Synchronizing pristine" + +copyHashed :: String -> Cache -> Compression -> String -> IO () +copyHashed k c compr z = do runStateT cph $ HashDir { permissions = RO, cache = c, + compress = compr, rootHash = z } + return () + where cph = do cc <- readroot + lift $ tediousSize k (length cc) + mapM_ cp cc + cp (F,n,h) = do ps <- readhash h + lift $ finishedOneIO k (fn2fp n) + lift $ writeAtomicFilePS (fn2fp n) ps + cp (D,n,h) = do lift $ createDirectoryIfMissing False (fn2fp n) + lift $ finishedOneIO k (fn2fp n) + lift $ withCurrentDirectory (fn2fp n) $ copyHashed k c compr h + +copyPartialsHashed :: FilePathLike fp => + Cache -> Compression -> String -> [fp] -> IO () +copyPartialsHashed c compr root = mapM_ (copyPartialHashed c compr root) + +copyPartialHashed :: FilePathLike fp => Cache -> Compression -> String -> fp -> IO () +copyPartialHashed c compr root ff = + do createDirectoryIfMissing True (basename $ toFilePath ff) + runStateT (cp $ fp2fn $ toFilePath ff) $ + HashDir { permissions = RO, cache = c, + compress=compr, rootHash = root } + return () + where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse + cp f = do mt <- identifyThing f + case mt of + Just (D,h) -> do lift $ createDirectoryIfMissing True (fn2fp f) + lift $ withCurrentDirectory (fn2fp f) $ copyHashed "" c compr h + Just (F,h) -> do ps <- readhash h + lift $ writeAtomicFilePS (fn2fp f) ps + Nothing -> return () + +-- | Seems to list all hashes reachable from "root". +listHashedContents :: String -> Cache -> String -> IO [String] +listHashedContents k c root = + do beginTedious k + tediousSize k 1 + x <- fst `fmap` runStateT (lhc (D,fp2fn ".",root)) (HashDir RO c NoCompression root) + endTedious k + return x + where lhc :: (ObjType, FileName, String) -> HashedIO r a [String] + lhc (D,dname,d) = do xs <- inh d $ readroot + lift $ finishedOneIO k (fn2fp dname) + lift $ tediousSize k (length $ filter (\(x,_,_) -> x == D) xs) + hcxs <- mapM lhc xs + return (d:concat hcxs) + lhc (F,_,h) = return [h] + +clean_hashdir :: Cache -> HashedDir -> [String] -> IO () +clean_hashdir c dir_ hashroots = + do -- we'll remove obsolete bits of "dir" + debugMessage $ "Cleaning out " ++ (hashedDir dir_) ++ "..." + let hashdir = darcsdir ++ "/" ++ (hashedDir dir_) ++ "/" + hs <- concat `fmap` (mapM (listHashedContents "cleaning up..." c) hashroots) + fs <- filter okayHash `fmap` getDirectoryContents hashdir + mapM_ (removeFileMayNotExist . (hashdir++)) (fs \\ hs) + -- and also clean out any global caches. + debugMessage "Cleaning out any global caches..." + cleanCachesWithHint c dir_ (fs \\ hs) diff --git a/src/Darcs/Repository/HashedRepo.hs b/src/Darcs/Repository/HashedRepo.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/HashedRepo.hs @@ -0,0 +1,401 @@ +-- Copyright (C) 2006-2007 David Roundy +-- +-- 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; if not, write to the Free Software Foundation, +-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +#include "gadts.h" + +module Darcs.Repository.HashedRepo ( revert_tentative_changes, finalize_tentative_changes, + slurp_pristine, sync_repo, clean_pristine, + copy_pristine, copy_partials_pristine, pristine_from_working, + apply_to_tentative_pristine, + replacePristineFromSlurpy, + add_to_tentative_inventory, remove_from_tentative_inventory, + read_repo, read_tentative_repo, write_and_read_patch, + write_tentative_inventory, copy_repo, slurp_all_but_darcs, + readHashedPristineRoot + ) where + +import System.Directory ( doesFileExist, createDirectoryIfMissing ) +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO ( stderr, hPutStrLn ) +import Data.List ( delete ) +import Control.Monad ( unless ) + +import Workaround ( renameFile ) +import Darcs.Flags ( DarcsFlag, Compression ) +import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) +import Darcs.RepoPath ( FilePathLike, ioAbsoluteOrRemote, toPath ) +import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, speculateFileUsingCache, + writeFileUsingCache, + unionCaches, repo2cache, okayHash, takeHash, + HashedDir(..), hashedDir ) +import Darcs.Repository.HashedIO ( applyHashed, slurpHashedPristine, + copyHashed, syncHashedPristine, copyPartialsHashed, + writeHashedPristine, clean_hashdir ) +import Darcs.Repository.InternalTypes ( Repository(..), extractCache ) +import Darcs.Hopefully ( PatchInfoAnd, patchInfoAndPatch, n2pia, info, + extractHash, createHashed ) +import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, slurp_remove, slurp ) +import Darcs.Patch ( RepoPatch, Patchy, Named, showPatch, patch2patchinfo, readPatch ) +import Darcs.Patch.Depends ( commute_to_end, slightly_optimize_patchset ) +import Darcs.Patch.Info ( PatchInfo, showPatchInfo, human_friendly, readPatchInfo ) +import Darcs.Ordered ( unsafeCoerceP, (:<)(..) ) +import Darcs.Patch.FileName ( fp2fn ) + +import ByteStringUtils ( gzReadFilePS, dropSpace ) +import qualified Data.ByteString as B (null, length, readFile, empty + ,tail, take, drop, ByteString) +import qualified Data.ByteString.Char8 as BC (unpack, dropWhile, break, pack) + +import Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text, invisiblePS ) +import SHA1 ( sha1PS ) +import Darcs.External ( copyFileOrUrl, cloneFile, fetchFilePS, Cachable( Uncachable ) ) +import Darcs.Lock ( writeBinFile, writeDocBinFile, writeAtomicFilePS, appendBinFile, appendDocBinFile ) +import Darcs.Utils ( withCurrentDirectory ) +import Progress ( beginTedious, tediousSize, endTedious, debugMessage, finishedOneIO ) +#include "impossible.h" +import Darcs.Ordered ( FL(..), RL(..), + mapRL, mapFL, lengthRL ) +import Darcs.Sealed ( Sealed(..), seal, unseal ) +import Darcs.Global ( darcsdir ) + +revert_tentative_changes :: IO () +revert_tentative_changes = + do cloneFile (darcsdir++"/hashed_inventory") (darcsdir++"/tentative_hashed_inventory") + i <- gzReadFilePS (darcsdir++"/hashed_inventory") + writeBinFile (darcsdir++"/tentative_pristine") $ "pristine:" ++ inv2pris i + +finalize_tentative_changes :: RepoPatch p => Repository p C(r u t) -> Compression -> IO () +finalize_tentative_changes r compr = + do let t = darcsdir++"/tentative_hashed_inventory" + -- first let's optimize it... + debugMessage "Optimizing the inventory..." + ps <- read_tentative_repo r "." + write_tentative_inventory (extractCache r) compr ps + -- then we'll add in the pristine cache, + i <- gzReadFilePS t + p <- gzReadFilePS $ darcsdir++"/tentative_pristine" + writeDocBinFile t $ pris2inv (inv2pris p) i + -- and rename it to its final value + renameFile t $ darcsdir++"/hashed_inventory" + -- note: in general we can't clean the pristine cache, because a + -- simultaneous get might be in progress + +readHashedPristineRoot :: Repository p C(r u t) -> IO (Maybe String) +readHashedPristineRoot (Repo d _ _ _) = + withCurrentDirectory d $ do + i <- (Just `fmap` gzReadFilePS (darcsdir++"/hashed_inventory")) `catch` (\_ -> return Nothing) + return $ inv2pris `fmap` i + +clean_pristine :: Repository p C(r u t) -> IO () +clean_pristine r@(Repo d _ _ _) = withCurrentDirectory d $ + do -- we'll remove obsolete bits of our pristine cache + debugMessage "Cleaning out the pristine cache..." + i <- gzReadFilePS (darcsdir++"/hashed_inventory") + clean_hashdir (extractCache r) HashedPristineDir [inv2pris i] + +add_to_tentative_inventory :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y) -> IO FilePath +add_to_tentative_inventory c compr p = + do hash <- snd `fmap` write_patch_if_necesary c compr p + appendDocBinFile (darcsdir++"/tentative_hashed_inventory") $ showPatchInfo $ info p + appendBinFile (darcsdir++"/tentative_hashed_inventory") $ "\nhash: " ++ hash ++ "\n" + return $ darcsdir++"/patches/" ++ hash + +remove_from_tentative_inventory :: RepoPatch p => Repository p C(r u t) -> Compression + -> FL (Named p) C(x t) -> IO () +remove_from_tentative_inventory repo compr to_remove = + -- FIXME: This algorithm should be *far* simpler. All we need do is + -- to to remove the patches from a patchset and then write that + -- patchset. The commutation behavior of PatchInfoAnd should track + -- which patches need to be rewritten for us. + do allpatches <- read_tentative_repo repo "." + skipped :< _ <- return $ commute_to_end to_remove allpatches + okay <- simple_remove_from_tentative_inventory repo compr + (mapFL patch2patchinfo to_remove ++ mapFL patch2patchinfo skipped) + unless okay $ bug "bug in HashedRepo.remove_from_tentative_inventory" + sequence_ $ mapFL (add_to_tentative_inventory (extractCache repo) compr . n2pia) skipped + +simple_remove_from_tentative_inventory :: forall p C(r u t). RepoPatch p => + Repository p C(r u t) -> Compression -> [PatchInfo] -> IO Bool +simple_remove_from_tentative_inventory repo compr pis = do + inv <- read_tentative_repo repo "." + case cut_inv pis inv of + Nothing -> return False + Just (Sealed inv') -> do write_tentative_inventory (extractCache repo) compr inv' + return True + where cut_inv :: [PatchInfo] -> PatchSet p C(x) -> Maybe (SealedPatchSet p) + cut_inv [] x = Just $ seal x + cut_inv x (NilRL:<:rs) = cut_inv x rs + cut_inv xs ((hp:<:r):<:rs) | info hp `elem` xs = cut_inv (info hp `delete` xs) (r:<:rs) + cut_inv _ _ = Nothing + +writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String +writeHashFile c compr subdir d = do debugMessage $ "Writing hash file to "++(hashedDir subdir) + writeFileUsingCache c compr subdir $ renderPS d + +read_repo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(r)) +read_repo repo d = do + realdir <- toPath `fmap` ioAbsoluteOrRemote d + Sealed ps <- read_repo_private repo realdir "hashed_inventory" `catch` + (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) + ioError e) + return $ unsafeCoerceP ps + +read_tentative_repo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(t)) +read_tentative_repo repo d = do + realdir <- toPath `fmap` ioAbsoluteOrRemote d + Sealed ps <- read_repo_private repo realdir "tentative_hashed_inventory" `catch` + (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) + ioError e) + return $ unsafeCoerceP ps + +read_repo_private :: RepoPatch p => Repository p C(r u t) + -> FilePath -> FilePath -> IO (SealedPatchSet p) +read_repo_private repo d iname = + do inventories <- read_inventory_private repo (d++"/"++darcsdir) iname + parseinvs inventories + where read_patches :: RepoPatch p => [(PatchInfo, String)] -> IO (Sealed (RL (PatchInfoAnd p) C(x))) + read_patches [] = return $ seal NilRL + read_patches allis@((i1,h1):is1) = + lift2Sealed (\p rest -> i1 `patchInfoAndPatch` p :<: rest) + (rp is1) + (createHashed h1 (const $ speculate h1 allis >> parse i1 h1)) + where rp :: RepoPatch p => [(PatchInfo, String)] -> IO (Sealed (RL (PatchInfoAnd p) C(x))) + rp [] = return $ seal NilRL + rp [(i,h),(il,hl)] = + lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest) + (rp [(il,hl)]) + (createHashed h (const $ speculate h (reverse allis) >> parse i h)) + rp ((i,h):is) = lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest) + (rp is) + (createHashed h (parse i)) + speculate :: String -> [(PatchInfo, String)] -> IO () + speculate h is = do already_got_one <- doesFileExist (d++"/"++darcsdir++"/patches/"++h) + unless already_got_one $ + mapM_ (speculateFileUsingCache (extractCache repo) HashedPatchesDir . snd) is + parse :: Patchy p => PatchInfo -> String -> IO (Sealed (p C(x))) + parse i h = do debugMessage ("Reading patch file: "++ show (human_friendly i)) + (fn,ps) <- fetchFileUsingCache (extractCache repo) HashedPatchesDir h + case readPatch ps of + Just (p,_) -> return p + Nothing -> fail $ unlines ["Couldn't parse file "++fn, + "which is patch", + renderString $ human_friendly i] + parseinvs :: RepoPatch p => [[(PatchInfo, String)]] -> IO (SealedPatchSet p) + parseinvs [] = return $ seal NilRL + parseinvs (i:is) = lift2Sealed (:<:) (parseinvs is) (read_patches i) + lift2Sealed :: (FORALL(y z) q C(y z) -> p C(x y) -> r C(x z)) + -> IO (Sealed (p C(x))) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed (r C(x))) + lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap` unsafeInterleaveIO iox + Sealed y <- unseal seal `fmap` unsafeInterleaveIO ioy + return $ seal $ f y x + +write_and_read_patch :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y) + -> IO (PatchInfoAnd p C(x y)) +write_and_read_patch c compr p = do (i,h) <- write_patch_if_necesary c compr p + unsafeInterleaveIO $ readp h i + where parse i h = do debugMessage ("Rereading patch file: "++ show (human_friendly i)) + (fn,ps) <- fetchFileUsingCache c HashedPatchesDir h + case readPatch ps of + Just (x,_) -> return x + Nothing -> fail $ unlines ["Couldn't parse patch file "++fn, + "which is", + renderString $ human_friendly i] + readp h i = do Sealed x <- createHashed h (parse i) + return $ patchInfoAndPatch i $ unsafeCoerceP x + +write_tentative_inventory :: RepoPatch p => Cache -> Compression -> PatchSet p C(x) -> IO () +write_tentative_inventory c compr = write_either_inventory c compr "tentative_hashed_inventory" + +copy_repo :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> String -> IO () +copy_repo repo@(Repo outr _ _ _) opts inr = do + createDirectoryIfMissing False (outr++"/"++darcsdir++"/inventories") + copyFileOrUrl opts (inr++"/"++darcsdir++"/hashed_inventory") (outr++"/"++darcsdir++"/hashed_inventory") + Uncachable -- no need to copy anything but hashed_inventory! + appendBinFile (outr++"/"++darcsdir++"/prefs/sources") (show $ repo2cache inr `unionCaches` extractCache repo) + debugMessage "Done copying hashed inventory." + +write_either_inventory :: RepoPatch p => Cache -> Compression -> String -> PatchSet p C(x) -> IO () +write_either_inventory c compr iname x = + do createDirectoryIfMissing False $ darcsdir++"/inventories" + let k = "Writing inventory" + beginTedious k + tediousSize k (lengthRL x) + hsh <- write_inventory_private k c compr $ slightly_optimize_patchset x + endTedious k + case hsh of + Nothing -> writeBinFile (darcsdir++"/"++iname) "" + Just h -> gzReadFilePS (darcsdir++"/inventories/"++h) >>= writeAtomicFilePS (darcsdir++"/"++iname) + +write_inventory_private :: RepoPatch p => String -> Cache -> Compression + -> PatchSet p C(x) -> IO (Maybe String) +write_inventory_private _ _ _ NilRL = return Nothing +write_inventory_private _ _ _ (NilRL:<:NilRL) = return Nothing +write_inventory_private _ _ _ (NilRL:<:_) = -- This shouldn't be possible, so best to check... + bug "malformed PatchSet in HashedRepo.write_inventory_private" +write_inventory_private k c compr (x:<:xs) = + do resthash <- write_inventory_private k c compr xs + finishedOneIO k (case resthash of Nothing -> ""; Just h -> h) + inventory <- sequence $ mapRL (write_patch_if_necesary c compr) x + let inventorylist = hcat (map pihash $ reverse inventory) + inventorycontents = case resthash of + Just lasthash -> text ("Starting with inventory:\n"++lasthash) $$ + inventorylist + _ -> inventorylist + hash <- writeHashFile c compr HashedInventoriesDir inventorycontents + return $ Just hash + +write_patch_if_necesary :: RepoPatch p => Cache -> Compression + -> PatchInfoAnd p C(x y) -> IO (PatchInfo, String) +write_patch_if_necesary c compr hp = + seq infohp $ case extractHash hp of + Right h -> return (infohp, h) + Left p -> (\h -> (infohp, h)) `fmap` + writeHashFile c compr HashedPatchesDir (showPatch p) + where infohp = info hp + +pihash :: (PatchInfo,String) -> Doc +pihash (pinf,hash) = showPatchInfo pinf $$ text ("hash: " ++ hash ++ "\n") + +read_inventory_private :: Repository p C(r u t) -> String -> String + -> IO [[(PatchInfo, String)]] +read_inventory_private repo d iname = do + i <- skip_pristine `fmap` fetchFilePS (d++"/"++iname) Uncachable + (rest,str) <- case BC.break ((==)'\n') i of + (swt,pistr) | swt == BC.pack "Starting with inventory:" -> + case BC.break ((==)'\n') $ B.tail pistr of + (h,thisinv) | okayHash $ BC.unpack h -> + do r <- unsafeInterleaveIO $ read_inventories + (extractCache repo) (BC.unpack h) -- don't unpack twice! + return (r,thisinv) + _ -> fail $ "Bad hash in " ++ d ++ "/"++darcsdir++"/" ++ iname + _ -> return ([],i) + return $ reverse (read_patch_ids str) : rest + +read_inventories :: Cache -> String -> IO [[(PatchInfo, String)]] +read_inventories cache ihash = do + (fn,i_and_p) <- fetchFileUsingCache cache HashedInventoriesDir ihash + let i = skip_pristine i_and_p + (rest,str) <- case BC.break ((==)'\n') i of + (swt,pistr) | swt == BC.pack "Starting with inventory:" -> + case BC.break ((==)'\n') $ B.tail pistr of + (h,thisinv) | okayHash $ BC.unpack h -> + do r <- unsafeInterleaveIO $ + read_inventories cache (BC.unpack h) -- again. no. + return (r,thisinv) + _ -> fail $ "Bad hash in file " ++ fn + _ -> return ([],i) + return $ reverse (read_patch_ids str) : rest + +read_patch_ids :: B.ByteString -> [(PatchInfo, String)] +read_patch_ids inv | B.null inv = [] +read_patch_ids inv = case readPatchInfo inv of + Nothing -> [] + Just (pinfo,r) -> + case readHash r of + Nothing -> [] + Just (h,r') -> (pinfo,h) : read_patch_ids r' + +readHash :: B.ByteString -> Maybe (String, B.ByteString) +readHash s = let s' = dropSpace s + (l,r) = BC.break ((==)'\n') s' + (kw,h) = BC.break ((==)' ') l + in if kw /= BC.pack "hash:" || B.length h <= 1 + then Nothing + else Just (BC.unpack $ B.tail h,r) + +apply_pristine :: Patchy q => Cache -> [DarcsFlag] -> String -> String -> q C(x y) -> IO () +apply_pristine c opts d iname p = + do i <- gzReadFilePS (d++"/"++iname) + h <- applyHashed c opts (inv2pris i) p + writeDocBinFile (d++"/"++iname) $ pris2inv h i + +apply_to_tentative_pristine :: Patchy q => Cache -> [DarcsFlag] -> q C(x y) -> IO () +apply_to_tentative_pristine c opts p = apply_pristine c opts "." (darcsdir++"/tentative_pristine") p + +slurp_pristine :: Cache -> Compression -> String -> String -> IO Slurpy +slurp_pristine c compr d iname = do + i <- fetchFilePS (d++"/"++iname) Uncachable + slurp_pristine_private c compr i + +slurp_pristine_private :: Cache -> Compression -> B.ByteString -> IO Slurpy +slurp_pristine_private c compr inv = case inv2pris inv of + h | h == sha1PS B.empty -> return empty_slurpy + | otherwise -> slurpHashedPristine c compr h + +pristine_from_working :: Cache -> Compression -> IO () +pristine_from_working c compr = do + s <- slurp_all_but_darcs "." + replacePristineFromSlurpy c compr s + +replacePristineFromSlurpy :: Cache -> Compression -> Slurpy -> IO () +replacePristineFromSlurpy c compr s = do + h <- writeHashedPristine c compr s + let t = darcsdir++"/hashed_inventory" + i <- gzReadFilePS t + writeDocBinFile t $ pris2inv h i + +copy_pristine :: Cache -> Compression -> String -> String -> IO () +copy_pristine c compr d iname = do + i <- fetchFilePS (d++"/"++iname) Uncachable + debugMessage $ "Copying hashed pristine tree: "++inv2pris i + let k = "Copying pristine" + beginTedious k + copyHashed k c compr $ inv2pris i + endTedious k + +sync_repo :: Cache -> IO () +sync_repo c = do i <- B.readFile $ darcsdir++"/hashed_inventory" + s <- slurp_all_but_darcs "." + beginTedious "Synchronizing pristine" + syncHashedPristine c s $ inv2pris i + + +copy_partials_pristine :: FilePathLike fp => + Cache -> Compression -> String -> String -> [fp] -> IO () +copy_partials_pristine c compr d iname fps = + do i <- fetchFilePS (d++"/"++iname) Uncachable + copyPartialsHashed c compr (inv2pris i) fps + +inv2pris :: B.ByteString -> String +inv2pris inv | B.take pristine_name_length inv == pristine_name = + case takeHash $ B.drop pristine_name_length inv of + Just (h,_) -> h + Nothing -> error "Bad hash in inventory!" + | otherwise = sha1PS B.empty + +pris2inv :: String -> B.ByteString -> Doc +pris2inv h inv = invisiblePS pristine_name <> text h $$ invisiblePS (skip_pristine inv) + +pristine_name :: B.ByteString +pristine_name = BC.pack "pristine:" + +skip_pristine :: B.ByteString -> B.ByteString +skip_pristine ps + | B.take pristine_name_length ps == pristine_name = B.drop 1 $ BC.dropWhile (/= '\n') $ + B.drop pristine_name_length ps + | otherwise = ps + +pristine_name_length :: Int +pristine_name_length = B.length pristine_name + +slurp_all_but_darcs :: FilePath -> IO Slurpy +slurp_all_but_darcs d = do s <- slurp d + case slurp_remove (fp2fn $ "./"++darcsdir) s of + Nothing -> return s + Just s' -> return s' diff --git a/src/Darcs/Repository/Internal.hs b/src/Darcs/Repository/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Internal.hs @@ -0,0 +1,1062 @@ +-- Copyright (C) 2002-2004,2007-2008 David Roundy +-- Copyright (C) 2005 Juliusz Chroboczek +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes, PatternGuards #-} + +#include "gadts.h" + +module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), ($-), + maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor, + findRepository, amInRepository, amNotInRepository, + slurp_pending, pristineFromWorking, revertRepositoryChanges, + slurp_recorded, slurp_recorded_and_unrecorded, + read_pending, announce_merge_conflicts, setTentativePending, + check_unrecorded_conflicts, + withRecorded, + checkPristineAgainstSlurpy, + get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds, + get_unrecorded_in_files, get_unrecorded_in_files_unsorted, + read_repo, sync_repo, + prefsUrl, makePatchLazy, + add_to_pending, + withRepoLock, withRepoReadLock, + withRepository, withRepositoryDirectory, withGutsOf, + tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending, + tentativelyReplacePatches, + tentativelyMergePatches, considerMergeToWorking, + finalizeRepositoryChanges, + unrevertUrl, + applyToWorking, patchSetToPatches, + createPristineDirectoryTree, createPartialsPristineDirectoryTree, + replacePristineFromSlurpy, + optimizeInventory, cleanRepository, + getMarkedupFile, + PatchSet, SealedPatchSet, + setScriptsExecutable, + getRepository, rIO, + testTentative, testRecorded + ) where + +import Printer ( putDocLn, (<+>), text, ($$) ) + +import Data.Maybe ( isJust, isNothing ) +import Darcs.Repository.Prefs ( get_prefval ) +import Darcs.Resolution ( standard_resolution, external_resolution ) +import System.Exit ( ExitCode(..), exitWith ) +import System.Cmd ( system ) +import Darcs.External ( backupByCopying, clonePartialsTree ) +import Darcs.IO ( runTolerantly, runSilently ) +import Darcs.Repository.Pristine ( identifyPristine, nopristine, + easyCreatePristineDirectoryTree, slurpPristine, syncPristine, + easyCreatePartialsPristineDirectoryTree, + createPristineFromWorking ) +import qualified Darcs.Repository.Pristine as Pristine ( replacePristineFromSlurpy ) + +import Data.List ( (\\) ) +import Darcs.SignalHandler ( withSignalsBlocked ) +import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2, HashedInventory ), + identifyRepoFormat, format_has, + write_problem, read_problem, readfrom_and_writeto_problem ) +import System.Directory ( doesDirectoryExist, setCurrentDirectory, removeFile, + createDirectoryIfMissing ) +import Control.Monad ( liftM, when, unless ) +import Workaround ( getCurrentDirectory, renameFile, setExecutable ) + +import ByteStringUtils ( gzReadFilePS ) +import qualified Data.ByteString as B (ByteString, empty, readFile, isPrefixOf) +import qualified Data.ByteString.Char8 as BC (pack) + +import Darcs.Patch ( Patch, RealPatch, Effect, is_hunk, is_binary, description, + + try_to_shrink, commuteFL, commute, apply_to_filepaths ) +import Darcs.Patch.Prim ( try_shrinking_inverse, Conflict ) +import Darcs.Patch.Bundle ( scan_bundle, make_bundle ) +import Darcs.Patch.FileName ( FileName, fn2fp ) +import Darcs.Patch.TouchesFiles ( choose_touching ) +import Darcs.SlurpDirectory ( Slurpy, slurp_unboring, mmap_slurp, co_slurp, + slurp_has, list_slurpy_files ) +import Darcs.Hopefully ( PatchInfoAnd, info, n2pia, + hopefully, hopefullyM ) +import Darcs.Repository.ApplyPatches ( apply_patches ) +import qualified Darcs.Repository.HashedRepo as HashedRepo + ( revert_tentative_changes, finalize_tentative_changes, + remove_from_tentative_inventory, sync_repo, + copy_pristine, copy_partials_pristine, slurp_pristine, + apply_to_tentative_pristine, pristine_from_working, + write_tentative_inventory, write_and_read_patch, + add_to_tentative_inventory, + read_repo, read_tentative_repo, clean_pristine, + replacePristineFromSlurpy, + slurp_all_but_darcs ) +import qualified Darcs.Repository.DarcsRepo as DarcsRepo +import Darcs.Flags ( DarcsFlag(AnyOrder, Boring, LookForAdds, Verbose, Quiet, + MarkConflicts, AllowConflicts, NoUpdateWorking, + WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir, + SetScriptsExecutable, DryRun, IgnoreTimes, + Summary, NoSummary), + want_external_merge, compression ) +import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP, + (:\/:)(..), (:/\:)(..), (:>)(..), + (+>+), lengthFL, nullFL, + allFL, filterFL, + reverseRL, reverseFL, concatRL, mapFL, + mapFL_FL, concatFL ) +import Darcs.Patch ( RepoPatch, Patchy, Prim, merge, + joinPatches, sort_coalesceFL, + list_conflicted_files, list_touched_files, + Named, patchcontents, anonymous, + commuteRL, fromPrims, + patch2patchinfo, readPatch, + writePatch, effect, invert, + is_addfile, is_adddir, + is_setpref, + apply, apply_to_slurpy, + empty_markedup_file, MarkedUpFile + ) +import Darcs.Patch.Patchy ( Invert(..) ) +import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL ) +import Darcs.Patch.Info ( PatchInfo ) +import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) +import Darcs.Patch.Apply ( markup_file, LineMark(None) ) +import Darcs.Patch.Depends ( get_common_and_uncommon, deep_optimize_patchset ) +import Darcs.Diff ( unsafeDiffAtPaths, unsafeDiff ) +import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath, + ioAbsoluteOrRemote, toPath ) +import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort ) +import Progress ( debugMessage ) +import Darcs.ProgressPatches (progressFL) +import Darcs.URL ( is_file ) +import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter, filetype_function, + getCaches ) +import Darcs.Lock ( withLock, writeDocBinFile, withDelayedDir, removeFileMayNotExist, + withTempDir, withPermDir ) +import Darcs.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal ) +import Darcs.Repository.InternalTypes( Repository(..), RepoType(..) ) +import Darcs.Global ( darcsdir ) +#include "impossible.h" + +-- | Repository IO monad. This monad-like datatype is responsible for +-- sequencing IO actions that modify the tentative recorded state of +-- the repository. +newtype RIO p C(r u t t1) a = RIO { + unsafeUnRIO :: Repository p C(r u t) -> IO a -- ^ converts @RIO a@ to @IO a@. + } + +-- | This is just like @>>=@ from the Monad class except that it +-- respects type witness safe repository transformations. Even so, it +-- only tracks modifications to the tentative recorded state. +(>>>=) :: RIO p C(r u t t1) a -> (a -> RIO p C(r u t1 t2) b) -> RIO p C(r u t t2) b +m >>>= k = RIO $ \ (Repo x y z w) -> + do a <- unsafeUnRIO m (Repo x y z w) + unsafeUnRIO (k a) (Repo x y z w) + +-- | This corresponds to @>>@ from the Monad class. +(>>>) :: RIO p C(r u t t1) a -> RIO p C(r u t1 t2) b -> RIO p C(r u t t2) b +a >>> b = a >>>= (const b) + +-- | This corresponds to @return@ from the Monad class. +returnR :: a -> RIO p C(r u t t) a +returnR = rIO . return + +-- | This the @RIO@ equivalent of @liftIO@. +rIO :: IO a -> RIO p C(r u t t) a +rIO = RIO . const + +instance Functor (RIO p C(r u t t)) where + fmap f m = RIO $ \r -> fmap f (unsafeUnRIO m r) + +-- | We have an instance of Monad so that IO actions that do not +-- change the tentative recorded state are convenient in the IO monad. +instance Monad (RIO p C(r u t t)) where + (>>=) = (>>>=) + (>>) = (>>>) + return = returnR + fail = rIO . fail + +-- | Similar to the @ask@ function of the MonadReader class. +-- This allows actions in the RIO monad to get the current +-- repository. +-- FIXME: Don't export this. If we don't export this +-- it makes it harder for arbitrary IO actions to access +-- the repository and hence our code is easier to audit. +getRepository :: RIO p C(r u t t) (Repository p C(r u t)) +getRepository = RIO return + +maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (Either String (Repository p C(r u t))) +maybeIdentifyRepository opts "." = + do darcs <- doesDirectoryExist darcsdir + rf_or_e <- identifyRepoFormat "." + here <- toPath `fmap` ioAbsoluteOrRemote "." + case rf_or_e of + Left err -> return $ Left err + Right rf -> + case read_problem rf of + Just err -> return $ Left err + Nothing -> if darcs then do pris <- identifyPristine + cs <- getCaches opts here + return $ Right $ Repo here opts rf (DarcsRepository pris cs) + else return (Left "Not a repository") +maybeIdentifyRepository opts url' = + do url <- toPath `fmap` ioAbsoluteOrRemote url' + rf_or_e <- identifyRepoFormat url + case rf_or_e of + Left e -> return $ Left e + Right rf -> case read_problem rf of + Just err -> return $ Left err + Nothing -> do cs <- getCaches opts url + return $ Right $ Repo url opts rf (DarcsRepository nopristine cs) + +identifyDarcs1Repository :: [DarcsFlag] -> String -> IO (Repository Patch C(r u t)) +identifyDarcs1Repository opts url = + do er <- maybeIdentifyRepository opts url + case er of + Left s -> fail s + Right r -> return r + +identifyRepositoryFor :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> String -> IO (Repository p C(r u t)) +identifyRepositoryFor (Repo _ opts rf _) url = + do Repo absurl _ rf_ t <- identifyDarcs1Repository opts url + let t' = case t of DarcsRepository x c -> DarcsRepository x c + case readfrom_and_writeto_problem rf_ rf of + Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e + Nothing -> return $ Repo absurl opts rf_ t' + +isRight :: Either a b -> Bool +isRight (Right _) = True +isRight _ = False + +currentDirIsRepository :: IO Bool +currentDirIsRepository = isRight `liftM` maybeIdentifyRepository [] "." + +amInRepository :: [DarcsFlag] -> IO (Either String ()) +amInRepository (WorkRepoDir d:_) = + do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) + air <- currentDirIsRepository + if air + then return (Right ()) + else return (Left "You need to be in a repository directory to run this command.") +amInRepository (_:fs) = amInRepository fs +amInRepository [] = + seekRepo (Left "You need to be in a repository directory to run this command.") + +-- | hunt upwards for the darcs repository +-- This keeps changing up one parent directory, testing at each +-- step if the current directory is a repository or not. $ +-- WARNING this changes the current directory for good if matchFn succeeds +seekRepo :: Either String () + -- ^ what to return if we don't find a repository + -> IO (Either String ()) +seekRepo onFail = getCurrentDirectory >>= helper where + helper startpwd = do + air <- currentDirIsRepository + if air + then return (Right ()) + else do cd <- toFilePath `fmap` getCurrentDirectory + setCurrentDirectory ".." + cd' <- toFilePath `fmap` getCurrentDirectory + if cd' /= cd + then helper startpwd + else do setCurrentDirectory startpwd + return onFail + +amNotInRepository :: [DarcsFlag] -> IO (Either String ()) +amNotInRepository (WorkRepoDir d:_) = do createDirectoryIfMissing False d + -- note that the above could always fail + setCurrentDirectory d + amNotInRepository [] +amNotInRepository (_:f) = amNotInRepository f +amNotInRepository [] = + do air <- currentDirIsRepository + if air then return (Left $ "You may not run this command in a repository.") + else return $ Right () + +findRepository :: [DarcsFlag] -> IO (Either String ()) +findRepository (WorkRepoUrl d:_) | is_file d = + do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) + findRepository [] +findRepository (WorkRepoDir d:_) = + do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) + findRepository [] +findRepository (_:fs) = findRepository fs +findRepository [] = seekRepo (Right ()) + +slurp_pending :: RepoPatch p => Repository p C(r u t) -> IO Slurpy +slurp_pending repo@(Repo _ _ _ rt) = do + cur <- slurp_recorded repo + Sealed pend <- read_pending repo + case apply_to_slurpy pend cur of + Just pendcur -> return pendcur + Nothing -> do putStrLn "Yikes, pending has conflicts. Renaming file as_darcs/patches/pending_buggy" + renameFile (pendingName rt) (pendingName rt++"_buggy") + return cur + +slurp_recorded :: RepoPatch p => Repository p C(r u t) -> IO Slurpy +slurp_recorded (Repo dir opts rf (DarcsRepository _ c)) + | format_has HashedInventory rf = + HashedRepo.slurp_pristine c (compression opts) dir $ darcsdir++"/hashed_inventory" +slurp_recorded repository@(Repo dir _ _ (DarcsRepository p _)) = do + mc <- withCurrentDirectory dir $ slurpPristine p + case mc of (Just slurpy) -> return slurpy + Nothing -> withDelayedDir "pristine.temp" $ \abscd -> + do let cd = toFilePath abscd + createPristineDirectoryTree repository cd + mmap_slurp cd + +slurp_recorded_and_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (Slurpy, Slurpy) +slurp_recorded_and_unrecorded repo@(Repo r _ _ _) = do + cur <- slurp_recorded repo + Sealed pend <- read_pending repo + withCurrentDirectory r $ + case apply_to_slurpy pend cur of + Nothing -> fail "Yikes, pending has conflicts!" + Just pendslurp -> do unrec <- co_slurp pendslurp "." + return (cur, unrec) + +pendingName :: RepoType p -> String +pendingName (DarcsRepository _ _) = darcsdir++"/patches/pending" + +read_pending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL Prim C(r))) +read_pending (Repo r _ _ tp) = + withCurrentDirectory r (read_pendingfile (pendingName tp)) + +add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO () +add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () +add_to_pending repo p = + do pend <- get_unrecorded repo + make_new_pending repo (pend +>+ p) + +readPrims :: B.ByteString -> Sealed (FL Prim C(x)) +readPrims s = case readPatch s :: Maybe (Sealed (Patch C(x )), B.ByteString) of + Nothing -> Sealed NilFL + Just (Sealed p,_) -> Sealed (effect p) + +read_pendingfile :: String -> IO (Sealed (FL Prim C(x))) +read_pendingfile name = do + pend <- gzReadFilePS name `catchall` return B.empty + return $ readPrims pend + +make_new_pending :: forall p C(r u t y). RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> IO () +make_new_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () +make_new_pending repo@(Repo r _ _ tp) origp = + withCurrentDirectory r $ + do let newname = pendingName tp ++ ".new" + debugMessage $ "Writing new pending: " ++ newname + Sealed sfp <- return $ sift_for_pending origp + writeSealedPatch newname $ seal $ fromPrims $ sfp + cur <- slurp_recorded repo + Sealed p <- read_pendingfile newname + when (isNothing $ apply_to_slurpy p cur) $ do + let buggyname = pendingName tp ++ "_buggy" + renameFile newname buggyname + bugDoc $ text "There was an attempt to write an invalid pending!" + $$ text "If possible, please send the contents of" + <+> text buggyname + $$ text "along with a bug report." + renameFile newname (pendingName tp) + debugMessage $ "Finished writing new pending: " ++ newname + where writeSealedPatch :: FilePath -> Sealed (Patch C(x)) -> IO () + writeSealedPatch fp (Sealed p) = writePatch fp p + +sift_for_pending :: FL Prim C(x y) -> Sealed (FL Prim C(x)) +sift_for_pending simple_ps = + let oldps = maybe simple_ps id $ try_shrinking_inverse $ crude_sift simple_ps + in if allFL (\p -> is_addfile p || is_adddir p) $ oldps + then seal oldps + else fromJust $ do + Sealed x <- return $ sfp NilFL $ reverseFL oldps + return (case try_to_shrink x of + ps | lengthFL ps < lengthFL oldps -> sift_for_pending ps + | otherwise -> seal ps) + where sfp :: FL Prim C(a b) -> RL Prim C(c a) -> Sealed (FL Prim C(c)) + sfp sofar NilRL = seal sofar + sfp sofar (p:<:ps) + | is_hunk p || is_binary p + = case commuteFL (p :> sofar) of + Right (sofar' :> _) -> sfp sofar' ps + Left _ -> sfp (p:>:sofar) ps + sfp sofar (p:<:ps) = sfp (p:>:sofar) ps + +get_unrecorded_no_look_for_adds :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r y)) +get_unrecorded_no_look_for_adds r paths = get_unrecorded_private (filter (/= LookForAdds)) r paths + +get_unrecorded_unsorted :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u)) +get_unrecorded_unsorted r = get_unrecorded_in_files_unsorted r [] + +get_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u)) +get_unrecorded r = get_unrecorded_private id r [] + +-- | Gets the unrecorded changes in the given paths in the current repository, +-- without sorting them for presentation to the user +get_unrecorded_in_files_unsorted :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r u)) +get_unrecorded_in_files_unsorted = get_unrecorded_private (AnyOrder:) + +-- | Gets the unrecorded changes in the given paths in the current repository. +get_unrecorded_in_files :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r u)) +get_unrecorded_in_files = get_unrecorded_private id + +-- | The /unrecorded/ includes the pending and the working directory changes. +-- The third argument is a list of paths: if this list is [], it will diff +-- the whole repo, but if there are elements in it, the function will return +-- only changes to files under those paths. The paths must be fixed paths +-- starting with ".", but need not yet be unique. +get_unrecorded_private :: RepoPatch p => ([DarcsFlag]->[DarcsFlag]) -> Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r y)) +get_unrecorded_private _ (Repo _ opts _ _) _ + | NoUpdateWorking `elem` opts = return $ unsafeCoerceP NilFL +get_unrecorded_private modopts repository@(Repo r oldopts _ _) files = + withCurrentDirectory r (do + debugMessage "Looking for unrecorded changes..." + cur <- slurp_pending repository + work <- if LookForAdds `elem` opts + then do nboring <- if Boring `elem` opts + then return $ darcsdir_filter + else boring_file_filter + slurp_unboring (myfilt cur nboring) "." + else co_slurp cur "." + ftf <- filetype_function + Sealed pend <- read_pending repository + let changed_files = apply_to_filepaths pend filesFP + pre_changed_files = apply_to_filepaths (invert pend) filesFP + Sealed relevantPend <- return $ if null files + then seal pend + else choose_touching pre_changed_files pend + debugMessage "diffing dir..." + let diffs = if null files + then unsafeDiff opts ftf cur work + else unsafeDiffAtPaths (ignoreTimes, lookForAdds, summary) ftf cur work changed_files + dif = if AnyOrder `elem` opts + then relevantPend +>+ diffs + else sort_coalesceFL $ relevantPend +>+ diffs + seq dif $ debugMessage "Found unrecorded changes." + return dif) + where myfilt s nboring f = slurp_has f s || nboring [f] /= [] + opts = modopts oldopts + -- NoSummary/Summary both present gives False + -- Just Summary gives True + -- Just NoSummary gives False + -- Neither gives False + summary = Summary `elem` opts && NoSummary `notElem` opts + lookForAdds = LookForAdds `elem` opts + ignoreTimes = IgnoreTimes `elem` opts + filesFP = map fn2fp files + +-- @todo: we should not have to open the result of HashedRepo and +-- seal it. Instead, update this function to work with type witnesses +-- by fixing DarcsRepo to match HashedRepo in the handling of +-- Repository state. +read_repo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(r)) +read_repo repo@(Repo r opts rf _) + | format_has HashedInventory rf = do ps <- HashedRepo.read_repo repo r + return ps + | otherwise = do Sealed ps <- DarcsRepo.read_repo opts r + return $ unsafeCoerceP ps + +readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(t)) +readTentativeRepo repo@(Repo r opts rf _) + | format_has HashedInventory rf = do ps <- HashedRepo.read_tentative_repo repo r + return ps + | otherwise = do Sealed ps <- DarcsRepo.read_tentative_repo opts r + return $ unsafeCoerceP ps + +makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y)) +makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p + | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.write_and_read_patch c (compression opts) p + | otherwise = withCurrentDirectory r $ DarcsRepo.write_and_read_patch opts p + +sync_repo :: Repository p C(r u t) -> IO () +sync_repo (Repo r _ rf (DarcsRepository _ c)) + | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.sync_repo c +sync_repo (Repo r _ _ (DarcsRepository p _)) = withCurrentDirectory r $ syncPristine p + +prefsUrl :: Repository p C(r u t) -> String +prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs" + +unrevertUrl :: Repository p C(r u t) -> String +unrevertUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/patches/unrevert" + +applyToWorking :: Patchy p => Repository p1 C(r u t) -> [DarcsFlag] -> p C(u y) -> IO () +applyToWorking (Repo r _ _ (DarcsRepository _ _)) opts patch = + withCurrentDirectory r $ if Quiet `elem` opts + then runSilently $ apply opts patch + else runTolerantly $ apply opts patch + +handle_pend_for_add :: forall p q C(r u t x y). (RepoPatch p, Effect q) + => Repository p C(r u t) -> q C(x y) -> IO () +handle_pend_for_add (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () +handle_pend_for_add (Repo _ _ _ rt) p = + do let pn = pendingName rt ++ ".tentative" + Sealed pend <- (readPrims `fmap` gzReadFilePS pn) `catchall` (return $ Sealed NilFL) + let effectp = if allFL is_simple pend then crude_sift $ effect p + else effect p + Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) pend + writePatch pn $ fromPrims_ newpend + where rmpend :: FL Prim C(a b) -> FL Prim C(a c) -> Sealed (FL Prim C(b)) + rmpend NilFL x = Sealed x + rmpend _ NilFL = Sealed NilFL + rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys + rmpend (x:>:xs) ys = + case commuteWhatWeCanFL (x:>xs) of + a:>x':>b -> case rmpend a ys of + Sealed ys' -> case commute (invert (x':>:b) :> ys') of + Just (ys'' :> _) -> seal ys'' + Nothing -> seal $ invert (x':>:b)+>+ys' + -- DJR: I don't think this + -- last case should be + -- reached, but it also + -- shouldn't lead to + -- corruption. + fromPrims_ :: FL Prim C(a b) -> Patch C(a b) + fromPrims_ = fromPrims + +is_simple :: Prim C(x y) -> Bool +is_simple x = is_hunk x || is_binary x || is_setpref x + +crude_sift :: FL Prim C(x y) -> FL Prim C(x y) +crude_sift xs = if allFL is_simple xs then filterFL ishunkbinary xs else xs + where ishunkbinary :: Prim C(x y) -> EqCheck C(x y) + ishunkbinary x | is_hunk x || is_binary x = unsafeCoerceP IsEq + | otherwise = NotEq + +data HashedVsOld a = HvsO { old, hashed :: a } + +decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a +decideHashedOrNormal rf (HvsO { hashed = h, old = o }) + | format_has HashedInventory rf = h + | otherwise = o + + +tentativelyMergePatches :: RepoPatch p + => Repository p C(r u t) -> String -> [DarcsFlag] + -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) + -> IO (Sealed (FL Prim C(u))) +tentativelyMergePatches = tentativelyMergePatches_ MakeChanges + +considerMergeToWorking :: RepoPatch p + => Repository p C(r u t) -> String -> [DarcsFlag] + -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) + -> IO (Sealed (FL Prim C(u))) +considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges + +data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq ) + +tentativelyMergePatches_ :: forall p C(r u t y x). RepoPatch p + => MakeChanges + -> Repository p C(r u t) -> String -> [DarcsFlag] + -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) + -> IO (Sealed (FL Prim C(u))) +tentativelyMergePatches_ mc r cmd opts usi themi = + do let us = mapFL_FL hopefully usi + them = mapFL_FL hopefully themi + _ :/\: pc <- return $ merge (progressFL "Merging them" them :\/: progressFL "Merging us" us) + pend <- get_unrecorded_unsorted r -- we don't care if it looks pretty... + anonpend <- anonymous (fromPrims pend) + pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL) + let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $ mapFL_FL patchcontents pw + Sealed standard_resolved_pw <- return $ standard_resolution pwprim + debugMessage "Checking for conflicts..." + mapM_ backupByCopying $ list_touched_files standard_resolved_pw + debugMessage "Announcing conflicts..." + have_conflicts <- announce_merge_conflicts cmd opts standard_resolved_pw + debugMessage "Checking for unrecorded conflicts..." + have_unrecorded_conflicts <- check_unrecorded_conflicts opts pc + debugMessage "Reading working directory..." + (_, working) <- slurp_recorded_and_unrecorded r + debugMessage "Working out conflicts in actual working directory..." + Sealed pw_resolution <- + case (want_external_merge opts, have_conflicts || have_unrecorded_conflicts) of + (Nothing,_) -> return $ if AllowConflicts `elem` opts + then seal NilFL + else seal standard_resolved_pw + (_,False) -> return $ seal standard_resolved_pw + (Just c, True) -> external_resolution working c + (effect us +>+ pend) + (effect them) pwprim + debugMessage "Applying patches to the local directories..." + when (mc == MakeChanges) $ + do let doChanges :: FL (PatchInfoAnd p) C(x r) -> IO () + doChanges NilFL = applyps r themi + doChanges _ = applyps r (mapFL_FL n2pia pc) + doChanges usi + setTentativePending r (effect pend' +>+ pw_resolution) + return $ seal (effect pwprim +>+ pw_resolution) + where mapAdd :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> [IO ()] + mapAdd _ NilFL = [] + mapAdd r'@(Repo dir df rf dr) (a:>:as) = + -- we construct a new Repository object on the recursive case so that the + -- recordedstate of the repository can match the fact that we just wrote a patch + tentativelyAddPatch_ DontUpdatePristine r' opts a : mapAdd (Repo dir df rf dr) as + applyps :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> IO () + applyps repo ps = do debugMessage "Adding patches to inventory..." + sequence_ $ mapAdd repo ps + debugMessage "Applying patches to pristine..." + applyToTentativePristine repo ps + +announce_merge_conflicts :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool +announce_merge_conflicts cmd opts resolved_pw = + case nubsort $ list_touched_files $ resolved_pw of + [] -> return False + cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts + || want_external_merge opts /= Nothing + then do putStrLn "We have conflicts in the following files:" + putStrLn $ unwords cfs + return True + else do putStrLn "There are conflicts in the following files:" + putStrLn $ unwords cfs + fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++ + "If you would rather apply the patch and mark the conflicts,\n"++ + "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++ + "These can set as defaults by adding\n"++ + " "++cmd++" mark-conflicts\n"++ + "to "++darcsdir++"/prefs/defaults in the target repo. " + +check_unrecorded_conflicts :: forall p C(r y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(r y) -> IO Bool +check_unrecorded_conflicts opts _ | NoUpdateWorking `elem` opts = return False +check_unrecorded_conflicts opts pc = + do repository <- identifyDarcs1Repository opts "." + cuc repository + where cuc :: Repository Patch C(r u t) -> IO Bool + cuc r = do Sealed mpend <- read_pending r :: IO (Sealed (FL Prim C(r))) + case mpend of + NilFL -> return False + pend -> + case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of + _ :/\: pend' -> + case list_conflicted_files pend' of + [] -> return False + fs -> do yorn <- promptYorn + ("You have conflicting local changes to:\n" + ++ unwords fs++"\nProceed?") + when (yorn /= 'y') $ + do putStrLn "Cancelled." + exitWith ExitSuccess + return True + fromPrims_ :: FL Prim C(a b) -> p C(a b) + fromPrims_ = fromPrims + +tentativelyAddPatch :: RepoPatch p + => Repository p C(r u t) -> [DarcsFlag] -> PatchInfoAnd p C(r y) -> IO () +tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine + +data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq + +tentativelyAddPatch_ :: RepoPatch p + => UpdatePristine -> Repository p C(r u t) -> [DarcsFlag] + -> PatchInfoAnd p C(r y) -> IO () +tentativelyAddPatch_ _ _ opts _ + | DryRun `elem` opts = bug "tentativelyAddPatch_ called when --dry-run is specified" +tentativelyAddPatch_ up r@(Repo dir _ rf (DarcsRepository _ c)) opts p = + withCurrentDirectory dir $ + do decideHashedOrNormal rf $ HvsO { + hashed = HashedRepo.add_to_tentative_inventory c (compression opts) p, + old = DarcsRepo.add_to_tentative_inventory opts (hopefully p) } + when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..." + applyToTentativePristine r p + debugMessage "Updating pending..." + handle_pend_for_add r p + +applyToTentativePristine :: (Effect q, Patchy q) => Repository p C(r u t) -> q C(r y) -> IO () +applyToTentativePristine (Repo dir opts rf (DarcsRepository _ c)) p = + withCurrentDirectory dir $ + do when (Verbose `elem` opts) $ putDocLn $ text "Applying to pristine..." <+> description p + decideHashedOrNormal rf $ HvsO {hashed = HashedRepo.apply_to_tentative_pristine c opts p, + old = DarcsRepo.add_to_tentative_pristine p} + +-- | This fuction is unsafe because it accepts a patch that works on the tentative +-- pending and we don't currently track the state of the tentative pending. +tentativelyAddToPending :: forall p C(r u t x y). RepoPatch p + => Repository p C(r u t) -> [DarcsFlag] -> FL Prim C(x y) -> IO () +tentativelyAddToPending (Repo _ opts _ _) _ _ + | NoUpdateWorking `elem` opts = return () + | DryRun `elem` opts = bug "tentativelyAddToPending called when --dry-run is specified" +tentativelyAddToPending (Repo dir _ _ rt) _ patch = + withCurrentDirectory dir $ do + let pn = pendingName rt + tpn = pn ++ ".tentative" + Sealed pend <- readPrims `liftM` (gzReadFilePS tpn `catchall` (return B.empty)) + FlippedSeal newpend_ <- return $ newpend (unsafeCoerceP pend :: FL Prim C(a x)) patch + writePatch tpn $ fromPrims_ newpend_ + where newpend :: FL Prim C(a b) -> FL Prim C(b c) -> FlippedSeal (FL Prim) C(c) + newpend NilFL patch_ = flipSeal patch_ + newpend p patch_ = flipSeal $ p +>+ patch_ + fromPrims_ :: FL Prim C(a b) -> Patch C(a b) + fromPrims_ = fromPrims + +-- | setTentativePending is basically unsafe. It overwrites the pending state with a new one, not related to +-- the repository state. +setTentativePending :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> IO () +setTentativePending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () +setTentativePending (Repo dir _ _ rt) patch = do + Sealed prims <- return $ sift_for_pending patch + withCurrentDirectory dir $ + writePatch (pendingName rt ++ ".tentative") $ fromPrims_ prims + where fromPrims_ :: FL Prim C(a b) -> Patch C(a b) + fromPrims_ = fromPrims + +-- | prepend is basically unsafe. It overwrites the pending state +-- with a new one, not related to the repository state. +prepend :: forall p C(r u t x y). RepoPatch p => + Repository p C(r u t) -> FL Prim C(x y) -> IO () +prepend (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () +prepend (Repo _ _ _ rt) patch = + do let pn = pendingName rt ++ ".tentative" + Sealed pend <- readPrims `liftM` (gzReadFilePS pn `catchall` (return B.empty)) + Sealed newpend_ <- return $ newpend pend patch + writePatch pn $ fromPrims_ (crude_sift newpend_) + where newpend :: FL Prim C(b c) -> FL Prim C(a b) -> Sealed (FL Prim C(a)) + newpend NilFL patch_ = seal patch_ + newpend p patch_ = seal $ patch_ +>+ p + fromPrims_ :: FL Prim C(a b) -> Patch C(a b) + fromPrims_ = fromPrims + +tentativelyRemovePatches :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] + -> FL (Named p) C(x t) -> IO () +tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine + +tentativelyRemovePatches_ :: forall p C(r u t x). RepoPatch p => UpdatePristine + -> Repository p C(r u t) -> [DarcsFlag] + -> FL (Named p) C(x t) -> IO () +tentativelyRemovePatches_ up repository@(Repo dir _ rf (DarcsRepository _ c)) opts ps = + withCurrentDirectory dir $ do + when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..." + prepend repository $ effect ps + remove_from_unrevert_context repository ps + debugMessage "Removing changes from tentative inventory..." + if format_has HashedInventory rf + then do HashedRepo.remove_from_tentative_inventory repository (compression opts) ps + when (up == UpdatePristine) $ + HashedRepo.apply_to_tentative_pristine c opts $ + progressFL "Applying inverse to pristine" $ invert ps + else DarcsRepo.remove_from_tentative_inventory (up==UpdatePristine) opts ps + +tentativelyReplacePatches :: forall p C(r u t x). RepoPatch p => Repository p C(r u t) -> [DarcsFlag] + -> FL (Named p) C(x t) -> IO () +tentativelyReplacePatches repository@(Repo x y z w) opts ps = + -- tentativelyRemovePatches_ leaves the repository in state C(x u t) + do tentativelyRemovePatches_ DontUpdatePristine repository opts ps + -- Now we add the patches back so that the repo again has state C(r u t) + sequence_ $ mapAdd ((Repo x y z w) :: Repository p C(x u t)) ps + where mapAdd :: Repository p C(i l m) -> FL (Named p) C(i j) -> [IO ()] + mapAdd _ NilFL = [] + mapAdd r@(Repo dir df rf dr) (a:>:as) = + -- we construct a new Repository object on the recursive case so that the + -- recordedstate of the repository can match the fact that we just wrote a patch + tentativelyAddPatch_ DontUpdatePristine r opts (n2pia a) : mapAdd (Repo dir df rf dr) as + +finalize_pending :: RepoPatch p => Repository p C(r u t) -> IO () +finalize_pending (Repo dir opts _ rt) + | NoUpdateWorking `elem` opts = + withCurrentDirectory dir $ removeFileMayNotExist $ (pendingName rt) +finalize_pending repository@(Repo dir _ _ rt) = do + withCurrentDirectory dir $ do let pn = pendingName rt + tpn = pn ++ ".tentative" + tpfile <- gzReadFilePS tpn `catchall` (return B.empty) + Sealed tpend <- return $ readPrims tpfile + Sealed new_pending <- return $ sift_for_pending tpend + make_new_pending repository new_pending + +finalizeRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO () +finalizeRepositoryChanges (Repo _ opts _ _) + | DryRun `elem` opts = bug "finalizeRepositoryChanges called when --dry-run specified" +finalizeRepositoryChanges repository@(Repo dir opts rf _) + | format_has HashedInventory rf = + withCurrentDirectory dir $ do debugMessage "Considering whether to test..." + testTentative repository + debugMessage "Finalizing changes..." + withSignalsBlocked $ do HashedRepo.finalize_tentative_changes repository (compression opts) + finalize_pending repository + debugMessage "Done finalizing changes..." +finalizeRepositoryChanges repository@(Repo dir _ _ (DarcsRepository _ _)) = + withCurrentDirectory dir $ do debugMessage "Considering whether to test..." + testTentative repository + debugMessage "Finalizing changes..." + withSignalsBlocked $ do DarcsRepo.finalize_pristine_changes + DarcsRepo.finalize_tentative_changes + finalize_pending repository + +testTentative :: RepoPatch p => Repository p C(r u t) -> IO () +testTentative = testAny withTentative + +testRecorded :: RepoPatch p => Repository p C(r u t) -> IO () +testRecorded = testAny withRecorded + +testAny :: RepoPatch p => (Repository p C(r u t) + -> ((AbsolutePath -> IO ()) -> IO ()) + -> (AbsolutePath -> IO ()) -> IO ()) + -> Repository p C(r u t) -> IO () +testAny withD repository@(Repo dir opts _ _) = + when (Test `elem` opts) $ withCurrentDirectory dir $ + do let putInfo = if not $ Quiet `elem` opts then putStrLn else const (return ()) + debugMessage "About to run test if it exists." + testline <- get_prefval "test" + case testline of + Nothing -> return () + Just testcode -> + withD repository (wd "testing") $ \_ -> + do putInfo "Running test...\n" + when (SetScriptsExecutable `elem` opts) setScriptsExecutable + ec <- system testcode + if ec == ExitSuccess + then putInfo "Test ran successfully.\n" + else do putInfo "Test failed!\n" + exitWith ec + where wd = if LeaveTestDir `elem` opts then withPermDir else withTempDir + +revertRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO () +revertRepositoryChanges (Repo _ opts _ _) + | DryRun `elem` opts = bug "revertRepositoryChanges called when --dry-run is specified" +revertRepositoryChanges r@(Repo dir opts rf dr@(DarcsRepository _ _)) = + withCurrentDirectory dir $ + do removeFileMayNotExist (pendingName dr ++ ".tentative") + Sealed x <- read_pending r + setTentativePending r $ effect x + when (NoUpdateWorking `elem` opts) $ removeFileMayNotExist $ pendingName dr + decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revert_tentative_changes, + old = DarcsRepo.revert_tentative_changes } + +patchSetToPatches :: RepoPatch p => RL (RL (PatchInfoAnd p)) C(x y) -> FL (Named p) C(x y) +patchSetToPatches patchSet = mapFL_FL hopefully $ reverseRL $ concatRL patchSet + +getUMask :: [DarcsFlag] -> Maybe String +getUMask [] = Nothing +getUMask ((UMask u):_) = Just u +getUMask (_:l) = getUMask l + +withGutsOf :: Repository p C(r u t) -> IO () -> IO () +withGutsOf (Repo _ _ rf _) | format_has HashedInventory rf = id + | otherwise = withSignalsBlocked + +withRepository :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a +withRepository opts1 = withRepositoryDirectory opts1 "." + +withRepositoryDirectory :: forall a. [DarcsFlag] -> String + -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a +withRepositoryDirectory opts1 url job = + do Repo dir opts rf rt <- identifyDarcs1Repository opts1 url + let rt' = case rt of DarcsRepository t c -> DarcsRepository t c + if format_has Darcs2 rf + then do debugMessage $ "Identified darcs-2 repo: " ++ dir + job1_ (Repo dir opts rf rt') + else do debugMessage $ "Identified darcs-1 repo: " ++ dir + job2_ (Repo dir opts rf rt) + where job1_ :: Repository (FL RealPatch) C(r u r) -> IO a + job1_ = job + job2_ :: Repository Patch C(r u r) -> IO a + job2_ = job + + +-- RankNTypes +-- $- works around the lack of impredicative instantiation in GHC +($-) ::((forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a) + -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a +x $- y = x y + +withRepoLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a +withRepoLock opts job = + withRepository opts $- \repository@(Repo _ _ rf _) -> + do case write_problem rf of + Nothing -> return () + Just err -> fail err + let name = "./"++darcsdir++"/lock" + wu = case (getUMask opts) of + Nothing -> id + Just u -> withUMask u + wu $ if DryRun `elem` opts + then job repository + else withLock name (revertRepositoryChanges repository >> job repository) + +withRepoReadLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a +withRepoReadLock opts job = + withRepository opts $- \repository@(Repo _ _ rf _) -> + do case write_problem rf of + Nothing -> return () + Just err -> fail err + let name = "./"++darcsdir++"/lock" + wu = case (getUMask opts) of Nothing -> id + Just u -> withUMask u + wu $ if format_has HashedInventory rf || DryRun `elem` opts + then job repository + else withLock name (revertRepositoryChanges repository >> job repository) + +remove_from_unrevert_context :: forall p C(r u t x). RepoPatch p + => Repository p C(r u t) -> FL (Named p) C(x t) -> IO () +remove_from_unrevert_context repository ps = do + Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (NilRL:<:NilRL)) + remove_from_unrevert_context_ bundle + where unrevert_impossible unrevert_loc = + do yorn <- promptYorn "This operation will make unrevert impossible!\nProceed?" + case yorn of + 'n' -> fail "Cancelled." + 'y' -> removeFile unrevert_loc `catchall` return () + _ -> impossible + pis = mapFL patch2patchinfo ps + unrevert_patch_bundle :: IO (SealedPatchSet p) + unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository) + case scan_bundle pf of + Right foo -> return foo + Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err + remove_from_unrevert_context_ :: PatchSet p C(z) -> IO () + remove_from_unrevert_context_ (NilRL :<: NilRL) = return () + remove_from_unrevert_context_ bundle = do + let unrevert_loc = unrevertUrl repository + debugMessage "Adjusting the context of the unrevert changes..." + ref <- readTentativeRepo repository + case get_common_and_uncommon (bundle, ref) of + (common,(h_us:<:NilRL):<:NilRL :\/: NilRL:<:NilRL) -> + case commuteRL (reverseFL ps :> hopefully h_us) of + Nothing -> unrevert_impossible unrevert_loc + Just (us' :> _) -> do + s <- slurp_recorded repository + writeDocBinFile unrevert_loc $ + make_bundle [] s + (common \\ pis) (us':>:NilFL) + (common,(x:<:NilRL):<:NilRL:\/:_) + | isr && any (`elem` common) pis -> unrevert_impossible unrevert_loc + | isr -> return () + where isr = isJust $ hopefullyM x + _ -> unrevert_impossible unrevert_loc + +-- | Writes out a fresh copy of the inventory that minimizes the +-- amount of inventory that need be downloaded when people pull from +-- the repository. +-- +-- Specifically, it breaks up the inventory on the most recent tag. +-- This speeds up most commands when run remotely, both because a +-- smaller file needs to be transfered (only the most recent +-- inventory). It also gives a guarantee that all the patches prior +-- to a given tag are included in that tag, so less commutation and +-- history traversal is needed. This latter issue can become very +-- important in large repositories. +optimizeInventory :: RepoPatch p => Repository p C(r u t) -> IO () +optimizeInventory repository@(Repo r opts rf (DarcsRepository _ c)) = + do ps <- read_repo repository + decideHashedOrNormal rf $ + HvsO { hashed = do revertRepositoryChanges repository + HashedRepo.write_tentative_inventory c (compression opts) $ deep_optimize_patchset ps + finalizeRepositoryChanges repository, + old = DarcsRepo.write_inventory r $ deep_optimize_patchset ps + } + +cleanRepository :: RepoPatch p => Repository p C(r u t) -> IO () +cleanRepository repository@(Repo _ _ rf _) = + decideHashedOrNormal rf $ + HvsO { hashed = HashedRepo.clean_pristine repository, + old = return () } + +replacePristineFromSlurpy :: Repository p C(r u t) -> Slurpy -> IO () +replacePristineFromSlurpy (Repo r opts rf (DarcsRepository pris c)) s + | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.replacePristineFromSlurpy c (compression opts) s + | otherwise = withCurrentDirectory r $ Pristine.replacePristineFromSlurpy s pris + +createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO () +createPristineDirectoryTree repo@(Repo r opts rf (DarcsRepository pris c)) reldir + | format_has HashedInventory rf = + do createDirectoryIfMissing True reldir + withCurrentDirectory reldir $ HashedRepo.copy_pristine c (compression opts) r (darcsdir++"/hashed_inventory") + | otherwise = + do dir <- toPath `fmap` ioAbsoluteOrRemote reldir + done <- withCurrentDirectory r $ easyCreatePristineDirectoryTree pris dir + unless done $ do Sealed patches <- (seal . reverseRL . concatRL) `liftM` read_repo repo + createDirectoryIfMissing True dir + withCurrentDirectory dir $ apply_patches [] patches + +-- fp below really should be FileName +createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p C(r u t) -> [fp] -> FilePath -> IO () +createPartialsPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) prefs dir + | format_has HashedInventory rf = + do createDirectoryIfMissing True dir + withCurrentDirectory dir $ + HashedRepo.copy_partials_pristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs +createPartialsPristineDirectoryTree r@(Repo rdir _ _ (DarcsRepository pris _)) prefs dir + = withCurrentDirectory rdir $ + do done <- easyCreatePartialsPristineDirectoryTree prefs pris dir + unless done $ withRecorded r (withTempDir "recorded") $ \_ -> do + clonePartialsTree "." dir (map toFilePath prefs) + +pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO () +pristineFromWorking (Repo dir opts rf (DarcsRepository _ c)) + | format_has HashedInventory rf = + withCurrentDirectory dir $ HashedRepo.pristine_from_working c (compression opts) +pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) = + withCurrentDirectory dir $ createPristineFromWorking p + +withRecorded :: RepoPatch p => Repository p C(r u t) + -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a +withRecorded repository mk_dir f + = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) + f d + +checkPristineAgainstSlurpy :: RepoPatch p => Repository p C(r u t) -> Slurpy -> IO Bool +checkPristineAgainstSlurpy repository@(Repo _ opts _ _) s2 = + do s1 <- slurp_recorded repository + ftf <- filetype_function + -- The @$!@ is necessary because some code called from this function uses + -- unsafeInterleaveIO around functions that throw exceptions. If one used + -- @$@ instead of @$!@ here, those exceptions might not be caught by code + -- that runs this function inside a @catch@. + return $! nullFL $ unsafeDiff (LookForAdds:IgnoreTimes:opts) ftf s1 s2 + +withTentative :: forall p a C(r u t). RepoPatch p => + Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a) + -> (AbsolutePath -> IO a) -> IO a +withTentative (Repo dir opts rf (DarcsRepository _ c)) mk_dir f + | format_has HashedInventory rf = + mk_dir $ \d -> do HashedRepo.copy_pristine c (compression opts) dir (darcsdir++"/tentative_pristine") + f d +withTentative repository@(Repo dir opts _ _) mk_dir f = + withRecorded repository mk_dir $ \d -> + do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine") + apply opts $ joinPatches ps + f d + where read_patches :: FilePath -> IO (Sealed (FL p C(x))) + read_patches fil = do ps <- B.readFile fil + return $ case readPatch ps of + Just (x, _) -> x + Nothing -> seal NilFL + +getMarkedupFile :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> FilePath -> IO MarkedUpFile +getMarkedupFile repository pinfo f = do + Sealed (FlippedSeal patches) <- (seal . dropWhileFL ((/= pinfo) . info) + . reverseRL . concatRL) `liftM` read_repo repository + return $ snd $ do_mark_all patches (f, empty_markedup_file) + where dropWhileFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(r v) -> FlippedSeal (FL a) C(v) + dropWhileFL _ NilFL = flipSeal NilFL + dropWhileFL p xs@(x:>:xs') + | p x = dropWhileFL p xs' + | otherwise = flipSeal xs +do_mark_all :: RepoPatch p => FL (PatchInfoAnd p) C(x y) + -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) +do_mark_all (hp:>:pps) (f, mk) = + case hopefullyM hp of + Just p -> do_mark_all pps $ markup_file (info hp) (patchcontents p) (f, mk) + Nothing -> (f, [(BC.pack "Error reading a patch!",None)]) +do_mark_all NilFL (f, mk) = (f, mk) + +-- | Sets scripts in or below the current directory executable. A script is any file that starts +-- with the bytes '#!'. This is used sometimes for --set-scripts-executable, but at other times +-- --set-scripts-executable is handled by the hunk patch case of applyFL. +setScriptsExecutable :: IO () +setScriptsExecutable = do + debugMessage "Making scripts executable" + myname <- getCurrentDirectory + c <- list_slurpy_files `fmap` (HashedRepo.slurp_all_but_darcs myname) + let setExecutableIfScript f = + do contents <- B.readFile f + when (BC.pack "#!" `B.isPrefixOf` contents) $ do + debugMessage ("Making executable: " ++ f) + setExecutable f True + mapM_ setExecutableIfScript c diff --git a/src/Darcs/Repository/InternalTypes.hs b/src/Darcs/Repository/InternalTypes.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/InternalTypes.hs @@ -0,0 +1,42 @@ +-- Copyright (C) 2006-2007 David Roundy +-- +-- 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; if not, write to the Free Software Foundation, +-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +-- , KindSignatures #-} + +#include "gadts.h" + +module Darcs.Repository.InternalTypes ( Repository(..), RepoType(..), Pristine(..) + , extractCache + ) where + +import Darcs.Repository.Cache ( Cache ) +import Darcs.Flags ( DarcsFlag ) +import Darcs.Repository.Format ( RepoFormat ) + +data Pristine + = NoPristine !String + | PlainPristine !String + | HashedPristine + deriving ( Show ) + +data Repository (p :: * C(-> * -> *)) C(recordedstate unrecordedstate tentativestate) = Repo !String ![DarcsFlag] !RepoFormat !(RepoType p) deriving ( Show ) + +data RepoType (p :: * C(-> * -> *)) = DarcsRepository !Pristine Cache deriving ( Show ) + +extractCache :: Repository p C(r u t) -> Cache +extractCache (Repo _ _ _ (DarcsRepository _ c)) = c diff --git a/src/Darcs/Repository/Motd.lhs b/src/Darcs/Repository/Motd.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Motd.lhs @@ -0,0 +1,49 @@ +% Copyright (C) 2002-2004 David Roundy +% +% 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. + + +\begin{code} +module Darcs.Repository.Motd (get_motd, show_motd) where +import Control.Monad ( unless ) +import Darcs.Flags ( DarcsFlag( Quiet, XMLOutput ) ) +import Darcs.External ( fetchFilePS, Cachable(..) ) +import Darcs.Global ( darcsdir ) +import qualified Data.ByteString as B (null, hPut, empty, ByteString) +import Darcs.Utils ( catchall ) +import System.IO ( stdout ) +\end{code} + +\paragraph{motd}\label{motd} +The \verb!_darcs/prefs/motd! file may contain a ``message of the day'' +which will be displayed to users who get or pull from the repository without the +\verb!--quiet! option. + +\begin{code} +-- | Fetch and return the message of the day for a given repository. +get_motd :: String -> IO B.ByteString +get_motd repo = fetchFilePS (repo++"/"++darcsdir++"/prefs/motd") (MaxAge 600) + `catchall` return B.empty + +-- | Display the message of the day for a given repository, +-- unless either the 'XMLOutput' or the 'Quiet' flags are passed in +show_motd :: [DarcsFlag] -> String -> IO () +show_motd opts repo = unless (Quiet `elem` opts || XMLOutput `elem` opts) $ do + motd <- get_motd repo + unless (B.null motd) + $ do B.hPut stdout motd + putStrLn "**********************" +\end{code} diff --git a/src/Darcs/Repository/Prefs.lhs b/src/Darcs/Repository/Prefs.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Prefs.lhs @@ -0,0 +1,528 @@ +% Copyright (C) 2002-2003 David Roundy +% +% 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. + + +\begin{code} +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Repository.Prefs ( add_to_preflist, get_preflist, set_preflist, + get_global, environmentHelpHome, + defaultrepo, set_defaultrepo, + get_prefval, set_prefval, change_prefval, + def_prefval, + write_default_prefs, + boring_regexps, boring_file_filter, darcsdir_filter, + FileType(..), filetype_function, + getCaches, + binaries_file_help + ) where + +import System.IO.Error ( isDoesNotExistError ) +import Control.Monad ( unless, when, mplus ) +import Text.Regex ( Regex, mkRegex, matchRegex, ) +import Data.Char ( toUpper ) +import Data.Maybe ( isJust, catMaybes ) +import Data.List ( nub, isPrefixOf, union ) +import System.Directory ( getAppUserDataDirectory ) +import System.FilePath ( () ) + +import Darcs.Flags ( DarcsFlag( NoCache, NoSetDefault, DryRun, Ephemeral, RemoteRepo ) ) +import Darcs.RepoPath ( AbsolutePath, ioAbsolute, toFilePath, getCurrentDirectory ) +import Darcs.Utils ( catchall, stripCr ) +import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) ) +import Darcs.Patch.FileName ( fp2fn ) +import Darcs.External ( gzFetchFilePS, Cachable( Cachable ) ) +import qualified Data.ByteString.Char8 as BC ( unpack ) +import qualified Data.ByteString as B ( empty ) +import Darcs.Global ( darcsdir ) +import Darcs.Repository.Cache ( Cache(..), CacheType(..), CacheLoc(..), + WritableOrNot(..) ) +import Darcs.URL ( is_file ) +\end{code} + +\section{prefs} + +The \verb!_darcs! directory contains a \verb!prefs! directory. This +directory exists simply to hold user configuration settings specific to +this repository. The contents of this directory are intended to be +modifiable by the user, although in some cases a mistake in such a +modification may cause darcs to behave strangely. + + + +\input{Darcs/ArgumentDefaults.lhs} + +\begin{code} +write_default_prefs :: IO () +write_default_prefs = do set_preflist "boring" default_boring + set_preflist "binaries" default_binaries + set_preflist "motd" [] +\end{code} + +\paragraph{repos} +The \verb!_darcs/prefs/repos! file contains a list of repositories you have +pulled from or pushed to, and is used for autocompletion of pull and push +commands in bash. Feel free to delete any lines from this list that might +get in there, or to delete the file as a whole. + +\paragraph{author}\label{author_prefs} +The \verb!_darcs/prefs/author! file contains the email address (or name) to +be used as the author when patches are recorded in this repository, +e.g.\ \verb!David Roundy !. This +file overrides the contents of the environment variables +\verb!$DARCS_EMAIL! and \verb!$EMAIL!. + +\paragraph{boring}\label{boring} +The \verb!_darcs/prefs/boring! file may contain a list of regular +expressions describing files, such as object files, that you do not expect +to add to your project. As an example, the boring file that I use with +my darcs repository is: +\begin{verbatim} +\.hi$ +\.o$ +^\.[^/] +^_ +~$ +(^|/)CVS($|/) +\end{verbatim} +A newly created repository has a longer boring file that +includes many common source control, backup, temporary, and compiled files. + +You may want to have the boring file under version +control. To do this you can use darcs setpref to set the value +``boringfile'' to the name of your desired boring file +(e.g.\ \verb-darcs setpref boringfile .boring-, where \verb-.boring- +is the repository path of a file +that has been +darcs added to your repository). The boringfile preference overrides +\verb!_darcs/prefs/boring!, so be sure to copy that file to the boringfile. + +You can also set up a ``boring'' regexps +file in your home directory, named \verb!~/.darcs/boring!, +on MS Windows~\ref{ms_win}, which will be +used with all of your darcs repositories. + +Any file not already managed by darcs and whose repository path (such +as \verb!manual/index.html!) matches any of +the boring regular expressions is considered boring. The boring file is +used to filter the files provided to darcs add, to allow you to use a +simple \verb-darcs add newdir newdir/*- +without accidentally adding a bunch of +object files. It is also used when the \verb!--look-for-adds! flag is +given to whatsnew or record. +Note that once a file has been added to darcs, it is not considered +boring, even if it matches the boring file filter. + +\begin{code} +{-# NOINLINE default_boring #-} +default_boring :: [String] +default_boring = ["# Boring file regexps:", + "", + "### compiler and interpreter intermediate files", + "# haskell (ghc) interfaces", + "\\.hi$", "\\.hi-boot$", "\\.o-boot$", + "# object files", + "\\.o$","\\.o\\.cmd$", + "# profiling haskell", + "\\.p_hi$", "\\.p_o$", + "# haskell program coverage resp. profiling info", + "\\.tix$", "\\.prof$", + "# fortran module files", + "\\.mod$", + "# linux kernel", + "\\.ko\\.cmd$","\\.mod\\.c$", + "(^|/)\\.tmp_versions($|/)", + "# *.ko files aren't boring by default because they might", + "# be Korean translations rather than kernel modules", + "# \\.ko$", + "# python, emacs, java byte code", + "\\.py[co]$", "\\.elc$","\\.class$", + "# objects and libraries; lo and la are libtool things", + "\\.(obj|a|exe|so|lo|la)$", + "# compiled zsh configuration files", + "\\.zwc$", + "# Common LISP output files for CLISP and CMUCL", + "\\.(fas|fasl|sparcf|x86f)$", + "", + "### build and packaging systems", + "# cabal intermediates", + "\\.installed-pkg-config", + "\\.setup-config", + "# standard cabal build dir, might not be boring for everybody", + "# ^dist(/|$)", + "# autotools", + "(^|/)autom4te\\.cache($|/)", "(^|/)config\\.(log|status)$", + "# microsoft web expression, visual studio metadata directories", + "\\_vti_cnf$", + "\\_vti_pvt$", + "# gentoo tools", + "\\.revdep-rebuild.*", + "# generated dependencies", + "^\\.depend$", + "", + "### version control systems", + "# cvs", + "(^|/)CVS($|/)","\\.cvsignore$", + "# cvs, emacs locks", + "^\\.#", + "# rcs", + "(^|/)RCS($|/)", ",v$", + "# subversion", + "(^|/)\\.svn($|/)", + "# mercurial", + "(^|/)\\.hg($|/)", + "# git", + "(^|/)\\.git($|/)", + "# bzr", + "\\.bzr$", + "# sccs", + "(^|/)SCCS($|/)", + "# darcs", + "(^|/)"++darcsdir++"($|/)", "(^|/)\\.darcsrepo($|/)", + "^\\.darcs-temp-mail$", + "-darcs-backup[[:digit:]]+$", + "# gnu arch", + "(^|/)(\\+|,)", + "(^|/)vssver\\.scc$", + "\\.swp$","(^|/)MT($|/)", + "(^|/)\\{arch\\}($|/)","(^|/).arch-ids($|/)", + "# bitkeeper", + "(^|/)BitKeeper($|/)","(^|/)ChangeSet($|/)", + "", + "### miscellaneous", + "# backup files", + "~$","\\.bak$","\\.BAK$", + "# patch originals and rejects", + "\\.orig$", "\\.rej$", + "# X server", + "\\..serverauth.*", + "# image spam", + "\\#", "(^|/)Thumbs\\.db$", + "# vi, emacs tags", + "(^|/)(tags|TAGS)$", + "#(^|/)\\.[^/]", + "# core dumps", + "(^|/|\\.)core$", + "# partial broken files (KIO copy operations)", + "\\.part$", + "# waf files, see http://code.google.com/p/waf/", + "(^|/)\\.waf-[[:digit:].]+-[[:digit:]]+($|/)", + "(^|/)\\.lock-wscript$", + "# mac os finder", + "(^|/)\\.DS_Store$" ] + +darcsdir_filter :: [FilePath] -> [FilePath] +darcsdir_filter = filter (not.is_darcsdir) +is_darcsdir :: FilePath -> Bool +is_darcsdir ('.':'/':f) = is_darcsdir f +is_darcsdir "." = True +is_darcsdir "" = True +is_darcsdir ".." = True +is_darcsdir "../" = True +is_darcsdir fp = darcsdir `isPrefixOf` fp + +-- | The path of the global preference directory; @~/.darcs@ on Unix, +-- and @%APPDATA%/darcs@ on Windows. +global_prefs_dir :: IO (Maybe FilePath) +global_prefs_dir = (getAppUserDataDirectory "darcs" >>= return.Just) + `catchall` (return Nothing) + +environmentHelpHome :: ([String], [String]) +environmentHelpHome = (["HOME", "APPDATA"], [ + "Per-user preferences are set in $HOME/.darcs (on Unix) or", + "%APPDATA%/darcs (on Windows). This is also the default location of", + "the cache."]) + +get_global :: String -> IO [String] +get_global f = do + dir <- global_prefs_dir + case dir of + (Just d) -> get_preffile $ d f + Nothing -> return [] + +global_cache_dir :: IO (Maybe FilePath) +global_cache_dir = slash_cache `fmap` global_prefs_dir + where slash_cache = fmap ( "cache") + +boring_regexps :: IO [Regex] +boring_regexps = do + borefile <- def_prefval "boringfile" (darcsdir ++ "/prefs/boring") + bores <- get_lines borefile `catchall` return [] + gbs <- get_global "boring" + return $ map mkRegex $ bores ++ gbs + +boring_file_filter :: IO ([FilePath] -> [FilePath]) +boring_file_filter = boring_regexps >>= return . actual_boring_file_filter + +noncomments :: [String] -> [String] +noncomments ss = filter is_ok ss + where is_ok "" = False + is_ok ('#':_) = False + is_ok _ = True + +get_lines :: ReadableDirectory m => FilePath -> m [String] +get_lines f = (notconflicts . noncomments . map stripCr . lines) + `fmap` mReadBinFile (fp2fn f) + where notconflicts = filter nc + startswith [] _ = True + startswith (x:xs) (y:ys) | x == y = startswith xs ys + startswith _ _ = False + nc l | startswith "v v v v v v v" l = False + nc l | startswith "*************" l = False + nc l | startswith "^ ^ ^ ^ ^ ^ ^" l = False + nc _ = True + +-- | From a list of paths, filter out any that are within @_darcs@ or +-- match a boring regexp. +actual_boring_file_filter :: [Regex] -> [FilePath] -> [FilePath] +actual_boring_file_filter regexps files = filter (not . boring . normalize) files + where boring file = is_darcsdir file || + any (\regexp -> isJust $ matchRegex regexp file) regexps + +normalize :: FilePath -> FilePath +normalize ('.':'/':f) = normalize f +normalize f = normalize_helper $ reverse f + where + normalize_helper ('/':rf) = normalize_helper rf + normalize_helper rf = reverse rf +\end{code} + +\paragraph{binaries} +The \verb!_darcs/prefs/binaries! file may contain a list of regular +expressions describing files that should be treated as binary files rather +than text files. Darcs automatically treats files containing +\verb!^Z\! or \verb!'\0'! within the first 4096 bytes as being binary files. +You probably will want to have the binaries file under +version control. To do this you can use darcs setpref to set the value +``binariesfile'' to the name of your desired binaries file +(e.g.\ \verb'darcs setpref binariesfile ./.binaries', where +\verb'.binaries' is a file that has been +darcs added to your repository). As with the boring file, you can also set +up a \verb!~/.darcs/binaries! file if you like, on MS Windows~\ref{ms_win}. + +\begin{code} +data FileType = BinaryFile | TextFile + deriving (Eq) + +{-# NOINLINE default_binaries #-} +-- | The lines that will be inserted into @_darcs/prefs/binaries@ when +-- @darcs init@ is run. Hence, a list of comments, blank lines and +-- regular expressions (ERE dialect). +-- +-- Note that while this matches .gz and .GZ, it will not match .gZ, +-- i.e. it is not truly case insensitive. +default_binaries :: [String] +default_binaries = help ++ + ["\\.(" ++ e ++ "|" ++ map toUpper e ++ ")$" | e <- extensions ] + where extensions = ["a","bmp","bz2","doc","elc","exe","gif","gz","iso", + "jar","jpe?g","mng","mpe?g","p[nbgp]m","pdf","png", + "pyc","so","tar","tgz","tiff?","z","zip"] + help = map ("# "++) binaries_file_help + +binaries_file_help :: [String] +binaries_file_help = + ["This file contains a list of extended regular expressions, one per", + "line. A file path matching any of these expressions is assumed to", + "contain binary data (not text). The entries in ~/.darcs/binaries (if", + "it exists) supplement those in this file.", + "", + "Blank lines, and lines beginning with an octothorpe (#) are ignored.", + "See regex(7) for a description of extended regular expressions."] + +filetype_function :: IO (FilePath -> FileType) +filetype_function = do + binsfile <- def_prefval "binariesfile" (darcsdir ++ "/prefs/binaries") + bins <- get_lines binsfile `catch` + (\e-> if isDoesNotExistError e then return [] else ioError e) + gbs <- get_global "binaries" + regexes <- return (map (\r -> mkRegex r) (bins ++ gbs)) + let isbin f = or $ map (\r -> isJust $ matchRegex r f) regexes + ftf f = if isbin $ normalize f then BinaryFile else TextFile + in + return ftf + +-- this avoids a circular dependency with Repository +prefsDirectory :: ReadableDirectory m => m String +prefsDirectory = + do darcs <- mDoesDirectoryExist $ fp2fn darcsdir + if darcs + then return $ darcsdir ++ "/prefs/" + else fail $ "Directory " ++ darcsdir ++ "/ does not exist!" + +withPrefsDirectory :: ReadableDirectory m => (String -> m ()) -> m () +withPrefsDirectory j = do prefs <- prefsDirectory `mplus` return "x" + when (prefs /= "x") $ j prefs + +add_to_preflist :: WriteableDirectory m => String -> String -> m () +add_to_preflist p s = withPrefsDirectory $ \prefs -> do + hasprefs <- mDoesDirectoryExist $ fp2fn prefs + unless hasprefs $ mCreateDirectory $ fp2fn prefs + pl <- get_preflist p + mWriteBinFile (fp2fn $ prefs ++ p) $ unlines $ union [s] pl + +get_preflist :: ReadableDirectory m => String -> m [String] +get_preflist p = do prefs <- prefsDirectory `mplus` return "x" + if (prefs /= "x") then get_preffile $ prefs ++ p + else return [] + +get_preffile :: ReadableDirectory m => FilePath -> m [String] +get_preffile f = do + hasprefs <- mDoesFileExist (fp2fn f) + if hasprefs + then get_lines f + else return [] + +set_preflist :: WriteableDirectory m => String -> [String] -> m () +set_preflist p ls = withPrefsDirectory $ \prefs -> do + haspref <- mDoesDirectoryExist $ fp2fn prefs + if haspref + then mWriteBinFile (fp2fn $ prefs ++ p) (unlines ls) + else return () + +def_prefval :: String -> String -> IO String +def_prefval p d = do + pv <- get_prefval p + case pv of Nothing -> return d + Just v -> return v + +get_prefval :: ReadableDirectory m => String -> m (Maybe String) +get_prefval p = + do pl <- get_preflist "prefs" + case map snd $ filter ((==p).fst) $ map (break (==' ')) pl of + [val] -> case words val of + [] -> return Nothing + _ -> return $ Just $ tail val + _ -> return Nothing + +set_prefval :: WriteableDirectory m => String -> String -> m () +set_prefval p v = do pl <- get_preflist "prefs" + set_preflist "prefs" $ + filter ((/=p).fst.(break (==' '))) pl ++ [p++" "++v] + +change_prefval :: WriteableDirectory m => String -> String -> String -> m () +change_prefval p f t = + do pl <- get_preflist "prefs" + ov <- get_prefval p + newval <- case ov of + Nothing -> return t + Just old -> if old == f then return t else return old + set_preflist "prefs" $ + filter ((/=p).fst.(break(==' '))) pl ++ [p++" "++newval] + +defaultrepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String] +defaultrepo opts _ [] = + do let fixR r | not (is_file r) = return r + | otherwise = do absr <- ioAbsolute r + return $ toFilePath absr + case [r | RemoteRepo r <- opts] of + [] -> do defrepo <- get_preflist "defaultrepo" + case defrepo of + [r] -> (:[]) `fmap` fixR r + _ -> return [] + rs -> mapM fixR rs +defaultrepo _ _ r = return r + +set_defaultrepo :: String -> [DarcsFlag] -> IO () +set_defaultrepo r opts = do doit <- if (NoSetDefault `notElem` opts && DryRun `notElem` opts && r_is_not_tmp) + then return True + else do olddef <- + get_preflist "defaultrepo" + return (olddef == []) + when doit + (set_preflist "defaultrepo" [r]) + add_to_preflist "repos" r + `catchall` return () -- we don't care if this fails! + where + r_is_not_tmp = not $ r `elem` [x | RemoteRepo x <- opts] +\end{code} + +\paragraph{email} +The \verb!_darcs/prefs/email! file is used to provide the e-mail address for your +repository that others will use when they \verb!darcs send! a patch back to you. +The contents of the file should simply be an e-mail address. + + +\paragraph{sources} +The \verb!_darcs/prefs/sources! file is used to indicate alternative +locations from which to download patches when using a ``hashed'' +repository. This file contains lines such as: +\begin{verbatim} +cache:/home/droundy/.darcs/cache +readonly:/home/otheruser/.darcs/cache +repo:http://darcs.net +\end{verbatim} +This would indicate that darcs should first look in +\verb!/home/droundy/.darcs/cache! for patches that might be missing, and if +the patch isn't there, it should save a copy there for future use. In that +case, darcs will look in \verb!/home/otheruser/.darcs/cache! to see if that +user might have downloaded a copy, but won't try to save a copy there, of +course. Finally, it will look in \verb!http://darcs.net!. Note that the +\verb!sources! file can also exist in \verb!~/.darcs/!. Also note that the +sources mentioned in your \verb!sources! file will be tried \emph{before} +the repository you are pulling from. This can be useful in avoiding +downloading patches multiple times when you pull from a remote repository +to more than one local repository. + +We strongly advise that you enable a global cache directory, which will +allow darcs to avoid re-downloading patches (for example, when doing a +second darcs get of the same repository), and also allows darcs to use hard +links to reduce disk usage. To do this, simply +\begin{verbatim} +mkdir -p $HOME/.darcs/cache +echo cache:$HOME/.darcs/cache > $HOME/.darcs/sources +\end{verbatim} +Note that the cache directory should reside on the same filesystem as your +repositories, so you may need to vary this. You can also use multiple +cache directories on different filesystems, if you have several filesystems +on which you use darcs. + +On MS Windows~\ref{ms_win}) + +\begin{code} +getCaches :: [DarcsFlag] -> String -> IO Cache +getCaches opts repodir = + do here <- parsehs `fmap` get_preffile (darcsdir ++ "/prefs/sources") + there <- (parsehs . lines . BC.unpack) `fmap` + (gzFetchFilePS (repodir ++ "/" ++ darcsdir ++ "/prefs/sources") Cachable + `catchall` return B.empty) + globalcachedir <- global_cache_dir + let globalcache = case (nocache,globalcachedir) of + (True,_) -> [] + (_,Just d) -> [Cache Directory Writable d] + _ -> [] + globalsources <- parsehs `fmap` get_global "sources" + thisdir <- getCurrentDirectory + let thisrepo = if Ephemeral `elem` opts + then [Cache Repo NotWritable $ toFilePath thisdir] + else [Cache Repo Writable $ toFilePath thisdir] + return $ Ca $ nub $ thisrepo ++ globalcache ++ globalsources ++ + here ++ [Cache Repo NotWritable repodir] ++ there + where + parsehs = catMaybes . map readln . noncomments + readln l | take 5 l == "repo:" = Just (Cache Repo NotWritable (drop 5 l)) + | take 9 l == "thisrepo:" = Just (Cache Repo Writable (drop 9 l)) + | nocache = Nothing + | take 6 l == "cache:" = Just (Cache Directory Writable (drop 6 l)) + | take 9 l == "readonly:" = Just (Cache Directory NotWritable (drop 9 l)) + | otherwise = Nothing + nocache = NoCache `elem` opts + +\end{code} + diff --git a/src/Darcs/Repository/Pristine.hs b/src/Darcs/Repository/Pristine.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Pristine.hs @@ -0,0 +1,198 @@ +-- Copyright (C) 2002-2005 David Roundy +-- Copyright (C) 2004 Juliusz Chroboczek +-- +-- 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. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Repository.Pristine ( Pristine, flagsToPristine, nopristine, + createPristine, removePristine, identifyPristine, + slurpPristine, + applyPristine, createPristineFromWorking, + syncPristine, replacePristineFromSlurpy, + getPristinePop, + pristineDirectory, pristineToFlagString, + easyCreatePristineDirectoryTree, + easyCreatePartialsPristineDirectoryTree + ) where + +import Data.Maybe ( isJust ) +import Control.Monad ( when, liftM ) +import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist, + renameDirectory, removeFile ) +import Darcs.Lock ( rm_recursive, writeBinFile ) +import Darcs.Diff ( sync ) +import Workaround ( getCurrentDirectory ) +import Darcs.SlurpDirectory ( Slurpy, mmap_slurp, co_slurp, writeSlurpy ) +import Darcs.Utils ( catchall ) + +import Darcs.PopulationData ( Population, getPopFrom ) +import Darcs.Flags ( DarcsFlag( PristinePlain, PristineNone ) ) +import Darcs.Repository.Format ( RepoFormat, format_has, + RepoProperty(HashedInventory) ) +import Darcs.IO ( WriteableDirectory(mWithCurrentDirectory) ) +import Darcs.Patch ( Patchy, apply ) +import Darcs.Patch.Info ( PatchInfo ) +import Darcs.Patch.FileName ( fp2fn ) +import qualified Data.ByteString as B (empty) +import Darcs.RepoPath ( FilePathLike, toFilePath ) +import SHA1 ( sha1PS ) +import Darcs.External ( cloneTree, cloneTreeExcept, clonePartialsTree ) +import Darcs.Repository.InternalTypes ( Pristine(..) ) +import Darcs.Global ( darcsdir ) +#include "impossible.h" + +nopristine :: Pristine +nopristine = NoPristine "aack?" + +pristineName :: String +pristineName = "pristine" + +identifyPristine :: IO (Pristine) +identifyPristine = do mp <- reallyIdentifyPristine + case mp of + Nothing -> fail "Pristine tree doesn't exist." + Just pristine -> return pristine + +reallyIdentifyPristine :: IO (Maybe Pristine) +reallyIdentifyPristine = + do dir <- findpristine doesDirectoryExist "" + none <- findpristine doesFileExist ".none" + hashinv <- doesFileExist $ darcsdir++"/hashed_inventory" + hashpris <- doesDirectoryExist hashedPristineDirectory + case (dir, none, hashinv && hashpris) of + (Nothing, Nothing, False) -> return Nothing + (Just n, Nothing, False) -> + return (Just (PlainPristine n)) + (Nothing, Just n, False) -> + return (Just (NoPristine n)) + (Nothing, Nothing, True) -> + return (Just HashedPristine) + _ -> fail "Multiple pristine trees." + where findpristine fn ext = + do e1 <- fn n1 + e2 <- fn n2 + case (e1, e2) of + (False, False) -> return Nothing + (True, False) -> return (Just n1) + (False, True) -> return (Just n2) + (True, True) -> fail "Multiple pristine trees." + where n1 = darcsdir++"/pristine" ++ ext + n2 = darcsdir++"/current" ++ ext + +flagsToPristine :: [DarcsFlag] -> RepoFormat -> Pristine +flagsToPristine _ rf | format_has HashedInventory rf = HashedPristine +flagsToPristine (PristineNone : _) _ = NoPristine (darcsdir++"/" ++ pristineName ++ ".none") +flagsToPristine (PristinePlain : _) _ = PlainPristine (darcsdir++"/" ++ pristineName) +flagsToPristine (_ : t) rf = flagsToPristine t rf +flagsToPristine [] rf = flagsToPristine [PristinePlain] rf + +createPristine :: Pristine -> IO Pristine +createPristine p = + do oldpristine <- reallyIdentifyPristine + when (isJust oldpristine) $ fail "Pristine tree already exists." + case p of + NoPristine n -> writeBinFile n "Do not delete this file.\n" + PlainPristine n -> createDirectory n + HashedPristine -> do createDirectory hashedPristineDirectory + writeFile (hashedPristineDirectory++"/"++sha1PS B.empty) "" + return p + +hashedPristineDirectory :: String +hashedPristineDirectory = darcsdir++"/pristine.hashed" + +removePristine :: Pristine -> IO () +removePristine (NoPristine n) = removeFile n +removePristine (PlainPristine n) = rm_recursive n +removePristine HashedPristine = rm_recursive hashedPristineDirectory + +slurpPristine :: Pristine -> IO (Maybe Slurpy) +slurpPristine (PlainPristine n) = do cwd <- getCurrentDirectory + slurpy <- mmap_slurp (cwd ++ "/" ++ n) + return (Just slurpy) +slurpPristine (NoPristine _) = return Nothing +slurpPristine HashedPristine = + bug "HashedPristine is not implemented yet." + +applyPristine :: Patchy p => Pristine -> p C(x y) -> IO () +applyPristine (NoPristine _) _ = return () +-- We don't need flags for now, since we don't care about +-- SetScriptsExecutable for the pristine cache. +applyPristine (PlainPristine n) p = + mWithCurrentDirectory (fp2fn n) $ apply [] p +applyPristine HashedPristine _ = + bug "3 HashedPristine is not implemented yet." + +createPristineFromWorking :: Pristine -> IO () +createPristineFromWorking (NoPristine _) = return () +createPristineFromWorking (PlainPristine n) = cloneTreeExcept [darcsdir] "." n +createPristineFromWorking HashedPristine = + bug "HashedPristine is not implemented yet." + +syncPristine :: Pristine -> IO () +syncPristine (NoPristine _) = return () +syncPristine (PlainPristine n) = + do ocur <- mmap_slurp n + owork <- co_slurp ocur "." + sync n ocur owork +syncPristine HashedPristine = return () -- FIXME this should be implemented! + +replacePristineFromSlurpy :: Slurpy -> Pristine -> IO () +replacePristineFromSlurpy _ (NoPristine _) = return () +replacePristineFromSlurpy s (PlainPristine n) = + do rm_recursive nold + `catchall` return () + writeSlurpy s ntmp + renameDirectory n nold + renameDirectory ntmp n + return () + where nold = darcsdir ++ "/" ++ pristineName ++ "-old" + ntmp = darcsdir ++ "/" ++ pristineName ++ "-tmp" +replacePristineFromSlurpy _ HashedPristine = + bug "HashedPristine is not implemented yet." + +getPristinePop :: PatchInfo -> Pristine -> IO (Maybe Population) +getPristinePop pinfo (PlainPristine n) = + Just `liftM` getPopFrom n pinfo +getPristinePop _ _ = return Nothing + +pristineDirectory :: Pristine -> Maybe String +pristineDirectory (PlainPristine n) = Just n +pristineDirectory _ = Nothing + +pristineToFlagString :: Pristine -> String +pristineToFlagString (NoPristine _) = "--no-pristine-tree" +pristineToFlagString (PlainPristine _) = "--plain-pristine-tree" +pristineToFlagString HashedPristine = + bug "HashedPristine is not implemented yet." + +easyCreatePristineDirectoryTree :: Pristine -> FilePath -> IO Bool +easyCreatePristineDirectoryTree (NoPristine _) _ = return False +easyCreatePristineDirectoryTree (PlainPristine n) p + = cloneTree n p >> return True +easyCreatePristineDirectoryTree HashedPristine _ = + bug "HashedPristine is not implemented yet." + +easyCreatePartialsPristineDirectoryTree :: FilePathLike fp => [fp] -> Pristine + -> FilePath -> IO Bool +easyCreatePartialsPristineDirectoryTree _ (NoPristine _) _ = return False +easyCreatePartialsPristineDirectoryTree prefs (PlainPristine n) p + = clonePartialsTree n p (map toFilePath prefs) >> return True +easyCreatePartialsPristineDirectoryTree _ HashedPristine _ = + bug "HashedPristine is not implemented yet." diff --git a/src/Darcs/Repository/Repair.hs b/src/Darcs/Repository/Repair.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Repository/Repair.hs @@ -0,0 +1,165 @@ +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Darcs.Repository.Repair ( replayRepository, + RepositoryConsistency(..) ) + where + +import Control.Monad ( when, unless ) +import Control.Exception ( finally ) +import Data.Maybe ( catMaybes ) +import Data.List ( sort ) +import System.Directory ( createDirectoryIfMissing ) + +import Darcs.SlurpDirectory ( empty_slurpy, withSlurpy, Slurpy, SlurpMonad, syncSlurpy ) +import Darcs.Lock( rm_recursive ) +import Darcs.Hopefully ( PatchInfoAnd, info ) + +import Darcs.Ordered ( FL(..), RL(..), lengthFL, reverseFL, reverseRL, concatRL, + mapRL ) +import Darcs.Patch.Depends ( get_patches_beyond_tag ) +import Darcs.Patch.Patchy ( applyAndTryToFix ) +import Darcs.Patch.Info ( PatchInfo( .. ), human_friendly ) +import Darcs.Patch.Set ( PatchSet ) +import Darcs.Patch ( RepoPatch, patch2patchinfo ) + +import Darcs.Repository.Format ( identifyRepoFormat, + RepoProperty ( HashedInventory ), format_has ) +import Darcs.Repository.Cache ( Cache, HashedDir( HashedPristineDir ) ) +import Darcs.Repository.HashedIO ( slurpHashedPristine, writeHashedPristine, + clean_hashdir ) +import Darcs.Repository.HashedRepo ( readHashedPristineRoot ) +import Darcs.Repository.Checkpoint ( get_checkpoint_by_default ) +import Darcs.Repository.InternalTypes ( extractCache ) +import Darcs.Repository ( Repository, read_repo, + checkPristineAgainstSlurpy, + makePatchLazy ) + +import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal ) +import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO ) +import Darcs.Utils ( catchall ) +import Darcs.Global ( darcsdir ) +import Darcs.Flags ( compression ) +import Printer ( Doc, putDocLn, text ) +import Darcs.Arguments ( DarcsFlag( Verbose, Quiet ) ) +#include "impossible.h" + +run_slurpy :: Slurpy -> SlurpMonad a -> IO (Slurpy, a) +run_slurpy s f = + case withSlurpy s f of + Left err -> fail err + Right x -> return x + +update_slurpy :: Repository p -> Cache -> [DarcsFlag] -> Slurpy -> IO Slurpy +update_slurpy r c opts s = do + current <- readHashedPristineRoot r + h <- writeHashedPristine c (compression opts) s + s' <- slurpHashedPristine c (compression opts) h + clean_hashdir c HashedPristineDir $ catMaybes [Just h, current] + return s' + +replaceInFL :: FL (PatchInfoAnd a) + -> [(PatchInfo, PatchInfoAnd a)] + -> FL (PatchInfoAnd a) +replaceInFL orig [] = orig +replaceInFL NilFL _ = impossible +replaceInFL (o:>:orig) ch@((o',c):ch_rest) + | info o == o' = c:>:replaceInFL orig ch_rest + | otherwise = o:>:replaceInFL orig ch + +applyAndFix :: RepoPatch p => Cache -> [DarcsFlag] -> Slurpy -> Repository p -> FL (PatchInfoAnd p) -> IO (FL (PatchInfoAnd p), Slurpy, Bool) +applyAndFix _ _ s _ NilFL = return (NilFL, s, True) +applyAndFix c opts s_ r psin = + do beginTedious k + tediousSize k $ lengthFL psin + (repaired, slurpy, ok) <- aaf s_ psin + endTedious k + orig <- (reverseRL . concatRL) `fmap` read_repo r + return (replaceInFL orig repaired, slurpy, ok) + where k = "Replaying patch" + aaf s NilFL = return ([], s, True) + aaf s (p:>:ps) = do + (s', mp') <- run_slurpy s $ applyAndTryToFix p + let !infp = info p -- assure that 'p' can be garbage collected. + finishedOneIO k $ show $ human_friendly $ infp + s'' <- syncSlurpy (update_slurpy r c opts) s' + (ps', s''', restok) <- aaf s'' ps + case mp' of + Nothing -> return (ps', s''', restok) + Just (e,pp) -> do putStrLn e + p' <- makePatchLazy r pp + return ((infp, p'):ps', s''', False) + +data RepositoryConsistency p = + RepositoryConsistent + | BrokenPristine Slurpy + | BrokenPatches Slurpy (PatchSet p) + +check_uniqueness :: RepoPatch p => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p -> IO () +check_uniqueness putVerbose putInfo repository = + do putVerbose $ text "Checking that patch names are unique..." + r <- read_repo repository + case has_duplicate $ mapRL info $ concatRL r of + Nothing -> return () + Just pinf -> do putInfo $ text "Error! Duplicate patch name:" + putInfo $ human_friendly pinf + fail "Duplicate patches found." + +has_duplicate :: Ord a => [a] -> Maybe a +has_duplicate li = hd $ sort li + where hd [_] = Nothing + hd [] = Nothing + hd (x1:x2:xs) | x1 == x2 = Just x1 + | otherwise = hd (x2:xs) +replayRepository' :: (RepoPatch p) => Repository p -> [DarcsFlag] -> IO (RepositoryConsistency p) +replayRepository' repo opts = do + let putVerbose s = when (Verbose `elem` opts) $ putDocLn s + putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s + check_uniqueness putVerbose putInfo repo + maybe_chk <- get_checkpoint_by_default repo + let c = extractCache repo + createDirectoryIfMissing False $ darcsdir ++ "/pristine.hashed" + rooth <- writeHashedPristine c (compression opts) empty_slurpy + s <- slurpHashedPristine c (compression opts) rooth + putVerbose $ text "Applying patches..." + patches <- read_repo repo + (s', newpatches, patches_ok) <- case maybe_chk of + Just (Sealed chk) -> + do let chtg = patch2patchinfo chk + putVerbose $ text "I am repairing from a checkpoint." + (s'', _) <- run_slurpy s $ applyAndTryToFix chk + (_, s_, ok) <- applyAndFix c opts s'' repo + (reverseRL $ concatRL $ unsafeUnflippedseal $ get_patches_beyond_tag chtg patches) + return (s_, patches, ok) + Nothing -> do debugMessage "Fixing any broken patches..." + let psin = reverseRL $ concatRL patches + (ps, s_, ok) <- applyAndFix c opts s repo psin + debugMessage "Done fixing broken patches..." + return (s_, (reverseFL ps :<: NilRL), ok) + debugMessage "Checking pristine against slurpy" + is_same <- checkPristineAgainstSlurpy repo s' `catchall` return False + -- TODO is the latter condition needed? Does a broken patch imply pristine + -- difference? Why, or why not? + return (if is_same && patches_ok + then RepositoryConsistent + else if patches_ok + then BrokenPristine s' + else BrokenPatches s' newpatches) + +cleanupRepositoryReplay :: Repository p -> IO () +cleanupRepositoryReplay r = do + let c = extractCache r + rf_or_e <- identifyRepoFormat "." + rf <- case rf_or_e of Left e -> fail e + Right x -> return x + unless (format_has HashedInventory rf) $ + rm_recursive $ darcsdir ++ "/pristine.hashed" + when (format_has HashedInventory rf) $ do + current <- readHashedPristineRoot r + clean_hashdir c HashedPristineDir $ catMaybes [current] + +replayRepository :: (RepoPatch p) => Repository p -> [DarcsFlag] -> (RepositoryConsistency p -> IO a) -> IO a +replayRepository r opt f = run `finally` cleanupRepositoryReplay r + where run = do + st <- replayRepository' r opt + f st diff --git a/src/Darcs/Resolution.lhs b/src/Darcs/Resolution.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Resolution.lhs @@ -0,0 +1,240 @@ +% Copyright (C) 2003,2005 David Roundy +% +% 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. + +\begin{code} +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Darcs.Resolution ( standard_resolution, + external_resolution, + patchset_conflict_resolutions, + ) where + +import System.FilePath.Posix ( () ) +import System.Exit ( ExitCode( ExitSuccess ) ) +import System.Directory ( setCurrentDirectory, getCurrentDirectory ) +import Data.List ( zip4 ) +import Control.Monad ( when ) + +import Darcs.Patch ( RepoPatch, Prim, joinPatches, resolve_conflicts, + effect, + apply_to_filepaths, patchcontents, + invert, list_conflicted_files, commute ) +import Darcs.RepoPath ( toFilePath ) +import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (+>+), + mapFL_FL, reverseRL, lengthFL ) + +import CommandLine ( parseCmd ) +import Darcs.Hopefully ( hopefully ) +import Darcs.Utils ( askUser ) +import Darcs.SlurpDirectory ( Slurpy, slurp, write_files ) +import Darcs.Patch.Set ( PatchSet ) +import Darcs.Diff ( unsafeDiff ) +import Darcs.Sealed ( Sealed(..) ) +import Darcs.Repository.Prefs ( filetype_function ) +import Exec ( exec, Redirect(..) ) +import Darcs.Lock ( withTempDir ) +import Darcs.External ( cloneTree ) +import Darcs.Patch.Apply ( apply_to_slurpy ) + +--import Darcs.ColorPrinter ( traceDoc ) +--import Printer ( greenText, ($$), Doc ) +--import Darcs.Patch ( showPatch ) + +standard_resolution :: RepoPatch p => p C(x y) -> Sealed (FL Prim C(y)) +standard_resolution p = merge_list $ map head $ resolve_conflicts p + +merge_list :: [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x)) +merge_list patches = doml NilFL patches + where doml :: FL Prim C(x y) -> [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x)) + doml mp (Sealed p:ps) = + case commute (invert p :> mp) of + Just (mp' :> _) -> doml (effect p +>+ effect mp') ps + Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions. + doml mp [] = Sealed mp +\end{code} + +\paragraph{Resolution of conflicts}\label{resolution} + +To resolve conflicts using an external tool, you need to specify a command +to use, e.g. +\begin{verbatim} +--external-merge 'opendiff %1 %2 -ancestor %a -merge %o' +\end{verbatim} +The \verb!%1! and \verb!%2! are replaced with the two versions to be +merged, \verb!%a! is replaced with the common ancestor of the two versions. +Most importantly, \verb!%o! is replaced with the name of the output file +that darcs will require to be created holding the merged version. The +above example works with the FileMerge.app tool that comes with Apple's +developer tools. To use xxdiff, you would use +\begin{verbatim} +--external-merge 'xxdiff -m -O -M %o %1 %a %2' +\end{verbatim} +To use \verb!kdiff3!, you can use +\begin{verbatim} +--external-merge 'kdiff3 --output %o %a %1 %2' +\end{verbatim} +To use \verb!tortoiseMerge!, you can use +\begin{verbatim} +--external-merge 'tortoiseMerge /base:"%a" /mine:"%1" /theirs:"%2" /merged:"%o"' +\end{verbatim} +(\verb!tortoiseMerge! is a nice merge tool that comes with TortoiseSVN and works well +on Windows.) + +% Fixme: Is it actually a shell command on MS Windows? +Note that the command is split into space-separated words and the first one is +\verb!exec!ed with the rest as arguments---it is not a shell command. In particular, +on Windows this means that the first command path should not contain spaces and +you should make sure the command is in your \verb!PATH!. + +The substitution of the \verb!%! escapes is done everywhere. If you need to prevent +substitution you can use a double percentage sign, i.e. \verb!%%a! is substituted with +\verb!%a!. Here is an example script to use the Emacs' Ediff package for merging. +% This is indented so that the leading #s don't confuse the preprocessor. +\begin{verbatim} + #! /bin/sh + # External merge command for darcs, using Emacs Ediff, via server if possible. + # It needs args %1 %2 %a %o, i.e. the external merge command is, say, + # `emerge3 %1 %2 %a %o'. + test $# -eq 4 || exit 1 + form="(ediff-merge-files-with-ancestor" + while test $# -gt 0; do + count=$count. + if [ $count = .... ]; then + form=$form\ nil # Lisp STARTUP-HOOKS arg + fi + case $1 in # Worry about quoting -- escape " and \ + *[\"\\]* ) form=$form\ \"$(echo $1 | sed -e's/["\\]/\\\0/g')\" ;; + *) form=$form\ \"$1\" ;; + esac + shift + done + form=$form')' + ( emacsclient --eval "$form" || # Emacs 22 server + gnudoit "$form" || # XEmacs/Emacs 21 server + emacs --eval "$form" || # Relatively slow to start up + xemacs -eval "$form" # Horribly slow to start up + ) 2>/dev/null +\end{verbatim} +It would be invoked like: +\begin{verbatim} +--external-merge 'emerge3 %1 %2 %a %o' +\end{verbatim} + +If you figure out how to use darcs with another merge tool, please let me +know what flags you used so I can mention it here. + +Note that if you do use an external merge tool, most likely you will want +to add to your defaults file +(\verb!_darcs/prefs/defaults! or \verb!~/.darcs/prefs!, see \ref{defaults}, +on MS Windows~\ref{ms_win}) +a line such as +\begin{verbatim} +ALL external-merge kdiff3 --output %o %a %1 %2 +\end{verbatim} +or +\begin{verbatim} +ALL external-merge tortoiseMerge /base:"%a" /mine:"%1" /theirs:"%2" /merged:"%o" +\end{verbatim} + +Note that the defaults file does not want quotes around the command. + +\begin{code} +external_resolution :: RepoPatch p => Slurpy -> String -> FL Prim C(x y) -> FL Prim C(x z) + -> p C(y a) + -> IO (Sealed (FL Prim C(a))) +external_resolution s1 c p1 p2 pmerged = do + sa <- apply_to_slurpy (invert p1) s1 + sm <- apply_to_slurpy pmerged s1 + s2 <- apply_to_slurpy p2 sa + let nms = list_conflicted_files pmerged + nas = apply_to_filepaths (invert pmerged) nms + n1s = apply_to_filepaths p1 nas + n2s = apply_to_filepaths p2 nas + ns = zip4 nas n1s n2s nms + in do + former_dir <- getCurrentDirectory + withTempDir "version1" $ \absd1 -> do + let d1 = toFilePath absd1 + write_files s1 n1s + setCurrentDirectory former_dir + withTempDir "ancestor" $ \absda -> do + let da = toFilePath absda + write_files sa nas + setCurrentDirectory former_dir + withTempDir "merged" $ \absdm -> do + let dm = toFilePath absdm + write_files sm nms + setCurrentDirectory former_dir + withTempDir "cleanmerged" $ \absdc -> do + let dc = toFilePath absdc + cloneTree dm "." + setCurrentDirectory former_dir + withTempDir "version2" $ \absd2 -> do + let d2 = toFilePath absd2 + write_files s2 n2s + mapM_ (externally_resolve_file c da d1 d2 dm) ns + sc <- slurp dc + sfixed <- slurp dm + ftf <- filetype_function + case unsafeDiff [] ftf sc sfixed of + di -> lengthFL di `seq` return (Sealed di) + -- The `seq` above forces the two slurpies to be read before + -- we delete their directories. + +externally_resolve_file :: String -> String -> String -> String -> String + -> (FilePath, FilePath, FilePath, FilePath) + -> IO () +externally_resolve_file c da d1 d2 dm (fa, f1, f2, fm) = do + putStrLn $ "Merging file "++fm++" by hand." + ec <- run c [('1', d1f1), ('2', d2f2), ('a', dafa), ('o', dmfm), ('%', "%")] + when (ec /= ExitSuccess) $ + putStrLn $ "External merge command exited with " ++ show ec + askUser "Hit return to move on, ^C to abort the whole operation..." + return () + +run :: String -> [(Char,String)] -> IO ExitCode +run c replacements = + case parseCmd replacements c of + Left err -> fail $ show err + Right (c2,_) -> rr c2 + where rr (command:args) = do putStrLn $ "Running command '" ++ + unwords (command:args) ++ "'" + exec command args (Null,Null,Null) + rr [] = return ExitSuccess + +patchset_conflict_resolutions :: RepoPatch p => PatchSet p C(x) -> Sealed (FL Prim C(x)) +patchset_conflict_resolutions (NilRL:<:_) = --traceDoc (greenText "no conflicts A") $ + Sealed NilFL +patchset_conflict_resolutions NilRL = --traceDoc (greenText "no conflicts B") $ + Sealed NilFL +patchset_conflict_resolutions (xs:<:_) + = --traceDoc (greenText "looking at resolutions" $$ + -- (sh $ resolve_conflicts $ joinPatches $ + -- mapFL_FL (patchcontents . hopefully) $ reverseRL xs )) $ + merge_list $ map head $ resolve_conflicts $ joinPatches $ + mapFL_FL (patchcontents . hopefully) $ reverseRL xs + --where sh :: [[Sealed (FL Prim)]] -> Doc + -- sh [] = greenText "no more conflicts" + -- sh (x:ps) = greenText "one conflict" $$ sh1 x $$ sh ps + -- sh1 :: [Sealed (FL Prim)] -> Doc + -- sh1 [] = greenText "end of unravellings" + -- sh1 (Sealed x:ps) = greenText "one unravelling:" $$ showPatch x $$ + -- sh1 ps +\end{code} diff --git a/src/Darcs/RunCommand.hs b/src/Darcs/RunCommand.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/RunCommand.hs @@ -0,0 +1,185 @@ +-- Copyright (C) 2002,2003,2005 David Roundy +-- +-- 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. + +module Darcs.RunCommand ( run_the_command ) where + +import Control.Monad ( unless, when ) +import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ), + OptDescr( Option ), + getOpt ) +import System.Exit ( ExitCode ( ExitSuccess ), exitWith ) + +import Darcs.Arguments ( DarcsFlag(..), + help, + option_from_darcsoption, + list_options ) +import Darcs.ArgumentDefaults ( get_default_flags ) +import Darcs.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ), + DarcsCommand, + command_name, + command_command, + command_prereq, + command_extra_arg_help, + command_extra_args, + command_argdefaults, + command_get_arg_possibilities, + command_options, command_alloptions, + disambiguate_commands, + get_command_help, get_command_mini_help, + get_subcommands, + extract_commands, + super_name, + subusage, chomp_newline ) +#ifdef HAVE_HASKELL_ZLIB +import Darcs.Commands.GZCRCs ( doCRCWarnings ) +import Darcs.Global ( atexit ) +#endif +import Darcs.Commands.Help ( command_control_list ) +import Darcs.External ( viewDoc ) +import Darcs.Global ( setDebugMode, setSshControlMasterDisabled, + setTimingsMode, setVerboseMode ) +import Darcs.Match ( checkMatchSyntax ) +import Progress ( setProgressMode ) +import Darcs.RepoPath ( getCurrentDirectory ) +import Darcs.Test ( run_posthook, run_prehook ) +import Darcs.Utils ( formatPath ) +import Printer ( text ) +import URL ( setDebugHTTP, setHTTPPipelining ) + +run_the_command :: String -> [String] -> IO () +run_the_command cmd args = + either fail rtc $ disambiguate_commands command_control_list cmd args + where + rtc (CommandOnly c, as) = run_command Nothing c as + rtc (SuperCommandOnly c, as) = run_raw_supercommand c as + rtc (SuperCommandSub c s, as) = run_command (Just c) s as + +-- This is the actual heavy lifter code, which is responsible for parsing the +-- arguments and then running the command itself. + +run_command :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO () + +run_command _ _ args -- Check for "dangerous" typoes... + | "-all" `elem` args = -- -all indicates --all --look-for-adds! + fail $ "Are you sure you didn't mean -" ++ "-all rather than -all?" +run_command msuper cmd args = do + cwd <- getCurrentDirectory + let options = opts1 ++ opts2 + (opts1, opts2) = command_options cwd cmd + case getOpt Permute + (option_from_darcsoption cwd list_options++options) args of + (opts,extra,[]) + | Help `elem` opts -> viewDoc $ text $ get_command_help msuper cmd + | ListOptions `elem` opts -> do + setProgressMode False + command_prereq cmd opts + file_args <- command_get_arg_possibilities cmd + putStrLn $ get_options_options (opts1++opts2) ++ unlines file_args + | otherwise -> consider_running msuper cmd (addVerboseIfDebug opts) extra + (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs) + where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts + | otherwise = opts + +consider_running :: Maybe DarcsCommand -> DarcsCommand + -> [DarcsFlag] -> [String] -> IO () +consider_running msuper cmd opts old_extra = do + cwd <- getCurrentDirectory + location <- command_prereq cmd opts + case location of + Left complaint -> fail $ "Unable to " ++ + formatPath ("darcs " ++ super_name msuper ++ command_name cmd) ++ + " here.\n\n" ++ complaint + Right () -> do + specops <- add_command_defaults cmd opts + extra <- (command_argdefaults cmd) specops cwd old_extra + when (Disable `elem` specops) $ + fail $ "Command "++command_name cmd++" disabled with --disable option!" + if command_extra_args cmd < 0 + then runWithHooks specops extra + else if length extra > command_extra_args cmd + then fail $ "Bad argument: `"++unwords extra++"'\n"++ + get_command_mini_help msuper cmd + else if length extra < command_extra_args cmd + then fail $ "Missing argument: " ++ + nth_arg (length extra + 1) ++ + "\n" ++ get_command_mini_help msuper cmd + else runWithHooks specops extra + where nth_arg n = nth_of n (command_extra_arg_help cmd) + nth_of 1 (h:_) = h + nth_of n (_:hs) = nth_of (n-1) hs + nth_of _ [] = "UNDOCUMENTED" + runWithHooks os ex = do + here <- getCurrentDirectory + checkMatchSyntax os + -- set any global variables + when (Timings `elem` os) setTimingsMode + when (Debug `elem` os) setDebugMode + when (DebugHTTP `elem` os) setDebugHTTP + when (Verbose `elem` os) setVerboseMode + when (Quiet `elem` os) $ setProgressMode False + when (HTTPPipelining `elem` os) $ setHTTPPipelining True + when (NoHTTPPipelining `elem` os) $ setHTTPPipelining False + unless (SSHControlMaster `elem` os) setSshControlMasterDisabled +#ifdef HAVE_HASKELL_ZLIB + unless (Quiet `elem` os) $ atexit $ doCRCWarnings (Verbose `elem` os) +#endif + -- actually run the command and its hooks + preHookExitCode <- run_prehook os here + if preHookExitCode /= ExitSuccess + then exitWith preHookExitCode + else do let fixFlag = FixFilePath here cwd + (command_command cmd) (fixFlag : os) ex + postHookExitCode <- run_posthook os here + exitWith postHookExitCode + +add_command_defaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag] +add_command_defaults cmd already = do + let (opts1, opts2) = command_alloptions cmd + defaults <- get_default_flags (command_name cmd) (opts1 ++ opts2) already + return $ already ++ defaults + +get_options_options :: [OptDescr DarcsFlag] -> String +get_options_options [] = "" +get_options_options (o:os) = + get_long_option o ++"\n"++ get_options_options os + +get_long_option :: OptDescr DarcsFlag -> String +get_long_option (Option _ [] _ _) = "" +get_long_option (Option a (o:os) b c) = "--"++o++ + get_long_option (Option a os b c) + +run_raw_supercommand :: DarcsCommand -> [String] -> IO () +run_raw_supercommand super [] = + fail $ "Command '"++ command_name super ++"' requires subcommand!\n\n" + ++ subusage super +run_raw_supercommand super args = do + cwd <- getCurrentDirectory + case getOpt RequireOrder + (option_from_darcsoption cwd help++ + option_from_darcsoption cwd list_options) args of + (opts,_,[]) + | Help `elem` opts -> + viewDoc $ text $ get_command_help Nothing super + | ListOptions `elem` opts -> do + putStrLn "--help" + mapM_ (putStrLn . command_name) (extract_commands $ get_subcommands super) + | otherwise -> + if Disable `elem` opts + then fail $ "Command " ++ (command_name super) ++ + " disabled with --disable option!" + else fail $ "Invalid subcommand!\n\n" ++ subusage super + (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs) diff --git a/src/Darcs/Sealed.hs b/src/Darcs/Sealed.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Sealed.hs @@ -0,0 +1,103 @@ +-- Copyright (C) 2007 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +-- , MagicHash, GADTs #-} + +#include "gadts.h" + +module Darcs.Sealed ( Sealed(..), seal, unseal, mapSeal, +#ifndef GADT_WITNESSES + unsafeUnseal, unsafeUnflippedseal, unsafeUnseal2, +#endif + Sealed2(..), seal2, unseal2, mapSeal2, + FlippedSeal(..), flipSeal, unsealFlipped, mapFlipped, + unsealM, liftSM + ) where + +import GHC.Base ( unsafeCoerce# ) +import Darcs.Show + +data Sealed a where + Sealed :: a C(x ) -> Sealed a + +seal :: a C(x ) -> Sealed a +seal = Sealed + +data Sealed2 a where + Sealed2 :: !(a C(x y )) -> Sealed2 a + +seal2 :: a C(x y ) -> Sealed2 a +seal2 = Sealed2 + +data FlippedSeal a C(y) where + FlippedSeal :: !(a C(x y)) -> FlippedSeal a C(y) + +flipSeal :: a C(x y) -> FlippedSeal a C(y) +flipSeal = FlippedSeal + +#ifndef GADT_WITNESSES +unsafeUnseal :: Sealed a -> a +unsafeUnseal (Sealed a) = a + +unsafeUnflippedseal :: FlippedSeal a -> a +unsafeUnflippedseal (FlippedSeal a) = a + +unsafeUnseal2 :: Sealed2 a -> a +unsafeUnseal2 (Sealed2 a) = a +#endif + +seriouslyUnsafeUnseal :: Sealed a -> a C(()) +seriouslyUnsafeUnseal (Sealed a) = unsafeCoerce# a + +unseal :: (FORALL(x) a C(x ) -> b) -> Sealed a -> b +unseal f x = f (seriouslyUnsafeUnseal x) + +-- laziness property: +-- unseal (const True) undefined == True + +unsealM :: Monad m => m (Sealed a) -> (FORALL(x) a C(x) -> m b) -> m b +unsealM m1 m2 = do sx <- m1 + unseal m2 sx + +liftSM :: Monad m => (FORALL(x) a C(x) -> b) -> m (Sealed a) -> m b +liftSM f m = do sx <- m + return (unseal f sx) + +mapSeal :: (FORALL(x) a C(x ) -> b C(x )) -> Sealed a -> Sealed b +mapSeal f = unseal (seal . f) + +mapFlipped :: (FORALL(x) a C(x y) -> b C(x z)) -> FlippedSeal a C(y) -> FlippedSeal b C(z) +mapFlipped f (FlippedSeal x) = FlippedSeal (f x) + +seriouslyUnsafeUnseal2 :: Sealed2 a -> a C(() ()) +seriouslyUnsafeUnseal2 (Sealed2 a) = unsafeCoerce# a + +unseal2 :: (FORALL(x y) a C(x y ) -> b) -> Sealed2 a -> b +unseal2 f a = f (seriouslyUnsafeUnseal2 a) + +mapSeal2 :: (FORALL(x y) a C(x y ) -> b C(x y )) -> Sealed2 a -> Sealed2 b +mapSeal2 f = unseal2 (seal2 . f) + +unsealFlipped :: (FORALL(x y) a C(x y) -> b) -> FlippedSeal a C(z) -> b +unsealFlipped f (FlippedSeal a) = f a + +instance Show1 a => Show (Sealed a) where + showsPrec d (Sealed x) = showParen (d > app_prec) $ showString "Sealed " . showsPrec1 (app_prec + 1) x +instance Show2 a => Show (Sealed2 a) where + showsPrec d (Sealed2 x) = showParen (d > app_prec) $ showString "Sealed2 " . showsPrec2 (app_prec + 1) x diff --git a/src/Darcs/SelectChanges.hs b/src/Darcs/SelectChanges.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/SelectChanges.hs @@ -0,0 +1,620 @@ +-- Copyright (C) 2002-2003 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -fglasgow-exts #-} +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +-- , ScopedTypeVariables, TypeOperators, PatternGuards #-} + +#include "gadts.h" + +module Darcs.SelectChanges ( with_selected_changes', + with_selected_changes_to_files', + with_selected_last_changes_to_files', + with_selected_last_changes_reversed', + with_selected_changes, + with_selected_changes_to_files, + with_selected_changes_reversed, + with_selected_last_changes_to_files, + with_selected_last_changes_to_files_reversed, + with_selected_last_changes_reversed, + view_changes, + with_selected_patch_from_repo, + ) where +import System.IO +import Data.List ( intersperse ) +import Data.Maybe ( catMaybes, isJust ) +import Data.Char ( toUpper ) +import Control.Monad ( when ) +import System.Exit ( exitWith, ExitCode(ExitSuccess) ) + +import English ( Noun(..), englishNum ) +import Darcs.Arguments ( showFriendly ) +import Darcs.Hopefully ( PatchInfoAnd, hopefully ) +import Darcs.Repository ( Repository, read_repo ) +import Darcs.Patch ( RepoPatch, Patchy, Prim, summary, + invert, list_touched_files, + commuteFL ) +import qualified Darcs.Patch ( thing, things ) +import Darcs.Ordered ( FL(..), RL(..), (:>)(..), + (+>+), lengthFL, lengthRL, concatRL, mapFL_FL, + spanFL, reverseFL, (+<+), mapFL, + unsafeCoerceP ) +import Darcs.Patch.Choices ( PatchChoices, patch_choices, patch_choices_tps, + force_first, force_last, make_uncertain, tag, + get_choices, + separate_first_middle_from_last, + separate_first_from_middle_last, + patch_slot, + select_all_middles, + force_matching_last, + force_matching_first, make_everything_later, + TaggedPatch, tp_patch, Slot(..), + ) +import Darcs.Patch.TouchesFiles ( deselect_not_touching, select_not_touching ) +import Darcs.PrintPatch ( printFriendly, printPatch, printPatchPager ) +import Darcs.Match ( have_nonrange_match, match_a_patch, match_a_patchread ) +import Darcs.Flags ( DarcsFlag( Summary, DontGrabDeps, Verbose, DontPromptForDependencies), isInteractive ) +import Darcs.Sealed ( FlippedSeal(..), flipSeal, seal2, unseal2 ) +import Darcs.Utils ( askUser, promptCharFancy ) +import Printer ( prefix, putDocLn ) +#include "impossible.h" + +data WhichChanges = Last | LastReversed | First | FirstReversed deriving (Eq, Show) + +type MatchCriterion p = FORALL(u v) WhichChanges -> [DarcsFlag] -> (p C(u v)) -> Bool + +type WithPatches p a C(x y) = + String -- jobname + -> [DarcsFlag] -- opts + -> FL p C(x y) -- patches to select among + -> ((FL p :> FL p) C(x y) -> IO a) -- job + -> IO a -- result of running job + +-- | The only difference with 'WithPatches' is the [FilePath] argument +type WithPatchesToFiles p a C(x y) = + String -- jobname + -> [DarcsFlag] -- opts + -> [FilePath] -- files + -> FL p C(x y) -- patches to select among + -> ((FL p :> FL p) C(x y) -> IO a) -- job + -> IO a -- result of running job + +with_selected_changes' + :: WithPatches Prim a C(x y) +with_selected_changes_to_files' + :: WithPatchesToFiles Prim a C(x y) +with_selected_last_changes_to_files' + :: WithPatchesToFiles Prim a C(x y) +with_selected_last_changes_reversed' + :: WithPatches Prim a C(x y) + +-- Common match criteria +triv :: MatchCriterion p +triv _ _ _ = True + +iswanted :: Patchy p => MatchCriterion (PatchInfoAnd p) +iswanted First opts p = match_a_patch opts . hopefully $ p +iswanted LastReversed opts p = match_a_patch opts . hopefully . invert $ p +iswanted Last _ _ = bug "don't support patch matching with Last in wasp" +iswanted FirstReversed _ _ = bug "don't support patch matching with FirstReversed in wasp" + +with_selected_changes' = wasc First triv +with_selected_changes_to_files' = wasc_ First triv +with_selected_last_changes_to_files' = wasc_ Last triv +with_selected_last_changes_reversed' = wasc LastReversed triv + +with_selected_changes :: RepoPatch p => WithPatches (PatchInfoAnd p) a C(x y) +with_selected_changes_to_files :: RepoPatch p => WithPatchesToFiles (PatchInfoAnd p) a C(x y) +with_selected_changes_reversed :: RepoPatch p => WithPatches (PatchInfoAnd p) a C(x y) +with_selected_last_changes_to_files :: RepoPatch p => WithPatchesToFiles (PatchInfoAnd p) a C(x y) +with_selected_last_changes_to_files_reversed :: RepoPatch p => WithPatchesToFiles (PatchInfoAnd p) a C(x y) +with_selected_last_changes_reversed :: RepoPatch p => WithPatches (PatchInfoAnd p) a C(x y) + +with_selected_changes = wasc First iswanted +with_selected_changes_to_files = wasc_ First iswanted +with_selected_changes_reversed = wasc FirstReversed iswanted +with_selected_last_changes_to_files = wasc_ Last iswanted +with_selected_last_changes_to_files_reversed = wasc_ LastReversed iswanted +with_selected_last_changes_reversed = wasc LastReversed iswanted + +-- | wasc and wasc_ are just shorthand for with_any_selected_changes +wasc :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatches p a C(x y) +wasc mwch crit j o = wasc_ mwch crit j o [] +wasc_ :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatchesToFiles p a C(x y) +wasc_ = with_any_selected_changes + +with_any_selected_changes :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatchesToFiles p a C(x y) +with_any_selected_changes Last crit jn opts fs = + with_any_selected_changes_last + (patches_to_consider_last' fs opts crit) + crit jn opts fs +with_any_selected_changes First crit jn opts fs = + with_any_selected_changes_first + (patches_to_consider_first' fs opts crit) + crit jn opts fs +with_any_selected_changes FirstReversed crit jn opts fs = + with_any_selected_changes_first_reversed + (patches_to_consider_first_reversed' fs opts crit) + crit jn opts fs +with_any_selected_changes LastReversed crit jn opts fs = + with_any_selected_changes_last_reversed + (patches_to_consider_last_reversed' fs opts crit) + crit jn opts fs + + +view_changes :: RepoPatch p => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO () +view_changes opts ps = do + text_view opts Nothing 0 NilRL init_tps init_pc + return () + where (init_pc, init_tps) = patch_choices_tps ps + +data KeyPress a = KeyPress { kp :: Char + , kpHelp :: String } + +helpFor :: String -> [[KeyPress a]] -> String +helpFor jobname options = + unlines $ [ "How to use "++jobname++":" ] + ++ (concat $ intersperse [""] $ map (map help) options) + ++ [ "" + , "?: show this help" + , "" + , ": accept the current default (which is capitalized)" + ] + where help i = kp i:(": "++kpHelp i) + +keysFor :: [[KeyPress a]] -> [Char] +keysFor = concatMap (map kp) + +with_selected_patch_from_repo :: forall p C(r u t). RepoPatch p => String -> Repository p C(r u t) -> [DarcsFlag] + -> (FORALL(a) (FL (PatchInfoAnd p) :> PatchInfoAnd p) C(a r) -> IO ()) -> IO () +with_selected_patch_from_repo jn repository opts job = do + p_s <- read_repo repository + sp <- wspfr jn (match_a_patchread opts) + (concatRL p_s) NilFL + case sp of + Just (FlippedSeal (skipped :> selected)) -> job (skipped :> selected) + Nothing -> do putStrLn $ "Cancelling "++jn++" since no patch was selected." + +-- | This ensures that the selected patch commutes freely with the skipped patches, including pending +-- and also that the skipped sequences has an ending context that matches the recorded state, z, +-- of the repository. +wspfr :: RepoPatch p => String -> (FORALL(a b) (PatchInfoAnd p) C(a b) -> Bool) + -> RL (PatchInfoAnd p) C(x y) -> FL (PatchInfoAnd p) C(y u) + -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd p) :> (PatchInfoAnd p)) C(u))) +wspfr _ _ NilRL _ = return Nothing +wspfr jn matches (p:<:pps) skipped + | not $ matches p = wspfr jn matches pps (p:>:skipped) + | otherwise = + case commuteFL (p :> skipped) of + Left _ -> do putStrLn "\nSkipping depended-upon patch:" + printFriendly [] p + wspfr jn matches pps (p:>:skipped) + Right (skipped' :> p') -> do + printFriendly [] p + let repeat_this = wspfr jn matches (p:<:pps) skipped + options = [[ KeyPress 'y' (jn++" this patch") + , KeyPress 'n' ("don't "++jn++" it") + , KeyPress 'v' "view this patch in full" + , KeyPress 'p' "view this patch in full with pager" + , KeyPress 'x' "view a summary of this patch" + , KeyPress 'q' ("cancel "++jn) + ]] + let prompt = "Shall I "++jn++" this patch?" + yorn <- promptCharFancy prompt (keysFor options) (Just 'n') "?h" + case yorn of + 'y' -> return $ Just $ flipSeal $ skipped' :> p' + 'n' -> wspfr jn matches pps (p:>:skipped) + 'v' -> printPatch p >> repeat_this + 'p' -> printPatchPager p >> repeat_this + 'x' -> do putDocLn $ prefix " " $ summary p + repeat_this + 'q' -> do putStrLn $ jn_cap++" cancelled." + exitWith $ ExitSuccess + _ -> do putStrLn $ helpFor jn options + repeat_this + where jn_cap = (toUpper $ head jn) : tail jn + +with_any_selected_changes_last :: forall p a C(x y). Patchy p + => (FL p C(x y) -> (FL p :> FL p) C(x y)) + -> MatchCriterion p + -> WithPatchesToFiles p a C(x y) +with_any_selected_changes_last p2c crit jobname opts _ ps job = + case p2c ps of + ps_to_consider :> other_ps -> + if not $ isInteractive opts + then job $ ps_to_consider :> other_ps + else do pc <- tentatively_text_select "" jobname (Noun "patch") Last crit + opts ps_len 0 NilRL init_tps init_pc + job $ selected_patches_last rejected_ps pc + where rejected_ps = ps_to_consider + ps_len = lengthFL init_tps + (init_pc, init_tps) = patch_choices_tps $ other_ps + +with_any_selected_changes_first :: forall p a C(x y). Patchy p + => (FL p C(x y) -> (FL p :> FL p) C(x y)) + -> MatchCriterion p + -> WithPatchesToFiles p a C(x y) +with_any_selected_changes_first p2c crit jobname opts _ ps job = + case p2c ps of + ps_to_consider :> other_ps -> + if not $ isInteractive opts + then job $ ps_to_consider :> other_ps + else do pc <- tentatively_text_select "" jobname (Noun "patch") First crit + opts ps_len 0 NilRL init_tps init_pc + job $ selected_patches_first rejected_ps pc + where rejected_ps = other_ps + ps_len = lengthFL init_tps + (init_pc, init_tps) = patch_choices_tps $ ps_to_consider + +with_any_selected_changes_first_reversed :: forall p a C(x y). Patchy p + => (FL p C(x y) -> (FL p :> FL p) C(y x)) + -> MatchCriterion p + -> WithPatchesToFiles p a C(x y) +with_any_selected_changes_first_reversed p2c crit jobname opts _ ps job = + case p2c ps of + ps_to_consider :> other_ps -> + if not $ isInteractive opts + then job $ invert other_ps :> invert ps_to_consider + else do pc <- tentatively_text_select "" jobname (Noun "patch") FirstReversed crit + opts ps_len 0 NilRL init_tps init_pc + job $ selected_patches_first_reversed rejected_ps pc + where rejected_ps = ps_to_consider + ps_len = lengthFL init_tps + (init_pc, init_tps) = patch_choices_tps other_ps + +with_any_selected_changes_last_reversed :: forall p a C(x y). Patchy p + => (FL p C(x y) -> (FL p :> FL p) C(y x)) + -> MatchCriterion p + -> WithPatchesToFiles p a C(x y) +with_any_selected_changes_last_reversed p2c crit jobname opts _ ps job = + case p2c ps of + ps_to_consider :> other_ps -> + if not $ isInteractive opts + then job $ invert other_ps :> invert ps_to_consider + else do pc <- tentatively_text_select "" jobname (Noun "patch") LastReversed crit + opts ps_len 0 NilRL init_tps init_pc + job $ selected_patches_last_reversed rejected_ps pc + where rejected_ps = other_ps + ps_len = lengthFL init_tps + (init_pc, init_tps) = patch_choices_tps ps_to_consider + + +patches_to_consider_first' :: Patchy p + => [FilePath] -- ^ files + -> [DarcsFlag] -- ^ opts + -> MatchCriterion p + -> FL p C(x y) -- ^ patches + -> (FL p :> FL p) C(x y) +patches_to_consider_first' fs opts crit ps = + let deselect_unwanted pc = + if have_nonrange_match opts + then if DontGrabDeps `elem` opts + then force_matching_last (not.iswanted_) pc + else make_everything_later $ force_matching_first iswanted_ pc + else pc + iswanted_ = crit First opts . tp_patch + in if null fs && not (have_nonrange_match opts) + then ps :> NilFL + else tp_patches $ separate_first_middle_from_last $ deselect_not_touching fs + $ deselect_unwanted $ patch_choices ps + +patches_to_consider_last' :: Patchy p + => [FilePath] -- ^ files + -> [DarcsFlag] -- ^ opts + -> MatchCriterion p + -> FL p C(x y) -- ^ patches + -> (FL p :> FL p) C(x y) +patches_to_consider_last' fs opts crit ps = + let deselect_unwanted pc = + if have_nonrange_match opts + then if DontGrabDeps `elem` opts + then force_matching_last (not.iswanted_) pc + else make_everything_later $ force_matching_first iswanted_ pc + else pc + iswanted_ = crit Last opts . tp_patch + in if null fs && not (have_nonrange_match opts) + then NilFL :> ps + else case get_choices $ select_not_touching fs $ deselect_unwanted $ patch_choices ps of + fc :> mc :> lc -> tp_patches $ fc :> mc +>+ lc + +patches_to_consider_first_reversed' :: Patchy p + => [FilePath] -- ^ files + -> [DarcsFlag] -- ^ opts + -> MatchCriterion p + -> FL p C(x y) -- ^ patches + -> (FL p :> FL p) C(y x) +patches_to_consider_first_reversed' fs opts crit ps = + let deselect_unwanted pc = + if have_nonrange_match opts + then if DontGrabDeps `elem` opts + then force_matching_last (not.iswanted_) pc + else make_everything_later $ force_matching_first iswanted_ pc + else pc + iswanted_ = crit FirstReversed opts . tp_patch + in if null fs && not (have_nonrange_match opts) + then NilFL :> (invert ps) + else case get_choices $ select_not_touching fs $ deselect_unwanted $ patch_choices $ invert ps of + fc :> mc :> lc -> tp_patches $ fc :> mc +>+ lc + +patches_to_consider_last_reversed' :: Patchy p + => [FilePath] -- ^ files + -> [DarcsFlag] -- ^ opts + -> MatchCriterion p + -> FL p C(x y) -- ^ patches + -> (FL p :> FL p) C(y x) +patches_to_consider_last_reversed' fs opts crit ps = + let deselect_unwanted pc = + if have_nonrange_match opts + then if DontGrabDeps `elem` opts + then force_matching_last (not.iswanted_) pc + else make_everything_later $ force_matching_first iswanted_ pc + else pc + iswanted_ = crit LastReversed opts . tp_patch + in + if null fs && not (have_nonrange_match opts) + then (invert ps) :> NilFL + else tp_patches $ separate_first_middle_from_last $ deselect_not_touching fs + $ deselect_unwanted $ patch_choices $ invert ps + +-- | Returns the results of a patch selection user interaction +selected_patches_last :: Patchy p => FL p C(x y) -> PatchChoices p C(y z) + -> (FL p :> FL p) C(x z) +selected_patches_last other_ps pc = + case get_choices pc of + fc :> mc :> lc -> other_ps +>+ mapFL_FL tp_patch (fc +>+ mc) :> mapFL_FL tp_patch lc + +selected_patches_first :: Patchy p => FL p C(y z) -> PatchChoices p C(x y) + -> (FL p :> FL p) C(x z) +selected_patches_first other_ps pc = + case separate_first_from_middle_last pc of + xs :> ys -> mapFL_FL tp_patch xs :> mapFL_FL tp_patch ys +>+ other_ps + +selected_patches_last_reversed :: Patchy p => FL p C(y x) -> PatchChoices p C(z y) + -> (FL p :> FL p) C(x z) +selected_patches_last_reversed other_ps pc = + case separate_first_from_middle_last pc of + xs :> ys -> invert (mapFL_FL tp_patch ys +>+ other_ps) :> invert (mapFL_FL tp_patch xs) + +selected_patches_first_reversed :: Patchy p => FL p C(z y) -> PatchChoices p C(y x) + -> (FL p :> FL p) C(x z) +selected_patches_first_reversed other_ps pc = + case get_choices pc of + fc :> mc :> lc -> invert (mapFL_FL tp_patch lc) :> invert (other_ps +>+ mapFL_FL tp_patch (fc +>+ mc)) + +text_select :: forall p C(x y z). Patchy p => String -> WhichChanges + -> MatchCriterion p -> [DarcsFlag] -> Int -> Int + -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y z) -> PatchChoices p C(x z) + -> IO ((PatchChoices p) C(x z)) + +text_select _ _ _ _ _ _ _ NilFL pc = return pc +text_select jn whichch crit opts n_max n + tps_done tps_todo@(tp:>:tps_todo') pc = do + (printFriendly opts) `unseal2` viewp + repeat_this -- prompt the user + where + do_next_action ja je = tentatively_text_select ja jn je whichch crit opts + n_max + (n+1) (tp:<:tps_done) tps_todo' + do_next = do_next_action "" (Noun "patch") + helper :: PatchChoices p C(a b) -> p C(a b) + helper = undefined + thing = Darcs.Patch.thing (helper pc) + things = Darcs.Patch.things (helper pc) + options_basic = + [ KeyPress 'y' (jn++" this "++thing) + , KeyPress 'n' ("don't "++jn++" it") + , KeyPress 'w' ("wait and decide later, defaulting to no") ] + options_file = + [ KeyPress 's' ("don't "++jn++" the rest of the changes to this file") + , KeyPress 'f' (jn++" the rest of the changes to this file") ] + options_view = + [ KeyPress 'v' ("view this "++thing++" in full") + , KeyPress 'p' ("view this "++thing++" in full with pager") + , KeyPress 'l' ("list all selected "++things) ] + options_summary = + [ KeyPress 'x' ("view a summary of this "++thing) ] + options_quit = + [ KeyPress 'd' (jn++" selected "++things++", skipping all the remaining "++things) + , KeyPress 'a' (jn++" all the remaining "++things) + , KeyPress 'q' ("cancel "++jn) ] + options_nav = + [ KeyPress 'j' ("skip to next "++thing) + , KeyPress 'k' ("back up to previous "++thing) ] + options = [options_basic] + ++ (if is_single_file_patch then [options_file] else []) + ++ [options_view ++ + if Summary `elem` opts then [] else options_summary] + ++ [options_quit] + ++ [options_nav ] + prompt = "Shall I "++jn++" this "++thing++"? " + ++ "(" ++ show (n+1) ++ "/" ++ show n_max ++ ") " + repeat_this :: IO ((PatchChoices p) C(x z)) + repeat_this = do + yorn <- promptCharFancy prompt (keysFor options) (Just the_default) "?h" + case yorn of + 'y' -> do_next $ force_yes (tag tp) pc + 'n' -> do_next $ force_no (tag tp) pc + 'w' -> do_next $ make_uncertain (tag tp) pc + 's' -> do_next_action "Skipped" (Noun "change") $ skip_file + 'f' -> do_next_action "Included" (Noun "change") $ do_file + 'v' -> printPatch `unseal2` viewp >> repeat_this + 'p' -> printPatchPager `unseal2` viewp >> repeat_this + 'l' -> do let selected = case get_choices pc of + (first_chs:>_:>last_chs) -> + if whichch == Last || whichch == FirstReversed + then map_patches last_chs + else map_patches first_chs + map_patches = mapFL (\a -> + (showFriendly opts) `unseal2` (seal2 $ tp_patch a)) + putStrLn $ "---- Already selected "++things++" ----" + mapM_ putDocLn $ selected + putStrLn $ "---- end of already selected "++things++" ----" + (printFriendly opts) `unseal2` viewp + repeat_this + 'x' -> do (putDocLn . prefix " " . summary) `unseal2` viewp + repeat_this + 'd' -> return pc + 'a' -> do ask_confirmation + return $ select_all_middles (whichch == Last || whichch == FirstReversed) pc + 'q' -> do putStrLn $ jn_cap++" cancelled." + exitWith $ ExitSuccess + 'j' -> case tps_todo' of + NilFL -> -- May as well work out the length now we have all + -- the patches in memory + text_select jn whichch crit opts + n_max n tps_done tps_todo pc + _ -> text_select jn whichch crit opts + n_max (n+1) (tp:<:tps_done) tps_todo' pc + 'k' -> case tps_done of + NilRL -> repeat_this + (tp':<:tps_done') -> + text_select jn whichch crit opts + n_max (n-1) tps_done' (tp':>:tps_todo) pc + 'c' -> text_select jn whichch crit opts + n_max n tps_done tps_todo pc + _ -> do putStrLn $ helpFor jn options + repeat_this + force_yes = if whichch == Last || whichch == FirstReversed then force_last else force_first + force_no = if whichch == Last || whichch == FirstReversed then force_first else force_last + patches_to_skip = (tag tp:) $ catMaybes + $ mapFL (\tp' -> if list_touched_files tp' == touched_files + then Just (tag tp') + else Nothing) tps_todo' + skip_file = foldr force_no pc patches_to_skip + do_file = foldr force_yes pc patches_to_skip + the_default = get_default (whichch == Last || whichch == FirstReversed) $ patch_slot tp pc + jn_cap = (toUpper $ head jn) : tail jn + touched_files = list_touched_files $ tp_patch tp + is_single_file_patch = length touched_files == 1 + viewp = if whichch == LastReversed || whichch == FirstReversed then seal2 $ invert (tp_patch tp) else seal2 $ tp_patch tp + ask_confirmation = + if jn `elem` ["unpull", "unrecord", "obliterate"] + then do yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? " + case yorn of + ('y':_) -> return () + _ -> exitWith $ ExitSuccess + else return () + +text_view :: forall p C(x y u r s). Patchy p => [DarcsFlag] -> Maybe Int -> Int + -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y u) -> PatchChoices p C(r s) + -> IO ((PatchChoices p) C(r s)) +text_view _ _ _ _ NilFL _ = return $ patch_choices $ unsafeCoerceP NilFL --return pc +text_view opts n_max n + tps_done tps_todo@(tp:>:tps_todo') pc = do + printFriendly opts (tp_patch tp) + putStr "\n" + repeat_this -- prompt the user + where + prev_patch :: IO ((PatchChoices p) C(r s)) + prev_patch = case tps_done of + NilRL -> repeat_this + (tp':<:tps_done') -> + text_view opts + n_max (n-1) tps_done' (tp':>:tps_todo) pc + next_patch :: IO ((PatchChoices p) C(r s)) + next_patch = case tps_todo' of + NilFL -> -- May as well work out the length now we have all + -- the patches in memory + text_view opts n_max + n tps_done NilFL pc + _ -> text_view opts n_max + (n+1) (tp:<:tps_done) tps_todo' pc + options_yn = + [ KeyPress 'y' "view this patch and go to the next" + , KeyPress 'n' "skip to the next patch" ] + options_view = + [ KeyPress 'v' "view this patch in full" + , KeyPress 'p' "view this patch in full with pager" ] + options_summary = + [ KeyPress 'x' "view a summary of this patch" ] + options_nav = + [ KeyPress 'q' ("quit view changes") + , KeyPress 'k' "back up to previous patch" + , KeyPress 'j' "skip to next patch" + , KeyPress 'c' "count total patch number" ] + options = [ options_yn ] + ++ [ options_view ++ + if Summary `elem` opts then [] else options_summary ] + ++ [ options_nav ] + prompt = "Shall I view this patch? " + ++ "(" ++ show (n+1) ++ "/" ++ maybe "?" show n_max ++ ")" + repeat_this :: IO ((PatchChoices p) C(r s)) + repeat_this = do + yorn <- promptCharFancy prompt (keysFor options) (Just 'n') "?h" + case yorn of + 'y' -> printPatch (tp_patch tp) >> next_patch + 'n' -> next_patch + 'v' -> printPatch (tp_patch tp) >> repeat_this + 'p' -> printPatchPager (tp_patch tp) >> repeat_this + 'x' -> do putDocLn $ prefix " " $ summary (tp_patch tp) + repeat_this + 'q' -> exitWith ExitSuccess + 'k' -> prev_patch + 'j' -> next_patch + 'c' -> text_view opts + count_n_max n tps_done tps_todo pc + _ -> do putStrLn $ helpFor "view changes" options + repeat_this + count_n_max | isJust n_max = n_max + | otherwise = Just $ lengthFL tps_todo + lengthRL tps_done +tentatively_text_select :: Patchy p => String -> String -> Noun -> WhichChanges + -> MatchCriterion p -> [DarcsFlag] + -> Int -> Int -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y z) + -> PatchChoices p C(x z) + -> IO ((PatchChoices p) C(x z)) +tentatively_text_select _ _ _ _ _ _ _ _ _ NilFL pc = return pc +tentatively_text_select jobaction jobname jobelement whichch crit + opts n_max n ps_done ps_todo pc = + case spanFL (\p -> decided $ patch_slot p pc) ps_todo of + skipped :> unskipped -> do + when (numSkipped > 0) show_skipped + let (boringThenInteresting) = + if DontPromptForDependencies `elem` opts + then spanFL (not.(crit whichch opts).tp_patch) unskipped + else NilFL :> unskipped + case boringThenInteresting of + boring :> interesting -> do + let numNotConsidered = lengthFL boring + numSkipped + text_select jobname whichch crit opts n_max (n + numNotConsidered) + (reverseFL boring +<+ reverseFL skipped +<+ ps_done) interesting pc + where + numSkipped = lengthFL skipped + show_skipped = do putStrLn $ _doing_ ++ _with_ ++ "." + when (Verbose `elem` opts) $ showskippedpatch skipped + where + _doing_ = _action_ ++ " " ++ jobname + _with_ = " of " ++ show numSkipped ++ " " ++ _elem_ "" + _action_ = if (length jobaction) == 0 then "Skipped" else jobaction + _elem_ = englishNum numSkipped jobelement + showskippedpatch :: Patchy p => FL (TaggedPatch p) C(y t) -> IO () + showskippedpatch (tp:>:tps) = (putDocLn $ prefix " " $ summary (tp_patch tp)) >> showskippedpatch tps + showskippedpatch NilFL = return () + +decided :: Slot -> Bool +decided InMiddle = False +decided _ = True + +get_default :: Bool -> Slot -> Char +get_default _ InMiddle = 'w' +get_default True InFirst = 'n' +get_default True InLast = 'y' +get_default False InFirst = 'y' +get_default False InLast = 'n' + +tp_patches :: (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y) + -> (FL p :> FL p) C(x y) +tp_patches (x:>y) = mapFL_FL tp_patch x :> mapFL_FL tp_patch y diff --git a/src/Darcs/Show.hs b/src/Darcs/Show.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Show.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} + +module Darcs.Show(Show1(..), Show2(..), showOp2, app_prec) where + +#include "gadts.h" + +class Show1 a where + show1 :: a C(x) -> String + show1 x = showsPrec1 0 x "" + showsPrec1 :: Int -> a C(x) -> ShowS + showsPrec1 _ x s = show1 x ++ s + +class Show2 a where + show2 :: a C(x y) -> String + show2 x = showsPrec2 0 x "" + showsPrec2 :: Int -> a C(x y) -> ShowS + showsPrec2 _ x s = show2 x ++ s + +showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a C(w x) -> b C(y z) -> String -> String +showOp2 prec opstr d x y = showParen (d > prec) $ showsPrec2 (prec + 1) x . + showString opstr . showsPrec2 (prec + 1) y + +app_prec :: Int +app_prec = 10 diff --git a/src/Darcs/SignalHandler.hs b/src/Darcs/SignalHandler.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/SignalHandler.hs @@ -0,0 +1,132 @@ +-- Copyright (C) 2003 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +-- , DeriveDataTypeable #-} + +module Darcs.SignalHandler ( withSignalsHandled, withSignalsBlocked, + catchInterrupt, catchNonSignal, + tryNonSignal, stdout_is_a_pipe ) where + +import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName ) +import Control.Exception ( dynExceptions, ioErrors, catchJust, Exception ( IOException ) ) +import System.Exit ( exitWith, ExitCode ( ExitFailure ) ) +import Control.Concurrent ( ThreadId, myThreadId ) +import Control.Exception ( catchDyn, throwDyn, throwDynTo, block ) +import System.Posix.Files ( getFdStatus, isNamedPipe ) +import System.Posix.IO ( stdOutput ) +import Data.Dynamic ( Typeable, fromDynamic ) +import System.IO ( hPutStrLn, stderr ) +import Control.Monad ( when ) + +import Workaround ( installHandler, raiseSignal, Handler(..), Signal, + sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE ) +#ifdef WIN32 +import CtrlC ( withCtrlCHandler ) +#endif + +stdout_is_a_pipe :: IO Bool +stdout_is_a_pipe + = catchJust ioErrors + (do stat <- getFdStatus stdOutput + return (isNamedPipe stat)) + (\_ -> return False) + +withSignalsHandled :: IO a -> IO a +newtype SignalException = SignalException Signal deriving (Typeable) + +withSignalsHandled job = do + thid <- myThreadId + mapM_ (ih thid) [sigINT, sigHUP, sigABRT, sigTERM, sigPIPE] + catchJust just_usererrors (job' thid `catchSignal` defaults) + die_with_string + where defaults s | s == sigINT = ew s "Interrupted!" + | s == sigHUP = ew s "HUP" + | s == sigABRT = ew s "ABRT" + | s == sigTERM = ew s "TERM" + | s == sigPIPE = exitWith $ ExitFailure $ 1 + | otherwise = ew s "Unhandled signal!" + ew sig s = do hPutStrLn stderr $ ("withSignalsHandled: " ++ s) + resethandler sig + raiseSignal sig -- ensure that our caller knows how we died + exitWith $ ExitFailure $ 1 + die_with_string e | take 6 e == "STDOUT" = + do is_pipe <- stdout_is_a_pipe + when (not is_pipe) $ + hPutStrLn stderr $ "\ndarcs failed: "++drop 6 e + exitWith $ ExitFailure $ 2 + die_with_string e = do hPutStrLn stderr $ "\ndarcs failed: "++e + exitWith $ ExitFailure $ 2 +#ifdef WIN32 + job' thid = + withCtrlCHandler (throwDynTo thid $ SignalException sigINT) job +#else + job' _ = job +#endif + +resethandler :: Signal -> IO () +resethandler s = do installHandler s Default Nothing + return () + +ih :: ThreadId -> Signal -> IO () +ih thid s = + do installHandler s (Catch $ throwDynTo thid $ SignalException s) Nothing + return () + +catchSignal :: IO a -> (Signal -> IO a) -> IO a +catchSignal job handler = + job `Control.Exception.catchDyn` (\(SignalException sig) -> handler sig) + +-- catchNonSignal is a drop-in replacement for Control.Exception.catch, which allows +-- us to catch anything but a signal. Useful for situations where we want +-- don't want to inhibit ctrl-C. + +catchNonSignal :: IO a -> (Control.Exception.Exception -> IO a) -> IO a +catchNonSignal = Control.Exception.catchJust notSig + where notSig x = case dynExceptions x of + Nothing -> Just x + Just d -> case fromDynamic d :: Maybe SignalException of + Just _ -> Nothing + Nothing -> Just x + +catchInterrupt :: IO a -> IO a -> IO a +catchInterrupt job handler = + job `catchSignal` h + where h s | s == sigINT = handler + | otherwise = throwDyn (SignalException s) + +tryNonSignal :: IO a -> IO (Either Control.Exception.Exception a) +tryNonSignal j = (Right `fmap` j) `catchNonSignal` \e -> return (Left e) + +just_usererrors :: Control.Exception.Exception -> Maybe String +just_usererrors (IOException e) | isUserError e = Just $ ioeGetErrorString e +just_usererrors (IOException e) | ioeGetFileName e == Just "" + = Just $ "STDOUT"++ioeGetErrorString e +just_usererrors _ = Nothing + +withSignalsBlocked :: IO () -> IO () +withSignalsBlocked job = (block job) `catchSignal` couldnt_do + where couldnt_do s | s == sigINT = oops "interrupt" + | s == sigHUP = oops "HUP" + | s == sigABRT = oops "ABRT" + | s == sigALRM = oops "ALRM" + | s == sigTERM = oops "TERM" + | s == sigPIPE = return () + | otherwise = oops "unknown signal" + oops s = hPutStrLn stderr $ "Couldn't handle " ++ s ++ + " since darcs was in a sensitive job." diff --git a/src/Darcs/SlurpDirectory.hs b/src/Darcs/SlurpDirectory.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/SlurpDirectory.hs @@ -0,0 +1,36 @@ +-- Copyright (C) 2002-2004 David Roundy +-- +-- 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. + +module Darcs.SlurpDirectory + (Slurpy, empty_slurpy, slurp, + mmap_slurp, co_slurp, slurp_unboring, + FileContents, + undefined_time, undefined_size, + doesFileReallyExist, doesDirectoryReallyExist, isFileReallySymlink, + wait_a_moment, + is_dir, is_file, + get_slurp, slurp_name, + slurp_has, slurp_has_anycase, slurp_hasfile, slurp_hasdir, + list_slurpy, list_slurpy_files, list_slurpy_dirs, get_path_list, + get_filecontents, get_dircontents, get_mtime, get_length, + slurp_modfile, slurp_remove, slurp_removefile, slurp_removedir, + write_files, + SlurpMonad, withSlurpy, writeSlurpy, syncSlurpy + ) + where + +import Darcs.SlurpDirectory.Internal diff --git a/src/Darcs/SlurpDirectory/Internal.hs b/src/Darcs/SlurpDirectory/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/SlurpDirectory/Internal.hs @@ -0,0 +1,677 @@ +-- Copyright (C) 2002-2004 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +-- | SlurpDirectory is intended to give a nice lazy way of traversing directory +-- trees. +module Darcs.SlurpDirectory.Internal + ( Slurpy(..), SlurpyContents(..), slurpies_to_map, map_to_slurpies, + FileContents, empty_slurpy, + slurp, mmap_slurp, slurp_unboring, co_slurp, + slurp_name, is_file, is_dir, + get_filecontents, get_dircontents, get_mtime, + get_length, get_slurp, + slurp_removefile, slurp_removedir, + slurp_remove, + slurp_modfile, slurp_hasfile, slurp_hasdir, + slurp_has_anycase, wait_a_moment, undefined_time, + undefined_size, + slurp_has, list_slurpy, list_slurpy_files, + get_path_list, + list_slurpy_dirs, + isFileReallySymlink, + doesFileReallyExist, doesDirectoryReallyExist, + SlurpMonad, withSlurpy, write_files, + writeSlurpy, syncSlurpy + ) where + +import System.IO +import System.Directory hiding ( getCurrentDirectory, renameFile ) +import Workaround ( getCurrentDirectory ) +import Darcs.Utils ( withCurrentDirectory, formatPath ) +import Darcs.RepoPath ( FilePathLike, toPath ) +import System.IO.Unsafe ( unsafeInterleaveIO ) +import Data.List ( isPrefixOf ) +import Control.Monad ( MonadPlus(..), when ) +import Data.Char ( toLower ) +import System.Posix.Types ( EpochTime ) +import System.Posix.Files + ( getSymbolicLinkStatus, modificationTime, + fileSize, + isRegularFile, isDirectory, isSymbolicLink + ) +import System.Posix ( sleep ) +import Data.Maybe ( catMaybes, isJust, maybeToList ) +import Data.Map (Map) +import qualified Data.Map as Map + +import Darcs.SignalHandler ( tryNonSignal ) +import Darcs.CheckFileSystem ( can_I_use_mmap ) +import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) ) + +import ByteStringUtils +import qualified Data.ByteString as B + +import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, norm_path, break_on_dir, + own_name, super_name ) +#if mingw32_HOST_OS +import Data.Int ( Int64 ) +#else +import System.Posix.Types ( FileOffset ) +#endif + +#include "impossible.h" + +#if mingw32_HOST_OS +type FileOffset = Int64 +#endif + +data Slurpy = Slurpy !FileName !SlurpyContents + +slurpy_to_pair :: Slurpy -> (FileName, SlurpyContents) +slurpy_to_pair (Slurpy fn sc) = (fn, sc) + +pair_to_slurpy :: (FileName, SlurpyContents) -> Slurpy +pair_to_slurpy = uncurry Slurpy + +type SlurpyMap = Map FileName SlurpyContents + +slurpies_to_map :: [Slurpy] -> SlurpyMap +slurpies_to_map = Map.fromList . map slurpy_to_pair + +map_to_slurpies :: SlurpyMap -> [Slurpy] +map_to_slurpies = map pair_to_slurpy . Map.toList + +data SlurpyContents = SlurpDir (Maybe String) SlurpyMap + | SlurpFile (Maybe String,EpochTime,FileOffset) FileContents +type FileContents = B.ByteString + +instance Show Slurpy where + show (Slurpy fn (SlurpDir _ l)) = + "Dir " ++ (fn2fp fn) ++ "\n" ++ + concat (map show $ map_to_slurpies l) ++ "End Dir " ++ (fn2fp fn) ++ "\n" + show (Slurpy fn (SlurpFile _ _)) = "File " ++ (fn2fp fn) ++ "\n" + +mapSlurpyNames :: (FileName -> FileName) -> Slurpy -> Slurpy +mapSlurpyNames f = onSlurpy + where onSlurpy (Slurpy fn sc) = Slurpy (f fn) (onSlurpyContents sc) + onSlurpyContents sf@(SlurpFile _ _) = sf + onSlurpyContents (SlurpDir x sm) = SlurpDir x . slurpies_to_map . map onSlurpy . map_to_slurpies $ sm + +slurp :: FilePathLike p => p -> IO Slurpy +mmap_slurp :: FilePath -> IO Slurpy +slurp_unboring :: (FilePath->Bool) -> FilePath -> IO Slurpy +empty_slurpy :: Slurpy +empty_slurpy = Slurpy (fp2fn ".") (SlurpDir Nothing Map.empty) +slurp_name :: Slurpy -> FilePath +is_file :: Slurpy -> Bool +is_dir :: Slurpy -> Bool + +get_filecontents :: Slurpy -> FileContents +get_dircontents :: Slurpy -> [Slurpy] +get_mtime :: Slurpy -> EpochTime +get_length :: Slurpy -> FileOffset + +instance Eq Slurpy where + s1 == s2 = (slurp_name s1) == (slurp_name s2) +instance Ord Slurpy where + s1 <= s2 = (slurp_name s1) <= (slurp_name s2) + +data SlurpMonad a = SM ((Either String Slurpy) + -> Either String (Slurpy, a)) +mksm :: (Slurpy -> Either String (Slurpy, a)) -> SlurpMonad a +mksm x = SM sm where sm (Left e) = Left e + sm (Right s) = x s + +instance Functor SlurpMonad where + fmap f m = m >>= return . f + +instance Monad SlurpMonad where + (SM p) >>= k = SM sm + where sm e = case p e of + Left er -> Left er + Right (s, a) -> case k a of + (SM q) -> q (Right s) + return a = SM ( \s -> case s of + Left e -> Left e + Right x -> Right (x, a) ) + fail e = SM ( \s -> case s of + Left x -> Left x + _ -> Left e ) + +instance MonadPlus SlurpMonad where + mzero = fail "SlurpMonad mzero" + (SM p) `mplus` (SM q) = SM sm + where sm e = case p e of + Left _ -> q e + okay -> okay + +instance ReadableDirectory SlurpMonad where + mDoesDirectoryExist d = smDoesDirectoryExist d + mDoesFileExist f = smDoesFileExist f + mInCurrentDirectory = smInSlurpy + mGetDirectoryContents = smGetDirContents + mReadFilePS = smReadFilePS + mReadFilePSs = smReadFilePSs + +instance WriteableDirectory SlurpMonad where + mWithCurrentDirectory = modifySubSlurpy + mSetFileExecutable _ _ = return () + mWriteFilePS = smWriteFilePS + mCreateDirectory = smCreateDirectory + mRename = smRename + mRemoveDirectory = smRemoveDirectory + mRemoveFile = smRemoveFile + +write_file :: Slurpy -> FileName -> IO () +write_file s fn = case withSlurpy s $ smReadFilePS fn of + Left err -> fail err + Right (_, c) -> do + ensureDirectories (super_name fn) + mWriteFilePS fn c + +try_write_file :: Slurpy -> FilePath -> IO () +try_write_file s fp = let fn = fp2fn fp in + if slurp_hasfile fn s + then write_file s fn + else if slurp_hasdir fn s + then ensureDirectories fn + else return () + +ensureDirectories :: WriteableDirectory m => FileName -> m () +ensureDirectories d = do + isPar <- mDoesDirectoryExist d + if isPar + then return () + else ensureDirectories (super_name d) >> (mCreateDirectory d) + +write_files :: Slurpy -> [FilePath] -> IO () +write_files s fps = mapM_ (try_write_file s) fps + +-- don't overwrite non-empty directories unless explicitly asked by +-- being passed "." (which always exists) +writeSlurpy :: Slurpy -> FilePath -> IO () +writeSlurpy s d = do + when (d /= ".") $ createDirectory d + withCurrentDirectory d $ write_files s (list_slurpy s) + +withSlurpy :: Slurpy -> SlurpMonad a -> Either String (Slurpy, a) +withSlurpy s (SM f) = f (Right s) + +smDoesDirectoryExist :: FileName -> SlurpMonad Bool +smDoesDirectoryExist d = mksm $ \s -> (Right (s, slurp_hasdir d s)) + +smDoesFileExist :: FileName -> SlurpMonad Bool +smDoesFileExist f = mksm $ \s -> (Right (s, slurp_hasfile f s)) + +-- smInSlurpy doesn't make any changes to the subdirectory. +smInSlurpy :: FileName -> SlurpMonad a -> SlurpMonad a +smInSlurpy d job = mksm sm + where sm s = case get_slurp d s of + Just s' | is_dir s' -> case withSlurpy s' job of + Left e -> Left e + Right (_,a) -> Right (s, a) + _ -> Left $ "smInSlurpy: Couldn't find directory " ++ + formatPath (fn2fp d) + +fromSlurpFile :: FileName -> (Slurpy -> a) -> SlurpMonad a +fromSlurpFile f job = mksm sm + where sm s = case get_slurp f s of + Just s' | is_file s' -> Right (s, job s') + _ -> Left $ "fromSlurpFile: Couldn't find file " ++ + formatPath (fn2fp f) + +modifySubSlurpy :: FileName -> SlurpMonad a -> SlurpMonad a +modifySubSlurpy d job = mksm sm + where sm s = case get_slurp_context d s of + Just (ctx, sub@(Slurpy _ (SlurpDir _ _))) -> + case withSlurpy sub job of + Left e -> Left e + Right (sub',a) -> Right (ctx sub', a) + _ -> Left $ "modifySubSlurpy: Couldn't find directory " ++ + formatPath (fn2fp d) + +modifyFileSlurpy :: FileName -> (Slurpy -> Slurpy) -> SlurpMonad () +modifyFileSlurpy f job = mksm sm + where sm s = case get_slurp_context f s of + Just (ctx, sf@(Slurpy _ (SlurpFile _ _))) -> Right (ctx $ job sf, ()) + _ -> Left $ "modifyFileSlurpy: Couldn't find file " ++ + formatPath (fn2fp f) + +insertSlurpy :: FileName -> Slurpy -> SlurpMonad () +insertSlurpy f news = mksm $ \s -> + if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s) + then Left $ "Error creating file "++fn2fp f + else Right (addslurp f news s, ()) + +smReadFilePS :: FileName -> SlurpMonad B.ByteString +smReadFilePS f = fromSlurpFile f get_filecontents + +smReadFilePSs :: FileName -> SlurpMonad [B.ByteString] +smReadFilePSs f = fromSlurpFile f (linesPS . get_filecontents) + +smGetDirContents :: SlurpMonad [FileName] +smGetDirContents = mksm $ \s -> Right (s, map slurp_fn $ get_dircontents s) + +smWriteFilePS :: FileName -> B.ByteString -> SlurpMonad () +smWriteFilePS f ps = -- this implementation could be made rather more direct + -- and limited to a single pass down the Slurpy + modifyFileSlurpy f (\_ -> sl) + `mplus` insertSlurpy f sl + where sl = Slurpy (own_name f) (SlurpFile undef_time_size ps) + +smCreateDirectory :: FileName -> SlurpMonad () +smCreateDirectory a = mksm sm + where sm s = case slurp_adddir a s of + Just s' -> Right (s', ()) + Nothing -> Left $ "Error creating directory "++fn2fp a + +smRename :: FileName -> FileName -> SlurpMonad () +smRename a b = mksm sm + where sm s = case slurp_move a b s of + Just s' -> Right (s', ()) + Nothing -> + -- Workaround for some old patches having moves when the source file doesn't exist. + if (slurp_has (fn2fp a) s) + then Left $ "Error moving "++fn2fp a++" to "++fn2fp b + else Right (s, ()) + +smRemove :: FileName -> SlurpMonad () +smRemove f = mksm sm + where sm s = case slurp_remove f s of + Nothing -> Left $ fn2fp f++" does not exist." + Just s' -> Right (s', ()) + +smRemoveFile :: FileName -> SlurpMonad () +smRemoveFile f = + do exists <- mDoesFileExist f + if exists then smRemove f + else fail $ "File "++fn2fp f++" does not exist." + +smRemoveDirectory :: FileName -> SlurpMonad () +smRemoveDirectory f = + do exists <- mDoesDirectoryExist f + if exists then smRemove f + else fail $ "Directory "++fn2fp f++" does not exist." + +-- | Here are a few access functions. +slurp_name (Slurpy n _) = fn2fp n +slurp_fn :: Slurpy -> FileName +slurp_fn (Slurpy n _) = n +slurp_setname :: FileName -> Slurpy -> Slurpy +slurp_setname f (Slurpy _ s) = Slurpy f s + +is_file (Slurpy _ (SlurpDir _ _)) = False +is_file (Slurpy _ (SlurpFile _ _)) = True + +is_dir (Slurpy _ (SlurpDir _ _)) = True +is_dir (Slurpy _ (SlurpFile _ _)) = False + +get_filecontents (Slurpy _ (SlurpFile _ c)) = c +get_filecontents _ = bug "Can't get_filecontents on SlurpDir." + +get_dircontents (Slurpy _ (SlurpDir _ c)) = map_to_slurpies c +get_dircontents _ = bug "Can't get_dircontents on SlurpFile." + +get_mtime (Slurpy _ (SlurpFile (_,t,_) _)) = t +get_mtime _ = bug "can't get_mtime on SlurpDir." +get_length (Slurpy _ (SlurpFile (_,_,l) _)) = l +get_length _ = bug "can't get_length on SlurpDir." + +undefined_time :: EpochTime +undefined_time = -1 +undefined_size :: FileOffset +undefined_size = -1 +undef_time_size :: (Maybe String, EpochTime, FileOffset) +undef_time_size = (Nothing, undefined_time, undefined_size) + +wait_a_moment :: IO () +wait_a_moment = do { sleep 1; return () } + -- HACKERY: In ghc 6.1, sleep has the type signature IO Int; it + -- returns an integer just like sleep(3) does. To stay compatible + -- with older versions, though, we just ignore sleep's return + -- value. Hackery, like I said. + +isFileReallySymlink :: FilePath -> IO Bool +isFileReallySymlink f = do fs <- getSymbolicLinkStatus f + return (isSymbolicLink fs) + +doesFileReallyExist :: FilePath -> IO Bool +doesFileReallyExist f = do fs <- getSymbolicLinkStatus f + return (isRegularFile fs) + +doesDirectoryReallyExist :: FilePath -> IO Bool +doesDirectoryReallyExist f = do fs <- getSymbolicLinkStatus f + return (isDirectory fs) + +-- |slurp is how we get a slurpy in the first place\ldots +slurp = slurp_unboring (\_->True) . toPath +mmap_slurp d = do canmmap <- can_I_use_mmap + if canmmap then genslurp True (\_->True) d + else genslurp False (\_->True) d +slurp_unboring = genslurp False +genslurp :: Bool -> (FilePath -> Bool) + -> FilePath -> IO Slurpy +genslurp usemm nb dirname = do + isdir <- doesDirectoryExist dirname + ms <- if isdir + then withCurrentDirectory dirname $ + do actualname <- getCurrentDirectory + genslurp_helper usemm nb (reverse actualname) "" "." + else do former_dir <- getCurrentDirectory + genslurp_helper usemm nb (reverse former_dir) "" dirname + case ms of + Just s -> return s + Nothing -> fail $ "Unable to read directory " ++ dirname ++ + " (it appears to be neither file nor directory)" + +unsafeInterleaveMapIO :: (a -> IO b) -> [a] -> IO [b] +unsafeInterleaveMapIO _ [] = return [] +unsafeInterleaveMapIO f (x:xs) + = do x' <- f x + xs' <- unsafeInterleaveIO $ unsafeInterleaveMapIO f xs + return (x':xs') + +genslurp_helper :: Bool -> (FilePath -> Bool) + -> FilePath -> String -> String -> IO (Maybe Slurpy) +genslurp_helper usemm nb formerdir fullpath dirname = do + fs <- getSymbolicLinkStatus fulldirname + if isRegularFile fs + then do let mtime = (Nothing, modificationTime fs, fileSize fs) + ls <- unsafeInterleaveIO $ myReadFileLinesPSetc fulldirname + return $ Just $ Slurpy (fp2fn dirname) $ SlurpFile mtime ls + else if isDirectory fs || (isSymbolicLink fs && dirname == ".") + then do sl <- unsafeInterleaveIO $ + do fnames <- getDirectoryContents fulldirname + unsafeInterleaveMapIO + (\f -> genslurp_helper usemm nb fulldirname' + (fullpath///f) f) + $ filter (nb . (fullpath///)) $ filter not_hidden fnames + return $ Just $ Slurpy (fp2fn dirname) $ SlurpDir Nothing $ slurpies_to_map $ catMaybes sl + else return Nothing + where fulldirname' = formerdir\\\dirname + fulldirname = reverse fulldirname' + myReadFileLinesPSetc = if usemm then mmapFilePS + else B.readFile + +not_hidden :: FilePath -> Bool +not_hidden "." = False +not_hidden ".." = False +not_hidden _ = True + +(\\\) :: FilePath -> FilePath -> FilePath +(\\\) "" d = d +(\\\) d "." = d +(\\\) d subdir = reverse subdir ++ "/" ++ d + +(///) :: FilePath -> FilePath -> FilePath +(///) "" d = d +(///) d "." = d +(///) d subdir = d ++ "/" ++ subdir + +co_slurp :: Slurpy -> FilePath -> IO Slurpy +co_slurp guide dirname = do + isdir <- doesDirectoryExist dirname + if isdir + then withCurrentDirectory dirname $ do + actualname <- getCurrentDirectory + Just slurpy <- co_slurp_helper (reverse actualname) guide + return slurpy + else error "Error coslurping!!! Please report this." + +co_slurp_helper :: FilePath -> Slurpy -> IO (Maybe Slurpy) +co_slurp_helper former_dir (Slurpy d (SlurpDir _ c)) = unsafeInterleaveIO $ do + let d' = fn2fp d + fn' = former_dir\\\d' + fn = reverse fn' + efs <- tryNonSignal $ getSymbolicLinkStatus fn + case efs of + Right fs + | isDirectory fs || (isSymbolicLink fs && d' == ".") -> + do sl <- unsafeInterleaveIO + $ unsafeInterleaveMapIO (co_slurp_helper fn') (map_to_slurpies c) + return $ Just $ Slurpy d $ SlurpDir Nothing $ slurpies_to_map $ catMaybes sl + _ -> return Nothing +co_slurp_helper former_dir (Slurpy f (SlurpFile _ _)) = unsafeInterleaveIO $ do + let fn' = former_dir\\\fn2fp f + fn = reverse fn' + efs <- tryNonSignal $ getSymbolicLinkStatus fn + case efs of + Right fs + | isRegularFile fs -> + do let mtime = (Nothing, modificationTime fs, fileSize fs) + ls <- unsafeInterleaveIO $ B.readFile fn + return $ Just $ Slurpy f $ SlurpFile mtime ls + _ -> return Nothing + +get_slurp_context_generic :: (Slurpy -> a) -> (a -> [Slurpy]) -> FileName -> Slurpy -> Maybe (a -> a, Slurpy) +get_slurp_context_generic h1 h2 fn0 s0 = + let norm_fn0 = norm_path fn0 in + if norm_fn0 == empty + then Just (id, s0) + else slurp_context_private norm_fn0 id s0 + where + slurp_context_private f ctx s@(Slurpy f' (SlurpFile _ _)) = + if f == f' then Just (ctx, s) + else Nothing + slurp_context_private f ctx s@(Slurpy d (SlurpDir _ c)) + | f == d = Just (ctx, s) + | d == dot = + case break_on_dir f of + Just (dn,fn) | dn == dot -> + descend fn + _ -> + descend f + | otherwise = + case break_on_dir f of + Just (dn,fn) -> + if dn == d + then descend fn + else Nothing + _ -> Nothing + where + descend fname = + case findSubSlurpy fname c of + Nothing -> Nothing + Just this -> slurp_context_private + fname + (ctx . h1 . Slurpy d . SlurpDir Nothing . foldr (uncurry Map.insert) (Map.delete (slurp_fn this) c) . map slurpy_to_pair . h2) + this + + dot = fp2fn "." + empty = fp2fn "" + +-- |get_slurp_context navigates to a specified filename in the given slurpy, +-- and returns the child slurpy at that point together with a update function that can be used +-- to reconstruct the original slurpy from a replacement value for the child slurpy. +get_slurp_context :: FileName -> Slurpy -> Maybe (Slurpy -> Slurpy, Slurpy) +get_slurp_context = get_slurp_context_generic id return + +-- |A variant of 'get_slurp_context' that allows for removing the child slurpy +-- altogether by passing in 'Nothing' to the update function. +-- If the child slurpy happened to be at the top level and 'Nothing' was passed in, +-- then the result of the update function will also be 'Nothing', otherwise it will always +-- be a 'Just' value. +get_slurp_context_maybe :: FileName -> Slurpy -> Maybe (Maybe Slurpy -> Maybe Slurpy, Slurpy) +get_slurp_context_maybe = get_slurp_context_generic Just maybeToList + +-- |A variant of 'get_slurp_context' that allows for replacing the child slurpy by +-- a list of slurpies. The result of the update function will always be a singleton +-- list unless the child slurpy was at the top level. +-- Currently unused. +-- get_slurp_context_list :: FileName -> Slurpy -> Maybe ([Slurpy] -> [Slurpy], Slurpy) +-- get_slurp_context_list = get_slurp_context_generic return id + +-- | It is important to be able to readily modify a slurpy. +slurp_remove :: FileName -> Slurpy -> Maybe Slurpy +slurp_remove fname s@(Slurpy _ (SlurpDir _ _)) = + case get_slurp_context_maybe fname s of + Just (ctx, _) -> ctx Nothing + Nothing -> Nothing +slurp_remove _ _ = bug "slurp_remove only acts on SlurpDirs" + +slurp_removefile :: FileName -> Slurpy -> Maybe Slurpy +slurp_removefile f s = + if slurp_hasfile f s + then case slurp_remove f s of + s'@(Just (Slurpy _ (SlurpDir _ _))) -> s' + _ -> impossible + else Nothing + +slurp_move :: FileName -> FileName -> Slurpy -> Maybe Slurpy +slurp_move f f' s = + if not (slurp_has (fn2fp f') s) && slurp_hasdir (super_name f') s + then case get_slurp f s of + Nothing -> Nothing + Just sf -> + case slurp_remove f s of + Nothing -> Nothing + Just (s'@(Slurpy _ (SlurpDir _ _))) -> + Just $ addslurp f' (slurp_setname (own_name f') sf) s' + _ -> impossible + else Nothing + +addslurp :: FileName -> Slurpy -> Slurpy -> Slurpy +addslurp fname s s' = + case get_slurp_context (super_name fname) s' of + Just (ctx, Slurpy d (SlurpDir _ c)) -> ctx (Slurpy d (SlurpDir Nothing (uncurry Map.insert (slurpy_to_pair s) c))) + _ -> s' + +get_slurp :: FileName -> Slurpy -> Maybe Slurpy +get_slurp f s = fmap snd (get_slurp_context f s) + +slurp_removedir :: FileName -> Slurpy -> Maybe Slurpy +slurp_removedir f s = + case get_slurp f s of + Just (Slurpy _ (SlurpDir _ l)) | Map.null l -> + case slurp_remove f s of + s'@(Just (Slurpy _ (SlurpDir _ _))) -> s' + _ -> impossible + _ -> Nothing + +slurp_adddir :: FileName -> Slurpy -> Maybe Slurpy +slurp_adddir f s = + if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s) + then Nothing + else Just $ addslurp f (Slurpy (own_name f) (SlurpDir Nothing Map.empty)) s + +-- |Code to modify a given file in a slurpy. +slurp_modfile :: FileName -> (FileContents -> Maybe FileContents) + -> Slurpy -> Maybe Slurpy +slurp_modfile fname modify sl = + case get_slurp_context fname sl of + Just (ctx, Slurpy ff (SlurpFile _ c)) -> + case modify c of + Nothing -> Nothing + Just c' -> Just (ctx (Slurpy ff (SlurpFile undef_time_size c'))) + _ -> + Nothing + +slurp_hasfile :: FileName -> Slurpy -> Bool +slurp_hasfile f s = + case get_slurp f s of + Just s' | is_file s' -> True + _ -> False + +slurp_has :: FilePath -> Slurpy -> Bool +slurp_has f s = isJust (get_slurp (fp2fn f) s) + +slurp_has_anycase :: FilePath -> Slurpy -> Bool +slurp_has_anycase fname s = + seq normed_name $ isJust $ get_slurp normed_name $ mapSlurpyNames tolower s + where normed_name = norm_path $ fp2fn $ map toLower fname + +tolower :: FileName -> FileName +tolower = fp2fn . (map toLower) . fn2fp + +findSubSlurpy :: FileName -> SlurpyMap -> Maybe Slurpy +findSubSlurpy fn sm = + let topname = case break_on_dir fn of + Just (dn, _) -> dn + Nothing -> fn + in fmap (Slurpy topname) (Map.lookup topname sm) + +slurp_hasdir :: FileName -> Slurpy -> Bool +slurp_hasdir d _ | norm_path d == fp2fn "" = True +slurp_hasdir f (Slurpy _ (SlurpDir _ c)) = + seq f $ let f' = norm_path f + in case findSubSlurpy f' c of + Just s -> slurp_hasdir_private f' s + Nothing -> False +slurp_hasdir _ _ = False + +slurp_hasdir_private :: FileName -> Slurpy -> Bool +slurp_hasdir_private _ (Slurpy _ (SlurpFile _ _)) = False +slurp_hasdir_private f (Slurpy d (SlurpDir _ c)) + | f == d = True + | otherwise = + case break_on_dir f of + Just (dn,fn) -> + if dn == d + then case findSubSlurpy fn c of + Just s -> slurp_hasdir_private fn s + Nothing -> False + else False + _ -> False + +get_path_list :: Slurpy -> FilePath -> [FilePath] +get_path_list s fp = get_path_list' s ("./" ++ fp) + +get_path_list' :: Slurpy -> FilePath -> [FilePath] +get_path_list' s "" = list_slurpy s +get_path_list' (Slurpy f (SlurpFile _ _)) fp + | f' == fp = [f'] + where f' = fn2fp f +get_path_list' (Slurpy d (SlurpDir _ ss)) fp + | (d' ++ "/") `isPrefixOf` (fp ++ "/") + = let fp' = drop (length d' + 1) fp + in map (d' ///) $ concatMap (\s -> get_path_list' s fp') $ map_to_slurpies ss + where d' = fn2fp d +get_path_list' _ _ = [] + +list_slurpy :: Slurpy -> [FilePath] +list_slurpy (Slurpy f (SlurpFile _ _)) = [fn2fp f] +list_slurpy (Slurpy dd (SlurpDir _ ss)) = d : map (d ///) (concatMap list_slurpy (map_to_slurpies ss)) + where d = fn2fp dd + +list_slurpy_files :: Slurpy -> [FilePath] +list_slurpy_files (Slurpy f (SlurpFile _ _)) = [fn2fp f] +list_slurpy_files (Slurpy dd (SlurpDir _ ss)) = + map ((fn2fp dd) ///) (concatMap list_slurpy_files (map_to_slurpies ss)) + +list_slurpy_dirs :: Slurpy -> [FilePath] +list_slurpy_dirs (Slurpy _ (SlurpFile _ _)) = [] +list_slurpy_dirs (Slurpy dd (SlurpDir _ ss)) = + d : map (d ///) (concatMap list_slurpy_dirs (map_to_slurpies ss)) + where d = fn2fp dd + +unsyncedSlurpySize :: Slurpy -> Int +unsyncedSlurpySize (Slurpy _ (SlurpFile (_,_,size) ps)) + | size == undefined_size = B.length ps + | otherwise = 0 +unsyncedSlurpySize (Slurpy _ (SlurpDir _ ss)) = + sum $ map unsyncedSlurpySize (map_to_slurpies ss) + +slurp_sync_size :: Int +slurp_sync_size = 100 * 1000000 + +syncSlurpy :: (Slurpy -> IO Slurpy) -> Slurpy -> IO Slurpy +syncSlurpy put s = if unsyncedSlurpySize s > slurp_sync_size + then put s + else return s diff --git a/src/Darcs/Test.lhs b/src/Darcs/Test.lhs new file mode 100644 --- /dev/null +++ b/src/Darcs/Test.lhs @@ -0,0 +1,119 @@ +% Copyright (C) 2002-2005 David Roundy +% +% 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. + +\begin{code} +module Darcs.Test ( get_test, + run_posthook, run_prehook ) +where +import Darcs.RepoPath ( AbsolutePath ) +import Darcs.Utils ( withCurrentDirectory ) +import System.Exit ( ExitCode(..) ) +import System.Cmd ( system ) +import Control.Monad ( when ) + +import Darcs.Arguments ( DarcsFlag( Quiet, + AskPosthook, AskPrehook ), + get_posthook_cmd, get_prehook_cmd ) +import Darcs.Repository.Prefs ( get_prefval ) +import Darcs.Utils ( askUser ) +import System.IO ( hPutStrLn, stderr ) +\end{code} + +If you like, you can configure your repository to be able to run a test +suite of some sort. You can do this by using ``setpref'' to set the +``test'' value to be a command to run, e.g. +\begin{verbatim} +% darcs setpref test "sh configure && make && make test" +\end{verbatim} +Or, if you want to define a test specific to one copy of the repository, +you could do this by editing the file \verb!_darcs/prefs/prefs!. + +\begin{options} +--leave-test-directory, --remove-test-directory +\end{options} + +Normally darcs deletes the directory in which the test was run afterwards. +Sometimes (especially when the test fails) you'd prefer to be able to be +able to examine the test directory after the test is run. You can do this +by specifying the \verb!--leave-test-directory! flag. Alas, there is no +way to make darcs leave the test directory only if the test fails. The +opposite of \verb!--leave-test-directory! is +\verb!--remove-test-directory!, which could come in handy if you choose to +make \verb!--leave-test-directory! the default (see +section~\ref{defaults}). + +\begin{code} +get_test :: [DarcsFlag] -> IO (IO ExitCode) +get_test opts = + let putInfo s = when (not $ Quiet `elem` opts) $ putStr s + in do + testline <- get_prefval "test" + return $ + case testline of + Nothing -> return ExitSuccess + Just testcode -> do + putInfo "Running test...\n" + ec <- system testcode + if ec == ExitSuccess + then putInfo "Test ran successfully.\n" + else putInfo "Test failed!\n" + return ec + +run_posthook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode +run_posthook opts repodir = do ph <- get_posthook opts + withCurrentDirectory repodir $ run_hook opts "Posthook" ph + +get_posthook :: [DarcsFlag] -> IO (Maybe String) +get_posthook opts = case get_posthook_cmd opts of + Nothing -> return Nothing + Just command -> + if AskPosthook `elem` opts + then do yorn <- askUser ("\nThe following command is set to execute.\n"++ + "Execute the following command now (yes or no)?\n"++ + command++"\n") + case yorn of ('y':_) -> return $ Just command + _ -> do putStrLn "Posthook cancelled..." + return Nothing + else return $ Just command + +run_prehook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode +run_prehook opts repodir = do ph <- get_prehook opts + withCurrentDirectory repodir $ run_hook opts "Prehook" ph + +get_prehook :: [DarcsFlag] -> IO (Maybe String) +get_prehook opts = case get_prehook_cmd opts of + Nothing -> return Nothing + Just command -> + if AskPrehook `elem` opts + then do yorn <- askUser ("\nThe following command is set to execute.\n"++ + "Execute the following command now (yes or no)?\n"++ + command++"\n") + case yorn of ('y':_) -> return $ Just command + _ -> do putStrLn "Prehook cancelled..." + return Nothing + else return $ Just command + +run_hook :: [DarcsFlag] -> String -> Maybe String -> IO ExitCode +run_hook _ _ Nothing = return ExitSuccess +run_hook opts cname (Just command) = + do ec <- system command + when (Quiet `notElem` opts) $ + if ec == ExitSuccess + then putStrLn $ cname++" ran successfully." + else hPutStrLn stderr $ cname++" failed!" + return ec +\end{code} diff --git a/src/Darcs/TheCommands.hs b/src/Darcs/TheCommands.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/TheCommands.hs @@ -0,0 +1,106 @@ +-- Copyright (C) 2003 David Roundy +-- +-- 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. + +module Darcs.TheCommands ( command_control_list ) where + +import Darcs.Commands.Add ( add ) +import Darcs.Commands.AmendRecord ( amendrecord ) +import Darcs.Commands.Annotate ( annotate ) +import Darcs.Commands.Apply ( apply ) +import Darcs.Commands.Changes ( changes ) +import Darcs.Commands.Check ( check ) +import Darcs.Commands.Convert ( convert ) +import Darcs.Commands.Diff +import Darcs.Commands.Dist ( dist ) +import Darcs.Commands.Get ( get, clone ) +#ifdef HAVE_HASKELL_ZLIB +import Darcs.Commands.GZCRCs ( gzcrcs ) +#else +-- import just to check it compiles +import Darcs.Commands.GZCRCs () +#endif +import Darcs.Commands.Init ( initialize ) +import Darcs.Commands.Show ( show_command, list, query ) +import Darcs.Commands.MarkConflicts ( markconflicts, resolve ) +import Darcs.Commands.Move ( move, mv ) +import Darcs.Commands.Optimize ( optimize ) +import Darcs.Commands.Pull ( pull ) +import Darcs.Commands.Push ( push ) +import Darcs.Commands.Put ( put ) +import Darcs.Commands.Record ( record, commit ) +import Darcs.Commands.Remove ( remove, rm, unadd ) +import Darcs.Commands.Repair ( repair ) +import Darcs.Commands.Replace ( replace ) +import Darcs.Commands.Revert ( revert ) +import Darcs.Commands.Rollback ( rollback ) +import Darcs.Commands.Send ( send ) +import Darcs.Commands.SetPref ( setpref ) +import Darcs.Commands.Tag ( tag ) +import Darcs.Commands.TrackDown ( trackdown ) +import Darcs.Commands.TransferMode ( transfer_mode ) +import Darcs.Commands.Unrecord ( unrecord, unpull, obliterate ) +import Darcs.Commands.Unrevert ( unrevert ) +import Darcs.Commands.WhatsNew ( whatsnew ) +import Darcs.Commands ( CommandControl(Command_data,Hidden_command,Group_name) ) + +-- | The commands that darcs knows about (e.g. whatsnew, record), +-- organized into thematic groups. Note that hidden commands +-- are also listed here. +command_control_list :: [CommandControl] +command_control_list = [Group_name "Changing and querying the working copy:", + Command_data add, + Command_data remove, Hidden_command unadd, Hidden_command rm, + Command_data move, Hidden_command mv, + Command_data replace, + Command_data revert, + Command_data unrevert, + Command_data whatsnew, + Group_name "Copying changes between the working copy and the repository:", + Command_data record, Hidden_command commit, + Command_data unrecord, + Command_data amendrecord, + Command_data markconflicts, Hidden_command resolve, + Group_name "Direct modification of the repository:", + Command_data tag, + Command_data setpref, + Group_name "Querying the repository:", + Command_data diff_command, + Command_data changes, + Command_data annotate, + Command_data dist, + Command_data trackdown, + Command_data show_command, Hidden_command list, Hidden_command query, + Hidden_command transfer_mode, + Group_name "Copying patches between repositories with working copy update:", + Command_data pull, + Command_data obliterate, Hidden_command unpull, + Command_data rollback, + Command_data push, + Command_data send, + Command_data apply, + Command_data get, Hidden_command clone, + Command_data put, + Group_name "Administrating repositories:", + Command_data initialize, + Command_data optimize, + Command_data check, + Command_data repair, + Command_data convert +#ifdef HAVE_HASKELL_ZLIB + ,Hidden_command gzcrcs +#endif + ] diff --git a/src/Darcs/URL.hs b/src/Darcs/URL.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/URL.hs @@ -0,0 +1,81 @@ +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +{- +Copyright (C) 2004 David Roundy + +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. +-} + +{-| + + Path resolving: + + * A URL contains the sequence @\":\/\/\"@. + + * A local filepath does not contain colons, except + as second character (windows drives). + + * A path that is neither a URL nor a local file + is an ssh-path. + + Examples: + + > /usr/repo/foo -- local file + > c:/src/darcs -- local file + > http://darcs.net/ -- URL + > peter@host:/path -- ssh + > droundy@host: -- ssh + > host:/path -- ssh + + This means that single-letter hosts in ssh-paths do not work, + unless a username is provided. + + Perhaps ssh-paths should use @\"ssh:\/\/user\@host\/path\"@-syntax instead? +-} + +module Darcs.URL ( + is_file, is_url, is_ssh, is_relative, is_absolute, + is_ssh_nopath + ) where + +#include "impossible.h" + +is_relative :: String -> Bool +is_relative (_:':':_) = False +is_relative f@(c:_) = is_file f && c /= '/' && c /= '~' +is_relative "" = bug "Empty filename in is_relative" + +is_absolute :: String -> Bool +is_absolute "" = bug "is_absolute called with empty filename" +is_absolute f = is_file f && (not $ is_relative f) + +is_file :: String -> Bool +is_file (_:_:fou) = ':' `notElem` fou +is_file _ = True + +is_url :: String -> Bool +is_url (':':'/':'/':_:_) = True +is_url (_:x) = is_url x +is_url "" = False + +is_ssh :: String -> Bool +is_ssh s = not (is_file s || is_url s) + +is_ssh_nopath :: String -> Bool +is_ssh_nopath s = case reverse s of + ':':x@(_:_:_) -> ':' `notElem` x + _ -> False diff --git a/src/Darcs/Utils.hs b/src/Darcs/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Utils.hs @@ -0,0 +1,258 @@ +-- Various utility functions that do not belong anywhere else. + +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand, + clarify_errors, prettyException, prettyError, + putStrLnError, putDocLnError, + withCurrentDirectory, + withUMask, askUser, stripCr, + showHexLen, add_to_error_loc, + maybeGetEnv, firstNotBlank, firstJustM, firstJustIO, + isUnsupportedOperationError, isHardwareFaultError, + get_viewer, edit_file, promptYorn, promptCharFancy, + environmentHelpEditor, environmentHelpPager, + formatPath ) where + +import Prelude hiding ( catch ) +import Control.Exception ( bracket, bracket_, catch, Exception(IOException), try ) +import GHC.IOBase ( IOException(ioe_location), + IOErrorType(UnsupportedOperation, HardwareFault) ) +import System.IO.Error ( isUserError, ioeGetErrorType, ioeGetErrorString ) + +import Darcs.SignalHandler ( catchNonSignal ) +import Numeric ( showHex ) +import System.Directory ( doesFileExist ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.Environment ( getEnv ) +import System.IO ( hPutStrLn, stderr ) +import Data.Char ( toUpper ) +import Darcs.RepoPath ( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath ) +import Data.Maybe ( listToMaybe, isJust ) +import Data.List ( group, sort ) +import Control.Monad ( when ) +import Exec ( exec_interactive ) +import Printer ( Doc, hPutDocLn ) +import Foreign.C.String ( CString, withCString ) +import Foreign.C.Error ( throwErrno ) +import Foreign.C.Types ( CInt ) + +import Progress ( withoutProgress ) + +import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine, + getInputChar, outputStrLn ) +import System.Console.Haskeline.Encoding ( encode ) +import qualified Data.ByteString as B ( readFile ) +import qualified Data.ByteString.Char8 as B ( unpack ) + +showHexLen :: (Integral a) => Int -> a -> String +showHexLen n x = let s = showHex x "" + in replicate (n - length s) ' ' ++ s + +add_to_error_loc :: Exception -> String -> Exception +add_to_error_loc (IOException ioe) s + = IOException $ ioe { ioe_location = s ++ ": " ++ ioe_location ioe } +add_to_error_loc e _ = e + +isUnsupportedOperationError :: IOError -> Bool +isUnsupportedOperationError = isUnsupportedOperationErrorType . ioeGetErrorType + +isUnsupportedOperationErrorType :: IOErrorType -> Bool +isUnsupportedOperationErrorType UnsupportedOperation = True +isUnsupportedOperationErrorType _ = False + +isHardwareFaultError :: IOError -> Bool +isHardwareFaultError = isHardwareFaultErrorType . ioeGetErrorType + +isHardwareFaultErrorType :: IOErrorType -> Bool +isHardwareFaultErrorType HardwareFault = True +isHardwareFaultErrorType _ = False + +catchall :: IO a -> IO a -> IO a +a `catchall` b = a `catchNonSignal` (\_ -> b) + +maybeGetEnv :: String -> IO (Maybe String) +maybeGetEnv s = (getEnv s >>= return.Just) `catchall` return Nothing -- err can only be isDoesNotExist + + +-- |The firstJustM returns the first Just entry in a list of monadic operations. This is close to +-- `listToMaybe `fmap` sequence`, but the sequence operator evaluates all monadic members of the +-- list before passing it along (i.e. sequence is strict). The firstJustM is lazy in that list +-- member monads are only evaluated up to the point where the first Just entry is obtained. +firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a) +firstJustM [] = return Nothing +firstJustM (e:es) = e >>= (\v -> if isJust v then return v else firstJustM es) + +-- |The firstJustIO is a slight modification to firstJustM: the +-- entries in the list must be IO monad operations and the +-- firstJustIO will silently turn any monad call that throws an +-- exception into Nothing, basically causing it to be ignored. +firstJustIO :: [IO (Maybe a)] -> IO (Maybe a) +firstJustIO = firstJustM . map (\o -> o `catchall` return Nothing) + + +clarify_errors :: IO a -> String -> IO a +clarify_errors a e = a `catch` (\x -> fail $ unlines [prettyException x,e]) + +prettyException :: Control.Exception.Exception -> String +prettyException (IOException e) | isUserError e = ioeGetErrorString e +prettyException e = show e + +prettyError :: IOError -> String +prettyError e | isUserError e = ioeGetErrorString e + | otherwise = show e + +-- | Given two shell commands as arguments, execute the former. The +-- latter is then executed if the former failed because the executable +-- wasn't found (code 127), wasn't executable (code 126) or some other +-- exception occurred. Other failures (such as the user holding ^C) +-- do not cause the second command to be tried. +ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode +a `ortryrunning` b = do + ret <- try a + case ret of + (Right (ExitFailure 126)) -> b -- command not executable + (Right (ExitFailure 127)) -> b -- command not found + (Right x) -> return x -- legitimate success/failure + (Left _) -> b -- an exception + +putStrLnError :: String -> IO () +putStrLnError = hPutStrLn stderr + +putDocLnError :: Doc -> IO () +putDocLnError = hPutDocLn stderr + +withCurrentDirectory :: FilePathLike p => p -> IO a -> IO a +withCurrentDirectory name m = + bracket + (do cwd <- getCurrentDirectory + when (toFilePath name /= "") (setCurrentDirectory name) + return cwd) + (\oldwd -> setCurrentDirectory oldwd `catchall` return ()) + (const m) + +foreign import ccall unsafe "umask.h set_umask" set_umask + :: CString -> IO CInt +foreign import ccall unsafe "umask.h reset_umask" reset_umask + :: CInt -> IO CInt + +withUMask :: String -> IO a -> IO a +withUMask umask job = + do rc <-withCString umask set_umask + when (rc < 0) (throwErrno "Couldn't set umask") + bracket_ + (return ()) + (reset_umask rc) + job + +askUser :: String -> IO String +askUser prompt = withoutProgress $ runInputT defaultSettings $ + getInputLine prompt + >>= maybe (error "askUser: unexpected end of input") return + -- Return the input as encoded, 8-bit Chars (same as the + -- non-Haskeline backend). + >>= fmap B.unpack . encode + +stripCr :: String -> String +stripCr "" = "" +stripCr "\r" = "" +stripCr (c:cs) = c : stripCr cs + +-- |Returns Just l where l is first non-blank string in input array; Nothing if no non-blank entries +firstNotBlank :: [String] -> Maybe String +firstNotBlank = listToMaybe . filter (not . null) + + +-- Format a path for screen output, +-- so that the user sees where the path begins and ends. +-- Could (should?) also warn about unprintable characters here. +formatPath :: String -> String +formatPath path = "\"" ++ quote path ++ "\"" + where quote "" = "" + quote (c:cs) = if c=='\\' || c=='"' + then '\\':c:quote cs + else c:quote cs + +breakCommand :: String -> (String, [String]) +breakCommand s = case words s of + (arg0:args) -> (arg0,args) + [] -> (s,[]) + +nubsort :: Ord a => [a] -> [a] +nubsort = map head . group . sort + + +edit_file :: FilePathLike p => p -> IO ExitCode +edit_file ff = do + ed <- get_editor + old_content <- file_content + ec <- exec_interactive ed f + `ortryrunning` exec_interactive "emacs" f + `ortryrunning` exec_interactive "emacs -nw" f + `ortryrunning` exec_interactive "nano" f +#ifdef WIN32 + `ortryrunning` exec_interactive "edit" f +#endif + new_content <- file_content + when (new_content == old_content) $ do + yorn <- promptYorn "File content did not change. Continue anyway?" + when (yorn == 'n') $ do putStrLn "Aborted." + exitWith ExitSuccess + return ec + where f = toFilePath ff + file_content = do + exists <- doesFileExist f + if exists then do content <- B.readFile f + return $ Just content + else return Nothing + +get_editor :: IO String +get_editor = getEnv "DARCS_EDITOR" `catchall` + getEnv "DARCSEDITOR" `catchall` + getEnv "VISUAL" `catchall` + getEnv "EDITOR" `catchall` return "vi" + +environmentHelpEditor :: ([String], [String]) +environmentHelpEditor = (["DARCS_EDITOR", "DARCSEDITOR", "VISUAL", "EDITOR"],[ + "To edit a patch description of email comment, Darcs will invoke an", + "external editor. Your preferred editor can be set as any of the", + "environment variables $DARCS_EDITOR, $DARCSEDITOR, $VISUAL or $EDITOR.", + "If none of these are set, vi(1) is used. If vi crashes or is not", + "found in your PATH, emacs, emacs -nw, nano and (on Windows) edit are", + "each tried in turn."]) + +get_viewer :: IO String +get_viewer = getEnv "DARCS_PAGER" `catchall` + getEnv "PAGER" `catchall` return "less" + +environmentHelpPager :: ([String], [String]) +environmentHelpPager = (["DARCS_PAGER", "PAGER"],[ + "Darcs will sometimes invoke a pager if it deems output to be too long", + "to fit onscreen. Darcs will use the pager specified by $DARCS_PAGER", + "or $PAGER. If neither are set, `less' will be used."]) + +promptYorn :: [Char] -> IO Char +promptYorn p = promptCharFancy p "yn" Nothing [] + +promptCharFancy :: String -> [Char] -> Maybe Char -> [Char] -> IO Char +promptCharFancy p chs md help_chs = withoutProgress $ runInputT defaultSettings $ + loopChar + where + loopChar = do + let prompt = p ++ " [" ++ setDefault chs ++ "]" ++ helpStr + a <- getInputChar prompt >>= maybe (error "promptCharFancy: unexpected end of input") + return + case () of + _ | a `elem` chs -> return a + | a == ' ' -> case md of Nothing -> tryAgain + Just d -> return d + | a `elem` help_chs -> return a + | otherwise -> tryAgain + helpStr = case help_chs of + [] -> "" + (h:_) -> ", or " ++ (h:" for help: ") + tryAgain = do outputStrLn "Invalid response, try again!" + loopChar + setDefault s = case md of Nothing -> s + Just d -> map (setUpper d) s + setUpper d c = if d == c then toUpper c else c diff --git a/src/DateMatcher.hs b/src/DateMatcher.hs new file mode 100644 --- /dev/null +++ b/src/DateMatcher.hs @@ -0,0 +1,168 @@ +-- Copyright (C) 2004 David Roundy +-- +-- 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. + + +{-# OPTIONS_GHC -fglasgow-exts #-} +{-# LANGUAGE ExistentialQuantification #-} + +module DateMatcher ( parseDateMatcher + -- for debugging only + , DateMatcher(..), getMatchers ) where + +import Control.Exception ( catchJust, userErrors ) +import Data.Maybe ( isJust ) +import System.Time +import IsoDate ( parseDate, englishDateTime, englishInterval, englishLast, iso8601_interval, + resetCalendar, subtractFromMCal, getLocalTz, + MCalendarTime(..), toMCalendarTime, unsafeToCalendarTime, + unsetTime, + ) +import Text.ParserCombinators.Parsec ( eof, parse, ParseError ) + +-- | 'withinDay' @x y@ is true if @x <= y < (x + one_day)@ +-- Note that this converts the two dates to @ClockTime@ to avoid +-- any timezone-related errors +withinDay :: CalendarTime -> CalendarTime -> Bool +withinDay a b = within (Just $ toClockTime a) + (Just (addToClockTime day $ toClockTime a)) + (toClockTime b) + where day = TimeDiff 0 0 1 0 0 0 0 + +-- | 'dateRange' @x1 x2 y@ is true if @x1 <= y < x2@ +-- Since @x1@ and @x2@ can be underspecified, we simply assume the +-- first date that they could stand for. +dateRange :: Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool +dateRange a b c = cDateRange (fmap unsafeToCalendarTime a) + (fmap unsafeToCalendarTime b) c + +-- | 'cDateRange' @x1 x2 y@ is true if @x1 <= y < x2@ +cDateRange :: Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool +cDateRange a b c = within (fmap toClockTime a) + (fmap toClockTime b) (toClockTime c) + +-- | 'within' @x1 x2 y@ is true if @x1 <= y < x2@ +within :: Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool +within (Just start) (Just end) time = start <= time && time < end +within Nothing (Just end) time = time < end +within (Just start) Nothing time = start <= time +within _ _ _ = undefined + +-- | 'samePartialDate' @range exact@ is true if @exact@ falls +-- within the a range of dates represented by @range@. +-- The purpose of this function is to support matching on partially +-- specified dates. That is, if you only specify the date 2007, +-- this function should match any dates within that year. On the +-- other hand, if you specify 2007-01, this function will match any +-- dates within that month. This function only matches up to the +-- second. +samePartialDate :: MCalendarTime -> CalendarTime -> Bool +samePartialDate a b_ = + within (Just clockA) + (Just $ addToClockTime interval clockA) + (toClockTime calB) + where interval + | isJust (mctSec a) = second + | isJust (mctMin a) = minute + | isJust (mctHour a) = hour + | isJust (mctYDay a) = day + | mctWeek a = maybe week (const day) (mctWDay a) + | isJust (mctDay a) = day + | isJust (mctMonth a) = month + | otherwise = year + year = TimeDiff 1 0 0 0 0 0 0 + month = TimeDiff 0 1 0 0 0 0 0 + week = TimeDiff 0 0 7 0 0 0 0 + day = TimeDiff 0 0 1 0 0 0 0 + hour = TimeDiff 0 0 0 1 0 0 0 + minute = TimeDiff 0 0 0 0 1 0 0 + second = TimeDiff 0 0 0 0 0 1 0 + -- + clockA = toClockTime $ unsafeToCalendarTime a + calB = resetCalendar b_ + +-- | A 'DateMatcher' combines a potential parse for a date string +-- with a "matcher" function that operates on a given date. +-- We use an existential type on the matcher to allow +-- the date string to either be interpreted as a point in time +-- or as an interval. +data DateMatcher = forall d . (Show d) => + DM String -- name + (Either ParseError d) -- parser + (d -> CalendarTime -> Bool) -- matcher + +-- | 'parseDateMatcher' @s@ return the first matcher in +-- 'getMatchers' that can parse 's' +parseDateMatcher :: String -> IO (CalendarTime -> Bool) +parseDateMatcher d = + do matcher <- tryMatchers `fmap` getMatchers d + -- Hack: test the matcher against the current date and discard the results. + -- We just want to make sure it won't throw any exceptions when we use it for real. + matcher `fmap` now >>= (`seq` return matcher) + `catchUserError` + -- If the user enters a date > maxint seconds ago, the toClockTime + -- function cannot work. + \e -> if e == "Time.toClockTime: invalid input" + then error "Can't handle dates that far back!" + else error e + where + catchUserError = catchJust userErrors + +-- | 'getMatchers' @d@ returns the list of matchers that will be +-- applied on @d@. If you wish to extend the date parsing code, +-- this will likely be the function that you modify to do so. +getMatchers :: String -> IO [DateMatcher] +getMatchers d = + do rightNow <- now + let midnightToday = unsetTime rightNow + mRightNow = toMCalendarTime rightNow + matchIsoInterval (Left dur) = dateRange (Just $ dur `subtractFromMCal` mRightNow) (Just mRightNow) + matchIsoInterval (Right (a,b)) = dateRange (Just a) (Just b) + tzNow <- getLocalTz + return -- note that the order of these is quite important as some matchers + -- can match the same date. + [ DM "from English date" + (parseDateWith $ englishLast midnightToday) + (\(a,_) -> cDateRange (Just a) Nothing) + , DM "specific English date" + (parseDateWith $ englishDateTime midnightToday) + withinDay + , DM "English interval" + (parseDateWith $ englishInterval rightNow) + (uncurry cDateRange) + , DM "ISO 8601 interval" + (parseDateWith $ iso8601_interval tzNow) + matchIsoInterval + , DM "CVS, ISO 8601, or old style date" + (parseDate tzNow d) + samePartialDate ] + where + tillEof p = do { x <- p; eof; return x } + parseDateWith p = parse (tillEof p) "" d + +-- | 'tryMatchers' @ms@ returns the first successful match in @ms@ +-- It is an error if there are no matches +tryMatchers :: [DateMatcher] -> (CalendarTime -> Bool) +tryMatchers (DM _ parsed matcher : ms) = + case parsed of + Left _ -> tryMatchers ms + Right d -> matcher d +tryMatchers [] = error "Can't support fancy dates." + +-- darcs-doc: self-explanatory +now :: IO CalendarTime +now = getClockTime >>= toCalendarTime + diff --git a/src/English.hs b/src/English.hs new file mode 100644 --- /dev/null +++ b/src/English.hs @@ -0,0 +1,76 @@ +-- Copyright (C) 2008 Eric Kow +-- +-- 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. + +-- | This modules provides rudimentary natural language generation +-- (NLG) utilities. That is, generating natural language from a +-- machine representation. Initially, only English is supported at +-- all. Representations are implemented for: +-- +-- * countable nouns (plurality); and +-- * lists of clauses (foo, bar and/or baz). +module English where + +import Data.List (isSuffixOf, intersperse) + +-- | > englishNum 0 (Noun "watch") "" == "watches" +-- > englishNum 1 (Noun "watch") "" == "watch" +-- > englishNum 2 (Noun "watch") "" == "watches" +englishNum :: Countable n => Int -> n -> ShowS +englishNum x = if x == 1 then singular else plural + +-- | Things that have a plural and singular spelling +class Countable a where + plural :: a -> ShowS + singular :: a -> ShowS + +-- | This only distinguishes between nouns with a final -ch, +-- and nouns which do not. +-- More irregular nouns will just need to have their own type +-- +-- > plural (Noun "batch") "" == "batches" +-- > plural (Noun "bat") "" == "bats" +-- > plural (Noun "mouse") "" == "mouses" -- :-( +newtype Noun = Noun String + +instance Countable Noun where + -- more irregular nouns will just need to have their own type + plural (Noun s) | "ch" `isSuffixOf` s = showString s . showString "es" + plural (Noun s) = showString s . showChar 's' + singular (Noun s) = showString s + +-- | > singular This (Noun "batch") "" == "this batch" +-- > plural This (Noun "batch") "" == "these batches" +data This = This Noun + +instance Countable This where + plural (This s) = showString "these " . plural s + singular (This s) = showString "this " . singular s + +-- | Given a list of things, combine them thusly: +-- +-- > orClauses ["foo", "bar", "baz"] == "foo, bar or baz" +andClauses, orClauses :: [String] -> String +andClauses = intersperseLast ", " " and " +orClauses = intersperseLast ", " " or " + +-- | As 'intersperse', with a different separator for the last +-- | interspersal. +intersperseLast :: String -> String -> [String] -> String +intersperseLast _ _ [] = "" +intersperseLast _ _ [clause] = clause +intersperseLast sep sepLast clauses = + concat (intersperse sep $ init clauses) ++ sepLast ++ last clauses diff --git a/src/Exec.hs b/src/Exec.hs new file mode 100644 --- /dev/null +++ b/src/Exec.hs @@ -0,0 +1,180 @@ +-- Copyright (C) 2003 David Roundy +-- +-- 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. + + +{-# OPTIONS_GHC -fglasgow-exts #-} +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +-- , DeriveDataTypeable #-} + +module Exec ( exec, exec_interactive, + withoutNonBlock, + Redirects, Redirect(..), + ExecException(..) + ) where + +import Data.Typeable ( Typeable ) + +#ifndef WIN32 +import Control.Exception ( bracket ) +import System.Posix.Env ( setEnv, getEnv, unsetEnv ) +import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput ) +import System.IO ( stdin ) +#else +import Control.Exception ( catchJust, Exception(IOException) ) +import Data.List ( isInfixOf ) +#endif + +import System.Exit ( ExitCode (..) ) +import System.Cmd ( system ) +import System.IO ( IOMode(..), openBinaryFile, stdout ) +import System.Process ( runProcess, terminateProcess, waitForProcess ) +import GHC.Handle ( hDuplicate ) + -- urgh. hDuplicate isn't available from a standard place. +import Control.Exception ( bracketOnError ) + +import Darcs.Global ( whenDebugMode ) +import Progress ( withoutProgress ) + +{- + A redirection is a three-tuple of values (in, out, err). + The most common values are: + + AsIs don't change it + Null /dev/null on Unix, NUL on Windows + File open a file for reading or writing + + There is also the value Stdout, which is only meaningful for + redirection of errors, and is performed AFTER stdout is + redirected so that output and errors mix together. StdIn and + StdErr could be added as well if they are useful. + + NOTE: Lots of care must be taken when redirecting stdin, stdout + and stderr to one of EACH OTHER, since the ORDER in which they + are changed have a significant effect on the result. +-} + +type Redirects = (Redirect, Redirect, Redirect) +data Redirect = AsIs | Null | File FilePath + | Stdout + deriving Show + +{- + ExecException is thrown by exec if any system call fails, + for example because the executable we're trying to run + doesn't exist. +-} +-- ExecException cmd args redirecs errorDesc +data ExecException = ExecException String [String] Redirects String + deriving (Typeable,Show) + + +_dev_null :: FilePath +#ifdef WIN32 +_dev_null = "NUL" +#else +_dev_null = "/dev/null" +#endif + +{- + We use System.Process, which does the necessary quoting + and redirection for us behind the scenes. +-} + +exec :: String -> [String] -> Redirects -> IO ExitCode +exec cmd args (inp,out,err) = withoutProgress $ do + h_stdin <- redirect inp ReadMode + h_stdout <- redirect out WriteMode + h_stderr <- redirect err WriteMode +-- putStrLn (unwords (cmd:args ++ map show [inp,out,err])) + withExit127 $ bracketOnError + (do whenDebugMode $ putStrLn $ unwords $ cmd:args ++ ["; #"] ++ map show [inp,out,err] + runProcess cmd args Nothing Nothing h_stdin h_stdout h_stderr) + (terminateProcess) + (waitForProcess) + where + redirect AsIs _ = return Nothing + redirect Null mode = Just `fmap` openBinaryFile _dev_null mode + redirect (File "/dev/null") mode = redirect Null mode + redirect (File f) mode = Just `fmap` openBinaryFile f mode + redirect Stdout _ = Just `fmap` hDuplicate stdout + -- hDuplicate stdout rather than passing stdout itself, + -- because runProcess closes the Handles we pass it. + +exec_interactive :: String -> String -> IO ExitCode + +#ifndef WIN32 +{- +This should handle arbitrary commands interpreted by the shell on Unix since +that's what people expect. But we don't want to allow the shell to interpret +the argument in any way, so we set an environment variable and call +cmd "$DARCS_ARGUMENT" +-} +exec_interactive cmd arg = withoutProgress $ do + let var = "DARCS_ARGUMENT" + stdin `seq` return () + withoutNonBlock $ bracket + (do oldval <- getEnv var + setEnv var arg True + return oldval) + (\oldval -> + do case oldval of + Nothing -> unsetEnv var + Just val -> setEnv var val True) + (\_ -> withExit127 $ system $ cmd++" \"$"++var++"\"") + +#else + +exec_interactive cmd arg = withoutProgress $ do + system $ cmd ++ " " ++ arg +#endif + +withoutNonBlock :: IO a -> IO a + +#ifndef WIN32 +{- +Do IO without NonBlockingRead on stdInput. + +This is needed when running unsuspecting external commands with interactive +mode - if read from terminal is non-blocking also write to terminal is +non-blocking. +-} +withoutNonBlock x = + do nb <- queryFdOption stdInput NonBlockingRead + if nb + then bracket + (do setFdOption stdInput NonBlockingRead False) + (\_ -> setFdOption stdInput NonBlockingRead True) + (\_ -> x) + else do x +#else +withoutNonBlock x = do x +#endif + +{- +Ensure that we exit 127 if the thing we are trying to run does not exist +(Only needed under Windows) +-} +withExit127 :: IO ExitCode -> IO ExitCode +#ifdef WIN32 +withExit127 a = catchJust notFoundError a (const $ return $ ExitFailure 127) + +notFoundError :: Exception -> Maybe () +notFoundError (IOException e) | "runProcess: does not exist" `isInfixOf` show e = Just () +notFoundError _ = Nothing +#else +withExit127 = id +#endif diff --git a/src/HTTP.hs b/src/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/HTTP.hs @@ -0,0 +1,107 @@ +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module HTTP( fetchUrl, postUrl, request_url, wait_next_url ) where + +import Darcs.Global ( debugFail ) + +#ifdef HAVE_HTTP +import Control.Monad ( when ) +import Data.IORef ( newIORef, readIORef, writeIORef, IORef ) +import Network.HTTP +import Network.URI +import System.Environment ( getEnv ) +import System.IO.Error ( ioeGetErrorString ) +import System.IO.Unsafe ( unsafePerformIO ) +import Darcs.Global ( debugMessage ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +#endif + +fetchUrl :: String -> IO String +postUrl + :: String -- ^ url + -> String -- ^ body + -> String -- ^ mime type + -> IO () -- ^ result + +request_url :: String -> FilePath -> a -> IO String +wait_next_url :: IO (String, String) + +#ifdef HAVE_HTTP + +headers :: [Header] +headers = [Header HdrUserAgent $ "darcs-HTTP/" ++ PACKAGE_VERSION] + +fetchUrl url = case parseURI url of + Nothing -> fail $ "Invalid URI: " ++ url + Just uri -> do debugMessage $ "Fetching over HTTP: "++url + proxy <- getProxy + when (not $ null proxy) $ + debugFail "No proxy support for HTTP package yet (try libcurl)!" + resp <- simpleHTTP $ Request { rqURI = uri, + rqMethod = GET, + rqHeaders = headers, + rqBody = "" } + case resp of + Right res@Response { rspCode = (2,0,0) } -> return (rspBody res) + Right Response { rspCode = (x,y,z) } -> + debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error getting " ++ show uri + Left err -> debugFail $ show err + +postUrl url body mime = case parseURI url of + Nothing -> fail $ "Invalid URI: " ++ url + Just uri -> do debugMessage $ "Posting to HTTP: "++url + proxy <- getProxy + when (not $ null proxy) $ + debugFail "No proxy support for HTTP package yet (try libcurl)!" + resp <- simpleHTTP $ Request { rqURI = uri, + rqMethod = POST, + rqHeaders = headers ++ [Header HdrContentType mime, + Header HdrAccept "text/plain", + Header HdrContentLength + (show $ length body) ], + rqBody = body } + case resp of + Right res@Response { rspCode = (2,y,z) } -> do + putStrLn $ "Success 2" ++ show y ++ show z + putStrLn (rspBody res) + return () + Right res@Response { rspCode = (x,y,z) } -> do + putStrLn $ rspBody res + debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error posting to " ++ show uri + Left err -> debugFail $ show err + +requestedUrl :: IORef (String, FilePath) +requestedUrl = unsafePerformIO $ newIORef ("", "") + +request_url u f _ = do + (u', _) <- readIORef requestedUrl + if null u' + then do writeIORef requestedUrl (u, f) + return "" + else return "URL already requested" + +wait_next_url = do + (u, f) <- readIORef requestedUrl + if null u + then return ("", "No URL requested") + else do writeIORef requestedUrl ("", "") + e <- (fetchUrl u >>= \s -> B.writeFile f (BC.pack s) >> return "") `catch` h + return (u, e) + where h = return . ioeGetErrorString + +getProxy :: IO String +getProxy = + getEnv "http_proxy" + `catch` \_ -> getEnv "HTTP_PROXY" + `catch` \_ -> return "" +#else + +fetchUrl _ = debugFail "Network.HTTP does not exist" +postUrl _ _ _ = debugFail "Cannot use http POST because darcs was not compiled with Network.HTTP." + +request_url _ _ _ = debugFail "Network.HTTP does not exist" +wait_next_url = debugFail "Network.HTTP does not exist" + +#endif diff --git a/src/IsoDate.hs b/src/IsoDate.hs new file mode 100644 --- /dev/null +++ b/src/IsoDate.hs @@ -0,0 +1,844 @@ +-- Copyright (C) 2003 Peter Simons +-- Copyright (C) 2003 David Roundy +-- +-- 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. + + +module IsoDate ( getIsoDateTime, readLocalDate, readUTCDate, + parseDate, getLocalTz, + englishDateTime, englishInterval, englishLast, + iso8601_interval, iso8601_duration, + cleanLocalDate, resetCalendar, + MCalendarTime(..), subtractFromMCal, addToMCal, + toMCalendarTime, unsafeToCalendarTime, + unsetTime, TimeInterval + ) where + +import Text.ParserCombinators.Parsec +import System.Time +import System.IO.Unsafe ( unsafePerformIO ) +import Data.Char ( toUpper, isDigit ) +import Data.Maybe ( fromMaybe ) +import Control.Monad ( liftM, liftM2 ) +import qualified Data.ByteString.Char8 as B + +type TimeInterval = (Maybe CalendarTime, Maybe CalendarTime) + +-- | Read/interpret a date string, assuming UTC if timezone +-- is not specified in the string (see 'readDate') +-- Warning! This errors out if we fail to interpret the +-- date +readUTCDate :: String -> CalendarTime +readUTCDate = readDate 0 + +-- | Convert a date string into ISO 8601 format (yyyymmdd variant) +-- assuming local timezone if not specified in the string +-- Warning! This errors out if we fail to interpret the date +cleanLocalDate :: String -> String +cleanLocalDate = showIsoDateTime . resetCalendar + . readDate (unsafePerformIO getLocalTz) + +-- | Read/interpret a date string, assuming local timezone if not +-- specified in the string +readLocalDate :: String -> CalendarTime +readLocalDate = readDate (unsafePerformIO getLocalTz) + +-- | Return the local timezone offset from UTC in seconds +getLocalTz :: IO Int +getLocalTz = ctTZ `liftM` (getClockTime >>= toCalendarTime) + +-- | Parse a date string with 'parseDate' +-- Warning! This errors out if we fail to interpret the date +-- Uses its first argument as the default time zone. +readDate :: Int -> String -> CalendarTime +readDate tz d = + case parseDate tz d of + Left e -> error $ "bad date: "++d++" - "++show e + Right ct -> resetCalendar $ unsafeToCalendarTime ct + +-- | Parse a date string, assuming a default timezone if +-- the date string does not specify one. The date formats +-- understood are those of 'showIsoDateTime' and 'date_time' +parseDate :: Int -> String -> Either ParseError MCalendarTime +parseDate tz d = + if length d >= 14 && B.all isDigit bd + then Right $ toMCalendarTime $ + CalendarTime (readI $ B.take 4 bd) + (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd) + (readI $ B.take 2 $ B.drop 6 bd) -- Day + (readI $ B.take 2 $ B.drop 8 bd) -- Hour + (readI $ B.take 2 $ B.drop 10 bd) -- Minute + (readI $ B.take 2 $ B.drop 12 bd) -- Second + 0 Sunday 0 -- Picosecond, weekday and day of year unknown + "GMT" 0 False + else let dt = do { x <- date_time tz; eof; return x } + in parse dt "" d + where bd = B.pack (take 14 d) + readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s) + +-- | Display a 'CalendarTime' in the ISO 8601 format without any +-- separators, e.g. 20080825142503 +showIsoDateTime :: CalendarTime -> String +showIsoDateTime ct = concat [ show $ ctYear ct + , twoDigit . show . (+1) . fromEnum $ ctMonth ct + , twoDigit . show $ ctDay ct + , twoDigit . show $ ctHour ct + , twoDigit . show $ ctMin ct + , twoDigit . show $ ctSec ct + ] + where twoDigit [] = undefined + twoDigit x@(_:[]) = '0' : x + twoDigit x@(_:_:[]) = x + twoDigit _ = undefined + +-- | The current time in the format returned by 'showIsoDateTime' +getIsoDateTime :: IO String +getIsoDateTime = (showIsoDateTime . toUTCTime) `liftM` getClockTime + +----- Parser Combinators --------------------------------------------- + +-- | Case-insensitive variant of Parsec's 'char' function. +caseChar :: Char -> GenParser Char a Char +caseChar c = satisfy (\x -> toUpper x == toUpper c) + +-- | Case-insensitive variant of Parsec's 'string' function. +caseString :: String -> GenParser Char a () +caseString cs = mapM_ caseChar cs cs + +-- | Match a parser at least @n@ times. +manyN :: Int -> GenParser a b c -> GenParser a b [c] +manyN n p + | n <= 0 = return [] + | otherwise = liftM2 (++) (count n p) (many p) + +-- | Match a parser at least @n@ times, but no more than @m@ times. +manyNtoM :: Int -> Int -> GenParser a b c -> GenParser a b [c] +manyNtoM n m p + | n < 0 = return [] + | n > m = return [] + | n == m = count n p + | n == 0 = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m])) + | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p) + + +----- Date/Time Parser ----------------------------------------------- + +-- | Try each of these date parsers in the following order +-- +-- (1) 'cvs_date_time' +-- +-- (2) 'iso8601_date_time' +-- +-- (3) 'old_date_time +date_time :: Int -> CharParser a MCalendarTime +date_time tz = + choice [try $ toMCalendarTime `fmap` cvs_date_time tz, + try $ iso8601_date_time tz, + toMCalendarTime `fmap` old_date_time] + +-- | CVS-style date/times, e.g. +-- 2007/08/25 14:25:39 GMT +-- Note that time-zones are optional here. +cvs_date_time :: Int -> CharParser a CalendarTime +cvs_date_time tz = + do y <- year + char '/' + mon <- month_num + char '/' + d <- day + my_spaces + h <- hour + char ':' + m <- minute + char ':' + s <- second + z <- option tz $ my_spaces >> zone + return (CalendarTime y mon d h m s 0 Monday 0 "" z False) + +-- | \"Old\"-style dates, e.g. +-- Tue Jan 3 14:08:07 EST 1999 +-- darcs-doc: Question (what does the "old" stand for really?) +old_date_time :: CharParser a CalendarTime +old_date_time = do wd <- day_name + my_spaces + mon <- month_name + my_spaces + d <- day + my_spaces + h <- hour + char ':' + m <- minute + char ':' + s <- second + my_spaces + z <- zone + my_spaces + y <- year + return (CalendarTime y mon d h m s 0 wd 0 "" z False) + +-- | ISO 8601 dates and times. Please note the following flaws: +-- +-- I am reluctant to implement: +-- +-- * years > 9999 +-- +-- * truncated representations with implied century (89 for 1989) +-- +-- I have not implemented: +-- +-- * repeated durations (not relevant) +-- +-- * lowest order component fractions in intervals +-- +-- * negative dates (BC) +-- +-- I have not verified or have left too relaxed: +-- +-- * the difference between 24h and 0h +-- +-- * allows stuff like 2005-1212; either you use the hyphen all the way +-- (2005-12-12) or you don't use it at all (20051212), but you don't use +-- it halfway, likewise with time +-- +-- * No bounds checking whatsoever on intervals! +-- (next action: read iso doc to see if bounds-checking required?) -} +iso8601_date_time :: Int -> CharParser a MCalendarTime +iso8601_date_time localTz = try $ + do d <- iso8601_date + t <- option id $ try $ do optional $ oneOf " T" + iso8601_time + return $ t $ d { mctTZ = Just localTz } + +-- | Three types of ISO 8601 date: +-- +-- * calendar date, e.g., 1997-07-17, 1997-07, 199707, 1997 +-- +-- * week+day in year, e.g., 1997-W32-4 +-- +-- * day in year, e.g, 1997-273 +iso8601_date :: CharParser a MCalendarTime +iso8601_date = + do d <- calendar_date <|> week_date <|> ordinal_date + return $ foldr ($) nullMCalendar d + where + calendar_date = -- yyyy-mm-dd + try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ] + -- allow other variants to be parsed correctly + notFollowedBy (digit <|> char 'W') + return d + week_date = --yyyy-Www-d + try $ do yfn <- year_ + optional dash + char 'W' + -- offset human 'week 1' -> computer 'week 0' + w' <- (\x -> x-1) `liftM` two_digits + mwd <- option Nothing $ do { optional dash; Just `fmap` n_digits 1 } + let y = resetCalendar . unsafeToCalendarTime . yfn $ nullMCalendar { mctDay = Just 1 } + firstDay = ctWDay y + -- things that make this complicated + -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday + -- 2. the first week is the one that contains at least Thursday + -- if the year starts after Thursday, then some days of the year + -- will have already passed before the first week + let afterThursday = firstDay == Sunday || firstDay > Thursday + w = if afterThursday then w'+1 else w' + yday = (7 * w) + fromMaybe 1 mwd + diff c = c { mctWeek = True + , mctWDay = toEnum `fmap` mwd + , mctDay = Just yday } + return [(diff.yfn)] + ordinal_date = -- yyyy-ddd + try $ optchain year_ [ (dash, yearDay_) ] + -- + year_ = try $ do y <- four_digits "year (0000-9999)" + return $ \c -> c { mctYear = Just y } + month_ = try $ do m <- two_digits "month (1 to 12)" + return $ \c -> c { mctMonth = Just $ intToMonth m } + day_ = try $ do d <- two_digits "day in month (1 to 31)" + return $ \c -> c { mctDay = Just d } + yearDay_ = try $ do d <- n_digits 3 "day in year (001 to 366)" + return $ \c -> c { mctDay = Just d + , mctYDay = Just (d - 1) } + dash = char '-' + +-- | Note that this returns a function which sets the time on +-- another calendar (see 'iso8601_date_time' for a list of +-- flaws +iso8601_time :: CharParser a (MCalendarTime -> MCalendarTime) +iso8601_time = try $ + do ts <- optchain hour_ [ (colon , min_) + , (colon , sec_) + , (oneOf ",.", pico_) ] + z <- option id $ choice [ zulu , offset ] + return $ foldr (.) id (z:ts) + where + hour_ = do h <- two_digits + return $ \c -> c { mctHour = Just h } + min_ = do m <- two_digits + return $ \c -> c { mctMin = Just m } + sec_ = do s <- two_digits + return $ \c -> c { mctSec = Just s } + pico_ = do digs <- many digit + let picoExp = 12 + digsExp = length digs + let frac | null digs = 0 + | digsExp > picoExp = read $ take picoExp digs + | otherwise = 10 ^ (picoExp - digsExp) * (read digs) + return $ \c -> c { mctPicosec = Just $ frac } + zulu = do { char 'Z'; return (\c -> c { mctTZ = Just 0 }) } + offset = do sign <- choice [ do { char '+' >> return 1 } + , do { char '-' >> return (-1) } ] + h <- two_digits + m <- option 0 $ do { optional colon; two_digits } + return $ \c -> c { mctTZ = Just $ sign * 60 * ((h*60)+m) } + colon = char ':' + +-- | Intervals in ISO 8601, e.g., +-- +-- * 2008-09/2012-08-17T16:30 +-- +-- * 2008-09/P2Y11MT16H30M +-- +-- * P2Y11MT16H30M/2012-08-17T16:30 +-- +-- See 'iso8601_duration' +iso8601_interval :: Int -> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime)) +iso8601_interval localTz = leftDur <|> rightDur where + leftDur = + do dur <- iso8601_duration + end <- option Nothing $ do { char '/'; Just `liftM` isoDt } + return $ case end of + Nothing -> Left dur + Just e -> Right (dur `subtractFromMCal` e, e) + rightDur = + do start <- isoDt + char '/' + durOrEnd <- Left `liftM` iso8601_duration <|> Right `liftM` isoDt + return $ case durOrEnd of + Left dur -> Right (start, dur `addToMCal` start) + Right end -> Right (start, end) + isoDt = iso8601_date_time localTz + +-- | Durations in ISO 8601, e.g., +-- +-- * P4Y (four years) +-- +-- * P5M (five months) +-- +-- * P4Y5M (four years and five months) +-- +-- * P4YT3H6S (four years, three hours and six seconds) +iso8601_duration :: CharParser a TimeDiff +iso8601_duration = + do char 'P' + y <- block 0 'Y' + mon <- block 0 'M' + d <- block 0 'D' + (h,m,s) <- option (0,0,0) $ + do char 'T' + h' <- block (-1) 'H' + m' <- block (-1) 'M' + s' <- block (-1) 'S' + let unset = (== (-1)) + if all unset [h',m',s'] + then fail "T should be omitted if time is unspecified" + else let clear x = if (unset x) then 0 else x + in return (clear h', clear m', clear s') + -- + return $ TimeDiff y mon d h m s 0 + where block d c = option d $ try $ + do n <- many1 digit + char c + return $ read n + +-- | 'optchain' @p xs@ parses a string with the obligatory +-- parser @p@. If this suceeds, it continues on to the +-- rest of the input using the next parsers down the +-- chain. Each part of the chain consists of a parser +-- for a separator and for the content itself. The +-- separator is optional. +-- +-- A good use of this function is to help in parsing ISO +-- ISO 8601 dates and times. For example, the parser +-- @optchain year [(dash, month), (dash, day)]@ accepts +-- dates like 2007 (only the year is used), 2007-07 (only +-- the year and month), 200707 (only the year and month +-- with no separator), 2007-07-19 (year, month and day). +optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b] +optchain p next = try $ + do r1 <- p + r2 <- case next of + [] -> return [] + ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 } + return (r1:r2) + +n_digits :: Int -> CharParser a Int +n_digits n = read `liftM` count n digit + +two_digits, four_digits :: CharParser a Int +two_digits = n_digits 2 +four_digits = n_digits 4 + +-- | One or more space. +-- WARNING! This only matches on the space character, not on +-- whitespace in general +my_spaces :: CharParser a String +my_spaces = manyN 1 $ char ' ' + +-- | English three-letter day abbreviations (e.g. Mon, Tue, Wed) +day_name :: CharParser a Day +day_name = choice + [ caseString "Mon" >> return Monday + , try (caseString "Tue") >> return Tuesday + , caseString "Wed" >> return Wednesday + , caseString "Thu" >> return Thursday + , caseString "Fri" >> return Friday + , try (caseString "Sat") >> return Saturday + , caseString "Sun" >> return Sunday + ] + +-- | Four-digit year +year :: CharParser a Int +year = four_digits + +-- | One or two digit month (e.g. 3 for March, 11 for November) +month_num :: CharParser a Month +month_num = do mn <- manyNtoM 1 2 digit + return $ intToMonth $ (read mn :: Int) + +-- | January is 1, February is 2, etc +intToMonth :: Int -> Month +intToMonth 1 = January +intToMonth 2 = February +intToMonth 3 = March +intToMonth 4 = April +intToMonth 5 = May +intToMonth 6 = June +intToMonth 7 = July +intToMonth 8 = August +intToMonth 9 = September +intToMonth 10 = October +intToMonth 11 = November +intToMonth 12 = December +intToMonth _ = error "invalid month!" + +-- | English three-letter month abbreviations (e.g. Jan, Feb, Mar) +month_name :: CharParser a Month +month_name = choice + [ try (caseString "Jan") >> return January + , caseString "Feb" >> return February + , try (caseString "Mar") >> return March + , try (caseString "Apr") >> return April + , caseString "May" >> return May + , try (caseString "Jun") >> return June + , caseString "Jul" >> return July + , caseString "Aug" >> return August + , caseString "Sep" >> return September + , caseString "Oct" >> return October + , caseString "Nov" >> return November + , caseString "Dec" >> return December + ] + +-- | day in one or two digit notation +day :: CharParser a Int +day = do d <- manyNtoM 1 2 digit + return (read d :: Int) + +-- | hour in two-digit notation +hour :: CharParser a Int +hour = two_digits + +-- | minute in two-digit notation +minute :: CharParser a Int +minute = two_digits + +-- | second in two-digit notation +second :: CharParser a Int +second = two_digits + +-- | limited timezone support +-- +-- * +HHMM or -HHMM +-- +-- * Universal timezones: UTC, UT +-- +-- * Zones from GNU coreutils/lib/getdate.y, less half-hour ones -- +-- sorry Newfies. +-- +-- * any sequence of alphabetic characters (WARNING! treated as 0!) +zone :: CharParser a Int +zone = choice + [ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) } + , do { char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) } + , mkZone "UTC" 0 + , mkZone "UT" 0 + , mkZone "GMT" 0 + , mkZone "WET" 0 + , mkZone "WEST" 1 + , mkZone "BST" 1 + , mkZone "ART" (-3) + , mkZone "BRT" (-3) + , mkZone "BRST" (-2) + , mkZone "AST" (-4) + , mkZone "ADT" (-3) + , mkZone "CLT" (-4) + , mkZone "CLST" (-3) + , mkZone "EST" (-5) + , mkZone "EDT" (-4) + , mkZone "CST" (-6) + , mkZone "CDT" (-5) + , mkZone "MST" (-7) + , mkZone "MDT" (-6) + , mkZone "PST" (-8) + , mkZone "PDT" (-7) + , mkZone "AKST" (-9) + , mkZone "AKDT" (-8) + , mkZone "HST" (-10) + , mkZone "HAST" (-10) + , mkZone "HADT" (-9) + , mkZone "SST" (-12) + , mkZone "WAT" 1 + , mkZone "CET" 1 + , mkZone "CEST" 2 + , mkZone "MET" 1 + , mkZone "MEZ" 1 + , mkZone "MEST" 2 + , mkZone "MESZ" 2 + , mkZone "EET" 2 + , mkZone "EEST" 3 + , mkZone "CAT" 2 + , mkZone "SAST" 2 + , mkZone "EAT" 3 + , mkZone "MSK" 3 + , mkZone "MSD" 4 + , mkZone "SGT" 8 + , mkZone "KST" 9 + , mkZone "JST" 9 + , mkZone "GST" 10 + , mkZone "NZST" 12 + , mkZone "NZDT" 13 + -- if we don't understand it, just give a GMT answer... + , do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' ']) + (lookAhead space_digit); + return 0 } + ] + where mkZone n o = try $ do { caseString n; return (o*60*60) } + space_digit = try $ do { char ' '; oneOf ['0'..'9'] } + +----- English dates and intervals ----------------------------------------------- + +-- | In English, either a date followed by a time, or vice-versa, e.g, +-- +-- * yesterday at noon +-- +-- * yesterday tea time +-- +-- * 12:00 yesterday +-- +-- See 'englishDate' and 'englishTime' +-- Uses its first argument as "now", i.e. the time relative to which +-- "yesterday", "today" etc are to be interpreted +englishDateTime :: CalendarTime -> CharParser a CalendarTime +englishDateTime now = + try $ dateMaybeAtTime <|> timeThenDate + where + -- yesterday (at) noon + dateMaybeAtTime = try $ + do ed <- englishDate now + t <- option Nothing $ try $ + do { space; optional $ caseString "at "; Just `liftM` englishTime } + return $ fromMaybe id t $ ed + -- tea time 2005-12-04 + timeThenDate = try $ + do t <- englishTime + optional $ char ',' + space + ed <- englishDate now + return $ t $ unsetTime $ ed + +-- | Specific dates in English as specific points of time, e.g, +-- +-- * today +-- +-- * yesterday +-- +-- * last week (i.e. the beginning of that interval) +-- +-- * 4 months ago (via 'englishAgo') +-- +-- The first argument is "now". +englishDate :: CalendarTime -> CharParser a CalendarTime +englishDate now = try $ + (caseString "today" >> (return $ resetCalendar now)) + <|> (caseString "yesterday" >> (return $ oneDay `subtractFromCal` now) ) + <|> fst `fmap` englishLast now + <|> englishAgo now + where oneDay = TimeDiff 0 0 1 0 0 0 0 + +-- | English expressions for points in the past, e.g. +-- +-- * 4 months ago +-- +-- * 1 day ago +-- +-- * day before yesterday +-- +-- See 'englishDuration' +englishAgo :: CalendarTime -> CharParser a CalendarTime +englishAgo now = + try $ do p <- englishDuration + try $ do space + (m,ref) <- (try $ caseString "ago" >> return ((-1), now)) + <|> do m <- beforeMod <|> afterMod + space + d <- englishDate now + <|> fst `fmap` englishLast now + <|> unsafeToCalendarTime `fmap` iso8601_date_time (ctTZ now) + return (m,d) + return $ multiplyDiff m p `addToCal` ref + where + beforeMod = try $ caseString "before" >> return (-1) + afterMod = try $ caseString "after" >> return 1 + +-- | English expressions for intervals of time, +-- +-- * before tea time (i.e. from the beginning of time) +-- +-- * after 14:00 last month (i.e. till now) +-- +-- * between last year and last month +-- +-- * in the last three months (i.e. from then till now) +-- +-- * 4 months ago (i.e. till now; see 'englishAgo') +englishInterval :: CalendarTime -> CharParser a TimeInterval +englishInterval now = twixt <|> before <|> after <|> inTheLast <|> lastetc + where + englishDT = (unsafeToCalendarTime `fmap` iso8601_date_time (ctTZ now) + <|> englishDateTime now) + before = try $ + do caseString "before" + space + end <- englishDT + return (Just theBeginning, Just end) + after = try $ + do caseString "after" + space + start <- englishDT + return (Just start, Nothing) + twixt = try $ + do caseString "between" + space + start <- englishDT + space + caseString "and" + space + end <- englishDT + return (Just start, Just end) + inTheLast = try $ + do caseString "in the last" + space + dur <- englishDuration + return (Just $ dur `subtractFromCal` now, Just now) + lastetc = + do l <- englishAgo now + return (Just l, Just now) + +-- | Durations in English that begin with the word \"last\", +-- E.g. \"last 4 months\" is treated as the duration between +-- 4 months ago and now +englishLast :: CalendarTime -> CharParser a (CalendarTime, CalendarTime) +englishLast now = + -- last year, last week, last 3 years, etc + try $ do caseString "last" + space + d <- englishDuration + return (d `subtractFromCal` now, now) + +-- | Either an 'iso8601_time' or one of several common +-- English time expressions like 'noon' or 'tea time' +englishTime :: CharParser a (CalendarTime->CalendarTime) +englishTime = try $ + choice [ wrapM `fmap` iso8601_time + , namedTime "noon" 12 0 + , namedTime "midnight" 0 0 + , namedTime "tea time" 16 30 + , namedTime "bed time" 2 30 + , namedTime "proper bed time" 21 30 ] + where namedTime name h m = try $ + do caseString name + return $ \c -> c { ctHour = h, ctMin = m } + wrapM f = unsafeToCalendarTime . f . toMCalendarTime + +-- | Some English durations, e.g. +-- +-- * day +-- +-- * 4 score +-- +-- * 7 years +-- +-- * 12 months +-- +-- This is not particularly strict about what it accepts. +-- For example, "7 yeares", "4 scores" or "1 days" are +-- just fine. +englishDuration :: CharParser a TimeDiff +englishDuration = try $ + do n <- option 1 $ do { x <- many1 digit; space; (return $ read x) } + b <- base + optional (caseString "es" <|> caseString "s") + let current = multiplyDiff n b + next <- option noTimeDiff $ try $ do + { optional space; char ',' ; optional space ; englishDuration } + return $ addDiff current next + where + base = choice + [ try $ caseString "score" >> (return $ TimeDiff 20 0 0 0 0 0 0) -- why not? + , caseString "year" >> (return $ TimeDiff 1 0 0 0 0 0 0) + , try $ caseString "month" >> (return $ TimeDiff 0 1 0 0 0 0 0) + , caseString "fortnight" >> (return $ TimeDiff 0 0 14 0 0 0 0) + , caseString "week" >> (return $ TimeDiff 0 0 7 0 0 0 0) + , caseString "day" >> (return $ TimeDiff 0 0 1 0 0 0 0) + , caseString "hour" >> (return $ TimeDiff 0 0 0 1 0 0 0) + , caseString "minute" >> (return $ TimeDiff 0 0 0 0 1 0 0) + , caseString "second" >> (return $ TimeDiff 0 0 0 0 0 1 0) ] + +----- Calendar and TimeDiff manipulation --------------------------------------------- + +-- | The very beginning of time, i.e. 1970-01-01 +theBeginning :: CalendarTime +theBeginning = unsafePerformIO $ toCalendarTime $ TOD 0 0 + +-- | An 'MCalenderTime' is an underspecified 'CalendarTime' +-- It is used for parsing dates. For example, if you want to parse +-- the date '4 January', it may be useful to underspecify the year +-- by setting it to 'Nothing'. This uses almost the same fields as +-- 'System.Time.CalendarTime', a notable exception being that we +-- introduce 'mctWeek' to indicate if a weekday was specified or not +data MCalendarTime = MCalendarTime + { mctYear :: Maybe Int + , mctMonth :: Maybe Month + , mctDay :: Maybe Int + , mctHour :: Maybe Int + , mctMin :: Maybe Int + , mctSec :: Maybe Int + , mctPicosec :: Maybe Integer + , mctWDay :: Maybe Day + , mctYDay :: Maybe Int + , mctTZName :: Maybe String + , mctTZ :: Maybe Int + , mctIsDST :: Maybe Bool + , mctWeek :: Bool -- is set or not +} deriving Show + +-- | Trivially convert a 'CalendarTime' to a fully specified +-- 'MCalendarTime' (note that this sets the 'mctWeek' flag to +-- @False@ +toMCalendarTime :: CalendarTime -> MCalendarTime +toMCalendarTime (CalendarTime a b c d e f g h i j k l) = + MCalendarTime (Just a) (Just b) (Just c) (Just d) (Just e) (Just f) + (Just g) (Just h) (Just i) (Just j) (Just k) (Just l) + False + +-- | Returns the first 'CalendarTime' that falls within a 'MCalendarTime' +-- This is only unsafe in the sense that it plugs in default values +-- for fields that have not been set, e.g. @January@ for the month +-- or @0@ for the seconds field. +-- Maybe we should rename it something happier. +-- See also 'resetCalendar' +unsafeToCalendarTime :: MCalendarTime -> CalendarTime +unsafeToCalendarTime m = + CalendarTime + { ctYear = fromMaybe 0 $ mctYear m + , ctMonth = fromMaybe January $ mctMonth m + , ctDay = fromMaybe 1 $ mctDay m + , ctHour = fromMaybe 0 $ mctHour m + , ctMin = fromMaybe 0 $ mctMin m + , ctSec = fromMaybe 0 $ mctSec m + , ctPicosec = fromMaybe 0 $ mctPicosec m + , ctWDay = fromMaybe Sunday $ mctWDay m + , ctYDay = fromMaybe 0 $ mctYDay m + , ctTZName = fromMaybe "" $ mctTZName m + , ctTZ = fromMaybe 0 $ mctTZ m + , ctIsDST = fromMaybe False $ mctIsDST m + } + +addToCal :: TimeDiff -> CalendarTime -> CalendarTime +addToCal td = toUTCTime . addToClockTime td . toClockTime + +subtractFromCal :: TimeDiff -> CalendarTime -> CalendarTime +subtractFromCal = addToCal . multiplyDiff (-1) + +addToMCal :: TimeDiff -> MCalendarTime -> MCalendarTime +addToMCal td mc = + copyCalendar (addToCal td $ unsafeToCalendarTime mc) mc + +subtractFromMCal :: TimeDiff -> MCalendarTime -> MCalendarTime +subtractFromMCal = addToMCal . multiplyDiff (-1) + +-- surely there is a more concise way to express these +addDiff :: TimeDiff -> TimeDiff -> TimeDiff +addDiff (TimeDiff a1 a2 a3 a4 a5 a6 a7) (TimeDiff b1 b2 b3 b4 b5 b6 b7) = + TimeDiff (a1+b1) (a2+b2) (a3+b3) (a4+b4) (a5+b5) (a6+b6) (a7 + b7) + +-- | 'multiplyDiff' @i d@ multiplies every field in @d@ with @i@ +-- +-- FIXME; this seems like a terrible idea! it seems like +-- we should get rid of it if at all possible, maybe adding an +-- invertDiff function +multiplyDiff :: Int -> TimeDiff -> TimeDiff +multiplyDiff m (TimeDiff a1 a2 a3 a4 a5 a6 a7) = + TimeDiff (a1*m) (a2*m) (a3*m) (a4*m) (a5*m) (a6*m) (a7 * (toInteger m)) + +nullMCalendar :: MCalendarTime +nullMCalendar = MCalendarTime Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing + False + +-- | Set a calendar to UTC time any eliminate any inconsistencies within +-- (for example, where the weekday is given as @Thursday@, but this does not +-- match what the numerical date would lead one to expect) +resetCalendar :: CalendarTime -> CalendarTime +resetCalendar = toUTCTime . toClockTime + +-- | 'copyCalendar' @c mc@ replaces any field which is +-- specified in @mc@ with the equivalent field in @c@ +-- @copyCalendar c nullMCalendar == nullMCalendar@ +copyCalendar :: CalendarTime -> MCalendarTime -> MCalendarTime +copyCalendar c mc = mc + { mctYear = mctYear mc >> Just (ctYear c) + , mctMonth = mctMonth mc >> Just (ctMonth c) + , mctDay = mctDay mc >> Just (ctDay c) + , mctHour = mctHour mc >> Just (ctHour c) + , mctMin = mctMin mc >> Just (ctMin c) + , mctSec = mctSec mc >> Just (ctSec c) + , mctPicosec = mctPicosec mc >> Just (ctPicosec c) + , mctWDay = mctWDay mc >> Just (ctWDay c) + , mctYDay = mctYDay mc >> Just (ctYDay c) + , mctTZName = mctTZName mc >> Just (ctTZName c) + , mctTZ = mctTZ mc >> Just (ctTZ c) + , mctIsDST = mctIsDST mc >> Just (ctIsDST c) + } + +-- | Zero the time fields of a 'CalendarTime' +unsetTime :: CalendarTime -> CalendarTime +unsetTime mc = mc + { ctHour = 0 + , ctMin = 0 + , ctSec = 0 + , ctPicosec = 0 + } diff --git a/src/Lcs.hs b/src/Lcs.hs new file mode 100644 --- /dev/null +++ b/src/Lcs.hs @@ -0,0 +1,478 @@ +-- Copyright (C) 2002 David Roundy +-- Copyright (C) 2005 Benedikt Schmidt +-- +-- 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. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +-- | LCS stands for Longest Common Subsequence, and it is a relatively +-- challenging problem to find an LCS efficiently. This module implements +-- the algorithm described in: +-- +-- "An O(ND) Difference Algorithm and its Variations", Eugene Myers, +-- Algorithmica Vol. 1 No. 2, 1986, pp. 251-266; +-- especially the variation described in section 4.2 and most refinements +-- implemented in GNU diff (D is the edit-distance). +-- +-- There is currently no heuristic to reduce the running time and produce +-- suboptimal output for large inputs with many differences. It behaves like +-- GNU diff with the -d option in this regard. +-- +-- In the first step, a hash value for every line is calculated and collisions +-- are marked with a special value. This reduces a string comparison to an +-- int comparison for line tuples where at least one of the hash values is +-- not equal to the special value. After that, lines which only exists in one +-- of the files are removed and marked as changed which reduces the running +-- time of the following difference algorithm. GNU diff additionally removes +-- lines that appear very often in the other file in some cases. +-- The last step tries to create longer changed regions and line up deletions +-- in the first file to insertions in the second by shifting changed lines +-- forward and backward. +module Lcs ( getChanges, aLen, + BArray, PArray, BSTArray, + shiftBoundaries ) where + +import Control.Monad +import Data.Int +import Control.Monad.ST +import Data.Maybe +import ByteStringUtils (hashPS) +import qualified Data.ByteString as B (empty, ByteString) +import Data.Array.Base +import Data.Array.Unboxed +import qualified Data.Map as Map ( lookup, empty, insertWith ) +#include "impossible.h" + +-- | create a list of changes between a and b, each change has the form +-- (starta, lima, startb, limb) which means that a[starta, lima) +-- has to be replaced by b[startb, limb) +getChanges :: [B.ByteString] -> [B.ByteString] + -> [(Int,[B.ByteString],[B.ByteString])] +getChanges a b = dropStart (initP a) (initP b) 1 + +dropStart :: PArray -> PArray -> Int + -> [(Int,[B.ByteString],[B.ByteString])] +dropStart a b off + | off > (aLen a) = [(off - 1, [], getSlice b off (aLen b))] + | off > (aLen b) = [(off - 1, getSlice a off (aLen a), [])] + | a!off == b!off = dropStart a b (off + 1) + | otherwise = dropEnd a b off 0 + +dropEnd :: PArray -> PArray -> Int -> Int + -> [(Int,[B.ByteString],[B.ByteString])] +dropEnd a b off end + | off > alast = [(off - 1, [], getSlice b off blast)] + | off > blast = [(off - 1, getSlice a off alast, [])] + | a!alast == b!blast = dropEnd a b off (end + 1) + | otherwise = getChanges' (a, (off, alast)) (b, (off, blast)) + where alast = aLen a - end + blast = aLen b - end + +getSlice :: PArray -> Int -> Int -> [B.ByteString] +getSlice a from to + | from > to = [] + | otherwise = (a!(from)):(getSlice a (from + 1) to) + +getChanges' :: (PArray, (Int, Int)) -> (PArray, (Int, Int)) + -> [(Int,[B.ByteString],[B.ByteString])] +getChanges' (a, abounds) (b, bbounds) = + map (convertPatch 0 a b) $ createPatch c_a c_b + where + -- If the last few characters of two lines are the same, the lines are + -- probably the same. The choice of 20 is plucked out of the air. + toHash x bnds = listArray bnds [ hashPS $ x!i | i <- range bnds] + ah = toHash a abounds :: HArray + mkAMap m (i:is) = + let ins (_,_,_,new) (collision,_,_,old) = + (collision || not (new == old), True, False, old) + m' = Map.insertWith ins (ah!i) (False, True, False, a!i) m + in mkAMap m' is + mkAMap m _ = m + hm_a = mkAMap Map.empty (range abounds) + -- + bh = toHash b bbounds :: HArray + mkBMap m (i:is) = + let ins (_,_,_,new) (collision,in_a,_,old) = + (collision || not (new == old), in_a, True, old) + m' = Map.insertWith ins (bh!i) (False, False, True, b!i) m + in mkBMap m' is + mkBMap m _ = m + hm = mkBMap hm_a (range bbounds) + -- take care of collisions, if there are different lines with the + -- same hash in both files, then set the hash to markColl, + -- PackedStrings are compared for two lines with the hash markColl + get (i, h) = case Map.lookup h hm of + Just (_,False,_,_) -> Nothing + Just (_,_,False,_) -> Nothing + Just (False,True,True,_) -> Just (i, h) + Just (True,True,True,_) -> Just (i, markColl) + Nothing -> impossible + + a' = catMaybes $ map get [(i, ah!i) | i <- range (bounds ah)] + b' = catMaybes $ map get [(i, bh!i) | i <- range (bounds bh)] + + (c_a, c_b) = diffArr a' b' (a, abounds) (b, bbounds) + +-- | mark hash value where collision occured +markColl :: Int32 +markColl = 2345677 + +-- | return arrays with changes in a and b (1 indexed), offsets start with 0 +diffArr :: [(Int,Int32)] -> [(Int,Int32)] + -> (PArray, (Int, Int)) -> (PArray, (Int, Int)) + -> (BArray, BArray) +diffArr a b (p_a, (off_a, l_a)) (p_b, (off_b, l_b)) = runST ( + do let h_a = initH (map snd a) + h_b = initH (map snd b) + m_a = initM (map fst a) + m_b = initM (map fst b) + end_a = (aLen p_a) + end_b = (aLen p_b) + c_a <- initVChanged end_a + c_b <- initVChanged end_b + mapM_ (\ (l,_) -> writeArray c_a l False) $ a + mapM_ (\ (l,_) -> writeArray c_b l False) $ b + _ <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b 0 0 (aLen h_a) (aLen h_b) + let unchanged ar = do {xs <- getElems ar; return $ (length $ filter not $ xs) -1} + err <- liftM2 (/=) (unchanged c_a) (unchanged c_b) + when (err) impossible + -- Mark common lines at beginning and end + mapM_ (\ i -> writeArray c_a i False ) $ [1..(off_a - 1)] + mapM_ (\ i -> writeArray c_b i False ) $ [1..(off_b - 1)] + mapM_ (\ i -> writeArray c_a i False ) $ [(l_a + 1) .. (end_a)] + mapM_ (\ i -> writeArray c_b i False ) $ [(l_b + 1) .. (end_b)] + shiftBoundaries c_a c_b p_a 1 1 + shiftBoundaries c_b c_a p_b 1 1 + err1 <- liftM2 (/=) (unchanged c_a) (unchanged c_b) + when (err1) impossible + c_a' <- unsafeFreeze c_a + c_b' <- unsafeFreeze c_b + return (c_a', c_b')) + +-- | set changes array for a and b and return number of changed lines +cmpseq :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray + -> BSTArray s -> BSTArray s -> Int -> Int -> Int -> Int -> ST s Int +cmpseq _ _ _ _ _ _ _ _ _ _ 0 0 = do return 0 +cmpseq h_a h_b p_a p_b m_a m_b c_a c_b off_a off_b l_a l_b = do + let lim_a = off_a+l_a + lim_b = off_b+l_b + off_a' = findSnake h_a h_b p_a p_b m_a m_b off_a off_b l_a l_b off_a off_b + off_b' = off_b+off_a'-off_a + lim_a' = findSnakeRev h_a h_b p_a p_b m_a m_b lim_a lim_b off_a' off_b' + lim_b' = lim_b+lim_a'-lim_a + l_a' = lim_a'-off_a' + l_b' = lim_b'-off_b' + if l_a' == 0 || l_b' == 0 + then if l_a' == 0 + then do when (l_b' > 0) $ + mapM_ (\i -> writeArray c_b (m_b!i) True) + [(off_b' + 1) .. lim_b'] + return l_b' + else do when (l_a' > 0) $ + mapM_ (\i -> writeArray c_a (m_a!i) True) + [(off_a' + 1) .. lim_a'] + return l_a' + else do let m = l_a' + l_b' + del = l_a' - l_b' + dodd = odd $ del + v <- initV m + vrev <- initVRev m l_a' + writeArray vrev 0 l_a' + writeArray v 0 0 + (xmid, ymid, _) <- findDiag 1 h_a h_b p_a p_b m_a m_b v vrev + off_a' off_b' l_a' l_b' del dodd + when ((xmid == 0 && ymid == 0) || (xmid == l_a' && ymid == l_b') + || (xmid < 0 || ymid < 0 || xmid > l_a' || ymid > l_b')) + impossible + c1 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b + off_a' off_b' xmid ymid + c2 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b + (off_a' + xmid) (off_b' + ymid) + (l_a' - xmid) (l_b' - ymid) + return $ c1 + c2 + +-- | return (xmid, ymid, cost) for the two substrings +-- a[off_a+1..off_a+1+l_a] and b +findDiag :: Int -> HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray + -> VSTArray s -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> Bool + -> ST s (Int, Int, Int) +findDiag c h_a h_b p_a p_b m_a m_b v vrev off_a off_b l_a l_b del dodd = do + if c > l_a + l_b then error "findDiag failed" else return () + r <- findF + case r of + Just (xmid, ymid) -> return (xmid, ymid, (c*2 - 1)) + Nothing -> + do r' <- findR + case r' of + Just (xmid, ymid) -> return (xmid, ymid, c*2) + Nothing -> findDiag (c + 1) h_a h_b p_a p_b m_a m_b v vrev + off_a off_b l_a l_b del dodd + where fdmax = if c <= l_a then c else l_a - ((l_a + c) `mod` 2) + rdmax = if c <= l_b then c else l_b - ((l_b + c) `mod` 2) + lastrdmax = if (c-1) <= l_b then c-1 else l_b-((l_b + (c-1) `mod` 2)) + lastrdmin = -(if (c-1) <= l_a then c-1 else l_a-((l_a + (c-1)) `mod` 2)) + fdmin = -rdmax + rdmin = -fdmax + findF = findF' fdmax + findR = findR' rdmax + findF' d = do x <- findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b + if dodd && d - del >= lastrdmin && d - del <= lastrdmax + then do xr <- readArray vrev (d - del) + if xr <= x then return $ Just (x, x - d) + else if d <= fdmin then return Nothing + else findF' (d-2) + else if d <= fdmin then return Nothing else findF' (d-2) + findR' d = do x <- findOneRev h_a h_b p_a p_b m_a m_b vrev d del off_a off_b + if not dodd && (d + del >= fdmin) && (d + del <= fdmax) + then do xf <- readArray v (d + del) + if x <= xf then return $ Just (x,x-del-d) + else if d <= rdmin then return Nothing + else findR' (d-2) + else if d <= rdmin then return Nothing else findR' (d-2) + +-- | find position on diag d with one more insert/delete going forward +findOne :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray + -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int +findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b = do + x0 <- do xbelow <- readArray v (d - 1) + xover <- readArray v (d + 1) + return $ if xover > xbelow then xover else xbelow + 1 + let y0 = x0 - d + x = findSnake h_a h_b p_a p_b m_a m_b (x0+off_a) (y0+off_b) + l_a l_b off_a off_b + writeArray v d (x - off_a) + return (x-off_a) + +-- | follow snake from northwest to southeast, x and y are absolute positions +findSnake :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray + -> Int -> Int -> Int -> Int -> Int -> Int -> Int +findSnake h_a h_b p_a p_b m_a m_b x y l_a l_b off_a off_b = + if x < l_a + off_a && y < l_b + off_b && h_a!(x+1) == h_b!(y+1) + && (h_a!(x+1) /= markColl || p_a!(m_a!(x+1)) == p_b!(m_b!(y+1))) + then findSnake h_a h_b p_a p_b m_a m_b (x + 1) (y + 1) l_a l_b off_a off_b + else x + +-- | find position on diag d with one more insert/delete going backward +findOneRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray + -> VSTArray s -> Int -> Int -> Int -> Int -> ST s Int +findOneRev h_a h_b p_a p_b m_a m_b v d del off_a off_b = do + x0 <- do xbelow <- readArray v (d - 1) + xover <- readArray v (d + 1) + return $ if xbelow < xover then xbelow else xover-1 + let y0 = x0 - del - d + x = findSnakeRev h_a h_b p_a p_b m_a m_b (x0+off_a) (y0+off_b) + off_a off_b + writeArray v d (x-off_a) + return (x-off_a) + +-- | follow snake from southeast to northwest, x and y are absolute positions +findSnakeRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray + -> Int -> Int -> Int -> Int -> Int +findSnakeRev h_a h_b p_a p_b m_a m_b x y off_a off_b = + if x > off_a && y > off_b && h_a!x == h_b!y + && (h_a!x /= markColl || p_a!(m_a!x) == p_b!(m_b!y)) + then findSnakeRev h_a h_b p_a p_b m_a m_b (x - 1) (y - 1) off_a off_b + else x + +-- | try to create nicer diffs by shifting around regions of changed lines +shiftBoundaries :: BSTArray s -> BSTArray s -> PArray -> Int -> Int -> ST s () +shiftBoundaries c_a c_b p_a i_ j_ = + do x <- nextChanged c_a i_ + case x of + Just start -> + do let skipped = start - i_ + j1 <- nextUnchangedN c_b skipped j_ + end <- nextUnchanged c_a start + j2 <- nextUnchanged c_b j1 + (i3,j3) <- expand start end j2 + shiftBoundaries c_a c_b p_a i3 j3 + Nothing -> return () -- no change up to end of file + where noline = (aLen p_a) + 1 + expand start i j = + do let len = i - start + (start0,i0,j0) <- shiftBackward start i j + b <- if j0 > 1 then readArray c_b (j0-1) else return False + let corr = if b then i0 else noline + let blank = if p_a!(i0-1) == B.empty then i0 + else noline + (start1,i1,j1,corr1,blank1) <- shiftForward start0 i0 j0 corr blank + -- prefer corresponding to ending with blank line + let newi = if corr1 == noline then blank1 + else corr1 + (start2,i2,j2) <- moveCorr start1 i1 j1 newi + if len /= i2 - start2 + then expand start2 i2 j2 + else return (i2, j2) + shiftBackward start i j = + if start > 1 && p_a!(i-1) == p_a!(start-1) + then do when (i == start) impossible + b1 <- readArray c_a (i-1) + b2 <- readArray c_a (start-1) + when ((not b1) || b2) impossible + writeArray c_a (i-1) False + writeArray c_a (start-1) True + b <- if start > 2 then readArray c_a (start-2) + else return False + start' <- if b then liftM (1+) (prevUnchanged c_a (start-2)) + else return (start-1) + j' <- prevUnchanged c_b (j-1) + shiftBackward start' (i-1) j' + else do return (start,i,j) + shiftForward start i j corr blank = + if i <= aLen p_a && p_a!i == p_a!start && + -- B.empty at the end of file marks empty line after final newline + not ((i == aLen p_a) && (p_a!i == B.empty)) + then do when (i == start) impossible + b1 <- readArray c_a i + b2 <- readArray c_a start + when ((not b2) || b1) impossible + writeArray c_a i True + writeArray c_a start False + i0 <- nextUnchanged c_a (i+1) + j0 <- nextUnchanged c_b (j+1) + let corr0 = if i0 > (i+1) then noline + else if j0-j > 2 then i0 else corr + let blank0 = if i0 > i+1 then noline + else if p_a!(i0-1) == B.empty then i0 + else blank + shiftForward (start+1) i0 j0 corr0 blank0 + else do return (start,i,j,corr,blank) + moveCorr start i j corr = + if corr >= i + then return (start,i,j) + else do b1 <- readArray c_a (i-1) + b2 <- readArray c_a (start-1) + when ((not b1) || b2) impossible + when (p_a!(i-1) /= p_a!(start-1)) impossible + writeArray c_a (i-1) False + writeArray c_a (start-1) True + j' <- prevUnchanged c_b (j-1) + moveCorr (start-1) (i-1) j' corr + +-- | goto next unchanged line, return the given line if unchanged +nextUnchanged :: BSTArray s -> Int -> ST s Int +nextUnchanged c i = do + len <- aLenM c + if i == len + 1 then return i + else do b <- readArray c i + if b then nextUnchanged c (i+1) + else return i + +-- | skip at least one unchanged line, if there is none advance +-- behind the last line +skipOneUnChanged :: BSTArray s -> Int -> ST s Int +skipOneUnChanged c i = do + len <- aLenM c + if i == len + 1 + then return i + else do b <- readArray c i + if not b then return (i+1) + else skipOneUnChanged c (i+1) + +-- | goto n-th next unchanged line +nextUnchangedN :: BSTArray s -> Int -> Int -> ST s Int +nextUnchangedN c n i = do + if n == 0 then return i + else do i' <- skipOneUnChanged c i + nextUnchangedN c (n-1) i' + +-- | goto next changed line, return the given line if changed +nextChanged :: BSTArray s -> Int -> ST s (Maybe Int) +nextChanged c i = do + len <- aLenM c + if i <= len + then do b <- readArray c i + if not b then nextChanged c (i+1) + else return $ Just i + else return Nothing + +-- | goto previous unchanged line, return the given line if unchanged +prevUnchanged :: BSTArray s -> Int -> ST s Int +prevUnchanged c i = do + b <- readArray c i + if b then prevUnchanged c (i-1) + else return i + +type HArray = UArray Int Int32 +type BArray = UArray Int Bool +type PArray = Array Int B.ByteString +type MapArray = UArray Int Int +type VSTArray s = STUArray s Int Int +type BSTArray s = STUArray s Int Bool + +initV :: Int -> ST s (VSTArray s) +initV dmax = do + newArray (-(dmax + 1), dmax + 1) (-1) + +initVRev :: Int -> Int -> ST s (VSTArray s) +initVRev dmax xmax = do + newArray (-(dmax + 1), dmax + 1) (xmax + 1) + +-- 1 indexed, v[0] is used as a guard element +initVChanged :: Int -> ST s (BSTArray s) +initVChanged l = do + a <- newArray (0, l) True + writeArray a 0 False + return a + -- set to false for all lines which have a mapping later + -- other lines are only present in one of the files + +initH :: [Int32] -> HArray +initH a = listArray (0, length a) (0:a) + +initM :: [Int] -> MapArray +initM a = listArray (0, length a) (0:a) + +initP :: [B.ByteString] -> PArray +initP a = listArray (0, length a) (B.empty:a) + +aLen :: (IArray a e) => a Int e -> Int +aLen a = snd $ bounds a +aLenM :: (MArray a e m) => a Int e -> m Int +aLenM a = getBounds a >>= return . snd + +convertPatch :: Int -> PArray -> PArray -> (Int, Int, Int, Int) + -> (Int,[B.ByteString],[B.ByteString]) +convertPatch off a b (a0,a1,b0,b1) + | b0 == b1 = (b0+off,getDelete a a0 a1,[]) + | a0 == a1 = (b0+off,[],getInsert b b0 b1) + | otherwise = (b0+off,getDelete a a0 a1,getInsert b b0 b1) + +getInsert :: PArray -> Int -> Int -> [B.ByteString] +getInsert b from to + | from >= to = [] + | otherwise = (b!(from+1)):(getInsert b (from+1) to) +getDelete :: PArray -> Int -> Int -> [B.ByteString] +getDelete a from to + | from >= to = [] + | otherwise = (a!(from+1)):(getDelete a (from+1) to) + +createPatch :: BArray -> BArray -> [(Int, Int, Int, Int)] +createPatch c_a c_b = + reverse $ createP c_a c_b (aLen c_a) (aLen c_b) + +createP :: BArray -> BArray -> Int -> Int -> [(Int, Int, Int, Int)] +createP _ _ 0 0 = [] +createP c_a c_b ia ib = + if c_a!ia || c_b!ib + then let ia' = skipChangedRev c_a ia + ib' = skipChangedRev c_b ib + in (ia',ia,ib',ib):(createP c_a c_b ia' ib') + else createP c_a c_b (ia-1) (ib-1) + +skipChangedRev :: BArray -> Int -> Int +skipChangedRev c i = if i >= 0 && c!i then skipChangedRev c (i-1) else i diff --git a/src/OldDate.hs b/src/OldDate.hs new file mode 100644 --- /dev/null +++ b/src/OldDate.hs @@ -0,0 +1,350 @@ +-- Copyright (C) 2003 Peter Simons +-- Copyright (C) 2003,2008 David Roundy +-- +-- 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. + +-- This module is intended to provide backwards-compatibility in the parsing +-- of darcs patches. In other words: don't change it, new features don't get +-- added here. The only user should be Darcs.Patch.Info. + +module OldDate ( readUTCDate, showIsoDateTime ) where + +import Text.ParserCombinators.Parsec +import System.Time +import Data.Char ( toUpper, isDigit ) +import Control.Monad ( liftM, liftM2 ) +import qualified Data.ByteString.Char8 as B +import Data.Maybe ( fromMaybe ) + +-- | Read/interpret a date string, assuming UTC if timezone +-- is not specified in the string +readUTCDate :: String -> CalendarTime +readUTCDate = readDate 0 + +readDate :: Int -> String -> CalendarTime +readDate tz d = + case parseDate tz d of + Left e -> error e + Right ct -> ct + +parseDate :: Int -> String -> Either String CalendarTime +parseDate tz d = + if length d >= 14 && B.all isDigit bd + then Right $ + CalendarTime (readI $ B.take 4 bd) + (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd) + (readI $ B.take 2 $ B.drop 6 bd) -- Day + (readI $ B.take 2 $ B.drop 8 bd) -- Hour + (readI $ B.take 2 $ B.drop 10 bd) -- Minute + (readI $ B.take 2 $ B.drop 12 bd) -- Second + 0 Sunday 0 -- Picosecond, weekday and day of year unknown + "GMT" 0 False + else let dt = do { x <- date_time tz; eof; return x } + in case parse dt "" d of + Left e -> Left $ "bad date: "++d++" - "++show e + Right ct -> Right ct + where bd = B.pack (take 14 d) + readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s) + +showIsoDateTime :: CalendarTime -> String +showIsoDateTime ct = concat [ show $ ctYear ct + , twoDigit . show . (+1) . fromEnum $ ctMonth ct + , twoDigit . show $ ctDay ct + , twoDigit . show $ ctHour ct + , twoDigit . show $ ctMin ct + , twoDigit . show $ ctSec ct + ] + where twoDigit [] = undefined + twoDigit x@(_:[]) = '0' : x + twoDigit x@(_:_:[]) = x + twoDigit _ = undefined + +----- Parser Combinators --------------------------------------------- + +-- |Case-insensitive variant of Parsec's 'char' function. + +caseChar :: Char -> GenParser Char a Char +caseChar c = satisfy (\x -> toUpper x == toUpper c) + +-- |Case-insensitive variant of Parsec's 'string' function. + +caseString :: String -> GenParser Char a () +caseString cs = mapM_ caseChar cs cs + +-- |Match a parser at least @n@ times. + +manyN :: Int -> GenParser a b c -> GenParser a b [c] +manyN n p + | n <= 0 = return [] + | otherwise = liftM2 (++) (count n p) (many p) + +-- |Match a parser at least @n@ times, but no more than @m@ times. + +manyNtoM :: Int -> Int -> GenParser a b c -> GenParser a b [c] +manyNtoM n m p + | n < 0 = return [] + | n > m = return [] + | n == m = count n p + | n == 0 = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m])) + | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p) + + +----- Date/Time Parser ----------------------------------------------- + +date_time :: Int -> CharParser a CalendarTime +date_time tz = + choice [try $ cvs_date_time tz, + try $ iso8601_date_time tz, + old_date_time] + +cvs_date_time :: Int -> CharParser a CalendarTime +cvs_date_time tz = + do y <- year + char '/' + mon <- month_num + char '/' + d <- day + my_spaces + h <- hour + char ':' + m <- minute + char ':' + s <- second + z <- option tz $ my_spaces >> zone + return (CalendarTime y mon d h m s 0 Monday 0 "" z False) + +old_date_time :: CharParser a CalendarTime +old_date_time = do wd <- day_name + my_spaces + mon <- month_name + my_spaces + d <- day + my_spaces + h <- hour + char ':' + m <- minute + char ':' + s <- second + my_spaces + z <- zone + my_spaces + y <- year + return (CalendarTime y mon d h m s 0 wd 0 "" z False) + +{- FIXME: In case you ever want to use this outside of darcs, you should note + that this implementation of ISO 8601 is not complete. + + reluctant to implement (ambiguous!): + * years > 9999 + * truncated representations with implied century (89 for 1989) + unimplemented: + * repeated durations (not relevant) + * lowest order component fractions in intervals + * negative dates (BC) + unverified or too relaxed: + * the difference between 24h and 0h + * allows stuff like 2005-1212; either you use the hyphen all the way + (2005-12-12) or you don't use it at all (20051212), but you don't use + it halfway, likewise with time + * No bounds checking whatsoever on intervals! + (next action: read iso doc to see if bounds-checking required?) -} +iso8601_date_time :: Int -> CharParser a CalendarTime +iso8601_date_time localTz = try $ + do d <- iso8601_date + t <- option id $ try $ do optional $ oneOf " T" + iso8601_time + return $ t $ d { ctTZ = localTz } + +iso8601_date :: CharParser a CalendarTime +iso8601_date = + do d <- calendar_date <|> week_date <|> ordinal_date + return $ foldr ($) nullCalendar d + where + calendar_date = -- yyyy-mm-dd + try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ] + -- allow other variants to be parsed correctly + notFollowedBy (digit <|> char 'W') + return d + week_date = --yyyy-Www-dd + try $ do yfn <- year_ + optional dash + char 'W' + -- offset human 'week 1' -> computer 'week 0' + w' <- (\x -> x-1) `liftM` two_digits + wd <- option 1 $ do { optional dash; n_digits 1 } + let y = yfn nullCalendar + firstDay = ctWDay y + -- things that make this complicated + -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday + -- 2. the first week is the one that contains at least Thursday + -- if the year starts after Thursday, then some days of the year + -- will have already passed before the first week + let afterThursday = firstDay == Sunday || firstDay > Thursday + w = if afterThursday then w'+1 else w' + diff c = c { ctDay = (7 * w) + wd - (fromEnum firstDay) } + return [(toUTCTime.toClockTime.diff.yfn)] + ordinal_date = -- yyyy-ddd + try $ optchain year_ [ (dash, yearDay_) ] + -- + year_ = try $ do y <- four_digits "year (0000-9999)" + return $ \c -> c { ctYear = y } + month_ = try $ do m <- two_digits "month (1 to 12)" + -- we (artificially) use ctPicosec to indicate + -- whether the month has been specified. + return $ \c -> c { ctMonth = intToMonth m, ctPicosec = 0 } + day_ = try $ do d <- two_digits "day in month (1 to 31)" + return $ \c -> c { ctDay = d } + yearDay_ = try $ do d <- n_digits 3 "day in year (1 to 366)" + return $ \c -> c { ctYDay = d } + dash = char '-' + +-- we return a function which sets the time on another calendar +iso8601_time :: CharParser a (CalendarTime -> CalendarTime) +iso8601_time = try $ + do ts <- optchain hour_ [ (colon , min_) + , (colon , sec_) + , (oneOf ",.", pico_) ] + z <- option id $ choice [ zulu , offset ] + return $ foldr (.) id (z:ts) + where + hour_ = do h <- two_digits + return $ \c -> c { ctHour = h } + min_ = do m <- two_digits + return $ \c -> c { ctMin = m } + sec_ = do s <- two_digits + return $ \c -> c { ctSec = s } + pico_ = do digs <- many digit + let picoExp = 12 + digsExp = length digs + let frac | null digs = 0 + | digsExp > picoExp = read $ take picoExp digs + | otherwise = 10 ^ (picoExp - digsExp) * (read digs) + return $ \c -> c { ctPicosec = frac } + zulu = do { char 'Z'; return (\c -> c { ctTZ = 0 }) } + offset = do sign <- choice [ do { char '+' >> return 1 } + , do { char '-' >> return (-1) } ] + h <- two_digits + m <- option 0 $ do { optional colon; two_digits } + return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) } + colon = char ':' + +optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b] +optchain p next = try $ + do r1 <- p + r2 <- case next of + [] -> return [] + ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 } + return (r1:r2) + +n_digits :: Int -> CharParser a Int +n_digits n = read `liftM` count n digit + +two_digits, four_digits :: CharParser a Int +two_digits = n_digits 2 +four_digits = n_digits 4 + +my_spaces :: CharParser a String +my_spaces = manyN 1 $ char ' ' + +day_name :: CharParser a Day +day_name = choice + [ caseString "Mon" >> return Monday + , try (caseString "Tue") >> return Tuesday + , caseString "Wed" >> return Wednesday + , caseString "Thu" >> return Thursday + , caseString "Fri" >> return Friday + , try (caseString "Sat") >> return Saturday + , caseString "Sun" >> return Sunday + ] + +year :: CharParser a Int +year = four_digits + +month_num :: CharParser a Month +month_num = do mn <- manyNtoM 1 2 digit + return $ intToMonth $ (read mn :: Int) + +intToMonth :: Int -> Month +intToMonth 1 = January +intToMonth 2 = February +intToMonth 3 = March +intToMonth 4 = April +intToMonth 5 = May +intToMonth 6 = June +intToMonth 7 = July +intToMonth 8 = August +intToMonth 9 = September +intToMonth 10 = October +intToMonth 11 = November +intToMonth 12 = December +intToMonth _ = error "invalid month!" + +month_name :: CharParser a Month +month_name = choice + [ try (caseString "Jan") >> return January + , caseString "Feb" >> return February + , try (caseString "Mar") >> return March + , try (caseString "Apr") >> return April + , caseString "May" >> return May + , try (caseString "Jun") >> return June + , caseString "Jul" >> return July + , caseString "Aug" >> return August + , caseString "Sep" >> return September + , caseString "Oct" >> return October + , caseString "Nov" >> return November + , caseString "Dec" >> return December + ] + +day :: CharParser a Int +day = do d <- manyNtoM 1 2 digit + return (read d :: Int) + +hour :: CharParser a Int +hour = two_digits + +minute :: CharParser a Int +minute = two_digits + +second :: CharParser a Int +second = two_digits + +zone :: CharParser a Int +zone = choice + [ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) } + , do { char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) } + , mkZone "UTC" 0 + , mkZone "UT" 0 + , mkZone "GMT" 0 + , mkZone "EST" (-5) + , mkZone "EDT" (-4) + , mkZone "CST" (-6) + , mkZone "CDT" (-5) + , mkZone "MST" (-7) + , mkZone "MDT" (-6) + , mkZone "PST" (-8) + , mkZone "PDT" (-7) + , mkZone "CEST" 2 + , mkZone "EEST" 3 + -- if we don't understand it, just give a GMT answer... + , do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' ']) + (lookAhead space_digit); + return 0 } + ] + where mkZone n o = try $ do { caseString n; return (o*60*60) } + space_digit = try $ do { char ' '; oneOf ['0'..'9'] } + +nullCalendar :: CalendarTime +nullCalendar = CalendarTime 0 January 0 0 0 0 1 Sunday 0 "" 0 False diff --git a/src/Printer.lhs b/src/Printer.lhs new file mode 100644 --- /dev/null +++ b/src/Printer.lhs @@ -0,0 +1,425 @@ + +A Document is at heart ShowS from the prelude +\htmladdnormallink{http://www.haskell.org/onlinereport/standard-prelude.html#\$tShowS} + +Essentially, if you give a Doc a string it'll print out whatever it +wants followed by that string. So \verb!(text "foo")! makes the Doc that +prints \verb!"foo"! followed by its argument. The combinator names are taken +from Text.PrettyPrint.HughesPJ, although the behaviour of the two libraries is +slightly different. + +The advantage of Printer over simple string appending/concatenating is +that the appends end up associating to the right, e.g.: + +\begin{verbatim} + (text "foo" <> text "bar") <> (text "baz" <> text "quux") "" += \s -> (text "foo" <> text "bar") ((text "baz" <> text "quux") s) "" += (text "foo" <> text "bar") ((text "baz" <> text "quux") "") += (\s -> (text "foo") (text "bar" s)) ((text "baz" <> text "quux") "") += text "foo" (text "bar" ((text "baz" <> text "quux") "")) += (\s -> "foo" ++ s) (text "bar" ((text "baz" <> text "quux") "")) += "foo" ++ (text "bar" ((text "baz" <> text "quux") "")) += "foo" ++ ("bar" ++ ((text "baz" <> text "quux") "")) += "foo" ++ ("bar" ++ ((\s -> text "baz" (text "quux" s)) "")) += "foo" ++ ("bar" ++ (text "baz" (text "quux" ""))) += "foo" ++ ("bar" ++ ("baz" ++ (text "quux" ""))) += "foo" ++ ("bar" ++ ("baz" ++ ("quux" ++ ""))) +\end{verbatim} + +The Empty alternative comes in because you want +\begin{verbatim} + text "a" $$ vcat xs $$ text "b" +\end{verbatim} +(\verb!$$! means ``above'', vcat is the list version of \verb!$$!) to be +\verb!"a\nb"! when \verb!xs! is \verb![]!, but without the concept of an +Empty Document each \verb!$$! would add a \verb!'\n'! and you'd end up with +\verb!"a\n\nb"!. Note that \verb!Empty /= text ""! (the latter would cause two +\verb!'\n'!s). + +This code was made generic in the element type by Juliusz Chroboczek. +\begin{code} +module Printer (Printable(..), Doc(Doc,unDoc), Printers, Printers'(..), Printer, Color(..), + hPutDoc, hPutDocLn, putDoc, putDocLn, + hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith, + renderString, renderStringWith, renderPS, renderPSWith, + renderPSs, renderPSsWith, lineColor, + prefix, insert_before_lastline, colorText, invisibleText, + hiddenText, hiddenPrefix, userchunk, text, + printable, wrap_text, + blueText, redText, greenText, magentaText, cyanText, + unsafeText, unsafeBoth, unsafeBothText, unsafeChar, + invisiblePS, packedString, unsafePackedString, userchunkPS, + simplePrinters, invisiblePrinter, simplePrinter, + doc, empty, (<>), (), (<+>), ($$), vcat, vsep, hcat, + minus, newline, plus, space, backslash, lparen, rparen, + parens, + errorDoc, + ) where + +import Data.List (intersperse) +import System.IO (Handle, stdout, hPutStr) +import ByteStringUtils ( linesPS ) +import qualified Data.ByteString as B (ByteString, hPut, concat) +import qualified Data.ByteString.Char8 as BC (unpack, pack, singleton) + +-- | A 'Printable' is either a String, a packed string, or a chunk of +-- text with both representations. +data Printable = S !String + | PS !B.ByteString + | Both !String !B.ByteString + +-- | 'space_p' is the 'Printable' representation of a space. +space_p :: Printable +space_p = Both " " (BC.singleton ' ') + +-- | 'newline_p' is the 'Printable' representation of a newline. +newline_p :: Printable +newline_p = S "\n" + +-- | Minimal 'Doc's representing the common characters 'space', 'newline' +-- 'minus', 'plus', and 'backslash'. +space, newline, plus, minus, backslash :: Doc +space = unsafeBoth " " (BC.singleton ' ') +newline = unsafeChar '\n' +minus = unsafeBoth "-" (BC.singleton '-') +plus = unsafeBoth "+" (BC.singleton '+') +backslash = unsafeBoth "\\" (BC.singleton '\\') + +-- | 'lparen' is the 'Doc' that represents @\"(\"@ +lparen :: Doc +lparen = unsafeBoth "(" (BC.singleton '(') + +-- | 'rparen' is the 'Doc' that represents @\")\"@ +rparen :: Doc +rparen = unsafeBoth ")" (BC.singleton ')') + +-- | @'parens' doc@ returns a 'Doc' with the content of @doc@ put within +-- a pair of parenthesis. +parens :: Doc -> Doc +parens d = lparen <> d <> rparen + +errorDoc :: Doc -> a +errorDoc = error . renderStringWith simplePrinters' + + +-- | 'putDocWith' puts a doc on stdout using the given printer. +putDocWith :: Printers -> Doc -> IO () +putDocWith prs = hPutDocWith prs stdout + +-- | 'putDocLnWith' puts a doc, followed by a newline on stdout using +-- the given printer. +putDocLnWith :: Printers -> Doc -> IO () +putDocLnWith prs = hPutDocLnWith prs stdout + + +-- | 'putDoc' puts a doc on stdout using the simple printer 'simplePrinters'. +putDoc :: Doc -> IO () +-- | 'putDocLn' puts a doc, followed by a newline on stdout using +-- 'simplePrinters' +putDocLn :: Doc -> IO () +putDoc = hPutDoc stdout +putDocLn = hPutDocLn stdout + +-- | 'hputDocWith' puts a doc on the given handle using the given printer. +hPutDocWith :: Printers -> Handle -> Doc -> IO () +-- | 'hputDocLnWith' puts a doc, followed by a newline on the given +-- handle using the given printer. +hPutDocLnWith :: Printers -> Handle -> Doc -> IO () + +hPutDocWith prs h d = hPrintPrintables h (renderWith (prs h) d) +hPutDocLnWith prs h d = hPutDocWith prs h (d newline) + +-- |'hputDoc' puts a doc on the given handle using 'simplePrinters' +hPutDoc :: Handle -> Doc -> IO () +-- 'hputDocLn' puts a doc, followed by a newline on the given handle using +-- 'simplePrinters'. +hPutDocLn :: Handle -> Doc -> IO () +hPutDoc = hPutDocWith simplePrinters +hPutDocLn = hPutDocLnWith simplePrinters + +-- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle h +hPrintPrintables :: Handle -> [Printable] -> IO () +hPrintPrintables h = mapM_ (hPrintPrintable h) + +-- | @hPrintPrintable h@ prints a 'Printable' to the handle h. +hPrintPrintable :: Handle -> Printable -> IO () +hPrintPrintable h (S ps) = hPutStr h ps +hPrintPrintable h (PS ps) = B.hPut h ps +hPrintPrintable h (Both _ ps) = B.hPut h ps + +-- | a 'Doc' is a bit of enriched text. 'Doc's get concatanated using +-- '<>', which is right-associative. +newtype Doc = Doc { unDoc :: St -> Document } + +-- | The State associated with a doc. Contains a set of printers for each +-- hanlde, and the current prefix of the document. +data St = St { printers :: !Printers', + current_prefix :: !([Printable] -> [Printable]) } +type Printers = Handle -> Printers' + +-- | A set of printers to print different types of text to a handle. +data Printers' = Printers {colorP :: !(Color -> Printer), + invisibleP :: !Printer, + hiddenP :: !Printer, + userchunkP :: !Printer, + defP :: !Printer, + lineColorT :: !(Color -> Doc -> Doc), + lineColorS :: !([Printable] -> [Printable]) + } +type Printer = Printable -> St -> Document + +data Color = Blue | Red | Green | Cyan | Magenta + +-- | 'Document' is a wrapper around '[Printable] -> [Printable]' which allows +-- for empty Documents. The simplest 'Documents' are built from 'String's +-- using 'text'. +data Document = Document ([Printable] -> [Printable]) + | Empty + +-- | renders a 'Doc' into a 'String' with control codes for the +-- special features of the doc. +renderString :: Doc -> String +renderString = renderStringWith simplePrinters' + +-- | renders a 'Doc' into a 'String' using a given set of printers. +renderStringWith :: Printers' -> Doc -> String +renderStringWith prs d = concatMap toString $ renderWith prs d + where toString (S s) = s + toString (PS ps) = BC.unpack ps + toString (Both s _) = s + +-- | renders a 'Doc' into 'B.ByteString' with control codes for the +-- special features of the Doc. See also 'readerString'. +renderPS :: Doc -> B.ByteString +renderPS = renderPSWith simplePrinters' + +-- | renders a 'Doc' into a list of 'PackedStrings', one for each line. +renderPSs :: Doc -> [B.ByteString] +renderPSs = renderPSsWith simplePrinters' + +-- | renders a doc into a 'B.ByteString' using a given set of printers. +renderPSWith :: Printers' -> Doc -> B.ByteString +renderPSWith prs d = B.concat $ renderPSsWith prs d + +-- | renders a 'Doc' into a list of 'PackedStrings', one for each +-- chunk of text that was added to the doc, using the given set of +-- printers. +renderPSsWith :: Printers' -> Doc -> [B.ByteString] +renderPSsWith prs d = map toPS $ renderWith prs d + where toPS (S s) = BC.pack s + toPS (PS ps) = ps + toPS (Both _ ps) = ps + +-- | renders a 'Doc' into a list of 'Printables' using a set of +-- printers. Each item of the list corresponds to a string that was +-- added to the doc. +renderWith :: Printers' -> Doc -> [Printable] +renderWith ps (Doc d) = case d (init_state ps) of + Empty -> [] + Document f -> f [] + +init_state :: Printers' -> St +init_state prs = St { printers = prs, current_prefix = id } + +prefix :: String -> Doc -> Doc +prefix s (Doc d) = Doc $ \st -> + let p = S s + st' = st { current_prefix = current_prefix st . (p:) } in + case d st' of + Document d'' -> Document $ (p:) . d'' + Empty -> Empty + + +insert_before_lastline :: Doc -> Doc -> Doc +insert_before_lastline a b = + case reverse $ map packedString $ linesPS $ renderPS a of + (ll:ls) -> vcat (reverse ls) $$ b $$ ll + [] -> error "empty Doc given as first argument of Printer.insert_before_last_line" + + +lineColor :: Color -> Doc -> Doc +lineColor c d = Doc $ \st -> case lineColorT (printers st) c d of + Doc d' -> d' st + +hiddenPrefix :: String -> Doc -> Doc +hiddenPrefix s (Doc d) = + Doc $ \st -> let pr = printers st + p = S (renderStringWith pr $ hiddenText s) + st' = st { current_prefix = current_prefix st . (p:) } + in case d st' of + Document d'' -> Document $ (p:) . d'' + Empty -> Empty + +-- | 'unsafeBoth' builds a Doc from a 'String' and a 'B.ByteString' representing +-- the same text, but does not check that they do. +unsafeBoth :: String -> B.ByteString -> Doc +unsafeBoth s ps = Doc $ simplePrinter (Both s ps) + +-- | 'unsafeBothText' builds a 'Doc' from a 'String'. The string is stored in the +-- Doc as both a String and a 'B.ByteString'. +unsafeBothText :: String -> Doc +unsafeBothText s = Doc $ simplePrinter (Both s (BC.pack s)) + +-- | 'packedString' builds a 'Doc' from a 'B.ByteString' using 'printable' +packedString :: B.ByteString -> Doc +-- | 'unsafePackedString' builds a 'Doc' from a 'B.ByteString' using 'simplePrinter' +unsafePackedString :: B.ByteString -> Doc +-- | 'invisiblePS' creates a 'Doc' with invisible text from a 'B.ByteString' +invisiblePS :: B.ByteString -> Doc +-- | 'userchunkPS' creates a 'Doc' representing a user chunk from a 'B.ByteString'. +userchunkPS :: B.ByteString -> Doc +packedString = printable . PS +unsafePackedString = Doc . simplePrinter . PS +invisiblePS = invisiblePrintable . PS +userchunkPS = userchunkPrintable . PS + +-- | 'unsafeChar' creates a Doc containing just one character. +unsafeChar :: Char -> Doc +unsafeChar = unsafeText . (:"") + +-- | 'text' creates a 'Doc' from a @String@, using 'printable'. +text :: String -> Doc +-- | 'unsafeText' creates a 'Doc' from a 'String', using 'simplePrinter' directly +unsafeText :: String -> Doc +-- | 'invisibleText' creates a 'Doc' containing invisible text from a @String@ +invisibleText :: String -> Doc +-- | 'hiddenText' creates a 'Doc' containing hidden text from a @String@ +hiddenText :: String -> Doc +-- | 'userchunk' creates a 'Doc' containing a user chunk from a @String@ +userchunk :: String -> Doc +-- | 'blueText' creates a 'Doc' containing blue text from a @String@ +blueText, redText, greenText, magentaText, cyanText :: String -> Doc +text = printable . S +unsafeText = Doc . simplePrinter . S +invisibleText = invisiblePrintable . S +hiddenText = hiddenPrintable . S +userchunk = userchunkPrintable . S +blueText = colorText Blue +redText = colorText Red +greenText = colorText Green +magentaText = colorText Magenta +cyanText = colorText Cyan + +-- | 'colorText' creates a 'Doc' containing colored text from a @String@ +colorText :: Color -> String -> Doc +colorText c = mkColorPrintable c . S + +-- | @'wrap_text' n s@ is a 'Doc' representing @s@ line-wrapped at 'n' characters +wrap_text :: Int -> String -> Doc +wrap_text n s = + vcat $ map text $ reverse $ "": (foldl add_to_line [] $ words s) + where add_to_line [] a = [a] + add_to_line ("":d) a = (a:d) + add_to_line (l:ls) new | length l + length new > n = new:l:ls + add_to_line (l:ls) new = (l ++ " " ++ new):ls + +-- | 'printable x' creates a 'Doc' from any 'Printable'. +printable, invisiblePrintable, hiddenPrintable, userchunkPrintable :: Printable -> Doc +printable x = Doc $ \st -> defP (printers st) x st + +mkColorPrintable :: Color -> Printable -> Doc +mkColorPrintable c x = Doc $ \st -> colorP (printers st) c x st +invisiblePrintable x = Doc $ \st -> invisibleP (printers st) x st +hiddenPrintable x = Doc $ \st -> hiddenP (printers st) x st +userchunkPrintable x = Doc $ \st -> userchunkP (printers st) x st + +-- | 'simplePrinters' is a 'Printers' which uses the set 'simplePriners\'' on any +-- handle. +simplePrinters :: Printers +simplePrinters _ = simplePrinters' + +-- | A set of default printers suitable for any handle. Does not use color. +simplePrinters' :: Printers' +simplePrinters' = Printers { colorP = const simplePrinter, + invisibleP = simplePrinter, + hiddenP = invisiblePrinter, + userchunkP = simplePrinter, + defP = simplePrinter, + lineColorT = const id, + lineColorS = id + } + +-- | 'simplePrinter' is the simplest 'Printer': it just concatenates together +-- the pieces of the 'Doc' +simplePrinter :: Printer +-- | 'invisiblePrinter' is the 'Printer' for hidden text. It just replaces +-- the document with 'empty'. It's useful to have a printer that doesn't +-- actually do anything because this allows you to have tunable policies, +-- for example, only printing some text if it's to the terminal, but not +-- if it's to a file or vice-versa. +invisiblePrinter :: Printer +simplePrinter x = unDoc $ doc (\s -> x:s) +invisiblePrinter _ = unDoc empty + +infixr 6 <> +infixr 6 <+> +infixr 5 $$ + +-- | The empty 'Doc'. +empty :: Doc +empty = Doc $ const Empty +doc :: ([Printable] -> [Printable]) -> Doc +doc f = Doc $ const $ Document f + +-- | '(<>)' is the concatenation operator for 'Doc's +(<>) :: Doc -> Doc -> Doc +-- | @a '' b@ is @a@ if it is not empty, else @b@. +() :: Doc -> Doc -> Doc +-- | @a '<+>' b@ is @a@ followed by a space, then @b@. +(<+>) :: Doc -> Doc -> Doc +-- | @a '$$' b@ is @a@ above @b@. +($$) :: Doc -> Doc -> Doc +-- a then b +Doc a <> Doc b = + Doc $ \st -> case a st of + Empty -> b st + Document af -> + Document (\s -> af $ case b st of + Empty -> s + Document bf -> bf s) + +-- empty if a empty, else a then b +Doc a Doc b = + Doc $ \st -> case a st of + Empty -> Empty + Document af -> Document (\s -> af $ case b st of + Empty -> s + Document bf -> bf s) + +-- a then space then b +Doc a <+> Doc b = + Doc $ \st -> case a st of + Empty -> b st + Document af -> Document (\s -> af $ case b st of + Empty -> s + Document bf -> + space_p:bf s) + +-- a above b +Doc a $$ Doc b = + Doc $ \st -> case a st of + Empty -> b st + Document af -> + Document (\s -> af $ case b st of + Empty -> s + Document bf -> sf (newline_p:pf (bf s))) + where pf = current_prefix st + sf = lineColorS $ printers st + +-- | 'vcat' piles vertically a list of 'Doc's. +vcat :: [Doc] -> Doc +vcat [] = empty +vcat ds = foldr1 ($$) ds + +-- | 'vsep' piles vertically a list of 'Doc's leaving a blank line between each. +vsep :: [Doc] -> Doc +vsep [] = empty +vsep ds = foldr1 ($$) $ intersperse (text "") ds + +-- | 'hcat' concatenates (horizontally) a list of 'Doc's +hcat :: [Doc] -> Doc +hcat [] = empty +hcat ds = foldr1 (<>) ds + +\end{code} + diff --git a/src/Progress.hs b/src/Progress.hs new file mode 100644 --- /dev/null +++ b/src/Progress.hs @@ -0,0 +1,202 @@ +-- Various utility functions that do not belong anywhere else. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +#include "gadts.h" + +module Progress ( beginTedious, endTedious, tediousSize, + debugMessage, debugFail, withoutProgress, + progress, progressKeepLatest, finishedOne, + finishedOneIO, progressList, minlist, + setProgressMode) where + +import Prelude hiding (lookup, catch) + +import Control.Exception ( catch, throw ) +import Control.Monad ( when ) +import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn, + hSetBuffering, hIsTerminalDevice, + Handle, BufferMode(LineBuffering) ) +import System.IO.Unsafe ( unsafePerformIO ) +import Data.Char ( toLower ) +import Data.Map ( Map, empty, adjust, insert, delete, lookup ) +import Data.Maybe ( isJust ) +import Control.Concurrent ( forkIO, threadDelay ) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef ) + +import Darcs.Global ( withDebugMode, debugMessage, putTiming, debugFail ) + +handleProgress :: IO () +handleProgress = do threadDelay 1000000 + handleMoreProgress "" 0 + +handleMoreProgress :: String -> Int -> IO () +handleMoreProgress k n = withProgressMode $ \m -> + if m then do s <- getProgressLast + mp <- getProgressData s + case mp of + Nothing -> do threadDelay 1000000 + handleMoreProgress k n + Just p -> do when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p + threadDelay 1000000 + handleMoreProgress s (sofar p) + else do threadDelay 1000000 + handleMoreProgress k n + +printProgress :: String -> ProgressData -> IO () +printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) = + myput (k++" "++show s++"/"++show t++" : "++l) (k++" "++show s++"/"++show t) +printProgress k (ProgressData {latest=Just l}) = + myput (k++" "++l) k +printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s = + myput (k++" "++show s++"/"++show t) (k++" "++show s) +printProgress k (ProgressData {sofar=s}) = + myput (k++" "++show s) k + +myput :: String -> String -> IO () +myput l s = withDebugMode $ \debugMode -> + if debugMode + then putTiming >> hPutStrLn stderr l + else if '\n' `elem` l + then myput (takeWhile (/= '\n') l) s + else if length l < 80 then putTiming >> simpleput l + else putTiming >> simpleput (take 80 s) + +{-# NOINLINE simpleput #-} +simpleput :: String -> IO () +simpleput = unsafePerformIO $ mkhPutCr stderr + +-- | @beginTedious k@ starts a tedious process and registers it in +-- '_progressData' with the key @k@. A tedious process is one for which we +-- want a progress indicator. +-- +-- Wouldn't it be safer if it had type String -> IO +-- ProgressDataKey, so that we can ensure there is no collision? +-- What happens if you call beginTedious twice with the same string, without +-- calling endTedious in the meantime? +beginTedious :: String -> IO () +beginTedious k = do debugMessage $ "Beginning " ++ (map toLower k) + setProgressData k $ ProgressData { sofar = 0, + latest = Nothing, + total = Nothing } + +-- | @endTedious k@ unregisters the tedious process with key @k@, printing "Done" if such +-- a tedious process exists. +endTedious :: String -> IO () +endTedious k = whenProgressMode $ do p <- getProgressData k + modifyIORef _progressData (\(a,m) -> (a,delete k m)) + when (isJust p) $ debugMessage $ "Done "++ + (map toLower k) + +tediousSize :: String -> Int -> IO () +tediousSize k s = updateProgressData k uptot + where uptot p = case total p of Just t -> seq ts $ p { total = Just ts } + where ts = t + s + Nothing -> p { total = Just s } + +minlist :: Int +minlist = 4 + +progressList :: String -> [a] -> [a] +progressList _ [] = [] +progressList k (x:xs) = if l < minlist then x:xs + else startit x : pl xs + where l = length (x:xs) + startit y = unsafePerformIO $ do beginTedious k + tediousSize k l + return y + pl [] = [] + pl [y] = unsafePerformIO $ do endTedious k + return [y] + pl (y:ys) = progress k y : pl ys + + +progress :: String -> a -> a +progress k a = unsafePerformIO $ progressIO k >> return a + +progressIO :: String -> IO () +progressIO "" = return () +progressIO k = do updateProgressData k (\p -> p { sofar = sofar p + 1, + latest = Nothing }) + putDebug k "" + +progressKeepLatest :: String -> a -> a +progressKeepLatest k a = unsafePerformIO $ progressKeepLatestIO k >> return a + +progressKeepLatestIO :: String -> IO () +progressKeepLatestIO "" = return () +progressKeepLatestIO k = do updateProgressData k (\p -> p {sofar = sofar p + 1}) + putDebug k "" + +finishedOne :: String -> String -> a -> a +finishedOne k l a = unsafePerformIO $ finishedOneIO k l >> return a + +finishedOneIO :: String -> String -> IO () +finishedOneIO "" _ = return () +finishedOneIO k l = do updateProgressData k (\p -> p { sofar = sofar p + 1, + latest = Just l }) + putDebug k l + +putDebug :: String -> String -> IO () +putDebug _ _ = return () +--putDebug k "" = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k +--putDebug k l = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k++" : "++l + +{-# NOINLINE _progressMode #-} +_progressMode :: IORef Bool +_progressMode = unsafePerformIO $ do hSetBuffering stderr LineBuffering + newIORef True + +{-# NOINLINE _progressData #-} +_progressData :: IORef (String, Map String ProgressData) +_progressData = unsafePerformIO $ do forkIO handleProgress + newIORef ("", empty) + +mkhPutCr :: Handle -> IO (String -> IO ()) +mkhPutCr fe = do + isTerm <- hIsTerminalDevice fe + stdoutIsTerm <- hIsTerminalDevice stdout + return $ if isTerm then \s -> do hPutStr fe $ '\r':s++"\r" + hFlush fe + let spaces = '\r':replicate (length s) ' '++"\r" + hPutStr fe spaces + when stdoutIsTerm $ hPutStr stdout spaces + else \s -> when (not $ null s) $ do hPutStrLn fe s + hFlush fe + +setProgressMode :: Bool -> IO () +setProgressMode m = writeIORef _progressMode m + +withoutProgress :: IO a -> IO a +withoutProgress j = withProgressMode $ \m -> do debugMessage "Disabling progress reports..." + setProgressMode False + a <- j `catch` \e -> setProgressMode m >> throw e + if m then debugMessage "Reenabling progress reports." + else debugMessage "Leaving progress reports off." + setProgressMode m + return a + +updateProgressData :: String -> (ProgressData -> ProgressData) -> IO () +updateProgressData k f = whenProgressMode $ modifyIORef _progressData (\(_,m) -> (k,adjust f k m)) + +setProgressData :: String -> ProgressData -> IO () +setProgressData k p = whenProgressMode $ modifyIORef _progressData (\(a,m) -> (a,insert k p m)) + +getProgressData :: String -> IO (Maybe ProgressData) +getProgressData k = withProgressMode $ \p -> if p then (lookup k . snd) `fmap` readIORef _progressData + else return Nothing + +getProgressLast :: IO String +getProgressLast = withProgressMode $ \p -> if p then fst `fmap` readIORef _progressData + else return "" + +whenProgressMode :: IO a -> IO () +whenProgressMode j = withProgressMode $ const $ j >> return () + +withProgressMode :: (Bool -> IO a) -> IO a +withProgressMode j = readIORef _progressMode >>= j + +data ProgressData = ProgressData { sofar :: !Int, + latest :: !(Maybe String), + total :: !(Maybe Int)} diff --git a/src/RegChars.hs b/src/RegChars.hs new file mode 100644 --- /dev/null +++ b/src/RegChars.hs @@ -0,0 +1,75 @@ +-- Copyright (C) 2003 David Roundy +-- +-- 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. + + +module RegChars ( regChars, + ) where + +(&&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) +(&&&) a b c = a c && b c + +(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) +(|||) a b c = a c || b c + +{-# INLINE regChars #-} + +-- | 'regChars' returns a filter function that tells if a char is a member +-- of the regChar expression or not. The regChar expression is basically a +-- set of chars, but it can contain ranges with use of the '-' (dash), and +-- it can also be specified as a complement set by prefixing with '^' +-- (caret). The dash and caret, as well as the backslash, can all be +-- escaped with a backslash to suppress their special meaning. +-- +-- NOTE: The '.' (dot) is allowed to be escaped. It has no special meaning +-- if it is not escaped, but the default 'filename_toks' in +-- Darcs.Commands.Replace uses an escaped dot (WHY?). + +regChars :: String -> (Char -> Bool) +regChars ('^':cs) = not . normalRegChars (unescapeChars cs) +regChars ('\\':'^':cs) = normalRegChars $ unescapeChars $ '^':cs +regChars cs = normalRegChars $ unescapeChars cs + +{-# INLINE unescapeChars #-} + +-- | 'unescapeChars' unescapes whitespace, which is escaped in the replace +-- patch file format. It will also unescape escaped carets, which is useful +-- for escaping a leading caret that should not invert the regChars. All +-- other escapes are left for the unescaping in 'normalRegChars'. + +unescapeChars :: String -> String +unescapeChars ('\\':'n':cs) = '\n' : unescapeChars cs +unescapeChars ('\\':'t':cs) = '\t' : unescapeChars cs +unescapeChars ('\\':'^':cs) = '^' : unescapeChars cs +unescapeChars (c:cs) = c : unescapeChars cs +unescapeChars [] = [] + +{-# INLINE normalRegChars #-} + +-- | 'normalRegChars' assembles the filter function. It handles special +-- chars, and also unescaping of escaped special chars. If a non-special +-- char is still escaped by now we get a failure. + +normalRegChars :: String -> (Char -> Bool) +normalRegChars ('\\':'.':cs) = (=='.') ||| normalRegChars cs +normalRegChars ('\\':'-':cs) = (=='-') ||| normalRegChars cs +normalRegChars ('\\':'\\':cs) = (=='\\') ||| normalRegChars cs +normalRegChars ('\\':c:_) = error $ "'\\"++[c]++"' not supported." +normalRegChars (c1:'-':c2:cs) = ((>= c1) &&& (<= c2)) ||| normalRegChars cs +normalRegChars (c:cs) = (== c) ||| normalRegChars cs +normalRegChars [] = \_ -> False + + diff --git a/src/SHA1.hs b/src/SHA1.hs new file mode 100644 --- /dev/null +++ b/src/SHA1.hs @@ -0,0 +1,206 @@ +-- Copyright (C) 2001, 2004 Ian Lynagh +-- +-- 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. + +{-# OPTIONS_GHC -fno-warn-name-shadowing -cpp #-} +{-# LANGUAGE CPP #-} + + +-- {-# OPTIONS_GHC -fglasgow-exts -fno-warn-name-shadowing #-} +-- -fglasgow-exts needed for nasty hack below +-- name shadowing disabled because a,b,c,d,e are shadowed loads in step 4 +module SHA1 (sha1PS) where + +import ByteStringUtils (unsafeWithInternals) +import qualified Data.ByteString as B (ByteString, pack, length, concat) + +import Data.Char (intToDigit) +import Data.Bits (xor, (.&.), (.|.), complement, rotateL, shiftL, shiftR) +import Data.Word (Word8, Word32) +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Marshal.Array (advancePtr) +import Foreign.Storable (peek, poke) +import System.IO.Unsafe (unsafePerformIO) + +data ABCDE = ABCDE !Word32 !Word32 !Word32 !Word32 !Word32 +data XYZ = XYZ !Word32 !Word32 !Word32 + +sha1PS :: B.ByteString -> String +sha1PS s = s5 + where s1_2 = sha1_step_1_2_pad_length s + abcde = sha1_step_3_init + abcde' = unsafePerformIO + $ unsafeWithInternals s1_2 (\ptr len -> + do let ptr' = castPtr ptr +#ifndef BIGENDIAN + fiddle_endianness ptr' len +#endif + sha1_step_4_main abcde ptr' len) + s5 = sha1_step_5_display abcde' + +fiddle_endianness :: Ptr Word32 -> Int -> IO () +fiddle_endianness p 0 = p `seq` return () +fiddle_endianness p n + = do x <- peek p + poke p $ shiftL x 24 + .|. shiftL (x .&. 0xff00) 8 + .|. (shiftR x 8 .&. 0xff00) + .|. shiftR x 24 + fiddle_endianness (p `advancePtr` 1) (n - 4) + +-- sha1_step_1_2_pad_length assumes the length is at most 2^61. +-- This seems reasonable as the Int used to represent it is normally 32bit, +-- but obviously could go wrong with large inputs on 64bit machines. +-- The B.ByteString library should probably move to Word64s if this is an +-- issue, though. + +sha1_step_1_2_pad_length :: B.ByteString -> B.ByteString +sha1_step_1_2_pad_length s + = let len = B.length s + num_nuls = (55 - len) `mod` 64 + padding = 128:replicate num_nuls 0 + len_w8s = reverse $ size_split 8 (fromIntegral len*8) + in B.concat [s, B.pack padding, B.pack len_w8s] + +size_split :: Int -> Integer -> [Word8] +size_split 0 _ = [] +size_split p n = fromIntegral d:size_split (p-1) n' + where (n', d) = divMod n 256 + +sha1_step_3_init :: ABCDE +sha1_step_3_init = ABCDE 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0 + +sha1_step_4_main :: ABCDE -> Ptr Word32 -> Int -> IO ABCDE +sha1_step_4_main abcde _ 0 = return $! abcde +sha1_step_4_main (ABCDE a0@a b0@b c0@c d0@d e0@e) s len + = do + (e, b) <- doit f1 0x5a827999 (x 0) a b c d e + (d, a) <- doit f1 0x5a827999 (x 1) e a b c d + (c, e) <- doit f1 0x5a827999 (x 2) d e a b c + (b, d) <- doit f1 0x5a827999 (x 3) c d e a b + (a, c) <- doit f1 0x5a827999 (x 4) b c d e a + (e, b) <- doit f1 0x5a827999 (x 5) a b c d e + (d, a) <- doit f1 0x5a827999 (x 6) e a b c d + (c, e) <- doit f1 0x5a827999 (x 7) d e a b c + (b, d) <- doit f1 0x5a827999 (x 8) c d e a b + (a, c) <- doit f1 0x5a827999 (x 9) b c d e a + (e, b) <- doit f1 0x5a827999 (x 10) a b c d e + (d, a) <- doit f1 0x5a827999 (x 11) e a b c d + (c, e) <- doit f1 0x5a827999 (x 12) d e a b c + (b, d) <- doit f1 0x5a827999 (x 13) c d e a b + (a, c) <- doit f1 0x5a827999 (x 14) b c d e a + (e, b) <- doit f1 0x5a827999 (x 15) a b c d e + (d, a) <- doit f1 0x5a827999 (m 16) e a b c d + (c, e) <- doit f1 0x5a827999 (m 17) d e a b c + (b, d) <- doit f1 0x5a827999 (m 18) c d e a b + (a, c) <- doit f1 0x5a827999 (m 19) b c d e a + (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e + (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d + (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c + (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b + (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a + (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e + (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d + (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c + (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b + (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a + (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e + (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d + (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c + (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b + (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a + (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e + (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d + (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c + (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b + (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a + (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e + (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d + (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c + (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b + (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a + (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e + (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d + (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c + (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b + (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a + (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e + (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d + (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c + (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b + (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a + (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e + (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d + (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c + (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b + (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a + (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e + (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d + (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c + (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b + (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a + (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e + (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d + (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c + (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b + (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a + (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e + (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d + (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c + (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b + (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a + (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e + (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d + (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c + (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b + (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a + let abcde' = ABCDE (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e) + sha1_step_4_main abcde' (s `advancePtr` 16) (len - 64) + where {-# INLINE f1 #-} + f1 (XYZ x y z) = (x .&. y) .|. ((complement x) .&. z) + {-# INLINE f2 #-} + f2 (XYZ x y z) = x `xor` y `xor` z + {-# INLINE f3 #-} + f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z) + {-# INLINE x #-} + x n = peek (s `advancePtr` n) + {-# INLINE m #-} + m n = do let base = s `advancePtr` (n .&. 15) + x0 <- peek base + x1 <- peek (s `advancePtr` ((n - 14) .&. 15)) + x2 <- peek (s `advancePtr` ((n - 8) .&. 15)) + x3 <- peek (s `advancePtr` ((n - 3) .&. 15)) + let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1 + poke base res + return res + {-# INLINE doit #-} + doit f k i a b c d e = a `seq` c `seq` + do i' <- i + return (rotateL a 5 + f (XYZ b c d) + e + i' + k, + rotateL b 30) + +sha1_step_5_display :: ABCDE -> String +sha1_step_5_display (ABCDE a b c d e) + = concatMap showAsHex [a, b, c, d, e] + +showAsHex :: Word32 -> String +showAsHex n = showIt 8 n "" + where + showIt :: Int -> Word32 -> String -> String + showIt 0 _ r = r + showIt i x r = case quotRem x 16 of + (y, z) -> let c = intToDigit (fromIntegral z) + in c `seq` showIt (i-1) y (c:r) diff --git a/src/Ssh.hs b/src/Ssh.hs new file mode 100644 --- /dev/null +++ b/src/Ssh.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +module Ssh ( grabSSH, runSSH, getSSH, copySSH, copySSHs, SSHCmd(..), + environmentHelpSsh, environmentHelpScp, environmentHelpSshPort + ) where + +import Prelude hiding ( lookup, catch ) + +import System.Exit ( ExitCode(..) ) +import System.Environment ( getEnv ) +#ifndef WIN32 +import System.Posix.Process ( getProcessID ) +#else +import Darcs.Utils ( showHexLen ) +import Data.Bits ( (.&.) ) +import System.Random ( randomIO ) +#endif +import System.IO ( Handle, hPutStr, hPutStrLn, hGetLine, hGetContents, hClose, hFlush ) +import System.IO.Unsafe ( unsafePerformIO ) +import System.Directory ( doesFileExist, createDirectoryIfMissing ) +import Control.Monad ( when ) +import System.Process ( runInteractiveProcess ) + +import Data.Map ( Map, empty, insert, lookup ) +import Data.IORef ( IORef, newIORef, readIORef, modifyIORef ) + +import Darcs.SignalHandler ( catchNonSignal ) +import Darcs.Utils ( withCurrentDirectory, breakCommand, prettyException, catchall ) +import Darcs.Global ( atexit, sshControlMasterDisabled, darcsdir, withDebugMode ) +import Darcs.Lock ( withTemp, withOpenTemp, tempdir_loc, removeFileMayNotExist ) +import Exec ( exec, Redirects, Redirect(..), ) +import Progress ( withoutProgress, debugMessage, debugFail, progressList ) + +import qualified Data.ByteString as B (ByteString, hGet, writeFile, readFile) +import qualified Data.ByteString.Char8 as BC (unpack) + +#include "impossible.h" + +{-# NOINLINE sshConnections #-} +sshConnections :: IORef (Map String (Maybe Connection)) +sshConnections = unsafePerformIO $ newIORef empty + +data Connection = C { inp :: !Handle, out :: !Handle, err :: !Handle, deb :: String -> IO () } + +withSSHConnection :: String -> (Connection -> IO a) -> IO a -> IO a +withSSHConnection x withconnection withoutconnection = + withoutProgress $ + do cs <- readIORef sshConnections + let uhost = takeWhile (/= ':') x + url = cleanrepourl x + case lookup url (cs :: Map String (Maybe Connection)) of + Just Nothing -> withoutconnection + Just (Just c) -> withconnection c + Nothing -> + do mc <- do (ssh,sshargs_) <- getSSHOnly SSH + let sshargs = sshargs_ ++ [uhost,"darcs","transfer-mode","--repodir",cleanrepodir x] + debugMessage $ "ssh "++unwords sshargs + (i,o,e,_) <- runInteractiveProcess ssh sshargs Nothing Nothing + l <- hGetLine o + if l == "Hello user, I am darcs transfer mode" + then return () + else debugFail "Couldn't start darcs transfer-mode on server" + let c = C { inp = i, out = o, err = e, + deb = \s -> debugMessage ("with ssh (transfer-mode) "++uhost++": "++s) } + modifyIORef sshConnections (insert url (Just c)) + return $ Just c + `catchNonSignal` + \e -> do debugMessage $ "Failed to start ssh connection:\n "++ + prettyException e + severSSHConnection x + debugMessage $ unlines $ + [ "NOTE: the server may be running a version of darcs prior to 2.0.0." + , "" + , "Installing darcs 2 on the server will speed up ssh-based commands." + ] + return Nothing + maybe withoutconnection withconnection mc + +severSSHConnection :: String -> IO () +severSSHConnection x = do debugMessage $ "Severing ssh failed connection to "++x + modifyIORef sshConnections (insert (cleanrepourl x) Nothing) + +cleanrepourl :: String -> String +cleanrepourl zzz | take (length dd) zzz == dd = "" + where dd = darcsdir++"/" +cleanrepourl (z:zs) = z : cleanrepourl zs +cleanrepourl "" = "" + +cleanrepodir :: String -> String +cleanrepodir = cleanrepourl . drop 1 . dropWhile (/= ':') + +grabSSH :: String -> Connection -> IO B.ByteString +grabSSH x c = do + let dir = drop 1 $ dropWhile (/= ':') x + dd = darcsdir++"/" + clean zzz | take (length dd) zzz == dd = drop (length dd) zzz + clean (_:zs) = clean zs + clean "" = bug $ "Buggy path in grabSSH: "++x + file = clean dir + failwith e = do severSSHConnection x + eee <- hGetContents (err c) -- ratify hGetContents: it's okay + -- here because we're only grabbing + -- stderr, and we're also about to + -- throw the contents. + debugFail $ e ++ " grabbing ssh file "++x++"\n"++eee + deb c $ "get "++file + hPutStrLn (inp c) $ "get " ++ file + hFlush (inp c) + l2 <- hGetLine (out c) + if l2 == "got "++file + then do showlen <- hGetLine (out c) + case reads showlen of + [(len,"")] -> B.hGet (out c) len + _ -> failwith "Couldn't get length" + else if l2 == "error "++file + then do e <- hGetLine (out c) + case reads e of + (msg,_):_ -> debugFail $ "Error reading file remotely:\n"++msg + [] -> failwith "An error occurred" + else failwith "Error" + +sshStdErrMode :: IO Redirect +sshStdErrMode = withDebugMode $ \amdebugging -> + return $ if amdebugging then AsIs else Null + +copySSH :: String -> FilePath -> IO () +copySSH uRaw f = withSSHConnection uRaw (\c -> grabSSH uRaw c >>= B.writeFile f) $ + do let u = escape_dollar uRaw + stderr_behavior <- sshStdErrMode + r <- runSSH SCP u [] [u,f] (AsIs,AsIs,stderr_behavior) + when (r /= ExitSuccess) $ + debugFail $ "(scp) failed to fetch: " ++ u + where {- '$' in filenames is troublesome for scp, for some reason.. -} + escape_dollar :: String -> String + escape_dollar = concatMap tr + where tr '$' = "\\$" + tr c = [c] + +copySSHs :: String -> [String] -> FilePath -> IO () +copySSHs u ns d = + withSSHConnection u (\c -> withCurrentDirectory d $ + mapM_ (\n -> grabSSH (u++"/"++n) c >>= B.writeFile n) $ + progressList "Copying via ssh" ns) $ + do let path = drop 1 $ dropWhile (/= ':') u + host = takeWhile (/= ':') u + cd = "cd "++path++"\n" + input = cd++(unlines $ map ("get "++) ns) + withCurrentDirectory d $ withOpenTemp $ \(th,tn) -> + withTemp $ \sftpoutput -> + do hPutStr th input + hClose th + stderr_behavior <- sshStdErrMode + r <- runSSH SFTP u [] [host] (File tn, File sftpoutput, stderr_behavior) + let files = if length ns > 5 + then (take 5 ns) ++ ["and " + ++ (show (length ns - 5)) ++ " more"] + else ns + hint = if take 1 path == "~" + then ["sftp doesn't expand ~, use path/ instead of ~/path/"] + else [] + when (r /= ExitSuccess) $ do + outputPS <- B.readFile sftpoutput + debugFail $ unlines $ + ["(sftp) failed to fetch files.", + "source directory: " ++ path, + "source files:"] ++ files ++ + ["sftp output:",BC.unpack outputPS] ++ + hint + +-- --------------------------------------------------------------------- +-- older ssh helper functions +-- --------------------------------------------------------------------- + +data SSHCmd = SSH | SCP | SFTP + +instance Show SSHCmd where + show SSH = "ssh" + show SCP = "scp" + show SFTP = "sftp" + +runSSH :: SSHCmd -> String -> [String] -> [String] -> Redirects -> IO ExitCode +runSSH cmd remoteAddr preArgs postArgs redirs = + do (ssh, args) <- getSSH cmd remoteAddr + exec ssh (preArgs ++ args ++ postArgs) redirs + +-- | Return the command and arguments needed to run an ssh command +-- along with any extra features like use of the control master. +-- See 'getSSHOnly' +getSSH :: SSHCmd -> String -- ^ remote path + -> IO (String, [String]) +getSSH cmd remoteAddr = + do (ssh, ssh_args) <- getSSHOnly cmd + cm_args <- if sshControlMasterDisabled + then return [] + else do -- control master + cmPath <- controlMasterPath remoteAddr + hasLaunchedCm <- doesFileExist cmPath + when (not hasLaunchedCm) $ launchSSHControlMaster remoteAddr + hasCmFeature <- doesFileExist cmPath + return $ if hasCmFeature then [ "-o ControlPath=" ++ cmPath ] else [] + let verbosity = case cmd of + SCP -> ["-q"] -- (p)scp is the only one that recognises -q + -- sftp and (p)sftp do not, and plink neither + _ -> [] + -- + return (ssh, verbosity ++ ssh_args ++ cm_args) + +-- | Return the command and arguments needed to run an ssh command. +-- First try the appropriate darcs environment variable and SSH_PORT +-- defaulting to "ssh" and no specified port. +getSSHOnly :: SSHCmd -> IO (String, [String]) +getSSHOnly cmd = + do ssh_command <- getEnv (evar cmd) `catchall` return (show cmd) + -- port + port <- (portFlag cmd `fmap` getEnv "SSH_PORT") `catchall` return [] + let (ssh, ssh_args) = breakCommand ssh_command + -- + return (ssh, ssh_args ++ port) + where + evar SSH = "DARCS_SSH" + evar SCP = "DARCS_SCP" + evar SFTP = "DARCS_SFTP" + portFlag SSH x = ["-p", x] + portFlag SCP x = ["-P", x] + portFlag SFTP x = ["-oPort="++x] + +environmentHelpSsh :: ([String], [String]) +environmentHelpSsh = (["DARCS_SSH"], [ + "Repositories of the form [user@]host:[dir] are taken to be remote", + "repositories, which Darcs accesses with the external program ssh(1).", + "", + "The environment variable $DARCS_SSH can be used to specify an", + "alternative SSH client. Arguments may be included, separated by", + "whitespace. The value is not interpreted by a shell, so shell", + "constructs cannot be used; in particular, it is not possible for the", + "program name to contain whitespace by using quoting or escaping."]) + +environmentHelpScp :: ([String], [String]) +environmentHelpScp = (["DARCS_SCP", "DARCS_SFTP"], [ + "When reading from a remote repository, Darcs will attempt to run", + "`darcs transfer-mode' on the remote host. This will fail if the", + "remote host only has Darcs 1 installed, doesn't have Darcs installed", + "at all, or only allows SFTP.", + "", + "If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).", + "The commands invoked can be customized with the environment variables", + "$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.", + "If the remote end allows only sftp, try setting DARCS_SCP=sftp."]) + +environmentHelpSshPort :: ([String], [String]) +environmentHelpSshPort = (["SSH_PORT"], [ + "If this environment variable is set, it will be used as the port", + "number for all SSH calls made by Darcs (when accessing remote", + "repositories over SSH). This is useful if your SSH server does not", + "run on the default port, and your SSH client does not support", + "ssh_config(5). OpenSSH users will probably prefer to put something", + "like `Host *.example.net Port 443' into their ~/.ssh/config file."]) + +-- | Return True if this version of ssh has a ControlMaster feature +-- The ControlMaster functionality allows for ssh multiplexing +hasSSHControlMaster :: Bool +hasSSHControlMaster = unsafePerformIO hasSSHControlMasterIO + +-- Because of the unsafePerformIO above, this can be called at any +-- point. It cannot rely on any state, not even the current directory. +hasSSHControlMasterIO :: IO Bool +hasSSHControlMasterIO = do + (ssh, _) <- getSSHOnly SSH + -- If ssh has the ControlMaster feature, it will recognise the + -- the -O flag, but exit with status 255 because of the nonsense + -- command. If it does not have the feature, it will simply dump + -- a help message on the screen and exit with 1. + sx <- exec ssh ["-O", "an_invalid_command"] (Null,Null,Null) + case sx of + ExitFailure 255 -> return True + _ -> return False + +-- | Launch an SSH control master in the background, if available. +-- We don't have to wait for it or anything. +-- Note also that this will cleanup after itself when darcs exits +launchSSHControlMaster :: String -> IO () +launchSSHControlMaster rawAddr = + when hasSSHControlMaster $ do + let addr = takeWhile (/= ':') rawAddr + (ssh, ssh_args) <- getSSHOnly SSH + cmPath <- controlMasterPath addr + removeFileMayNotExist cmPath + -- -f : put ssh in the background once it succeeds in logging you in + -- -M : launch as the control master for addr + -- -N : don't run any commands + -- -S : use cmPath as the ControlPath. Equivalent to -oControlPath= + exec ssh (ssh_args ++ [addr, "-S", cmPath, "-N", "-f", "-M"]) (Null,Null,AsIs) + atexit $ exitSSHControlMaster addr + return () + +-- | Tell the SSH control master for a given path to exit. +exitSSHControlMaster :: String -> IO () +exitSSHControlMaster addr = do + (ssh, ssh_args) <- getSSHOnly SSH + cmPath <- controlMasterPath addr + exec ssh (ssh_args ++ [addr, "-S", cmPath, "-O", "exit"]) (Null,Null,Null) + return () + +-- | Create the directory ssh control master path for a given address +controlMasterPath :: String -- ^ remote path (foo\@bar.com:file is ok; the file part with be stripped) + -> IO FilePath +controlMasterPath rawAddr = do + let addr = takeWhile (/= ':') rawAddr + tmp <- (fmap (/// ".darcs") $ getEnv "HOME") `catchall` tempdir_loc +#ifdef WIN32 + r <- randomIO + let suffix = (showHexLen 6 (r .&. 0xFFFFFF :: Int)) +#else + suffix <- show `fmap` getProcessID +#endif + let tmpDarcsSsh = tmp /// "darcs-ssh" + createDirectoryIfMissing True tmpDarcsSsh + return $ tmpDarcsSsh /// addr ++ suffix + +(///) :: FilePath -> FilePath -> FilePath +d /// f = d ++ "/" ++ f diff --git a/src/ThisVersion.hs b/src/ThisVersion.hs new file mode 100644 --- /dev/null +++ b/src/ThisVersion.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS -cpp #-} + +module ThisVersion ( darcs_version ) where + +#ifndef PACKAGE_VERSION +#define PACKAGE_VERSION "0" +#define PACKAGE_VERSION_STATE "no version info" +#endif + +{-# NOINLINE darcs_version #-} +darcs_version :: String +darcs_version = PACKAGE_VERSION ++ " (" ++ PACKAGE_VERSION_STATE ++ ")" diff --git a/src/URL.hs b/src/URL.hs new file mode 100644 --- /dev/null +++ b/src/URL.hs @@ -0,0 +1,370 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +module URL ( copyUrl, copyUrlFirst, pipeliningEnabledByDefault, + setDebugHTTP, setHTTPPipelining, waitUrl, + Cachable(Cachable, Uncachable, MaxAge), + environmentHelpProxy, environmentHelpProxyPassword + ) where + +import Data.IORef ( newIORef, readIORef, writeIORef, IORef ) +import Data.Map ( Map ) +import Data.List ( delete ) +import qualified Data.Map as Map +import System.Directory ( copyFile ) +import System.IO.Unsafe ( unsafePerformIO ) +import Control.Concurrent ( forkIO ) +import Control.Concurrent.Chan ( isEmptyChan, newChan, readChan, writeChan, Chan ) +import Control.Concurrent.MVar ( isEmptyMVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, withMVar, MVar ) +import Control.Monad ( unless, when ) +import Control.Monad.Trans ( liftIO ) +import Control.Monad.State ( evalStateT, get, modify, put, StateT ) +import Foreign.C.Types ( CInt ) + +import Workaround ( renameFile ) +import Darcs.Global ( atexit ) +import Progress ( debugFail, debugMessage ) +import Darcs.Lock ( removeFileMayNotExist ) + +import Numeric ( showHex ) +import System.Random ( randomRIO ) + +#ifdef HAVE_CURL +import Foreign.C.String ( withCString, peekCString, CString ) +#else +import qualified HTTP ( request_url, wait_next_url ) +#endif +#include "impossible.h" + +data UrlRequest = UrlRequest { url :: String + , file :: FilePath + , cachable :: Cachable + , priority :: Priority + , notifyVar :: MVar String } + +data Cachable = Cachable | Uncachable | MaxAge !CInt + deriving (Show, Eq) + +data UrlState = UrlState { inProgress :: Map String ( FilePath + , [FilePath] + , Cachable + , (MVar String) ) + , waitToStart :: Q String + , pipeLength :: Int + , randomJunk :: String } + +data Q a = Q [a] [a] + +readQ :: Q a -> Maybe (a, Q a) +readQ (Q (x:xs) ys) = Just (x, Q xs ys) +readQ (Q [] ys) = do x:xs <- Just $ reverse ys + Just (x, Q xs []) + +insertQ :: a -> Q a -> Q a +insertQ y (Q xs ys) = Q xs (y:ys) + +pushQ :: a -> Q a -> Q a +pushQ x (Q xs ys) = Q (x:xs) ys + +deleteQ :: Eq a => a -> Q a -> Q a +deleteQ x (Q xs ys) = Q (delete x xs) (delete x ys) + +elemQ :: Eq a => a -> Q a -> Bool +elemQ x (Q xs ys) = x `elem` xs || x `elem` ys + +emptyQ :: Q a +emptyQ = Q [] [] + +nullQ :: Q a -> Bool +nullQ (Q [] []) = True +nullQ _ = False + +data Priority = High | Low deriving Eq + +#if defined(CURL_PIPELINING) || defined(CURL_PIPELINING_DEFAULT) +pipeliningLimit :: Int +pipeliningLimit = 100 +#endif + +pipeliningEnabledByDefault :: Bool +#ifdef CURL_PIPELINING_DEFAULT +pipeliningEnabledByDefault = True +#else +pipeliningEnabledByDefault = False +#endif + +{-# NOINLINE maxPipeLength #-} +maxPipeLength :: IORef Int +maxPipeLength = unsafePerformIO $ newIORef $ +#ifdef CURL_PIPELINING_DEFAULT + pipeliningLimit +#else + 1 +#endif + +{-# NOINLINE urlNotifications #-} +urlNotifications :: MVar (Map String (MVar String)) +urlNotifications = unsafePerformIO $ newMVar Map.empty + +{-# NOINLINE urlChan #-} +urlChan :: Chan UrlRequest +urlChan = unsafePerformIO $ do + ch <- newChan + forkIO (urlThread ch) + return ch + +urlThread :: Chan UrlRequest -> IO () +urlThread ch = do junk <- flip showHex "" `fmap` randomRIO rrange + evalStateT urlThread' (UrlState Map.empty emptyQ 0 junk) + where rrange = (0, 2^(128 :: Integer) :: Integer) + urlThread' = do + empty <- liftIO $ isEmptyChan ch + st <- get + let l = pipeLength st + w = waitToStart st + reqs <- if not empty || (nullQ w && l == 0) + then liftIO readAllRequests + else return [] + mapM_ addReq reqs + checkWaitToStart + waitNextUrl + urlThread' + readAllRequests = do + r <- readChan ch + debugMessage $ "URL.urlThread ("++url r++"\n"++ + " -> "++file r++")" + empty <- isEmptyChan ch + reqs <- if not empty + then readAllRequests + else return [] + return (r:reqs) + addReq r = do + let u = url r + f = file r + c = cachable r + d <- liftIO $ alreadyDownloaded u + if d + then dbg "Ignoring UrlRequest of URL that is already downloaded." + else do + st <- get + let p = inProgress st + w = waitToStart st + e = (f, [], c, notifyVar r) + new_w = case priority r of + High -> pushQ u w + Low -> insertQ u w + new_st = st { inProgress = Map.insert u e p + , waitToStart = new_w } + case Map.lookup u p of + Just (f', fs', c', v) -> do + let new_c = minCachable c c' + when (c /= c') $ let new_p = Map.insert u (f', fs', new_c, v) p + in do modify (\s -> s { inProgress = new_p }) + dbg $ "Changing "++u++" request cachability from "++show c++" to "++show new_c + when (u `elemQ` w && priority r == High) $ do + modify (\s -> s { waitToStart = pushQ u (deleteQ u w) }) + dbg $ "Moving "++u++" to head of download queue." + if f `notElem` (f':fs') + then let new_p = Map.insert u (f', f:fs', new_c, v) p + in do modify (\s -> s { inProgress = new_p }) + dbg "Adding new file to existing UrlRequest." + else dbg "Ignoring UrlRequest of file that's already queued." + _ -> put new_st + alreadyDownloaded u = do + n <- liftIO $ withMVar urlNotifications (return . (Map.lookup u)) + case n of + Just v -> not `fmap` isEmptyMVar v + Nothing -> return True + +checkWaitToStart :: StateT UrlState IO () +checkWaitToStart = do + st <- get + let l = pipeLength st + mpl <- liftIO $ readIORef maxPipeLength + when (l < mpl) $ do + let w = waitToStart st + case readQ w of + Just (u,rest) -> do + case Map.lookup u (inProgress st) of + Just (f, _, c, v) -> do + dbg ("URL.request_url ("++u++"\n"++ + " -> "++f++")") + let f_new = f++"-new_"++randomJunk st + err <- liftIO $ request_url u f_new c + if null err + then do dbg "URL.request_url succeeded" + liftIO $ atexit (removeFileMayNotExist f_new) + put $ st { waitToStart = rest + , pipeLength = l + 1 } + else do dbg $ "Failed to start download URL "++u++": "++err + liftIO $ do removeFileMayNotExist f_new + putMVar v err + put $ st { waitToStart = rest } + _ -> bug $ "Possible bug in URL.checkWaitToStart "++u + checkWaitToStart + _ -> return () + +copyUrlFirst :: String -> FilePath -> Cachable -> IO () +copyUrlFirst = copyUrlWithPriority High + +copyUrl :: String -> FilePath -> Cachable -> IO () +copyUrl = copyUrlWithPriority Low + +copyUrlWithPriority :: Priority -> String -> String -> Cachable -> IO () +copyUrlWithPriority p u f c = do + debugMessage ("URL.copyUrlWithPriority ("++u++"\n"++ + " -> "++f++")") + v <- newEmptyMVar + let fn _ old_val = old_val + modifyMVar_ urlNotifications (return . (Map.insertWith fn u v)) + let r = UrlRequest u f c p v + writeChan urlChan r + +waitNextUrl :: StateT UrlState IO () +waitNextUrl = do + st <- get + let l = pipeLength st + when (l > 0) $ do + dbg "URL.waitNextUrl start" + (u, e) <- liftIO $ wait_next_url + let p = inProgress st + new_st = st { inProgress = Map.delete u p + , pipeLength = l - 1 } + liftIO $ if null e + then case Map.lookup u p of + Just (f, fs, _, v) -> do + renameFile (f++"-new_"++randomJunk st) f + mapM_ (safeCopyFile st f) fs + putMVar v e + debugMessage $ "URL.waitNextUrl succeeded: "++u++" "++f + Nothing -> bug $ "Possible bug in URL.waitNextUrl: "++u + else case Map.lookup u p of + Just (f, _, _, v) -> do + removeFileMayNotExist (f++"-new_"++randomJunk st) + putMVar v e + debugMessage $ "URL.waitNextUrl failed: "++ + u++" "++f++" "++e + Nothing -> bug $ "Another possible bug in URL.waitNextUrl: "++u++" "++e + unless (null u) $ put new_st + where safeCopyFile st f t = let new_t = t++"-new_"++randomJunk st + in do copyFile f new_t + renameFile new_t t + +waitUrl :: String -> IO () +waitUrl u = do debugMessage $ "URL.waitUrl "++u + r <- withMVar urlNotifications (return . (Map.lookup u)) + case r of + Just var -> do + e <- readMVar var + modifyMVar_ urlNotifications (return . (Map.delete u)) + unless (null e) (debugFail $ "Failed to download URL "++u++": "++e) + Nothing -> return () -- file was already downloaded + +dbg :: String -> StateT a IO () +dbg = liftIO . debugMessage + +minCachable :: Cachable -> Cachable -> Cachable +minCachable Uncachable _ = Uncachable +minCachable _ Uncachable = Uncachable +minCachable (MaxAge a) (MaxAge b) = MaxAge $ min a b +minCachable (MaxAge a) _ = MaxAge a +minCachable _ (MaxAge b) = MaxAge b +minCachable _ _ = Cachable + +#ifdef HAVE_CURL +cachableToInt :: Cachable -> CInt +cachableToInt Cachable = -1 +cachableToInt Uncachable = 0 +cachableToInt (MaxAge n) = n +#endif + +setHTTPPipelining :: Bool -> IO () +setHTTPPipelining False = writeIORef maxPipeLength 1 +setHTTPPipelining True = writeIORef maxPipeLength +#ifdef CURL_PIPELINING + pipeliningLimit +#else + 1 >> (putStrLn $ "Warning: darcs is compiled without HTTP pipelining "++ + "support, '--http-pipelining' argument is ignored.") +#endif + +setDebugHTTP :: IO () +request_url :: String -> FilePath -> Cachable -> IO String +wait_next_url :: IO (String, String) + +#ifdef HAVE_CURL + +setDebugHTTP = curl_enable_debug + +request_url u f cache = + withCString u $ \ustr -> + withCString f $ \fstr -> do + err <- curl_request_url ustr fstr (cachableToInt cache) >>= peekCString + return err + +wait_next_url = do + e <- curl_wait_next_url >>= peekCString + u <- curl_last_url >>= peekCString + return (u, e) + +foreign import ccall "hscurl.h curl_request_url" + curl_request_url :: CString -> CString -> CInt -> IO CString + +foreign import ccall "hscurl.h curl_wait_next_url" + curl_wait_next_url :: IO CString + +foreign import ccall "hscurl.h curl_last_url" + curl_last_url :: IO CString + +foreign import ccall "hscurl.h curl_enable_debug" + curl_enable_debug :: IO () + +#elif defined(HAVE_HTTP) + +setDebugHTTP = return () +request_url = HTTP.request_url +wait_next_url = HTTP.wait_next_url + +#else + +setDebugHTTP = debugMessage "URL.setDebugHttp works only with libcurl" +request_url _ _ _ = debugFail "URL.request_url: there is no libcurl!" +wait_next_url = debugFail "URL.wait_next_url: there is no libcurl!" + +#endif + +-- Usage of these environment variables happens in C code, so the +-- closest to "literate" user documentation is here, where the +-- offending function 'curl_request_url' is imported. +environmentHelpProxy :: ([String], [String]) +environmentHelpProxy = (["HTTP_PROXY", "HTTPS_PROXY", "FTP_PROXY", + "ALL_PROXY", "NO_PROXY"], [ + "If Darcs was built with libcurl, the environment variables HTTP_PROXY,", + "HTTPS_PROXY and FTP_PROXY can be set to the URL of a proxy in the form", + "", + " [protocol://][:port]", + "", + "In which case libcurl will use the proxy for the associated protocol", + "(HTTP, HTTPS and FTP). The environment variable ALL_PROXY can be used", + "to set a single proxy for all libcurl requests.", + "", + "If the environment variable NO_PROXY is a comma-separated list of host", + "names, access to those hosts will bypass proxies defined by the above", + "variables. For example, it is quite common to avoid proxying requests", + "to machines on the local network with", + "", + " NO_PROXY=localhost,*.localdomain", + "", + "For compatibility with lynx et al, lowercase equivalents of these", + "environment variables (e.g. $http_proxy) are also understood and are", + "used in preference to the uppercase versions.", + "", + "If Darcs was not built with libcurl, all these environment variables", + "are silently ignored, and there is no way to use a web proxy."]) + +environmentHelpProxyPassword :: ([String], [String]) +environmentHelpProxyPassword = (["DARCS_PROXYUSERPWD"], [ + "If Darcs was built with libcurl, and you are using a web proxy that", + "requires authentication, you can set the $DARCS_PROXYUSERPWD", + "environment variable to the username and password expected by the", + "proxy, separated by a colon. This environment variable is silently", + "ignored if Darcs was not built with libcurl."]) diff --git a/src/UTF8.lhs b/src/UTF8.lhs new file mode 100644 --- /dev/null +++ b/src/UTF8.lhs @@ -0,0 +1,173 @@ +Copyright (c) 2002, members of the Haskell Internationalisation Working +Group All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +* Neither the name of the Haskell Internationalisation Working Group nor + the names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +This module provides lazy stream encoding/decoding facilities for UTF-8, +the Unicode Transformation Format with 8-bit words. + +2002-09-02 Sven Moritz Hallberg + + +> {-# OPTIONS_GHC -cpp #-} +> module UTF8 +> ( encode ) where + + +SUNSET: we should remove this module after the 2009-07 release +of darcs and just use Codec.Binary.UTF8.String instead + +#ifdef HAVE_UTF8STRING +> import qualified Codec.Binary.UTF8.String (encode) +> import Data.Word (Word8) +#else +> import Data.Char (ord) +> import Data.Word (Word8, Word16, Word32) +> import Data.Bits (Bits, shiftR, (.&.), (.|.)) +#endif + + + +///- UTF-8 in General -/// + +Adapted from the Unicode standard, version 3.2, +Table 3.1 "UTF-8 Bit Distribution" (excluded are UTF-16 encodings): + + Scalar 1st Byte 2nd Byte 3rd Byte 4th Byte + 000000000xxxxxxx 0xxxxxxx + 00000yyyyyxxxxxx 110yyyyy 10xxxxxx + zzzzyyyyyyxxxxxx 1110zzzz 10yyyyyy 10xxxxxx + 000uuuzzzzzzyyyyyyxxxxxx 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx + +Also from the Unicode standard, version 3.2, +Table 3.1B "Legal UTF-8 Byte Sequences": + + Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte + U+0000..U+007F 00..7F + U+0080..U+07FF C2..DF 80..BF + U+0800..U+0FFF E0 A0..BF 80..BF + U+1000..U+CFFF E1..EC 80..BF 80..BF + U+D000..U+D7FF ED 80..9F 80..BF + U+D800..U+DFFF ill-formed + U+E000..U+FFFF EE..EF 80..BF 80..BF + U+10000..U+3FFFF F0 90..BF 80..BF 80..BF + U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF + U+100000..U+10FFFF F4 80..8F 80..BF 80..BF + + + +///- Encoding Functions -/// + +Must the encoder ensure that no illegal byte sequences are output or +can we trust the Haskell system to supply only legal values? +For now I include error case for the surrogate values U+D800..U+DFFF and +out-of-range scalars. + +The function is pretty much a transscript of table 3.1B with error checks. +It dispatches the actual encoding to functions specific to the number of +required bytes. + +#ifndef HAVE_UTF8STRING +> encodeOne :: Char -> [Word8] +> encodeOne c +>-- The report guarantees in (6.1.2) that this won't happen: +>-- | n < 0 = error "encodeUTF8: ord returned a negative value" +> | n < 0x0080 = encodeOne_onebyte n8 +> | n < 0x0800 = encodeOne_twobyte n16 +> | n < 0xD800 = encodeOne_threebyte n16 +> | n < 0xE000 = error "encodeUTF8: ord returned a surrogate value" +> | n < 0x10000 = encodeOne_threebyte n16 +>-- Haskell 98 only talks about 16 bit characters, but ghc handles 20.1. +> | n < 0x10FFFF = encodeOne_fourbyte n32 +> | otherwise = error "encodeUTF8: ord returned a value above 0x10FFFF" +> where +> n = ord c :: Int +> n8 = fromIntegral n :: Word8 +> n16 = fromIntegral n :: Word16 +> n32 = fromIntegral n :: Word32 +#endif + + +With the above, a stream decoder is trivial: + + +> encode :: [Char] -> [Word8] +#ifdef HAVE_UTF8STRING +> encode = Codec.Binary.UTF8.String.encode +#else +> encode = concatMap encodeOne +#endif + + +Now follow the individual encoders for certain numbers of bytes... + _ + / | __ ___ __ __ + / ^| // /__/ // // + /.==| \\ //_ // // +It's // || // \_/_//_//_ and it's here to stay! + +#ifndef HAVE_UTF8STRING +> encodeOne_onebyte :: Word8 -> [Word8] +> encodeOne_onebyte cp = [cp] +#endif + + +00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx + +#ifndef HAVE_UTF8STRING +> encodeOne_twobyte :: Word16 -> [Word8] +> encodeOne_twobyte cp = [(0xC0.|.ys), (0x80.|.xs)] +> where +> xs, ys :: Word8 +> ys = fromIntegral (shiftR cp 6) +> xs = (fromIntegral cp) .&. 0x3F +#endif + + +zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx + +#ifndef HAVE_UTF8STRING +> encodeOne_threebyte :: Word16 -> [Word8] +> encodeOne_threebyte cp = [(0xE0.|.zs), (0x80.|.ys), (0x80.|.xs)] +> where +> xs, ys, zs :: Word8 +> xs = (fromIntegral cp) .&. 0x3F +> ys = (fromIntegral (shiftR cp 6)) .&. 0x3F +> zs = fromIntegral (shiftR cp 12) +#endif + + +000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx + +#ifndef HAVE_UTF8STRING +> encodeOne_fourbyte :: Word32 -> [Word8] +> encodeOne_fourbyte cp = [0xF0.|.us, 0x80.|.zs, 0x80.|.ys, 0x80.|.xs] +> where +> xs, ys, zs, us :: Word8 +> xs = (fromIntegral cp) .&. 0x3F +> ys = (fromIntegral (shiftR cp 6)) .&. 0x3F +> zs = (fromIntegral (shiftR cp 12)) .&. 0x3F +> us = fromIntegral (shiftR cp 18) +#endif diff --git a/src/Workaround.hs b/src/Workaround.hs new file mode 100644 --- /dev/null +++ b/src/Workaround.hs @@ -0,0 +1,94 @@ +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Workaround ( renameFile, setExecutable, getCurrentDirectory, + installHandler, raiseSignal, Handler(..), Signal, + sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE ) where + +#ifdef WIN32 +import qualified System.Directory ( renameFile, getCurrentDirectory, removeFile ) +import qualified Control.Exception ( block ) +import qualified System.IO.Error ( isDoesNotExistError, ioError, catch ) +#else +import System.Posix.Signals(installHandler, raiseSignal, Handler(..), Signal, + sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE) +import System.Directory ( renameFile, getCurrentDirectory ) +import System.Posix.Files (fileMode,getFileStatus, setFileMode, + setFileCreationMask, + ownerReadMode, ownerWriteMode, ownerExecuteMode, + groupReadMode, groupWriteMode, groupExecuteMode, + otherReadMode, otherWriteMode, otherExecuteMode) +import Data.Bits ( (.&.), (.|.), complement ) +#endif + +#ifdef WIN32 +-- Dummy implementation of POSIX signals +data Handler = Default | Ignore | Catch (IO ()) +type Signal = Int + +installHandler :: Signal -> Handler -> Maybe () -> IO () +installHandler _ _ _ = return () + +raiseSignal :: Signal -> IO () +raiseSignal _ = return () + +sigINT, {- sigKILL, -} sigHUP, {- sigQUIT, -} sigABRT, sigALRM, sigTERM, sigPIPE :: Signal +sigINT = 0 +-- not used: sigKILL = 0 +sigHUP = 0 +-- not used: sigQUIT = 0 +sigABRT = 0 +sigTERM = 0 +sigPIPE = 0 +sigALRM = 0 + +{- +System.Directory.renameFile incorrectly fails when the new file already +exists. This code works around that bug at the cost of losing atomic +writes. +-} + +renameFile :: FilePath -> FilePath -> IO () +renameFile old new = Control.Exception.block $ + System.Directory.renameFile old new + `System.IO.Error.catch` \_ -> + do System.Directory.removeFile new + `System.IO.Error.catch` + (\e -> if System.IO.Error.isDoesNotExistError e + then return () + else System.IO.Error.ioError e) + System.Directory.renameFile old new + +setExecutable :: FilePath -> Bool -> IO () +setExecutable _ _ = return () + +{- +System.Directory.getCurrentDirectory returns a path with backslashes in it +under windows, and some of the code gets confused by that, so we override +getCurrentDirectory and translates '\\' to '/' +-} + +getCurrentDirectory :: IO FilePath +getCurrentDirectory = do d <- System.Directory.getCurrentDirectory + return $ map rb d + where rb '\\' = '/' + rb c = c + +#else + +setExecutable :: FilePath -> Bool -> IO () +setExecutable f ex = + do st <- getFileStatus f + umask <- setFileCreationMask 0 + setFileCreationMask umask + let rw = fileMode st .&. + (ownerReadMode .|. ownerWriteMode .|. + groupReadMode .|. groupWriteMode .|. + otherReadMode .|. otherWriteMode) + total = if ex then rw .|. + ((ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode) + .&. complement umask) + else rw + setFileMode f total + +#endif diff --git a/src/atomic_create.c b/src/atomic_create.c new file mode 100644 --- /dev/null +++ b/src/atomic_create.c @@ -0,0 +1,181 @@ +/* + Copyright (C) 2005 Juliusz Chroboczek + + 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. +*/ + +#include +#include +#include +#include +#include +#include + +#include +#include +#include + +#ifdef _WIN32 +#include +#include +#endif + +int sloppy_atomic_create(const char *p) +{ + int fd; + fd = open(p, O_WRONLY | O_EXCL | O_CREAT, 0666); + if(fd < 0) + return -1; + close(fd); + return 1; +} + +#ifdef _WIN32 + +int atomic_create(const char *p) +{ + return sloppy_atomic_create(p); +} + +#else + +static int careful_atomic_create(const char *p) +{ + /* O_EXCL is not available over NFSv2, and even under NFSv3, it is + broken on many systems. The following protocol is provably + safe assuming that: + - creation of hard links is atomic; + - stat hits the server rather than working from the cache. + */ + + static char hostname[65] = {'\0'}; + int fd, rc, saved_errno; +#define FILENAME_SIZE (11 + 15 + 8 + 1) + char *filename; + char *lastslash; + int dirlen; + struct timeval now; + struct stat sb; + + if(hostname[0] == '\0') { + char *c; + int i; + /* POSIX guarantees 65 is enough. */ + rc = gethostname(hostname, 65); + if(rc < 0 || rc >= 65) { + fprintf(stderr, "Error reading hostname when locking.\n"); + strcpy(hostname, "kremvax"); + } + c = strchr(hostname, '.'); + if(c != NULL) + *c = '\0'; + hostname[15] = '\0'; + /* clean up a few possible nasty characters folks might put in their hostname */ + for (i=0;i<15;i++) + if (hostname[i] == ':' || hostname[i] == '/' || hostname[i] == '\\') + hostname[i] = '-'; + } + + lastslash = strrchr(p, '/'); + dirlen = lastslash ? lastslash - p + 1 : 0; + + filename = malloc(dirlen + FILENAME_SIZE); + if(filename == NULL) + return -1; + + if(dirlen > 0) + memcpy(filename, p, dirlen); + filename[dirlen] = '\0'; + + gettimeofday(&now, NULL); + + rc = snprintf(filename + dirlen, FILENAME_SIZE, "darcs_lock_%s%04x%04x", + hostname, ((unsigned)getpid()) & 0xFFFF, + ((unsigned)(now.tv_usec ^ (now.tv_usec >> 16))) & 0xFFFF); + if(rc < 0 || rc >= FILENAME_SIZE) { + fprintf(stderr, "Error writing to lock filename (%d)\n", + rc < 0 ? errno : 0); + goto fail2; + } + + fd = open(filename, O_WRONLY | O_EXCL | O_CREAT, 0666); + if(fd < 0) + goto fail2; + + /* Paranoia: should cause the client to flush its metadata cache. */ + rc = close(fd); + if(rc < 0) { + fprintf(stderr, "Error closing file %s. (%d)\n", filename, errno); + goto fail; + } + + rc = link(filename, p); + if(rc >= 0) + goto success; + else if(errno == EPERM || errno == EOPNOTSUPP) { + /* Linux returns EPERM when making hard links on filesystems + that don't support them. */ + /* It seems that MacOS returns EOPNOTSUPP on filesystems that + don't support hard links. */ + unlink(filename); + free(filename); + return sloppy_atomic_create(p); + } else if(errno != EEXIST && errno != EIO) + goto fail; + + /* The link may still have been successful if we're running over + UDP and got EEXIST or EIO. Check the file's link count. */ + + rc = stat(filename, &sb); + if(rc < 0) { + goto fail; + } + + if(sb.st_nlink != 2) { + errno = EEXIST; + goto fail; + } + + success: + unlink(filename); + free(filename); + return 1; + + fail: + saved_errno = errno; + unlink(filename); + errno = saved_errno; + fail2: + free(filename); + return -1; +} + +int atomic_create(const char *p) +{ + static int sloppy = -1; + + if(sloppy < 0) { + char *s = getenv("DARCS_SLOPPY_LOCKS"); + sloppy = (s != NULL); + } + + if(sloppy) + return sloppy_atomic_create(p); + else + return careful_atomic_create(p); +} + +#endif diff --git a/src/atomic_create.h b/src/atomic_create.h new file mode 100644 --- /dev/null +++ b/src/atomic_create.h @@ -0,0 +1,25 @@ + +#include +#include +#include + +int sloppy_atomic_create(const char *p); +int atomic_create(const char *p); + +#ifdef _WIN32 +int mkstemp(char *p); +int pipe( int fildes[2] ); +int renamefile(const char *from, const char *to); +#endif + +int open_read(const char *fname); +int open_write(const char *fname); +int smart_wait(int pid); + +int execvp_no_vtalarm(const char *file, char *const argv[]); + +int is_symlink(const char *file); + +int stdout_is_a_pipe(); + +int maybe_relink(const char *src, const char *dst, int careful); diff --git a/src/best_practices.tex b/src/best_practices.tex new file mode 100644 --- /dev/null +++ b/src/best_practices.tex @@ -0,0 +1,611 @@ +% This file (unlike the rest of darcs) is in the public domain. + + +\chapter{Best practices} + +This chapter is intended to review various scenarios and describe in each +case effective ways of using darcs. There is no one ``best practice'', and +darcs is a sufficiently low-level tool that there are many high-level ways +one can use it, which can be confusing to new users. The plan (and hope) +is that various users will contribute here describing how they use darcs in +different environments. However, this is not a wiki, and contributions +will be edited and reviewed for consistency and wisdom. + + +\section{Creating patches} + +This section will lay down the concepts around patch creation. +The aim is to develop a way of thinking +that corresponds well to how darcs is behaving +--- even in complicated situations. + + In a single darcs repository you can think of two ``versions'' of the source tree. + They are called the \emph{working} and \emph{pristine} trees. + \emph{Working} is your normal source tree, with or without darcs alongside. + The only thing that makes it part of a darcs repository + is the \verb!_darcs! directory in its root. + \emph{Pristine} is the recorded state of the source tree. + The pristine tree is constructed from groups of changes, + called {\em patches\/} (some other version control systems use the + term {\em changeset\/} instead of {\em patch\/}).\footnote{If + you look inside \_darcs you will find files or directories named + {\tt patches} and {\tt inventories}, which store all the patches + ever recorded. If the repository holds a cached pristine tree, it + is stored in a directory called {\tt pristine} or {\tt current\/}; + otherwise, the fact that there is no pristine tree is marked + by the presence of a file called {\tt pristine.none} or {\tt + current.none}.} + Darcs will create and store these patches + based on the changes you make in \emph{working}. + + +\subsection{Changes} + If \emph{working} and \emph{pristine} are the same, + there are ``no changes'' in the repository. + Changes can be introduced (or removed) by editing the files in \emph{working}. + They can also be caused by darcs commands, + which can modify \emph{both} \emph{working} and \emph{pristine}. + It is important to understand for each darcs command + how it modifies \emph{working}, \emph{pristine} or both of them. + + \verb!whatsnew! (as well as \verb!diff!) can show + the difference between \emph{working} and \emph{pristine} to you. + It will be shown as a difference in \emph{working}. + In advanced cases it need \emph{not} be \emph{working} that has changed; + it can just as well have been \emph{pristine}, or both. + The important thing is the difference and what darcs can do with it. + +\subsection{Keeping or discarding changes} + If you have a difference in \emph{working}, you do two things + with it: \verb!record! it to keep it, or \verb!revert! it to lose the changes.% + \footnote{% + Revert can undo precious work in a blink. + To protect you from great grief, + the discarded changes are saved temporarily + so the latest revert can be undone with unrevert.} + + If you have a difference between \emph{working} and \emph{pristine}% + ---for example after editing some files in \emph{working}---% + \verb!whatsnew! will show some ``unrecorded changes''. + To save these changes, use \verb!record!. + It will create a new patch in \emph{pristine} with the same changes, + so \emph{working} and \emph{pristine} are no longer different. + To instead undo the changes in \emph{working}, use \verb!revert!. + It will modify the files in \emph{working} to be the same as in \emph{pristine} + (where the changes do not exist). + + +\subsection{Unrecording changes} + \verb!unrecord! is a command meant to be run only in private + repositories. Its intended purpose is to allow developers the flexibility + to undo patches that haven't been distributed yet. + + However, darcs does not prevent you from unrecording a patch that + has been copied to another repository. Be aware of this danger! + + If you \verb!unrecord! a patch, that patch will be deleted from \emph{pristine}. + This will cause \emph{working} to be different from \emph{pristine}, + and \verb!whatsnew! to report unrecorded changes. + The difference will be the same as just before that patch was \verb!record!ed. + Think about it. + \verb!record! examines what's different with \emph{working} + and constructs a patch with the same changes in \emph{pristine} + so they are no longer different. + \verb!unrecord! deletes this patch; + the changes in \emph{pristine} disappear and the difference is back. + + If the recorded changes included an error, + the resulting flawed patch can be unrecorded. + When the changes have been fixed, + they can be recorded again as a new---hopefully flawless---patch. + + If the whole change was wrong it can be discarded from \emph{working} too, + with \verb!revert!. + \verb!revert! will update \emph{working} to the state of \emph{pristine}, + in which the changes do no longer exist after the patch was deleted. + + Keep in mind that the patches are your history, + so deleting them with \verb!unrecord! makes it impossible to track + what changes you \emph{really} made. + Redoing the patches is how you ``cover the tracks''. + On the other hand, + it can be a very convenient way to manage and organize changes + while you try them out in your private repository. + When all is ready for shipping, + the changes can be reorganized in what seems as useful and impressive patches. + Use it with care. + + All patches are global, + so don't \emph{ever} replace an already ``shipped'' patch in this way! + If an erroneous patch is deleted and replaced with a better one, + you have to replace it in \emph{all} repositories that have a copy of it. + This may not be feasible, unless it's all private repositories. + If other developers have already made patches or tags in their repositories + that depend on the old patch, things will get complicated. + + +\subsection{Special patches and pending} + +The patches described in the previous sections have mostly been hunks. +A \emph{hunk} is one of darcs' primitive patch types, +and it is used to remove old lines and/or insert new lines. +There are other types of primitive patches, +such as \emph{adddir} and \emph{addfile} +which add new directories and files, +and \emph{replace} +which does a search-and-replace on tokens in files. + +Hunks are always calculated in place with a diff algorithm +just before \verb!whatsnew! or \verb!record!. +But other types of primitive patches need to be explicitly created +with a darcs command. +They are kept in \emph{pending}% +\footnote{In the file {\tt\_darcs/patches/pending}.} +until they are either recorded or reverted. + +\emph{Pending} can be thought of as a special extension of \emph{working}. +When you issue, e.g., a darcs \verb!replace! command, +the replace is performed on the files in \emph{working} +and at the same time a replace patch is put in \emph{pending}. +Patches in \emph{pending} describe special changes made in \emph{working}. +The diff algorithm will fictively apply these changes to \emph{pristine} +before it compares it to \emph{working}, +so all lines in \emph{working} that are changed by a \verb!replace! command +will also be changed in \emph{pending}$+$\emph{pristine} +when the hunks are calculated. +That's why no hunks with the replaced lines will be shown by \verb!whatsnew!; +it only shows the replace patch in \emph{pending} responsible for the change. + +If a special patch is recorded, it will simply be moved to \emph{pristine}. +If it is instead reverted, it will be deleted from \emph{pending} +and the accompanying change will be removed from \emph{working}. + +Note that reverting a patch in pending is \emph{not} the same as +simply removing it from pending. +It actually applies the inverse of the change to \emph{working}. +Most notable is that reverting an addfile patch +will delete the file in \emph{working} (the inverse of adding it). +So if you add the wrong file to darcs by mistake, +\emph{don't} \verb!revert! the addfile. +Instead use \verb!remove!, which cancels out the addfile in pending. + + +\section{Using patches} % still basics + +This section will lay down the concepts around patch distribution and branches. +The aim is to develop a way of thinking +that corresponds well to how darcs is behaving +--- even in complicated situations. + +A repository is a collection of patches. +Patches have no defined order, +but patches can have dependencies on other patches. +Patches can be added to a repository in any order +as long as all patches depended upon are there. +Patches can be removed from a repository in any order, +as long as no remaining patches depend on them. + +Repositories can be cloned to create branches. +Patches created in different branches may conflict. +A conflict is a valid state of a repository. +A conflict makes the working tree ambiguous until the conflict is resolved. + + +\subsection{Dependencies} + +There are two kinds of dependencies: +implicit dependencies and explicit dependencies. + +Implicit dependencies is the far most common kind. +These are calculated automatically by darcs. +If a patch removes a file or a line of code, +it will have to depend on the patch that added that file or line of code.\footnote{% +Actually it doesn't have to---in theory---, +but in practice it's hard to create ``negative'' files or lines in the working tree. +See the chapter about Theory of patches for other constraints.} +If a patch adds a line of code, +it will usually have to depend on the patch or patches that added the adjacent lines. + +Explicit dependencies can be created if you give the \verb|--ask-deps| option to \verb|darcs record|. +This is good for assuring that logical dependencies hold between patches. +It can also be used to group patches---% +a patch with explicit dependencies doesn't need to change anything---% +and pulling the patch also pulls all patches it was made to depend on. + + +\subsection{Branches: just normal repositories} + +Darcs does not have branches---it doesn't need to. +Every repository can be used as a branch. +This means that any two repositories are ``branches'' in darcs, +but it is not of much use unless they have a large portion of patches in common. +If they are different projects they will have nothing in common, +but darcs may still very well be able to merge them, +although the result probably is nonsense. +Therefore the word ``branch'' isn't a technical term in darcs; +it's just the way we think of one repository in relation to another. + +Branches are \emph{very} useful in darcs. +They are in fact \emph{necessary} if you want to do more than only simple work. +When you \verb|get| someone's repository from the Internet, +you are actually creating a branch of it. +It may first seem inefficient (or if you come from CVS---frightening), +not to say plain awkward. +But darcs is designed this way, and it has means to make it efficient. +The answer to many questions about how to do a thing with darcs is: ``use a branch''. +It is a simple and elegant solution with great power and flexibility, +which contributes to darcs' uncomplicated user interface. + +You create new branches (i.e., clone repositories) +with the \verb|get| and \verb|put| commands. + + +\subsection{Moving patches around---no versions} + +Patches are global, and a copy of a patch either is or is not present in a branch. +This way you can rig a branch almost any way you like, +as long as dependencies are fulfilled---% +darcs \emph{won't} let you break dependencies. +If you suspect a certain feature from some time ago introduced a bug, +you can remove the patch/patches that adds the feature, +and try without it.\footnote{% +darcs even has a special command, {\tt trackdown} +that automatically removes patches +until a specified test no longer fails.} + +Patches are added to a repository with \verb|pull| +and removed from the repositories with \verb|obliterate|. +Don't confuse these two commands with \verb|record| and \verb|unrecord|, +which constructs and deconstructs patches. + +It is important not to lose patches when (re)moving them around. +\verb|pull| needs a source repository to copy the patch from, +whereas \verb|obliterate| just erases the patch. +Beware that if you obliterate \emph{all} copies of a patch +it is completely lost---forever. +Therefore you should work with branches when you obliterate patches. +The \verb|obliterate| command can wisely be disabled in a dedicated main repository +by adding \verb|obliterate disable| to the repository's defaults file. + +For convenience, there is a \verb|push| command. +It works like \verb|pull| but in the other direction. +It also differs from \verb|pull| in an important way: +it starts a second instance of darcs to apply the patch in the target repository, +even if it's on the same computer. +It can cause surprises if you have a ``wrong'' darcs in your PATH. + + +\subsection{Tags---versions} + +While \verb|pull| and \verb|obliterate| can be used to +construct different ``versions'' in a repository, +it is often desirable to name specific configurations of patches +so they can be identified and retrieved easily later. +This is how darcs implements what is usually known as versions. +The command for this is \verb|tag|, +and it records a tag in the current repository. + +A tag is just a patch, but it only contains explicit dependencies. +It will depend on all the patches in the current repository.\footnote{% +It will omit patches already depended upon by other patches, +since they will be indirectly depended upon anyway.} +Darcs can recognize if a patch is as a tag; +tags are sometimes treated specially by darcs commands. + +While traditional revision control systems tag versions in the time line history, +darcs lets you tag any configuration of patches at any time, +and pass the tags around between branches. + +With the option \verb|--tag| to \verb|get| you can easily get +a named version in the repository +as a new branch. + + +\subsection{Conflicts} + +This part of darcs becomes a bit complicated, +and the description given here is slightly simplified. + +Conflicting patches are created when +you record changes to the same line in two different repositories. +Same line does \emph{not} mean the same line number and file name, +but the same line added by a common depended-upon patch. + +If you are using a darcs-2 repository (Section \ref{initialize}), +darcs does \emph{not} consider two patches making the \emph{same} change to be a +conflict, much in the same fashion as other version control systems. +(The caveat here is two non-identical patches with some identical +changes may conflict. For the most part, darcs should just do what you +expect). + +A conflict \emph{happens} when two conflicting patches meet in the same repository. +This is no problem for darcs; it can happily pull together just any patches. +But it is a problem for the files in \emph{working} (and \emph{pristine}). +The conflict can be thought of as +two patches telling darcs different things about what a file should look like. + +Darcs escapes this problem +by ignoring those parts\footnote{% +The primitive patches making up the total patch.} +of the patches that conflict. +They are ignored in \emph{both} patches. +If patch~A changes the line ``FIXME'' to ``FIXED'', +and patch~B changes the same line to ``DONE'', +the two patches together will produce the line ``FIXME''. +Darcs doesn't care which one you pulled into the repository first, +you still get the same result when the conflicting patches meet. +All other changes made by A and B are performed as normal. + +Darcs can mark a conflict for you in \emph{working}. +This is done with \verb|mark-conflicts|. +Conflicts are marked such that both conflicting changes +are inserted with special delimiter lines around them. +Then you can merge the two changes by hand, +and remove the delimiters. + +When you pull patches, +darcs automatically performs a \verb|mark-conflicts| for you if a conflict happens. +You can remove the markup with \verb|revert|, +Remember that the result will be the lines from +the previous version common to both conflicting patches. +The conflict marking can be redone again with \verb|mark-conflicts|. + +A special case is when a pulled patch conflicts with unrecorded changes in the repository. +The conflict will be automatically marked as usual, +but since the markup is \emph{also} an unrecorded change, +it will get mixed in with your unrecorded changes. +There is no guarantee you can revert \emph{only} the markup after this, +and \verb|resolve| will not be able to redo this markup later if you remove it. +It is good practice to record important changes before pulling. + +\verb|mark-conflicts| can't mark complicated conflicts. +In that case you'll have to use \verb|darcs diff| and other commands +to understand what the conflict is all about. +If for example two conflicting patches create the same file, +\verb|mark-conflicts| will pick just one of them, +and no delimiters are inserted. +So watch out if darcs tells you about a conflict. + +\verb|mark-conflicts| can also be used to check for unresolved conflicts. +If there are none, darcs replies ``No conflicts to resolve''. +While \verb|pull| reports when a conflict happens, +\verb|obliterate| and \verb|get| don't. + + +\subsection{Resolving conflicts} + +A conflict is resolved +(not marked, as with the command \verb|mark-conflicts|) +as soon as some new patch depends on the conflicting patches. +This will usually be the resolve patch you record after manually putting together the pieces +from the conflict markup produced by \verb|mark-conflicts| (or \verb|pull|). +But it can just as well be a tag. +So don't forget to fix conflicts before you accidently ``resolve'' them by recording other patches. + +If the conflict is with one of your not-yet-published patches, +you may choose to amend that patch rather than creating a resolve patch. + +If you want to back out and wait with the conflict, +you can \verb|obliterate| the conflicting patch you just pulled. +Before you can do that you have to \verb|revert| the conflict markups +that \verb|pull| inserted when the conflict happened. + +\section{Use a Global Cache} + +When working with darcs 2 it is recommended to use a global cache, as this +is one of the biggest performance enhancing tools of darcs 2. The global +cache acts as a giant patch pool where darcs first looks for a patch when +grabbing new patches. This saves time by not downloading the same patch +twice from a remote server. It also saves space by storing the patch only +once, if you ensure your cache and your repositories are on the same +hardlink-supporting filesystem. + +Darcs now enables a global patch cache under your home directory by default. +Older darcs 2.x versions required this manual step: + +\begin{verbatim} +$ mkdir -p $HOME/.darcs/cache +$ echo cache:$HOME/.darcs/cache > $HOME/.darcs/sources +\end{verbatim} + +On MS Windows~\ref{ms_win}, using \verb|cmd.exe| (Command Prompt under Accessories): + +\begin{verbatim} +> md "%UserProfile%\Application Data\darcs\cache" (notice double quotes!) +> echo cache:%UserProfile%\Application Data\darcs\cache > "%UserProfile%\Application Data\darcs\sources" +\end{verbatim} + +There are some other advanced things you can do in \verb!_darcs/prefs/sources!, +such as create per-repository caches, read-only caches and even set a +primary source repository above any used in a \verb|darcs get| or +\verb|darcs pull| command. + +\section{Distributed development with one primary developer} +\label{darcs-development-practices} + +This is how darcs itself is developed. There are many contributors to +darcs, but every contribution is reviewed and manually applied by myself. +For this sort of a situation, \verb|darcs send| is ideal, since the barrier for +contributions is very low, which helps encourage contributors. + +One could simply set the \verb!_darcs/prefs/email! value to the project +mailing list, but I also use darcs send to send my changes to the main +server, so instead the email address is set to +``\verb!Davids Darcs Repo !''. My +\verb-.procmailrc- +file on the server has the following rule: +\begin{verbatim} +:0 +* ^TODavids Darcs Repo +|(umask 022; darcs apply --reply darcs-devel@abridgegame.org \ + --repodir /path/to/repo --verify /path/to/allowed_keys) +\end{verbatim} +This causes darcs apply to be run on any email sent to ``Davids Darcs +Repo''. +\verb'apply' actually applies them only if they are signed by an +authorized key. Currently, the only authorized key is mine, but of course +this could be extended easily enough. + +The central darcs repository contains the following values in its +\verb!_darcs/prefs/defaults!: +\begin{verbatim} +apply test +apply verbose +apply happy-forwarding +\end{verbatim} +The first line tells apply to always run the test suite. The test suite is +in fact the main reason I use send rather than push, since it allows me to +easily continue working (or put my computer to sleep) while the tests are +being run on the main server. The second line is just there to improve the +email response that I get when a patch has either been applied or failed +the tests. The third line makes darcs not complain about unsigned patches, +but just to forward them to \verb!darcs-devel!. + +On my development computer, I have in my \verb!.muttrc! the following +alias, which allows me to easily apply patches that I get via email +directly to my darcs working directory: +\begin{verbatim} +macro pager A "(umask 022; darcs apply --no-test -v \ + --repodir ~/darcs)" +\end{verbatim} + + +\section{Development by a small group of developers in one office} +\label{dft-development-practices} + +This section describes the development method used for the density +functional theory code DFT++, which is available at +\verb!http://dft.physics.cornell.edu/dft!. + +We have a number of workstations which all mount the same \verb!/home! via NFS. +We created a special ``dft'' user, with the central repository living in that +user's home directory. The ssh public keys of authorized persons are added to +the ``dft'' user's \verb!.ssh/allowed_keys!, and we commit patches to this +repository using +\verb'darcs push'. As in Section~\ref{darcs-development-practices}, +we have the central repository set to run the test suite before the push goes +through. + +Note that no one ever runs as the dft user. + +A subtlety that we ran into showed up in the running of the test suite. +Since our test suite includes the running of MPI programs, it must be run +in a directory that is mounted across our cluster. To achieve this, we set +the \verb!$DARCS_TMPDIR! % following is added to make emacs color right:$ +environment variable to \verb!~/tmp!. + +Note that even though there are only four active developers at the moment, +the distributed nature of darcs still plays a large role. Each developer +works on a feature until it is stable, a process that often takes quite a +few patches, and only once it is stable does he +\verb'push' to the central repository. + +\section{Personal development} + +It's easy to have several personal development trees using darcs, even +when working on a team or with shared code. The number and method of +using each personal tree is limited only by such grand limitations as: +your disk space, your imagination, available time, etc. + +For example, if the central darcs repository for your development team +is $R_{c}$, you can create a local working directory for feature +$f_1$. This local working directory contains a full copy of $R_c$ +(as of the time of the ``darcs get'' operation) and can be denoted +$R_1$. In the midst of working on feature $f_1$, you realize it +requires the development of a separate feature $f_2$. Rather than +intermingling $f_1$ and $f_2$ in the same working tree, you can create +a new working tree for working on $f_2$, where that working tree +contains the repository $R_2$. + +While working on $f_2$, other developers may have made other changes; +these changes can be retrieved on a per-patch selection basis by +periodic ``darcs pull'' operations. + +When your work on $f_2$ is completed, you can publish it for the use +of other developers by a ``darcs push'' (or ``darcs send'') from $R_2$ +to $R_c$. Independently of the publishing of $f_2$, you can merge +your $f_2$ work into your $f_1$ working tree by a ``darcs pull $R_2$'' +in the $R_1$ development tree (or ``darcs push'' from $R_2$ to $R_1$). + +When your work on $f_1$ is completed, you publish it as well by a +``darcs push'' from $R_1$ to $R_c$. + +Your local feature development efforts for $f_1$ or $f_2$ can each +consist of multiple patches. When pushing or pulling to other trees, +these patches can either all be selected or specific patches can be +selected. Thus, if you introduce a set of debugging calls into the +code, you can commit the debugging code in a distictly separate patch +(or patches) that you will not push to $R_c$. + +\subsection{Private patches} + +As discussed in the section above, a developer may have various +changes to their local development repositories that they do not ever +wish to publish to a group repository (e.g. personal debugging code), +but which they would like to keep in their local repository, and +perhaps even share amongst their local repositories. + +This is easily done via darcs, since those private changes can be +committed in patches that are separate from other patches; during the +process of pushing patches to the common repository ($R_c$), the +developer is queried for which patches should be moved to ($R_c$) on a +patch-by-patch basis. + +The \verb!--complement! flag for the ``darcs pull'' operation can +further simplify this effort. If the developer copies (via ``darcs +push'' or ``darcs pull'') all private patches into a special +repository/working tree ($R_p$), then those patches are easily +disregarded for pulling by adding \verb!--complement! to the ``darcs +pull'' line and listing $R_p$ after the primary source repository. + +The \verb!--complement! flag is only available for ``darcs pull'', and +not ``darcs push'' or ``darcs send'', requiring the user to have pull +access to the target repository. While the actual public repository +is often not shared in this manner, it's simple to create a local +version of the public repository to act as the staging area for that +public repository. + +The following example extends the two feature addition example in the +previous section using a local staging repository ($R_l$) and a +private patch repository: + +\begin{verbatim} +$ cd working-dir +$ darcs get http://server/repos/Rc Rl + +$ darcs get Rl R1 +$ cd R1 +...development of f1 +$ darcs record -m'p1: f1 initial work' +... +$ darcs record -m'p2: my debugging tracepoints' +... + +$ cd .. +$ darcs get http://server/repos/Rc R2 +$ cd R2 +$ darcs pull -p p2 ../R1 +... development of f2 +$ darcs record -m'p3: f2 finished' + +$ cd .. +$ darcs get Rl Rp +$ cd Rp +$ darcs pull -p p2 ../R2 + +$ cd ../Rl +$ darcs pull --complement ../R2 ../Rp +$ darcs send +... for publishing f2 patches to Rc + +$ cd ../R1 +$ darcs pull ../R2 +... updates R1 with f2 changes from R2 +... more development of f1 +$ darcs record -m'p4: f1 feature finished.' + +$ cd ../Rl +$ darcs pull --complement ../R1 ../Rp +$ darcs send +\end{verbatim} + diff --git a/src/building_darcs.tex b/src/building_darcs.tex new file mode 100644 --- /dev/null +++ b/src/building_darcs.tex @@ -0,0 +1,93 @@ +\chapter{Building darcs} +\section{The Easy Way} +If your distribution provides a pre-built binary package of a recent +Darcs release, you are strongly encouraged to use that rather than +building Darcs yourself. + +If you have (or can install) the \texttt{cabal-install} package, this +is the next best option, as this will resolve build dependencies +automatically. To download, compile and install Darcs and its +dependencies via cabal-install, simply run +\begin{verbatim} +cabal update +cabal install darcs +\end{verbatim} + +\section{The Hard Way} +If you cannot install \texttt{cabal-install}, you need to run +\begin{verbatim} +ghc --make Setup +./Setup configure +./Setup build +./Setup install +\end{verbatim} + +This will require the following build dependencies: +\begin{itemize} +\item GHC 6.8 or higher; and +\item Cabal 1.6 or higher. +\end{itemize} + +%% Note: darcs.cabal tends to have build dependencies [x,y), but I +%% couldn't work out a way to describe this concisely (and +%% intelligibly to non-mathematicians). So I have lied and simply +%% said `or higher', since the upper bounds usually only declare +%% incompatibility with versions that don't exist yet. --twb, 2009 + +Additional build dependencies are declared in the \texttt{darcs.cabal} +file, and \texttt{./Setup configure} will tell you if any required +build dependencies aren't found. The build dependencies at time of +writing (Darcs 2.3) are as follows: +\begin{itemize} +\item the C library zlib; +\item the Haskell packages + \begin{itemize} + \item array 1.1 or 1.2; + \item containers 1.1 or 1.2; + \item directory 1.0; + \item filepath 1.1; + \item hashed-storage 0.3; + \item haskeline 0.6.1 or higher; + \item html 1.0; + \item mtl 1.0 or 1.1; + \item old-time 1.0; + \item parsec 2.1 or higher; + \item process 1.0; + \item random 1.0; and + \item regex-compat 0.71 or higher. + \end{itemize} +\end{itemize} + +Missing \emph{optional} build dependencies are only listed if +\texttt{./Setup configure} is passed the \texttt{--verbose} argument. +At time of writing they are: +\begin{itemize} +\item the C library libcurl (7.19.1 or higher recommended); +\item the Haskell packages + \begin{itemize} + \item bytestring 0.9; + \item bytestring-mmap 0.2 or higher; + \item http 3000 or 3001.1; + \item network 2.2; + \item terminfo 0.3. + \item utf8-string 0.3; and + \item zlib 0.5. + \end{itemize} +\end{itemize} + +\section{The Old Way} +Darcs can still be built with GNU autotools; this approach is +deprecated and will be removed after the 2.3 release. Run +\begin{verbatim} +autoconf +./configure +make +make install +\end{verbatim} + +The build dependencies are identical to the previous approach, except +that instead of the \texttt{Cabal} package, you will need +\begin{itemize} +\item GNU Make; and +\item GNU autoconf 2.50 or higher. +\end{itemize} diff --git a/src/c_compat.c b/src/c_compat.c new file mode 100644 --- /dev/null +++ b/src/c_compat.c @@ -0,0 +1,88 @@ + +#include +#include +#include +#include +#include +#include + +#include +#include +#include +#include + +#ifdef _WIN32 +#include +#include +#endif + +#ifndef _WIN32 + +int open_read(const char *fname) { + return open(fname, O_RDONLY); +} + +int open_write(const char *fname) { + return open(fname, O_WRONLY | O_TRUNC | O_CREAT, + S_IWUSR | S_IRUSR | S_IROTH | S_IRGRP); +} + +int get_errno() { + return errno; +} + +#include +#include +#if HAVE_SIGINFO_H +#include +#endif + +/* This waits and then returns the exit status of the process that was + waited for. */ +int smart_wait(int pid) { + int stat; + pid_t rc; + + do { + rc = waitpid(pid, &stat, 0); + } while(rc < 0 && errno == EINTR); + + if(rc < 0) { + perror("waitpid"); + return -138; + } else if (WIFEXITED(stat)) { + return WEXITSTATUS(stat); + } else if (WIFSIGNALED(stat)) { + /* Fixme: psignal isn't portable (not in POSIX). */ + psignal(WTERMSIG(stat), "Error in subprocess"); + return - WTERMSIG(stat); + } else { + return -137; + } +} + +#include +#include +#include +#include + +int execvp_no_vtalarm(const char *file, char *const argv[]) { + /* Reset the itimers in the child, so it doesn't get plagued + * by SIGVTALRM interrupts. + */ + struct timeval tv_null = { 0, 0 }; + struct itimerval itv; + itv.it_interval = tv_null; + itv.it_value = tv_null; + setitimer(ITIMER_REAL, &itv, NULL); + setitimer(ITIMER_VIRTUAL, &itv, NULL); + setitimer(ITIMER_PROF, &itv, NULL); + execvp(file, argv); + perror("Error in execvp"); + return errno; +} + +#include +#include +#endif + diff --git a/src/compat.h b/src/compat.h new file mode 100644 --- /dev/null +++ b/src/compat.h @@ -0,0 +1,12 @@ + +#include +#include +#include + +int open_read(const char *fname); +int open_write(const char *fname); +int smart_wait(int pid); +int get_errno(); + +int execvp_no_vtalarm(const char *file, char *const argv[]); + diff --git a/src/configuring_darcs.tex b/src/configuring_darcs.tex new file mode 100644 --- /dev/null +++ b/src/configuring_darcs.tex @@ -0,0 +1,264 @@ +% Copyright (C) 2004 David Roundy +% +% 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; if not, write to the Free Software Foundation, +% Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +\chapter{Configuring darcs}\label{configuring} + +There are several ways you can adjust darcs' behavior to suit your needs. +The first is to edit files in the \verb!_darcs/prefs/! directory of a +repository. Such configuration only applies when working with that +repository. To configure darcs on a per-user rather than per-repository +basis (but with essentially the same methods), you can edit (or create) +files in the \verb!~/.darcs/! directory. +Finally, the behavior of some darcs commands can be modified by setting +appropriate environment variables. + +\paragraph{Microsoft Windows}\label{ms_win} + +The global darcs directory is \verb!%APPDATA%\darcs\!. This typically expands to +\texttt{C:\textbackslash{}Documents And Settings\textbackslash{}\emph{user}\textbackslash{}Application Data\textbackslash{}darcs\textbackslash{}}. +This folder contains the cache, as well as all the per-user +settings files: preferences, boring etc... These will became the new defaults +that can be overridden on per-repository basis. + +\input{Darcs/Repository/Prefs.lhs} + +\input{Darcs/Repository/Motd.lhs} + +\section{Environment variables} + +There are a few environment variables whose contents affect darcs' +behavior. Here is a quick list of all the variables and their +documentation in the rest of the manual: + +\begin{tabular}{|l|r|} +\hline +\textbf{Variable} & \textbf{Section} \\ +\hline +DARCS\_EDITOR, EDITOR, VISUAL & \ref{env:DARCS_EDITOR} \\ +DARCS\_PAGER, PAGER & \ref{env:DARCS_PAGER} \\ +HOME & \ref{env:HOME} \\ +TERM & \ref{env:TERM} \\ +\hline +DARCS\_EMAIL, EMAIL & \ref{env:DARCS_EMAIL} \\ +\hline +DARCS\_APPLY\_FOO & \ref{env:DARCS_X_FOO} \\ +DARCS\_GET\_FOO & \ref{env:DARCS_X_FOO} \\ +DARCS\_MGET\_FOO & \ref{env:DARCS_X_FOO} \\ +DARCS\_MGETMAX & \ref{env:DARCS_MGETMAX} \\ +DARCS\_PROXYUSERPWD & \ref{env:DARCS_PROXYUSERPWD} \\ +DARCS\_SSH & \ref{env:DARCS_SSH} \\ +DARCS\_SCP & \ref{env:DARCS_SCP} \\ +DARCS\_SFTP & \ref{env:DARCS_SFTP} \\ +SSH\_PORT & \ref{env:SSH_PORT} \\ +\hline +DARCS\_ALTERNATIVE\_COLOR & \ref{env:DARCS_ALWAYS_COLOR}\\ +DARCS\_ALWAYS\_COLOR & \ref{env:DARCS_ALWAYS_COLOR}\\ +DARCS\_DO\_COLOR\_LINES & \ref{env:DARCS_DO_COLOR_LINES}\\ +DARCS\_DONT\_COLOR & \ref{env:DARCS_ALWAYS_COLOR} \\ +DARCS\_DONT\_ESCAPE\_TRAILING\_CR & \ref{env:DARCS_DONT_ESCAPE_white}\\ +DARCS\_DONT\_ESCAPE\_TRAILING\_SPACES & \ref{env:DARCS_DONT_ESCAPE_white} \\ +DARCS\_DONT\_ESCAPE\_8BIT & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\ +DARCS\_DONT\_ESCAPE\_ANYTHING & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\ +DARCS\_DONT\_ESCAPE\_ISPRINT & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\ +DARCS\_ESCAPE\_EXTRA & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\ +DARCS\_DONT\_ESCAPE\_EXTRA & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\ +\hline +\end{tabular} + +\section{General-purpose variables} + +\darcsEnv{DARCS_EDITOR} +\darcsEnv{DARCS_PAGER} +\darcsEnv{DARCS_TMPDIR} +\darcsEnv{DARCS_KEEP_TMPDIR} +\darcsEnv{HOME} + +\section{Remote repositories} +\darcsEnv{DARCS_SSH} +\darcsEnv{DARCS_SCP} +\darcsEnv{SSH_PORT} +\darcsEnv{HTTP_PROXY} +\darcsEnv{DARCS_PROXYUSERPWD} + +\paragraph{DARCS\_GET\_FOO, DARCS\_MGET\_FOO and DARCS\_APPLY\_FOO} +\label{env:DARCS_X_FOO} +When trying to access a repository with a URL beginning foo://, +darcs will invoke the program specified by the DARCS\_GET\_FOO +environment variable (if defined) to download each file, and the +command specified by the DARCS\_APPLY\_FOO environment variable (if +defined) when pushing to a foo:// URL. + +This method overrides all other ways of getting \verb!foo://xxx! URLs. + +Note that each command should be constructed so that it sends the downloaded +content to STDOUT, and the next argument to it should be the URL\@. Here are some +examples that should work for DARCS\_GET\_HTTP: + +\begin{verbatim} +fetch -q -o - +curl -s -f +lynx -source +wget -q -O - +\end{verbatim} + +Apart from such toy examples, it is likely that you will need to +manipulate the argument before passing it to the actual fetcher +program. For example, consider the problem of getting read access to +a repository on a CIFS (SMB) share without mount privileges: + +\begin{verbatim} +export DARCS_GET_SMB="smbclient -c get" +darcs get smb://fs/twb/Desktop/hello-world +\end{verbatim} + +The above command will not work for several reasons. Firstly, Darcs +will pass it an argument beginning with `smb:', which smbclient does +not understand. Secondly, the host and share `//fs/twb' must be +presented as a separate argument to the path `Desktop/hello-world'. +Thirdly, smbclient requires that `get' and the path be a single +argument (including a space), rather than two separate arguments. +Finally, smbclient's `get' command writes the file to disk, while +Darcs expects it to be printed to standard output. + +In principle, we could get around such problems by making the variable +contain a shell script, e.g. + +\begin{verbatim} +export DARCS_GET_SMB='sh -c "...; smbclient $x -c \"get $y\""' +\end{verbatim} + +Unfortunately, Darcs splits the command on whitespace and does not +understand that quotation or escaping, so there is no way to make +Darcs pass the text after `-c' to sh as a single argument. Therefore, +we instead need to put such one-liners in separate, executable scripts. + +Continuing our smbclient example, we create an executable script +\verb|~/.darcs/libexec/get_smb| with the following contents: + +\begin{verbatim} +#!/bin/bash -e +IFS=/ read host share file <<<"${1#smb://}" +smbclient //$host/$share -c "get $file -" +\end{verbatim} + +And at last we can say + +\begin{verbatim} +export DARCS_GET_SMB=~/.darcs/libexec/get_smb +darcs get smb://fs/twb/Desktop/hello-world +\end{verbatim} + + +If set, DARCS\_MGET\_FOO +will be used to fetch many files from a single repository simultaneously. +Replace FOO and foo as appropriate to handle other URL schemes. +These commands are \emph{not} interpreted by a shell, so you cannot +use shell metacharacters, and the first word in the command must +be the name of an executable located in your path. The GET command +will be called with a URL for each file. The MGET command will be +invoked with a number of URLs and is expected to download the files +to the current directory, preserving the file name but not the path. +The APPLY command will be called with a darcs patchfile piped into +its standard input. Example: + +\begin{verbatim} +wget -q +\end{verbatim} + +\paragraph{DARCS\_MGETMAX} +\label{env:DARCS_MGETMAX} +When invoking a DARCS\_MGET\_FOO command, darcs will limit the +number of URLs presented to the command to the value of this variable, +if set, or 200. + +These commands are \emph{not} interpreted by a shell, so you cannot use shell +meta-characters. + +\section{Highlighted output} +\label{env:DARCS_ALWAYS_COLOR} +\label{env:DARCS_DO_COLOR_LINES} +\label{env:DARCS_DONT_ESCAPE_white} + +If the terminal understands ANSI color escape sequences, +darcs will highlight certain keywords and delimiters when printing patches. +This can be turned off by setting the environment variable DARCS\_DONT\_COLOR to 1. +If you use a pager that happens to understand ANSI colors, like \verb!less -R!, +darcs can be forced always to highlight the output +by setting DARCS\_ALWAYS\_COLOR to 1. +If you can't see colors you can set DARCS\_ALTERNATIVE\_COLOR to 1, +and darcs will use ANSI codes for bold and reverse video instead of colors. +In addition, there is an extra-colorful mode, which is not enabled by +default, which can be activated with DARCS\_DO\_COLOR\_LINES. + +By default darcs will escape (by highlighting if possible) any kind of spaces at the end of lines +when showing patch contents. +If you don't want this you can turn it off by setting +DARCS\_DONT\_ESCAPE\_TRAILING\_SPACES to 1. +A special case exists for only carriage returns: +DARCS\_DONT\_ESCAPE\_TRAILING\_CR. + + +\section{Character escaping and non-ASCII character encodings} +\label{env:DARCS_DONT_ESCAPE_nonascii} + +Darcs needs to escape certain characters when printing patch contents to a terminal. +Characters like \emph{backspace} can otherwise hide patch content from the user, +and other character sequences can even in some cases redirect commands to the shell +if the terminal allows it. + +By default darcs will only allow printable 7-bit ASCII characters (including space), +and the two control characters \emph{tab} and \emph{newline}. +(See the last paragraph in this section for a way to tailor this behavior.) +All other octets are printed in quoted form (as \verb!^! or +\verb!\!\verb!!). + +Darcs has some limited support for locales. +If the system's locale is a single-byte character encoding, +like the Latin encodings, +you can set the environment variable DARCS\_DONT\_ESCAPE\_ISPRINT to 1 +and darcs will display all the printables in the current system locale +instead of just the ASCII ones. +NOTE: This curently does not work on some architectures if darcs is +compiled with GHC~6.4 or later. Some non-ASCII control characters might be printed +and can possibly spoof the terminal. + +For multi-byte character encodings things are less smooth. +UTF-8 will work if you set DARCS\_DONT\_ESCAPE\_8BIT to 1, +but non-printables outside the 7-bit ASCII range are no longer escaped. +E.g., the extra control characters from Latin-1 +might leave your terminal at the mercy of the patch contents. +Space characters outside the 7-bit ASCII range are no longer recognized +and will not be properly escaped at line endings. + +As a last resort you can set DARCS\_DONT\_ESCAPE\_ANYTHING to 1. +Then everything that doesn't flip code sets should work, +and so will all the bells and whistles in your terminal. +This environment variable can also be handy +if you pipe the output to a pager or external filter +that knows better than darcs how to handle your encoding. +Note that \emph{all} escaping, +including the special escaping of any line ending spaces, +will be turned off by this setting. + +There are two environment variables you can set +to explicitly tell darcs to not escape or escape octets. +They are +DARCS\_DONT\_ESCAPE\_EXTRA and DARCS\_ESCAPE\_EXTRA. +Their values should be strings consisting of the verbatim octets in question. +The do-escapes take precedence over the dont-escapes. +Space characters are still escaped at line endings though. +The special environment variable DARCS\_DONT\_ESCAPE\_TRAILING\_CR +turns off escaping of carriage return last on the line (DOS style). diff --git a/src/darcs.hs b/src/darcs.hs new file mode 100644 --- /dev/null +++ b/src/darcs.hs @@ -0,0 +1,72 @@ +-- Copyright (C) 2002-2003 David Roundy +-- +-- 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. + +{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE CPP #-} + +module Main (main) where + +import System.IO ( hSetBinaryMode) +import System.IO ( stdin, stdout ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.Environment ( getArgs ) +import Control.Exception ( Exception( AssertionFailed ), handleJust, catchDyn ) + +import Darcs.RunCommand ( run_the_command ) +import Darcs.Flags ( DarcsFlag(Verbose) ) +import Darcs.Commands.Help ( help_cmd, list_available_commands, print_version ) +import ThisVersion ( darcs_version ) +import Darcs.SignalHandler ( withSignalsHandled ) +import Context ( context ) +import Darcs.Global ( with_atexit ) +import Exec ( ExecException(..) ) +#include "impossible.h" + +assertions :: Control.Exception.Exception -> Maybe String +assertions (AssertionFailed s) = Just s +assertions _ = Nothing + +execExceptionHandler :: ExecException -> IO a +execExceptionHandler (ExecException cmd args redirects reason) = + do putStrLn $ "Failed to execute external command: " ++ unwords (cmd:args) ++ "\n" + ++ "Lowlevel error: " ++ reason ++ "\n" + ++ "Redirects: " ++ show redirects ++"\n" + exitWith $ ExitFailure 3 + +main :: IO () +main = with_atexit $ withSignalsHandled $ + flip catchDyn execExceptionHandler $ + handleJust assertions bug $ do + argv <- getArgs + case argv of + -- User called "darcs" without arguments. + [] -> print_version >> help_cmd [] [] + -- User called "darcs --foo" for some special foo. + ["-h"] -> help_cmd [] [] + ["--help"] -> help_cmd [] [] + ["--overview"] -> help_cmd [Verbose] [] + ["--commands"] -> list_available_commands + ["-v"] -> putStrLn darcs_version + ["--version"] -> putStrLn darcs_version + ["--exact-version"] -> do + putStrLn $ "darcs compiled on "++__DATE__++", at "++__TIME__ + putStrLn context + -- User called a normal darcs command, "darcs foo [args]". + _ -> do + hSetBinaryMode stdin True + hSetBinaryMode stdout True + run_the_command (head argv) (tail argv) diff --git a/src/features.tex b/src/features.tex new file mode 100644 --- /dev/null +++ b/src/features.tex @@ -0,0 +1,88 @@ +\section{Features} + +\paragraph{Record changes locally} +In darcs, the equivalent of a cvs ``commit'' is called record, because it +doesn't put the change into any remote or centralized repository. Changes +are always recorded locally, meaning no net access is required in order to +work on your project and record changes as you make them. Moreover, this +means that there is no need for a separate ``disconnected operation'' mode. + +\paragraph{Interactive records} +You can choose to perform an interactive record, in which case darcs will +prompt you for each change you have made and ask if you wish to record it. +Of course, you can tell darcs to record all the changes in a given file, or +to skip all the changes in a given file, or go back to a previous change, +or whatever. There is also an experimental graphical interface, which +allows you to view and choose changes even more easily, and in whichever +order you like. + +\paragraph{Unrecord local changes} +As a corollary to the ``local'' nature of the record operation, if a change +hasn't yet been published to the world---that is, if the local repository +isn't accessible by others---you can safely unrecord a change (even if it +wasn't the most recently recorded change) and then re-record it +differently, for example if you forgot to add a file, introduced a bug or +realized that what you recorded as a single change was really two separate +changes. + +\paragraph{Interactive everything else} +Most darcs commands support an interactive interface. The ``revert'' +command, for example, which undoes unrecorded changes has the same +interface as record, so you can easily revert just a single change. Pull, +push, send and apply all allow you to view and interactively select which +changes you wish to pull, push, send or apply. + +\paragraph{Test suites} +Darcs has support for integrating a test suite with a repository. If you +choose to use this, you can define a test command (e.g.\ ``make check'') and +have darcs run that command on a clean copy of the project either prior to +recording a change or prior to applying changes---and to reject changes +that cause the test to fail. + +\paragraph{Any old server} +Darcs does not require a specialized server in order to make a repository +available for read access. You can use http, ftp, or even just a plain old +ssh server to access your darcs repository. + +\paragraph{You decide write permissions} +Darcs doesn't try to manage write access. That's your business. Supported +push methods include direct ssh access (if you're willing to \emph{give} +direct ssh access away), using sudo to allow users who already have shell +access to only apply changes to the repository, or verification of +gpg-signed changes sent by email against a list of allowed keys. In +addition, there is good support for submission of patches by email that +are not automatically applied, but can easily be applied with a shell escape +from a mail reader (this is how I deal with contributions to darcs). + +\paragraph{Symmetric repositories} +Every darcs repository is created equal (well, with the exception of a +``partial'' repository, which doesn't contain a full history\ldots), and every +working directory has an associated repository. As a result, there is a +symmetry between ``uploading'' and ``downloading'' changes---you can use +the same commands (push or pull) for either purpose. + +\paragraph{CGI script} +Darcs has a CGI script that allows browsing of the repositories. + +\paragraph{Portable} +Darcs runs on UNIX (or UNIX-like) systems (which includes Mac~OS~X) as well +as on Microsoft Windows. + +\paragraph{File and directory moves} +Renames or moves of files and directories, of course are handled properly, +so when you rename a file or move it to a different directory, its history +is unbroken, and merges with repositories that don't have the file renamed +will work as expected. + +\paragraph{Token replace} +You can use the ``darcs replace'' command to modify all occurrences of a +particular token (defined by a configurable set of characters that are +allowed in ``tokens'') in a file. This has the advantage that merges with +changes that introduce new copies of the old token will have the effect of +changing it to the new token---which comes in handy when changing a +variable or function name that is used throughout a project. + +\paragraph{Configurable defaults} +You can easily configure the default flags passed to any command on either +a per-repository or a per-user basis or a combination thereof. + diff --git a/src/fpstring.c b/src/fpstring.c new file mode 100644 --- /dev/null +++ b/src/fpstring.c @@ -0,0 +1,187 @@ +/* + * Copyright (C) 2003 David Roundy + * Most of the UTF code is Copyright (C) 1999-2001 Free Software Foundation, Inc. + * This file is part of darcs. + * + * Darcs is free software; you can redistribute it and/or modify it under + * the terms of the GNU Library General Public License as published by the + * Free Software Foundation; either version 2 of the License, or (at your + * option) any later version. + * + * You should have received a copy of the GNU Library General Public + * License along with the GNU LIBICONV Library; see the file COPYING.LIB. + * If not, write to the Free Software Foundation, Inc., 51 Franklin Street, + * Fifth Floor, Boston, MA 02110-1301, USA. + * + */ +#include "fpstring.h" + +#include +#include +#include + +#ifdef _WIN32 +#include +#else +#include +#endif + +/* A locale-independent isspace(3) so patches are interpreted the same + * everywhere. */ +// #define ISSPACE(c) \ +// ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) == '\r') + +// int first_white(const char *s, int len) +// { +// const char *start; +// const char *end; +// +// for (start = s, end = s + len; s < end && !ISSPACE(*s); s++); +// +// return s - start; +// } + +// int first_nonwhite(const char *s, int len) +// { +// const char *start; +// const char *end; +// +// for (start = s, end = s + len; s < end && ISSPACE(*s); s++); +// +// return s - start; +// } + +int has_funky_char(const char *s, int len) +{ + // We check first for the more likely \0 so we can break out of + // memchr that much sooner. + return !!(memchr(s, 0, len) || memchr(s, 26, len)); + +} + +// ForeignPtr debugging stuff... + +static int num_alloced = 0; + +void debug_free(void *p) { + num_alloced--; + fprintf(stderr, "Freeing %p (%d left)\n", p, num_alloced); +} + +void debug_alloc(void *p, const char *name) { + num_alloced++; + fprintf(stderr, "Allocating %p named %s (%d left)\n", + p, name, num_alloced); +} + +/* Specification: RFC 2279 */ + +int utf8_to_ints(HsInt *pwc, const unsigned char *s, int n) { + /* returns number of unicode chars in the output. The output array is + assumed to have the same number of elements as the input array, which + is n. */ + + HsInt *pwc_original = pwc; + while (n > 0) { + unsigned char c = s[0]; + + if (c < 0x80) { + *pwc++ = c; + n--; + s++; + } else if (c < 0xc2) { + return -1; + } else if (c < 0xe0) { + if (n < 2) return -1; + if (!((s[1] ^ 0x80) < 0x40)) return -1; + *pwc++ = ((unsigned) (c & 0x1f) << 6) + | (unsigned) (s[1] ^ 0x80); + n -= 2; + s += 2; + } else if (c < 0xf0) { + if (n < 3) return -1; + if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (c >= 0xe1 || s[1] >= 0xa0))) + return -1; + *pwc++ = ((unsigned) (c & 0x0f) << 12) + | ((unsigned) (s[1] ^ 0x80) << 6) + | (unsigned) (s[2] ^ 0x80); + n -= 3; + s += 3; + } else if (c < 0xf8 && sizeof(unsigned)*8 >= 32) { + if (n < 4) return -1; + if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 + && (c >= 0xf1 || s[1] >= 0x90))) + return -1; + *pwc++ = ((unsigned) (c & 0x07) << 18) + | ((unsigned) (s[1] ^ 0x80) << 12) + | ((unsigned) (s[2] ^ 0x80) << 6) + | (unsigned) (s[3] ^ 0x80); + n -= 4; + s += 4; + } else if (c < 0xfc && sizeof(unsigned)*8 >= 32) { + if (n < 5) return -1; + if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (c >= 0xf9 || s[1] >= 0x88))) + return -1; + *pwc++ = ((unsigned) (c & 0x03) << 24) + | ((unsigned) (s[1] ^ 0x80) << 18) + | ((unsigned) (s[2] ^ 0x80) << 12) + | ((unsigned) (s[3] ^ 0x80) << 6) + | (unsigned) (s[4] ^ 0x80); + n -= 5; + s += 5; + } else if (c < 0xfe && sizeof(unsigned)*8 >= 32) { + if (n < 6) return -1; + if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (s[5] ^ 0x80) < 0x40 + && (c >= 0xfd || s[1] >= 0x84))) + return -1; + *pwc++ = ((unsigned) (c & 0x01) << 30) + | ((unsigned) (s[1] ^ 0x80) << 24) + | ((unsigned) (s[2] ^ 0x80) << 18) + | ((unsigned) (s[3] ^ 0x80) << 12) + | ((unsigned) (s[4] ^ 0x80) << 6) + | (unsigned) (s[5] ^ 0x80); + n -= 6; + s += 6; + } else + return -1; + } + return pwc - pwc_original; +} + +/* Conversion to and from hex */ + +void conv_to_hex(unsigned char *dest, unsigned char *from, int num_chars) +{ + static char hex[] = "0123456789abcdef"; + unsigned char *end; + + for (end = from + num_chars; from < end; from++) { + *dest++ = hex[*from >> 4]; + *dest++ = hex[*from & 0xf]; + } + + return; +} + +#define NYBBLE_TO_INT(c) \ + ((c) - ((c) >= 'a' ? 'a' - 10 : '0')) + +void conv_from_hex(unsigned char *dest, unsigned char *from, int num_chars) +{ + unsigned char *end; + unsigned char c; + + end = dest + num_chars; + while (dest < end) { + c = NYBBLE_TO_INT(*from) << 4, from++; + *dest++ = c | NYBBLE_TO_INT(*from), from++; + } + + return; +} diff --git a/src/fpstring.h b/src/fpstring.h new file mode 100644 --- /dev/null +++ b/src/fpstring.h @@ -0,0 +1,16 @@ +#include +#include + +int wfindps_helper(char c, const char *s, int len); +void debug_free(void *p); +void debug_alloc(void *p, const char *name); + +// int first_white(const char *s, int len); +// int first_nonwhite(const char *s, int len); +int has_funky_char(const char *s, int len); + +int utf8_to_ints(HsInt *pwc, const unsigned char *s, int n); + +void conv_to_hex(unsigned char *dest, unsigned char *from, int num_chars); +void conv_from_hex(unsigned char *dest, unsigned char *from, int num_chars); + diff --git a/src/gadts.h b/src/gadts.h new file mode 100644 --- /dev/null +++ b/src/gadts.h @@ -0,0 +1,11 @@ +#ifdef GADT_WITNESSES + +#define C(contexts) contexts +#define FORALL(types) forall types. + +#else + +#define C(contexts) +#define FORALL(types) + +#endif diff --git a/src/gpl.tex b/src/gpl.tex new file mode 100644 --- /dev/null +++ b/src/gpl.tex @@ -0,0 +1,414 @@ +% This is the FSF GPL, reformatted as an appendix by David Roundy + +% This file is intended to be included in another file. + +\chapter{The GNU General Public License} +\label{gpl} +\section*{Version 2, June 1991} + +\begin{center} +Version 2, June 1991 + +Copyright \copyright\ 1989, 1991 Free Software Foundation, Inc. + +\bigskip + +51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +\bigskip + +Everyone is permitted to copy and distribute verbatim copies +of this license document, but changing it is not allowed. + +\end{center} + +\section*{Preamble} +\begin{quote} +The licenses for most software are designed to take away your freedom to +share and change it. By contrast, the GNU General Public License is +intended to guarantee your freedom to share and change free software---to +make sure the software is free for all its users. This General Public +License applies to most of the Free Software Foundation's software and to +any other program whose authors commit to using it. (Some other Free +Software Foundation software is covered by the GNU Library General Public +License instead.) You can apply it to your programs, too. + +When we speak of free software, we are referring to freedom, not price. +Our General Public Licenses are designed to make sure that you have the +freedom to distribute copies of free software (and charge for this service +if you wish), that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free programs; +and that you know you can do these things. + +To protect your rights, we need to make restrictions that forbid anyone to +deny you these rights or to ask you to surrender the rights. These +restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + +For example, if you distribute copies of such a program, whether gratis or +for a fee, you must give the recipients all the rights that you have. You +must make sure that they, too, receive or can get the source code. And +you must show them these terms so they know their rights. + +We protect your rights with two steps: (1) copyright the software, and (2) +offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + +Also, for each author's protection and ours, we want to make certain that +everyone understands that there is no warranty for this free software. If +the software is modified by someone else and passed on, we want its +recipients to know that what they have is not the original, so that any +problems introduced by others will not reflect on the original authors' +reputations. + +Finally, any free program is threatened constantly by software patents. +We wish to avoid the danger that redistributors of a free program will +individually obtain patent licenses, in effect making the program +proprietary. To prevent this, we have made it clear that any patent must +be licensed for everyone's free use or not licensed at all. + +The precise terms and conditions for copying, distribution and +modification follow. +\end{quote} + +\begin{center} +{\Large \sc GNU General Public License +\\\vspace{3mm}Terms and Conditions For Copying, Distribution and Modification} +\end{center} + + +\begin{enumerate} + +\addtocounter{enumi}{-1} + +\item + +This License applies to any program or other work which contains a notice +placed by the copyright holder saying it may be distributed under the +terms of this General Public License. The ``Program'', below, refers to +any such program or work, and a ``work based on the Program'' means either +the Program or any derivative work under copyright law: that is to say, a +work containing the Program or a portion of it, either verbatim or with +modifications and/or translated into another language. (Hereinafter, +translation is included without limitation in the term ``modification''.) +Each licensee is addressed as ``you''. + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + +\item You may copy and distribute verbatim copies of the Program's source + code as you receive it, in any medium, provided that you conspicuously + and appropriately publish on each copy an appropriate copyright notice + and disclaimer of warranty; keep intact all the notices that refer to + this License and to the absence of any warranty; and give any other + recipients of the Program a copy of this License along with the Program. + +You may charge a fee for the physical act of transferring a copy, and you +may at your option offer warranty protection in exchange for a fee. + +\item + +You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + +\begin{enumerate} + +\item + +You must cause the modified files to carry prominent notices stating that +you changed the files and the date of any change. + +\item + +You must cause any work that you distribute or publish, that in +whole or in part contains or is derived from the Program or any +part thereof, to be licensed as a whole at no charge to all third +parties under the terms of this License. + +\item +If the modified program normally reads commands interactively +when run, you must cause it, when started running for such +interactive use in the most ordinary way, to print or display an +announcement including an appropriate copyright notice and a +notice that there is no warranty (or else, saying that you provide +a warranty) and that users may redistribute the program under +these conditions, and telling the user how to view a copy of this +License. (Exception: if the Program itself is interactive but +does not normally print such an announcement, your work based on +the Program is not required to print an announcement.) + +\end{enumerate} + + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + +\item +You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + +\begin{enumerate} + +\item + +Accompany it with the complete corresponding machine-readable +source code, which must be distributed under the terms of Sections +1 and 2 above on a medium customarily used for software interchange; or, + +\item + +Accompany it with a written offer, valid for at least three +years, to give any third party, for a charge no more than your +cost of physically performing source distribution, a complete +machine-readable copy of the corresponding source code, to be +distributed under the terms of Sections 1 and 2 above on a medium +customarily used for software interchange; or, + +\item + +Accompany it with the information you received as to the offer +to distribute corresponding source code. (This alternative is +allowed only for noncommercial distribution and only if you +received the program in object code or executable form with such +an offer, in accord with Subsection b above.) + +\end{enumerate} + + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + +\item +You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + +\item +You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + +\item +Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + +\item +If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + +\item +If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + +\item +The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and ``any +later version'', you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + +\item +If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + +\begin{center} +{\Large\sc +No Warranty +} +\end{center} + +\item +{\sc Because the program is licensed free of charge, there is no warranty +for the program, to the extent permitted by applicable law. Except when +otherwise stated in writing the copyright holders and/or other parties +provide the program ``as is'' without warranty of any kind, either expressed +or implied, including, but not limited to, the implied warranties of +merchantability and fitness for a particular purpose. The entire risk as +to the quality and performance of the program is with you. Should the +program prove defective, you assume the cost of all necessary servicing, +repair or correction.} + +\item +{\sc In no event unless required by applicable law or agreed to in writing +will any copyright holder, or any other party who may modify and/or +redistribute the program as permitted above, be liable to you for damages, +including any general, special, incidental or consequential damages arising +out of the use or inability to use the program (including but not limited +to loss of data or data being rendered inaccurate or losses sustained by +you or third parties or a failure of the program to operate with any other +programs), even if such holder or other party has been advised of the +possibility of such damages.} + +\end{enumerate} + + +\begin{center} +{\Large\sc End of Terms and Conditions} +\end{center} + +\section{Appendix: How to Apply These Terms to Your New Programs} + +If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to + attach them to the start of each source file to most effectively convey + the exclusion of warranty; and each file should have at least the + ``copyright'' line and a pointer to where the full notice is found. + +\begin{quote} +$<$one line to give the program's name and a brief idea of what it does.$>$ \\ +Copyright (C) $<$year$>$ $<$name of author$>$ \\ + +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 of the License, 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; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +\end{quote} + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + +\begin{quote} +Gnomovision version 69, Copyright (C) $<$year$>$ $<$name of author$>$ \\ +Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. \\ +This is free software, and you are welcome to redistribute it +under certain conditions; type `show c' for details. +\end{quote} + + +The hypothetical commands {\tt show w} and {\tt show c} should show the +appropriate parts of the General Public License. Of course, the commands +you use may be called something other than {\tt show w} and {\tt show c}; +they could even be mouse-clicks or menu items---whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a ``copyright disclaimer'' for the program, if +necessary. Here is a sample; alter the names: + +\begin{quote} +Yoyodyne, Inc., hereby disclaims all copyright interest in the program \\ +`Gnomovision' (which makes passes at compilers) written by James Hacker. \\ + +$<$signature of Ty Coon$>$, 1 April 1989 \\ +Ty Coon, President of Vice +\end{quote} + + +This General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications +with the library. If this is what you want to do, use the GNU Library +General Public License instead of this License. diff --git a/src/hscurl.c b/src/hscurl.c new file mode 100644 --- /dev/null +++ b/src/hscurl.c @@ -0,0 +1,305 @@ +#ifdef HAVE_CURL + +#include "hscurl.h" + +#include +#include +#include +#include +#include + +enum RESULT_CODES + { + RESULT_OK = 0, + RESULT_MALLOC_FAIL, + RESULT_SELECT_FAIL, + RESULT_MULTI_INIT_FAIL, + RESULT_EASY_INIT_FAIL, + RESULT_SLIST_APPEND_FAIL, + RESULT_NO_RUNNING_HANDLES, + RESULT_MULTI_INFO_READ_FAIL, + RESULT_UNKNOWN_MESSAGE, + RESULT_FILE_OPEN_FAIL + }; + +static const char *error_strings[] = + { + "", + "malloc() failed", + "select() failed", + "curl_multi_init() failed", + "curl_easy_init() failed", + "curl_slist_append() failed", + "curl_multi_perform() - no running handles", + "curl_multi_info_read() failed", + "curl_multi_info_read() returned unknown message", + "fopen() failed" + }; + +struct UrlData +{ + char *url; + FILE *file; + struct curl_slist *headers; +}; + +static int debug = 0; +static const char user_agent[] = + "darcs/" PACKAGE_VERSION " libcurl/" LIBCURL_VERSION; +static const char *proxypass; +static int init_done = 0; +static CURLM *multi = NULL; +static int msgs_in_queue = 0; +static char *last_url = NULL; + +static const char *perform() +{ + int error; + int running_handles, running_handles_last; + fd_set fd_read, fd_write, fd_except; + int max_fd; + long timeout; + struct timeval tval; + + error = curl_multi_perform(multi, &running_handles); + if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM) + return curl_multi_strerror(error); + if (running_handles == 0) + return error_strings[RESULT_NO_RUNNING_HANDLES]; + + running_handles_last = running_handles; + while (1) + { + while (error == CURLM_CALL_MULTI_PERFORM) + error = curl_multi_perform(multi, &running_handles); + + if (error != CURLM_OK) + return curl_multi_strerror(error); + + if (running_handles < running_handles_last) + break; + + FD_ZERO(&fd_read); + FD_ZERO(&fd_write); + FD_ZERO(&fd_except); + + error = curl_multi_fdset(multi, &fd_read, &fd_write, &fd_except, &max_fd); + if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM) + return curl_multi_strerror(error); + +#ifdef CURL_MULTI_TIMEOUT + error = curl_multi_timeout(multi, &timeout); + if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM) + return curl_multi_strerror(error); + + if (timeout == -1) +#endif + timeout = 100; + + tval.tv_sec = timeout / 1000; + tval.tv_usec = timeout % 1000 * 1000; + + while (select(max_fd + 1, &fd_read, &fd_write, &fd_except, &tval) < 0) + if (errno != EINTR) + { + if (debug) + perror(error_strings[RESULT_SELECT_FAIL]); + return error_strings[RESULT_SELECT_FAIL]; + } + + error = CURLM_CALL_MULTI_PERFORM; + } + + return NULL; +} + +const char *curl_request_url(const char *url, + const char *filename, + int cache_time) +{ + int error; + + if (init_done == 0) + { + error = curl_global_init(CURL_GLOBAL_ALL); + if (error != CURLE_OK) + return curl_easy_strerror(error); + proxypass = getenv("DARCS_PROXYUSERPWD"); + init_done = 1; + } + + if (multi == NULL) + { + multi = curl_multi_init(); + if (multi == NULL) + return error_strings[RESULT_MULTI_INIT_FAIL]; +#ifdef CURL_PIPELINING + error = curl_multi_setopt(multi, CURLMOPT_PIPELINING, 1); + if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM) + return curl_multi_strerror(error); +#endif + } + + CURL *easy = curl_easy_init(); + if (easy == NULL) + return error_strings[RESULT_EASY_INIT_FAIL]; + + if (debug) + { + error = curl_easy_setopt(easy, CURLOPT_VERBOSE, 1); + if (error != CURLE_OK) + return curl_easy_strerror(error); + } + + struct UrlData *url_data = malloc(sizeof(struct UrlData)); + if (url_data == NULL) + return error_strings[RESULT_MALLOC_FAIL]; + + url_data->url = strdup(url); + if (url_data->url == NULL) + return error_strings[RESULT_MALLOC_FAIL]; + + url_data->file = fopen(filename,"wb"); + if (url_data->file == NULL) + { + if (debug) + perror(error_strings[RESULT_FILE_OPEN_FAIL]); + return error_strings[RESULT_FILE_OPEN_FAIL]; + } + + error = curl_easy_setopt(easy, CURLOPT_PRIVATE, url_data); + if (error != CURLE_OK) + return curl_easy_strerror(error); + + error = curl_easy_setopt(easy, CURLOPT_URL, url_data->url); + if (error != CURLE_OK) + return curl_easy_strerror(error); + +#ifdef CURLOPT_WRITEDATA + error = curl_easy_setopt(easy, CURLOPT_WRITEDATA, url_data->file); +#else + error = curl_easy_setopt(easy, CURLOPT_FILE, url_data->file); +#endif + if (error != CURLE_OK) + return curl_easy_strerror(error); + + error = curl_easy_setopt(easy, CURLOPT_USERAGENT, user_agent); + if (error != CURLE_OK) + return curl_easy_strerror(error); + + error = curl_easy_setopt(easy, CURLOPT_FOLLOWLOCATION, 1); + if (error != CURLE_OK) + return curl_easy_strerror(error); + + error = curl_easy_setopt(easy, CURLOPT_FAILONERROR, 1); + if (error != CURLE_OK) + return curl_easy_strerror(error); + + error = curl_easy_setopt(easy, CURLOPT_HTTPAUTH, CURLAUTH_ANY); + if (error != CURLE_OK) + return curl_easy_strerror(error); + + /* libcurl currently always sends Pragma: no-cache, but never + Cache-Control, which is contradictory. We override both, just to + be sure. */ + url_data->headers = curl_slist_append(NULL, "Accept: */*"); + if(cache_time == 0) + { + url_data->headers = + curl_slist_append(url_data->headers, "Pragma: no-cache"); + url_data->headers = + curl_slist_append(url_data->headers, "Cache-Control: no-cache"); + } + else if(cache_time > 0) + { + /* This won't work well with HTTP/1.0 proxies. */ + char buf[40]; + snprintf(buf, sizeof(buf), "Cache-Control: max-age=%d", cache_time); + buf[sizeof(buf) - 1] = '\n'; + url_data->headers = curl_slist_append(url_data->headers, "Pragma:"); + url_data->headers = curl_slist_append(url_data->headers, buf); + } + else + { + url_data->headers = curl_slist_append(url_data->headers, "Pragma:"); + url_data->headers = curl_slist_append(url_data->headers, "Cache-Control:"); + } + if (url_data->headers == NULL) + return error_strings[RESULT_SLIST_APPEND_FAIL]; + + error = curl_easy_setopt(easy, CURLOPT_HTTPHEADER, url_data->headers); + if (error != CURLE_OK) + return curl_easy_strerror(error); + + if (proxypass && *proxypass) + { + error = curl_easy_setopt(easy, CURLOPT_PROXYUSERPWD, proxypass); + if (error != CURLE_OK) + return curl_easy_strerror(error); + } + + error = curl_multi_add_handle(multi, easy); + if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM) + return curl_multi_strerror(error); + + return error_strings[RESULT_OK]; +} + +const char *curl_wait_next_url() +{ + if (last_url != NULL) + { + free(last_url); + last_url = NULL; + } + + if (msgs_in_queue == 0) + { + const char *error = perform(); + if (error != NULL) + return error; + } + + CURLMsg *msg = curl_multi_info_read(multi, &msgs_in_queue); + if (msg == NULL) + return error_strings[RESULT_MULTI_INFO_READ_FAIL]; + + if (msg->msg == CURLMSG_DONE) + { + CURL *easy = msg->easy_handle; + CURLcode result = msg->data.result; + struct UrlData *url_data; + int error = curl_easy_getinfo(easy, CURLINFO_PRIVATE, (char **)&url_data); + if (error != CURLE_OK) + return curl_easy_strerror(error); + + last_url = url_data->url; + fclose(url_data->file); + curl_slist_free_all(url_data->headers); + free(url_data); + + error = curl_multi_remove_handle(multi, easy); + if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM) + return curl_multi_strerror(error); + curl_easy_cleanup(easy); + + if (result != CURLE_OK) + return curl_easy_strerror(result); + } + else + return error_strings[RESULT_UNKNOWN_MESSAGE]; + + return error_strings[RESULT_OK]; +} + +const char *curl_last_url() +{ + return last_url != NULL ? last_url : ""; +} + +void curl_enable_debug() +{ + debug = 1; +} + +#endif diff --git a/src/hscurl.h b/src/hscurl.h new file mode 100644 --- /dev/null +++ b/src/hscurl.h @@ -0,0 +1,9 @@ +const char *curl_request_url(const char *url, + const char *filename, + int cache_time); + +const char *curl_wait_next_url(); + +const char *curl_last_url(); + +void curl_enable_debug(); diff --git a/src/impossible.h b/src/impossible.h new file mode 100644 --- /dev/null +++ b/src/impossible.h @@ -0,0 +1,8 @@ +import qualified Darcs.Bug as Bug_ + +#define darcsBug (\imp_funny_name -> imp_funny_name (__FILE__,__LINE__,__TIME__,__DATE__)) + +#define bug (darcsBug Bug_._bug) +#define impossible (darcsBug Bug_._impossible) +#define fromJust (darcsBug Bug_._fromJust) +#define bugDoc (darcsBug Bug_._bugDoc) diff --git a/src/maybe_relink.c b/src/maybe_relink.c new file mode 100644 --- /dev/null +++ b/src/maybe_relink.c @@ -0,0 +1,173 @@ +/* + Copyright (C) 2005 Juliusz Chroboczek + + 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. +*/ + +#include +#include +#include +#include +#include +#include + +#include +#include +#include + +#ifdef _WIN32 +int +maybe_relink(const char *src, const char *dst, int careful) +{ + return 0; +} + +#else + +/* Tries to link src to dst if both files exist and have the same + contents. If careful is false only the file sizes are compared; if + it is true, the full contents are compared. + + This code assumes that dst cannot change behind our back -- the + caller is supposed to protect it by a lock. On the other hand, it + does handle simultaneous access to src, but only if src is never + modified in place. It should also be safe over NFS. + + Assumes that rename cannot fail mid-way on a single filesystem. + + Returns 1 on success, 0 if the files are already linked, -1 for an + error in errno, -2 if the files cannot be linked because they are not + the same, on different devices, or on a filesystem with no support for + hard links, -3 if there was a race condition, -4 if something unexpected + happened. */ + +int +maybe_relink(char *src, char *dst, int careful) +{ +#define RELINK_BUFFER_SIZE 8192 + + int len, rc, saved_errno; + char *tempname; + struct stat srcstat, dststat, tempstat; + struct timeval now; + + rc = stat(src, &srcstat); + if(rc < 0) { + if(errno == ENOENT) + return -2; + else + return -1; + } + + rc = stat(dst, &dststat); + if(rc < 0) return -1; + + if(!S_ISREG(srcstat.st_mode) || !S_ISREG(dststat.st_mode)) { + return -4; + } + + if(srcstat.st_dev != dststat.st_dev) { + return -2; + } + + if(srcstat.st_ino == dststat.st_ino) + /* Files are already linked */ + return 0; + + if(srcstat.st_size != dststat.st_size) + return -2; + + /* link is atomic even on NFS, we will fail gracefully if the name + is not unique. */ + gettimeofday(&now, NULL); + rc = strlen(dst) + 6; + tempname = malloc(rc); + if(tempname == NULL) return -1; + len = snprintf(tempname, rc, "%s-%04x", dst, + ((unsigned)(now.tv_usec ^ (now.tv_usec >> 16))) & 0xFFFF); + if(len < 0 || len >= rc) { + free(tempname); + return -4; + } + + rc = link(src, tempname); + if(rc < 0) { + /* We need to try to remove the link in case this was a + problem with NFS over an unreliable transport. */ + goto fail; + } + + rc = stat(tempname, &tempstat); + if(rc < 0) goto fail; + + /* Check for a race condition. The size and mtime checks are + gratuitious, but they don't cost much, and might save your data + if you're on a filesystem without i-nodes. */ + if(tempstat.st_ino != srcstat.st_ino || + tempstat.st_size != srcstat.st_size || + tempstat.st_mtime != srcstat.st_mtime) { + unlink(tempname); + free(tempname); + return -3; + } + if(careful) { + int fd1, fd2, i, rc1, rc2; + char buf1[RELINK_BUFFER_SIZE], buf2[RELINK_BUFFER_SIZE]; + + fd1 = open(tempname, O_RDONLY); + if(fd1 < 0) goto fail; + fd2 = open(dst, O_RDONLY); + if(fd2 < 0) { close(fd1); goto fail; } + + i = 0; + /* This comparison is approximate: it doesn't deal with short + reads and EINTR. It's okay, as these cases are rare and if + they happen, we're still safe. */ + while(i < tempstat.st_size) { + rc1 = read(fd1, buf1, RELINK_BUFFER_SIZE); + if(rc1 < 0) { close(fd1); close(fd2); goto fail; } + rc2 = read(fd2, buf2, RELINK_BUFFER_SIZE); + if(rc2 < 0) { close(fd1); close(fd2); goto fail; } + if(rc1 == 0 || rc1 != rc2 || memcmp(buf1, buf2, rc1) != 0) { + close(fd1); close(fd2); + unlink(tempname); + free(tempname); + return -2; + } + i += rc1; + } + close(fd1); close(fd2); + } + + rc = rename(tempname, dst); + if(rc < 0) goto fail; + + free(tempname); + return 1; + + fail: + saved_errno = errno; + unlink(tempname); + free(tempname); + errno = saved_errno; + if(errno == EPERM || errno == EOPNOTSUPP) + return -2; + return -1; + +#undef RELINK_BUFFER_SIZE +} + +#endif diff --git a/src/maybe_relink.h b/src/maybe_relink.h new file mode 100644 --- /dev/null +++ b/src/maybe_relink.h @@ -0,0 +1,1 @@ +int maybe_relink(const char *src, const char *dst, int careful); diff --git a/src/preproc.hs b/src/preproc.hs new file mode 100644 --- /dev/null +++ b/src/preproc.hs @@ -0,0 +1,184 @@ +-- | This program mangles a pseudo-LaTeX document into actual LaTeX. +-- There are three key changes to the input: +-- +-- * \\input{foo} is replaced by the contents of the file foo (after +-- it, too, is mangled). Note that this is relative to the +-- working directory, *not* relative to the file being parsed. +-- +-- * Anything between \\begin{code} and \\end{code} is deleted. +-- Note that this is quite unlike normal literate documentation +-- (for which we use Haddock, not LaTeX). +-- +-- * Some nonstandard pseudo-LaTeX commands are expanded into actual +-- LaTeX text. In particular, \\darcsCommand{foo} is replaced by +-- LaTeX markup describing the command @foo@. +module Main (main) where +import System.FilePath ( () ) +import System.Environment ( getArgs ) +import System.Exit ( exitWith, ExitCode(..) ) +import Text.Regex ( matchRegex, mkRegex ) +import Darcs.Commands ( DarcsCommand(SuperCommand, + command_sub_commands, command_name, + command_extra_arg_help, command_basic_options, + command_advanced_options, command_help, + command_description), + extract_commands ) +import Darcs.Arguments ( options_latex ) +import Darcs.Commands.Help ( command_control_list, environmentHelp ) +import English ( andClauses ) +import ThisVersion ( darcs_version ) + +the_commands :: [DarcsCommand] +the_commands = extract_commands command_control_list + +-- | The entry point for this program. The path to the TeX master +-- file is supplied as the first argument. Bootstrapping into +-- 'preproc' then happens by passing it a pseudo-document that +-- contains a single input (include) line. +main :: IO () +main = do + args <- getArgs + if length args < 1 + then exitWith $ ExitFailure 1 + else return () + putStrLn "%% This file was automatically generated by preproc." + c <- preproc ["\\input{"++head args++"}"] + mapM_ putStrLn c + +-- | Depending on whether pdflatex or htlatex is to be used, the LaTeX +-- output of this program must vary subtly. This procedure returns +-- true iff the command-line arguments contain @--html@. +am_html :: IO Bool +am_html = do args <- getArgs + return $ elem "--html" args + +-- | Given a list of input lines in pseudo-LaTeX, return the same +-- document in LaTeX. The pseudo-LaTeX lines are replaced, other +-- lines are used unmodified. +preproc :: [String] -> IO [String] +preproc [] = return [] -- Empty input, empty output. +preproc ("\\usepackage{html}":ss) = -- only use html package with latex2html + do rest <- preproc ss + ah <- am_html + if ah then return $ "\\usepackage{html}" : rest + else return $ "\\usepackage{hyperref}" : rest +preproc ("\\begin{code}":ss) = ignore ss + where ignore :: [String] -> IO [String] + ignore ("\\end{code}":ss') = preproc ss' + ignore (_:ss') = ignore ss' + ignore [] = return [] +preproc ("\\begin{options}":ss) = + do rest <- preproc ss + ah <- am_html + if ah then return $ "\\begin{rawhtml}" : "
" : rest + else return $ ("\\begin{Verbatim}[frame=lines,xleftmargin=1cm," ++ + "xrightmargin=1cm]") : rest +preproc ("\\end{options}":ss) = + do rest <- preproc ss + ah <- am_html + if ah then return $ "
" : "\\end{rawhtml}" : rest + else return $ "\\end{Verbatim}" : rest +preproc ("\\darcsVersion":ss) = do + rest <- preproc ss + return $ darcs_version:rest +preproc (s:ss) = do + rest <- preproc ss + let rx = mkRegex "^\\\\(input|darcs(Command|Env))\\{(.+)\\}$" + case matchRegex rx s of + Just ["input", _, path] -> + do cs <- readFile $ "src" path -- ratify readFile: not part of darcs executable + this <- preproc $ lines cs + return $ this ++ rest + Just ["darcsCommand", _, command] -> + return $ commandHelp command : rest + Just ["darcsEnv", _, variable] -> + return $ envHelp variable : rest + -- The base case for the whole preproc function. Nothing to + -- mangle, so this is an ordinary line of TeX, and we append it to + -- the result unmodified. + _ -> return $ s : rest + +commandHelp :: String -> String +commandHelp command = section ++ "{darcs " ++ command ++ "}\n" ++ + "\\label{" ++ command ++ "}\n" ++ + gh ++ get_options command ++ gd + where + section = if ' ' `elem` command then "\\subsubsection" else "\\subsection" + -- | Given a Darcs command name as a string, return that command's (multi-line) help string. + gh :: String + gh = escape_latex_specials $ command_property command_help the_commands command + -- | Given a Darcs command name as a string, return that command's (one-line) description string. + gd :: String + gd = command_property command_description the_commands command + +get_options :: String -> String +get_options comm = get_com_options $ get_c names the_commands + where names = words comm + +get_c :: [String] -> [DarcsCommand] -> [DarcsCommand] +get_c (name:ns) commands = + case ns of + [] -> [get name commands] + _ -> case get name commands of + c@SuperCommand { } -> + c:(get_c ns $ extract_commands $ command_sub_commands c) + _ -> + error $ "Not a supercommand: " ++ name + where get n (c:cs) | command_name c == n = c + | otherwise = get n cs + get n [] = error $ "No such command: "++n +get_c [] _ = error "no command specified" + +get_com_options :: [DarcsCommand] -> String +get_com_options c = + "\\par\\verb!Usage: darcs " ++ cmd ++ " [OPTION]... " ++ + args ++ "!\n\n" ++ "Options:\n\n" ++ options_latex opts1 ++ + (if null opts2 then "" else "\n\n" ++ "Advanced options:\n\n" ++ options_latex opts2) + where cmd = unwords $ map command_name c + args = unwords $ command_extra_arg_help $ last c + opts1 = command_basic_options $ last c + opts2 = command_advanced_options $ last c + +command_property :: (DarcsCommand -> String) -> [DarcsCommand] -> String + -> String +command_property property commands name = + property $ last c + where names = words name + c = get_c names commands + + + +envHelp :: String -> String +envHelp var = unlines $ render $ entry environmentHelp + where render (ks, ds) = + ("\\paragraph{" ++ escape_latex_specials (andClauses ks) ++ "}") : + ("\\label{env:" ++ var ++ "}") : + map escape_latex_specials ds + entry [] = undefined + entry (x:xs) | elem var $ fst x = x + | otherwise = entry xs + +-- | LaTeX treats a number of characters or sequences specially. +-- Therefore when including ordinary help text in a LaTeX document, it +-- is necessary to escape these characters in the way LaTeX expects. +escape_latex_specials :: String -> String +-- Order is important +escape_latex_specials = + (bs2 . amp . percent . carrot . dollar . underscore . rbrace . lbrace . bs1) + where + amp = replace "&" "\\&" + bs1 = replace "\\" "\001" + bs2 = replace "\001" "$\\backslash$" + carrot = replace "^" "\\^{}" + dollar = replace "$" "\\$" + lbrace = replace "{" "\\{" + percent = replace "%" "\\%" + rbrace = replace "}" "\\}" + underscore = replace "_" "\\_" + + replace :: Eq a => [a] -> [a] -> [a] -> [a] + replace _ _ [] = [] + replace find repl s = + if take (length find) s == find + then repl ++ (replace find repl (drop (length find) s)) + else [head s] ++ replace find repl (tail s) diff --git a/src/switching.tex b/src/switching.tex new file mode 100644 --- /dev/null +++ b/src/switching.tex @@ -0,0 +1,147 @@ +\section{Switching from CVS} + +Darcs is refreshingly different from CVS. + +CVS keeps version controlled data in a central repository, and +requires that users check out a working directory whenever they wish +to access the version-controlled sources. In order to modify the +central repository, a user needs to have write access to the central +repository; if he doesn't, CVS merely becomes a tool to get the latest +sources. + +In darcs there is no distinction between working directories and +repositories. In order to work on a project, a user makes a local +copy of the repository he wants to work in; he may then harness the +full power of version control locally. In order to distribute his +changes, a user who has write access can \emph{push} them to the +remote repository; one who doesn't can simply send them by e-mail in a +format that makes them easy to apply on the remote system. + +\paragraph{Darcs commands for CVS users} +Because of the different models used by cvs and darcs, it is +difficult to provide a complete equivalence between cvs and darcs. +A rough correspondence for the everyday commands follows:\\ +% The \hspace commands force a line break in the postscript output, +% but they are effectively ignored in the html output. +\begin{description}\addtolength{\itemsep}{-0.5\baselineskip} +\item[{\tt cvs checkout}\hspace*{100em}] + {\tt darcs get} +\item[{\tt cvs update}\hspace*{100em}] + {\tt darcs pull} +\item[{\tt cvs -n update}\hspace*{100em}] + {\tt darcs pull \verb!--dry-run!} + (summarize remote changes) +\item[{\tt cvs -n update}\hspace*{100em}] + {\tt darcs whatsnew \verb!--summary!} + (summarize local changes) +\item[{\tt cvs -n update | grep '?'}\hspace*{100em}] + {\tt darcs whatsnew -ls | grep \verb!^a! } + (list potential files to add) +\item[{\tt rm foo.txt; cvs update foo.txt}\hspace*{100em}] + {\tt darcs revert foo.txt} + (revert to foo.txt from repo) +\item[{\tt cvs diff}\hspace*{100em}] + {\tt darcs whatsnew} + (if checking local changes) +\item[{\tt cvs diff}\hspace*{100em}] + {\tt darcs diff} + (if checking recorded changes) +\item[{\tt cvs commit}\hspace*{100em}] + {\tt darcs record} + (if committing locally) +\item[{\tt cvs commit}\hspace*{100em}] + {\tt darcs tag} + (if marking a version for later use) +\item[{\tt cvs commit}\hspace*{100em}] + {\tt darcs push} or {\tt darcs send} + (if committing remotely) +\item[{\tt cvs diff | mail}\hspace*{100em}] + {\tt darcs send} +\item[{\tt cvs add}\hspace*{100em}] + {\tt darcs add} +\item[{\tt cvs tag -b}\hspace*{100em}] + {\tt darcs get} +\item[{\tt cvs tag}\hspace*{100em}] + {\tt darcs tag} +\end{description} + +\paragraph{Migrating CVS repositories to darcs} + +Tools and instructions for migrating CVS repositories to darcs are provided +on the darcs community website: +\htmladdnormallinkfoot{http://wiki.darcs.net/DarcsWiki/ConvertingFromCvs}{http://wiki.darcs.net/DarcsWiki/ConvertingFromCvs} + + +\section{Switching from arch} + +Although arch, like darcs, is a distributed system, and the two systems +have many similarities (both require no special server, for example), their +essential organization is very different. + +Like CVS, arch keeps data in two types of data structures: +repositories (called ``archives'') and working directories. In order +to modify a repository, one must first check out a corresponding +working directory. This requires that users remember a number of +different ways of pushing data around --- \verb|tla| \verb|get|, +\verb|update|, \verb|commit|, \verb|archive-mirror| and so on. + +In darcs, on the other hand, there is no distinction between working +directories and repositories, and just checking out your sources +creates a local copy of a repository. This allows you to harness the +full power of version control in any scratch copy of your sources, and +also means that there are just two ways to push data around: +\verb|darcs| \verb|record|, which stores edits into your local +repository, and \verb|pull|, which moves data between repositories. +(\verb|darcs| \verb|push| is merely the opposite of \verb|pull|; +\verb|send| and \verb|apply| are just the two halves of \verb|push|). + +\paragraph{Darcs commands for arch users} + +Because of the different models used by arch and darcs, it is +difficult to provide a complete equivalence between arch and darcs. +A rough correspondence for the everyday commands follows:\\ +\begin{description}\addtolength{\itemsep}{-0.5\baselineskip} +\item[{\tt tla init-tree}\hspace*{100em}] + {\tt darcs initialize} +\item[{\tt tla get}\hspace*{100em}] + {\tt darcs get} +\item[{\tt tla update}\hspace*{100em}] + {\tt darcs pull} +\item[{\tt tla file-diffs f | patch -R }\hspace*{100em}] + {\tt darcs revert} +\item[{\tt tla changes --diffs}\hspace*{100em}] + {\tt darcs whatsnew} +\item[{\tt tla logs}\hspace*{100em}] + {\tt darcs changes} +\item[{\tt tla file-diffs}\hspace*{100em}] + {\tt darcs diff -u} +\item[{\tt tla add}\hspace*{100em}] + {\tt darcs add} +\item[{\tt tla mv}\hspace*{100em}] + {\tt darcs move} + (not {\tt tla move}) +\item[{\tt tla commit}\hspace*{100em}] + {\tt darcs record} + (if committing locally) +\item[{\tt tla commit}\hspace*{100em}] + {\tt darcs tag} + (if marking a version for later use) +\item[{\tt tla commit}\hspace*{100em}] + {\tt darcs push} or {\tt darcs send} + (if committing remotely) +\item[{\tt tla archive-mirror}\hspace*{100em}] + {\tt darcs pull} or {\tt darcs push} +\item[{\tt tla tag}\hspace*{100em}] + {\tt darcs get} + (if creating a branch) +\item[{\tt tla tag}\hspace*{100em}] + {\tt darcs tag} + (if creating a tag). +\end{description} + +\paragraph{Migrating arch repositories to darcs} + +Tools and instructions for migrating arch repositories to darcs are provided +on the darcs community website: +\htmladdnormallinkfoot{http://wiki.darcs.net/DarcsWiki/ConvertingFromArch}{http://wiki.darcs.net/DarcsWiki/ConvertingFromArch} + diff --git a/src/umask.c b/src/umask.c new file mode 100644 --- /dev/null +++ b/src/umask.c @@ -0,0 +1,38 @@ +#include +#include +#include +#include +#include "umask.h" + +int +set_umask(char *mask_string) +{ +#ifndef WIN32 + int rc; + unsigned mask; + char *end; + + mask = strtoul(mask_string, &end, 8); + if(!end || *end != '\0') { + errno = EINVAL; + return -1; + } + + rc = umask(mask); + return rc; +#else + /* umask() has no useful meaning on win32. */ + return 0; +#endif /* #ifndef WIN32 ... else ... */ +} + +int +reset_umask(int old_mask) +{ +#ifndef WIN32 + umask(old_mask); + return 1; +#else + return 0; +#endif /* #ifndef WIN32 ... else ... */ +} diff --git a/src/umask.h b/src/umask.h new file mode 100644 --- /dev/null +++ b/src/umask.h @@ -0,0 +1,2 @@ +int set_umask(char *mask_string); +int reset_umask(int old_mask); diff --git a/src/unit.lhs b/src/unit.lhs new file mode 100644 --- /dev/null +++ b/src/unit.lhs @@ -0,0 +1,822 @@ +% Copyright (C) 2002-2005,2007 David Roundy +% +% 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. + +\documentclass{report} +\usepackage{color} + +\usepackage{verbatim} +\newenvironment{code}{\color{blue}\verbatim}{\endverbatim} + +\begin{document} + +% Definition of title page: +\title{ + Unit Testing for darcs in Haskell +} +\author{ + David Roundy % insert author(s) here +} + +\maketitle + +\tableofcontents % Table of Contents + +\chapter{Introduction} + +This is a unit testing program, which is intended to make sure that all the +functions of my darcs code work properly. + +\begin{code} +{-# OPTIONS_GHC -cpp -fno-warn-orphans -fno-warn-deprecations -fglasgow-exts #-} +{-# LANGUAGE CPP #-} + +module Main (main) where + +import System.IO.Unsafe ( unsafePerformIO ) +import ByteStringUtils hiding ( intercalate ) +import qualified Data.ByteString.Char8 as BC ( unpack, pack ) +import qualified Data.ByteString as B ( empty, concat, length, unpack, foldr, + cons, ByteString, null, filter, head ) +import Data.Char ( isPrint ) +import Darcs.Patch +import Darcs.Patch.Test +import Darcs.Patch.Unit ( patch_unit_tests ) +import Lcs ( shiftBoundaries ) +import Test.QuickCheck +import Printer ( renderPS, text ) +import Darcs.Patch.Commute +import Data.Array.Base +import Data.Array.Unboxed +import Control.Monad.ST +import Darcs.Ordered +import Darcs.Sealed ( Sealed(Sealed), unsafeUnseal ) +import Darcs.Email ( make_email, read_email, formatHeader ) +import Test.HUnit ( assertBool, assertFailure ) +import Test.Framework.Providers.QuickCheck2 ( testProperty ) +import Test.Framework.Providers.HUnit ( testCase ) +import Test.Framework.Runners.Console ( defaultMain ) +import Test.Framework ( Test ) + +#include "impossible.h" +\end{code} + +\chapter{Main body of code} + +\begin{code} +main :: IO () +main = do + putStr ("There are a total of "++(show (length primitive_test_patches)) + ++" primitive patches.\n") + putStr ("There are a total of "++ + (show (length test_patches))++" patches.\n") + defaultMain tests + +-- | Utility function to run bools with test-framework +testBool :: String -> Bool -> Test +testBool name test = testCase name (assertBool assertName test) + where assertName = "boolean test \"" ++ name ++ "\" should return True" + +-- | Utility function to run old tests that return a list of error messages, +-- with the empty list meaning success. +testStringList :: String -> [String] -> Test +testStringList name test = testCase name $ mapM_ assertFailure test + +-- | This is the big list of tests that will be run using testrunner. +tests :: [Test] +tests = patch_unit_tests ++ + [testBool "Checking that UTF-8 packing and unpacking preserves 'hello world'" + (unpackPSfromUTF8 (BC.pack "hello world") == "hello world"), + testBool "Checking that hex packing and unpacking preserves 'hello world'" + (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world") + == "hello world"), + testProperty "Checking that email can be parsed" + (\s -> + unlines ("":s++["", ""]) == + BC.unpack (read_email (renderPS + $ make_email "reponame" [] (Just (text "contents\n")) + (text $ unlines s) (Just "filename")))), + testProperty "Checking email header line length" email_header_no_long_lines, + testProperty "Checking email for illegal characters" email_header_ascii_chars, + testProperty "Checking for spaces at start of folded email header lines" email_header_lines_start, + testProperty "Checking that there are no empty lines in email headers" email_header_no_empty_lines, + testProperty "Checking that B.concat works" prop_concatPS, + testProperty "Checking that hex conversion works" prop_hex_conversion, + testProperty "Checking that show and read work right" prop_read_show, + testStringList "Checking known commutes" commute_tests, + testStringList "Checking known merges" merge_tests, + testStringList "Checking known canons" canonization_tests] + ++ check_subcommutes subcommutes_inverse "patch and inverse both commutex" + ++ check_subcommutes subcommutes_nontrivial_inverse "nontrivial commutes are correct" + ++ check_subcommutes subcommutes_failure "inverses fail" + ++ + [testProperty "Checking that commuting by patch and its inverse is ok" prop_commute_inverse, + --putStr "Checking that conflict resolution is valid... " + --runQuickCheckTest returnval prop_resolve_conflicts_valid + testProperty "Checking that a patch followed by its inverse is identity" prop_patch_and_inverse_is_identity, + -- The following tests are "wrong" with the Conflictor code. + --putStr "Checking that a simple smart_merge is sufficient... " + --runQuickCheckTest returnval prop_simple_smart_merge_good_enough + --putStr "Checking that an elegant merge is sufficient... " + --runQuickCheckTest returnval prop_elegant_merge_good_enough + testProperty "Checking that commutes are equivalent" prop_commute_equivalency, + testProperty "Checking that merges are valid" prop_merge_valid, + testProperty "Checking inverses being valid" prop_inverse_valid, + testProperty "Checking other inverse being valid" prop_other_inverse_valid, + testStringList "Checking merge swaps" merge_swap_tests, + -- The patch generator isn't smart enough to generate correct test + -- cases for the following: (which will be obsoleted soon, anyhow) + --putStr "Checking the order dependence of unravel... " + --runQuickCheckTest returnval prop_unravel_order_independent + --putStr "Checking the unravelling of three merges... " + --runQuickCheckTest returnval prop_unravel_three_merge + --putStr "Checking the unravelling of a merge of a sequence... " + --runQuickCheckTest returnval prop_unravel_seq_merge + testProperty "Checking inverse of inverse" prop_inverse_composition, + testProperty "Checking the order of commutes" prop_commute_either_order, + testProperty "Checking commutex either way" prop_commute_either_way, + testProperty "Checking the double commutex" prop_commute_twice, + testProperty "Checking that merges commutex and are well behaved" prop_merge_is_commutable_and_correct, + testProperty "Checking that merges can be swapped" prop_merge_is_swapable, + testProperty "Checking again that merges can be swapped (I'm paranoid) " prop_merge_is_swapable, + testStringList "Checking that the patch validation works" test_check, + testStringList "Checking commutex/recommute" commute_recommute_tests, + testStringList "Checking merge properties" generic_merge_tests, + testStringList "Testing the lcs code" show_lcs_tests, + testStringList "Checking primitive patch IO functions" primitive_show_read_tests, + testStringList "Checking IO functions" show_read_tests, + testStringList "Checking primitive commutex/recommute" primitive_commute_recommute_tests + ] +\end{code} + +\chapter{Unit Tester} + +The unit tester function is really just a glorified map for functions that +return lists, in which the lists get concatenated (where map would end up +with a list of lists). + +\begin{code} +type PatchUnitTest p = p -> [String] +type TwoPatchUnitTest = Patch -> Patch -> [String] + +parallel_pair_unit_tester :: TwoPatchUnitTest -> [(Patch:\/:Patch)] -> [String] +parallel_pair_unit_tester _ [] = [] +parallel_pair_unit_tester thetest ((p1:\/:p2):ps) + = (thetest p1 p2)++(parallel_pair_unit_tester thetest ps) + +pair_unit_tester :: TwoPatchUnitTest -> [(Patch: [String] +pair_unit_tester _ [] = [] +pair_unit_tester thetest ((p1: String -> Bool +email_header_no_long_lines field value = + not $ any (>78) $ map B.length $ bs_lines $ formatHeader cleanField value + where cleanField = clean_field_string field + +bs_lines :: B.ByteString -> [B.ByteString] +bs_lines = finalizeFold . B.foldr splitAtLines (B.empty, []) + where splitAtLines 10 (thisLine, prevLines) = (B.empty, thisLine:prevLines) + splitAtLines c (thisLine, prevLines) = (B.cons c thisLine, prevLines) + finalizeFold (lastLine, otherLines) = lastLine : otherLines + +-- Check that an email header does not contain non-ASCII characters +-- formatHeader doesn't escape field names, there is no such thing as non-ascii +-- field names afaik +email_header_ascii_chars :: String -> String -> Bool +email_header_ascii_chars field value + = not (any (>127) (B.unpack (formatHeader cleanField value))) + where cleanField = clean_field_string field + +-- Check that header the second and later lines of a header start with a space +email_header_lines_start :: String -> String -> Bool +email_header_lines_start field value = + all (\l -> B.null l || B.head l == 32) (tail headerLines) + where headerLines = bs_lines (formatHeader cleanField value) + cleanField = clean_field_string field + +-- Checks that there are no lines in email headers with only whitespace +email_header_no_empty_lines :: String -> String -> Bool +email_header_no_empty_lines field value = + all (not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines + where headerLines = bs_lines (formatHeader cleanField value) + cleanField = clean_field_string field + +clean_field_string :: String -> String +clean_field_string = filter (\c -> isPrint c && c < '\x80' && c /= ':') + +\end{code} + +\chapter{LCS} + +Here are a few quick tests of the shiftBoundaries function. + +\begin{code} +show_lcs_tests :: [String] +show_lcs_tests = concatMap check_known_shifts known_shifts +check_known_shifts :: ([Int],[Int],String,String,[Int],[Int]) + -> [String] +check_known_shifts (ca, cb, sa, sb, ca', cb') = runST ( + do ca_arr <- newListArray (0, length ca) $ toBool (0:ca) + cb_arr <- newListArray (0, length cb) $ toBool (0:cb) + let p_a = listArray (0, length sa) $ B.empty:(toPS sa) + p_b = listArray (0, length sb) $ B.empty:(toPS sb) + shiftBoundaries ca_arr cb_arr p_a 1 1 + shiftBoundaries cb_arr ca_arr p_b 1 1 + ca_res <- fmap (fromBool . tail) $ getElems ca_arr + cb_res <- fmap (fromBool . tail) $ getElems cb_arr + return $ if ca_res == ca' && cb_res == cb' then [] + else ["shiftBoundaries failed on "++sa++" and "++sb++" with " + ++(show (ca,cb))++" expected "++(show (ca', cb')) + ++" got "++(show (ca_res, cb_res))++"\n"]) + where toPS = map (\c -> if c == ' ' then B.empty else BC.pack [c]) + toBool = map (>0) + fromBool = map (\b -> if b then 1 else 0) + +known_shifts :: [([Int],[Int],String,String,[Int],[Int])] +known_shifts = + [([0,0,0],[0,1,0,1,0],"aaa","aaaaa", + [0,0,0],[0,0,0,1,1]), + ([0,1,0],[0,1,1,0],"cd ","c a ", + [0,1,0],[0,1,1,0]), + ([1,0,0,0,0,0,0,0,0],[1,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","dg{} ih{} if{}", + [1,0,0,0,0,0,0,0,0],[1,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end + ([0,0,0,0,0,0,0,0,0],[0,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","fg{} ih{} if{}", + [0,0,0,0,0,0,0,0,0],[0,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end + ([],[1,1],"","aa",[],[1,1]), + ([1,1],[],"aa","",[1,1],[])] + + +\end{code} + +\chapter{Show/Read tests} + +This test involves calling ``show'' to print a string describing a patch, +and then using readPatch to read it back in, and making sure the patch we +read in is the same as the original. Useful for making sure that I don't +have any stupid IO bugs. + +\begin{code} +show_read_tests :: [String] +show_read_tests = concatMap t_show_read test_patches ++ + concatMap t_show_read test_patches_named +primitive_show_read_tests :: [String] +primitive_show_read_tests = concatMap t_show_read primitive_test_patches +t_show_read :: (Eq p, Show p, Patchy p) => PatchUnitTest p +t_show_read p = + case readPatch $ renderPS $ showPatch p of + Just (Sealed p',_) -> if p' == p then [] + else ["Failed to read shown: "++(show p)++"\n"] + Nothing -> ["Failed to read at all: "++(show p)++"\n"] + +instance MyEq p => Eq (Named p) where + (==) = unsafeCompare +\end{code} + +\chapter{Canonization tests} + +This is a set of known correct canonizations, to make sure that I'm +canonizing as I ought. + +\begin{code} +canonization_tests :: [String] +canonization_tests = concatMap check_known_canon known_canons +check_known_canon :: (Patch, Patch) -> [String] +check_known_canon (p1,p2) = + if (fromPrims $ concatFL $ mapFL_FL canonize $ sort_coalesceFL $ effect p1) == p2 + then [] + else ["Canonization failed:\n"++show p1++"canonized is\n" + ++show (fromPrims $ concatFL $ mapFL_FL canonize $ sort_coalesceFL $ effect p1 :: Patch) + ++"which is not\n"++show p2] +known_canons :: [(Patch,Patch)] +known_canons = + [(quickhunk 1 "abcde" "ab", quickhunk 3 "cde" ""), + (quickhunk 1 "abcde" "bd", join_patches [quickhunk 1 "a" "", + quickhunk 2 "c" "", + quickhunk 3 "e" ""]), + (join_patches [quickhunk 4 "a" "b", + quickhunk 1 "c" "d"], + join_patches [quickhunk 1 "c" "d", + quickhunk 4 "a" "b"]), + (join_patches [quickhunk 1 "a" "", + quickhunk 1 "" "b"], + quickhunk 1 "a" "b"), + (join_patches [quickhunk 1 "ab" "c", + quickhunk 1 "cd" "e"], + quickhunk 1 "abd" "e"), + (quickhunk 1 "abcde" "cde", quickhunk 1 "ab" ""), + (quickhunk 1 "abcde" "acde", quickhunk 2 "b" "")] +quickhunk :: Int -> String -> String -> Patch +quickhunk l o n = fromPrim $ hunk "test" l (map (\c -> BC.pack [c]) o) + (map (\c -> BC.pack [c]) n) +\end{code} + +\chapter{Merge/unmgerge tests} + +It should always be true that if two patches can be unmerged, then merging +the resulting patches should give them back again. +\begin{code} +generic_merge_tests :: [String] +generic_merge_tests = + case take 400 [(p1:\/:p2)| + i <- [0..(length test_patches)-1], + p1<-[test_patches!!i], + p2<-drop i test_patches, + check_a_patch $ join_patches [invert p2,p1]] of + merge_pairs -> (parallel_pair_unit_tester t_merge_either_way_valid merge_pairs) ++ + (parallel_pair_unit_tester t_merge_swap_merge merge_pairs) +t_merge_either_way_valid :: TwoPatchUnitTest +t_merge_either_way_valid p1 p2 = + case join_patches [p2, quickmerge (p1:\/: p2)] of + combo2 -> + case join_patches [p1, quickmerge (p2:\/: p1)] of + combo1 -> + if not $ check_a_patch $ join_patches [combo1] + then ["oh my combo1 invalid:\n"++show p1++"and...\n"++show p2++show combo1] + else + if check_a_patch $ join_patches [invert combo1, combo2] + then [] + else ["merge both ways invalid:\n"++show p1++"and...\n"++show p2++ + show combo1++ + show combo2] +t_merge_swap_merge :: TwoPatchUnitTest +t_merge_swap_merge p1 p2 = + if (swapp $ merge (p2:\/: p1)) == merge (p1:\/:p2) + then [] + else ["Failed to swap merges:\n"++show p1++"and...\n"++show p2 + ++"merged:\n"++show (merge (p1:\/:p2))++"\n" + ++"merged and swapped:\n"++show (swapp $ merge (p2:\/: p1))++"\n"] + where swapp (x :/\: y) = y :/\: x + +instance Show p => Show (p :/\: p) where + show (x :/\: y) = show x ++ " :/\\: " ++ show y +instance Eq p => Eq (p :/\: p) where + (x :/\: y) == (x' :/\: y') = x == x' && y == y' +\end{code} + +\chapter{Commute/recommute tests} + +Here we test to see if commuting patch A and patch B and then commuting the +result gives us patch A and patch B again. The set of patches (A,B) is +chosen from the set of all pairs of test patches by selecting those which +commutex with one another. + +\begin{code} +commute_recommute_tests :: [String] +commute_recommute_tests = + case take 200 [(p2:checkseq [p1,p]) test_patches, + commutex (p2: pair_unit_tester t_commute_recommute commute_pairs + where checkseq ps = check_a_patch $ join_patches ps +primitive_commute_recommute_tests :: [String] +primitive_commute_recommute_tests = + pair_unit_tester t_commute_recommute + [(p1:>= commutex) == Just (p1:>= commutex) + ++ "\n"] +\end{code} + +\chapter{Commute tests} + +Here we provide a set of known interesting commutes. +\begin{code} +commute_tests :: [String] +commute_tests = + concatMap check_known_commute known_commutes++ + concatMap check_cant_commute known_cant_commute +check_known_commute :: (Patch:< Patch, Patch:< Patch) -> [String] +check_known_commute (p1: + if (p2a:< p1a) == (p2':< p1') + then [] + else ["Commute gave wrong value!\n"++show p1++"\n"++show p2 + ++"should be\n"++show p2'++"\n"++show p1' + ++"but is\n"++show p2a++"\n"++show p1a] + Nothing -> ["Commute failed!\n"++show p1++"\n"++show p2] + ++ + case commutex (p2': + if (p1a:< p2a) == (p1:< p2) + then [] + else ["Commute gave wrong value!\n"++show p2a++"\n"++show p1a + ++"should have been\n"++show p2'++"\n"++show p1'] + Nothing -> ["Commute failed!\n"++show p2'++"\n"++show p1'] +known_commutes :: [(Patch: [String] +check_cant_commute (p1: [] + _ -> [show p1 ++ "\n\n" ++ show p2 ++ + "\nArgh, these guys shouldn't commutex!\n"] +known_cant_commute :: [(Patch:< Patch)] +known_cant_commute = [ + (testhunk 2 ["o"] ["n"]:< + testhunk 1 [] ["A"]), + (testhunk 1 [] ["A"]:< + testhunk 1 ["o"] ["n"]), + (quickmerge (testhunk 2 ["o"] ["n"]:\/: + testhunk 2 ["o"] ["v"]):< + testhunk 1 [] ["a"]), + (fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])):< + fromPrim (addfile "test"))] + where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n) +\end{code} + +\chapter{Merge tests} + +Here we provide a set of known interesting merges. +\begin{code} +merge_tests :: [String] +merge_tests = + concatMap check_known_merge_equiv known_merge_equivs++ + concatMap check_known_merge known_merges +check_known_merge :: (Patch:\/: Patch, Patch:< Patch) -> [String] +check_known_merge (p1:\/:p2,p1': + if (p1a:< p2) == (p1':< p2') + then [] + else ["Merge gave wrong value!\n"++show p1++show p2 + ++"I expected\n"++show p1'++show p2' + ++"but found instead\n"++show p1a] +known_merges :: [(Patch:\/:Patch,Patch: [String] +check_known_merge_equiv (p1:\/: p2, pe) = + case quickmerge (p1:\/:p2) of + p1' -> if check_a_patch $ join_patches [invert p1, p2, p1', invert pe] + then [] + else ["Oh no, merger isn't equivalent...\n"++show p1++"\n"++show p2 + ++"in other words\n" ++ show (p1 :\/: p2) + ++"merges as\n" ++ show (merge $ p1 :\/: p2) + ++"merges to\n" ++ show (quickmerge $ p1 :\/: p2) + ++"which is equivalent to\n" ++ show (effect p1') + ++ "should all work out to\n" + ++ show pe] +known_merge_equivs :: [(Patch:\/: Patch, Patch)] +known_merge_equivs = [ + + -- The following tests are going to be failed by the + -- Conflictor code as a cleanup. + + --(addfile "test":\/: + -- adddir "test", + -- join_patches [adddir "test", + -- addfile "test-conflict"]), + --(move "silly" "test":\/: + -- adddir "test", + -- join_patches [adddir "test", + -- move "silly" "test-conflict"]), + --(addfile "test":\/: + -- move "old" "test", + -- join_patches [addfile "test", + -- move "old" "test-conflict"]), + --(move "a" "test":\/: + -- move "old" "test", + -- join_patches [move "a" "test", + -- move "old" "test-conflict"]), + (fromPrim (hunk "test" 1 [] [BC.pack "A"]):\/: + fromPrim (hunk "test" 1 [] [BC.pack "B"]), + fromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])), + (fromPrim (hunk "test" 1 [] [BC.pack "a"]):\/: + fromPrim (hunk "test" 1 [BC.pack "b"] []), + identity), + --hunk "test" 1 [] [BC.pack "v v v v v v v", + -- BC.pack "*************", + -- BC.pack "a", + -- BC.pack "b", + -- BC.pack "^ ^ ^ ^ ^ ^ ^"]), + (quickhunk 4 "a" "":\/: + quickhunk 3 "a" "", + quickhunk 3 "aa" ""), + (join_patches [quickhunk 1 "a" "bc", + quickhunk 6 "d" "ef"]:\/: + join_patches [quickhunk 3 "a" "bc", + quickhunk 8 "d" "ef"], + join_patches [quickhunk 3 "a" "bc", + quickhunk 8 "d" "ef", + quickhunk 1 "a" "bc", + quickhunk 7 "d" "ef"]), + (quickmerge (quickhunk 2 "" "bd":\/:quickhunk 2 "" "a"):\/: + quickmerge (quickhunk 2 "" "c":\/:quickhunk 2 "" "a"), + quickhunk 2 "" "abdc") + ] +\end{code} + +It also is useful to verify that it doesn't matter which order we specify +the patches when we merge. + +\begin{code} +merge_swap_tests :: [String] +merge_swap_tests = + concat + [check_merge_swap p1 p2 | + p1<-primitive_test_patches, + p2<-primitive_test_patches, + check_a_patch $ join_patches [invert p1,p2] + ] +check_merge_swap :: Patch -> Patch -> [String] +check_merge_swap p1 p2 = + case merge (p2:\/:p1) of + _ :/\: p2' -> + case merge (p1:\/:p2) of + _ :/\: p1' -> + case commutex (p2': + if p1'b /= p1' + then ["Merge swapping problem with...\np1 "++ + show p1++"merged with\np2 "++ + show p2++"p1' is\np1' "++ + show p1'++"p1'b is\np1'b "++ + show p1'b + ] + else [] + Nothing -> ["Merge commuting problem with...\np1 "++ + show p1++"merged with\np2 "++ + show p2++"gives\np2' "++ + show p2'++"which doesn't commutex with p1.\n" + ] +\end{code} + +\chapter{Patch test data} + +This is where we define the set of patches which we run our tests on. This +should be kept up to date with as many interesting permutations of patch +types as possible. + +\begin{code} +test_patches :: [Patch] +test_patches_named :: [Named Patch] +test_patches_addfile :: [Patch] +test_patches_rmfile :: [Patch] +test_patches_hunk :: [Patch] +primitive_test_patches :: [Patch] +test_patches_binary :: [Patch] +test_patches_composite_nocom :: [Patch] +test_patches_composite :: [Patch] +test_patches_two_composite_hunks :: [Patch] +test_patches_composite_hunks :: [Patch] +test_patches_composite_four_hunks :: [Patch] +test_patches_merged :: [Patch] +valid_patches :: [Patch] + +test_patches_named = [unsafePerformIO $ + namepatch "date is" "patch name" "David Roundy" [] + (fromPrim $ addfile "test"), + unsafePerformIO $ + namepatch "Sat Oct 19 08:31:13 EDT 2002" + "This is another patch" "David Roundy" + ["This log file has","two lines in it"] + (fromPrim $ rmfile "test")] +test_patches_addfile = map fromPrim + [addfile "test",adddir "test",addfile "test/test"] +test_patches_rmfile = map invert test_patches_addfile +test_patches_hunk = + [fromPrim $ hunk file line old new | + file <- ["test"], + line <- [1,2], + old <- map (map BC.pack) partials, + new <- map (map BC.pack) partials, + old /= new + ] + where partials = [["A"],["B"],[],["B","B2"]] + +primitive_test_patches = test_patches_addfile ++ + test_patches_rmfile ++ + test_patches_hunk ++ + [unsafeUnseal.fst.fromJust.readPatch $ + BC.pack "move ./test/test ./hello", + unsafeUnseal.fst.fromJust.readPatch $ + BC.pack "move ./test ./hello"] ++ + test_patches_binary + +test_patches_binary = + [fromPrim $ binary "./hello" + (BC.pack $ "agadshhdhdsa75745457574asdgg" ++ + "a326424677373735753246463gadshhdhdsaasdgg" ++ + "a326424677373735753246463gadshhdhdsaasdgg" ++ + "a326424677373735753246463gadshhdhdsaasdgg") + (BC.pack $ "adafjttkykrehhtrththrthrthre" ++ + "a326424677373735753246463gadshhdhdsaasdgg" ++ + "a326424677373735753246463gadshhdhdsaasdgg" ++ + "a326424677373735753246463gadshhdhdsaagg"), + fromPrim $ binary "./hello" + B.empty + (BC.pack "adafjttkykrere")] + +test_patches_composite_nocom = + take 50 [join_patches [p1,p2]| + p1<-primitive_test_patches, + p2<-filter (\p->checkseq [p1,p]) primitive_test_patches, + commutex (p2:checkseq [p1,p]) primitive_test_patches, + commutex (p2:checkseq [p1,p]) test_patches_hunk] + where checkseq ps = check_a_patch $ join_patches ps + +test_patches_composite_hunks = + take 100 [join_patches [p1,p2,p3]| + p1<-test_patches_hunk, + p2<-filter (\p->checkseq [p1,p]) test_patches_hunk, + p3<-filter (\p->checkseq [p1,p2,p]) test_patches_hunk] + where checkseq ps = check_a_patch $ join_patches ps + +test_patches_composite_four_hunks = + take 100 [join_patches [p1,p2,p3,p4]| + p1<-test_patches_hunk, + p2<-filter (\p->checkseq [p1,p]) test_patches_hunk, + p3<-filter (\p->checkseq [p1,p2,p]) test_patches_hunk, + p4<-filter (\p->checkseq [p1,p2,p3,p]) test_patches_hunk] + where checkseq ps = check_a_patch $ join_patches ps + +test_patches_merged = + take 200 + [joinPatches $ flattenFL p2+>+flattenFL (quickmerge (p1:\/:p2)) | + p1<-take 10 (drop 15 test_patches_composite_hunks)++primitive_test_patches + ++take 10 (drop 15 test_patches_two_composite_hunks) + ++ take 2 (drop 4 test_patches_composite_four_hunks), + p2<-take 10 test_patches_composite_hunks++primitive_test_patches + ++take 10 test_patches_two_composite_hunks + ++take 2 test_patches_composite_four_hunks, + check_a_patch $ join_patches [invert p1, p2], + commutex (p1: Bool +prop_hex_conversion s = + fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s +prop_concatPS :: [String] -> Bool +prop_concatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss) + +-- | Groups a set of tests by giving them the same prefix in their description. +-- When this is called as @check_subcommutes subcoms expl@, the prefix for a +-- test becomes @"Checking " ++ expl ++ " for subcommute "@. +check_subcommutes :: Testable a => [(String, a)] -> String + -> [Test] +check_subcommutes subcoms expl = map check_subcommute subcoms + where check_subcommute (name, test) = + let testName = "Checking" ++ expl ++ " for subcommute " ++ name + in testProperty testName test +\end{code} + +\end{document} + + diff --git a/src/win32/CtrlC.hs b/src/win32/CtrlC.hs new file mode 100644 --- /dev/null +++ b/src/win32/CtrlC.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module CtrlC (withCtrlCHandler) where + +import Data.Word ( Word32 ) +import Foreign.Ptr ( FunPtr ) +import Control.Exception ( bracket ) + +type Handler = Word32 -> IO Int + +foreign import ccall "wrapper" wrap :: Handler -> IO (FunPtr Handler) +foreign import stdcall "SetConsoleCtrlHandler" setConsoleCtrlHandler :: FunPtr Handler -> Int -> IO () + + +withCtrlCHandler :: IO () -> IO a -> IO a +withCtrlCHandler handler m = do + fp <- wrap (\_ctrlType -> handler >> return 1) + bracket (setConsoleCtrlHandler fp 1) (const $ setConsoleCtrlHandler fp 0) (const m) + + + diff --git a/src/win32/System/Posix.hs b/src/win32/System/Posix.hs new file mode 100644 --- /dev/null +++ b/src/win32/System/Posix.hs @@ -0,0 +1,43 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.Posix where + +import Foreign.Ptr ( Ptr, castPtr, plusPtr ) +import Foreign.Storable ( peek, poke, sizeOf ) +import Foreign.C.Types ( CInt, CUInt, CULong, CTime ) +import Foreign.C.String ( CString, withCString ) +import Foreign.Marshal.Alloc ( allocaBytes ) + +import System.Posix.Types ( EpochTime ) +import System.IO ( Handle ) + + +foreign import ccall "sys/utime.h _utime" c_utime :: CString -> Ptr a -> IO CInt + +setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO () +setFileTimes path atime mtime = path `withCString` \s -> do + allocaBytes 8 $ \p -> do + poke (castPtr p :: Ptr CTime) (atime) + poke (castPtr (plusPtr p 4) :: Ptr CTime) (mtime) + c_utime s p + return () + + +foreign import ccall "time" c_ctime :: Ptr CTime -> IO CInt + +epochTime :: IO EpochTime +epochTime = do + allocaBytes (sizeOf (undefined :: CTime)) $ \p -> do + c_ctime p + t <- peek p :: IO CTime + return t + +foreign import stdcall "winbase.h SleepEx" c_SleepEx :: CULong -> CUInt -> IO CInt + +sleep :: Integer -> IO CInt +sleep n = c_SleepEx (1000 * fromIntegral n) 1 + +handleToFd :: Handle -> IO Int +handleToFd _ = fail "handleToFd not supported!" + diff --git a/src/win32/System/Posix/Files.hsc b/src/win32/System/Posix/Files.hsc new file mode 100644 --- /dev/null +++ b/src/win32/System/Posix/Files.hsc @@ -0,0 +1,97 @@ +{-# OPTIONS_GHC -cpp #-} +module System.Posix.Files where + +import Foreign.Marshal.Alloc ( allocaBytes ) +import Foreign.C.Error ( throwErrnoIfMinus1Retry, throwErrnoPathIf_ ) +import Foreign.C.String ( withCString, withCWString, CWString ) +import Foreign.C.Types ( CTime, CInt ) +import Foreign.Ptr ( Ptr, nullPtr ) + +import System.Posix.Internals + ( FDType, CStat, c_fstat, lstat, + sizeof_stat, statGetType, + st_mode, st_size, st_mtime, + s_isreg, s_isdir, s_isfifo, ) +import System.Posix.Types ( Fd(..), CMode, EpochTime, FileMode ) + +import Data.Bits ( (.|.) ) + +#if mingw32_HOST_OS +import Data.Int ( Int64 ) +#else +import System.Posix.Types ( FileOffset ) +#endif + +##if mingw32_HOST_OS +type FileOffset = Int64 +##endif + +data FileStatus = FileStatus { + fst_type :: FDType, + fst_mode :: CMode, + fst_mtime :: CTime, + fst_size :: FileOffset + } + +getFdStatus :: Fd -> IO FileStatus +getFdStatus (Fd fd) = do + do_stat (c_fstat fd) + +do_stat :: (Ptr CStat -> IO CInt) -> IO FileStatus +do_stat stat_func = do + allocaBytes sizeof_stat $ \p -> do + throwErrnoIfMinus1Retry "do_stat" $ + stat_func p + tp <- statGetType p + mode <- st_mode p + mtime <- st_mtime p + size <- st_size p + return (FileStatus tp mode mtime (fromIntegral size)) + +isNamedPipe :: FileStatus -> Bool +isNamedPipe = s_isfifo . fst_mode + +isDirectory :: FileStatus -> Bool +isDirectory = s_isdir . fst_mode + +isRegularFile :: FileStatus -> Bool +isRegularFile = s_isreg . fst_mode + +isSymbolicLink :: FileStatus -> Bool +isSymbolicLink = const False + +linkCount :: FileStatus -> Int +linkCount _ = 1 + +modificationTime :: FileStatus -> EpochTime +modificationTime = fst_mtime + +fileSize :: FileStatus -> FileOffset +fileSize = fst_size + +fileMode :: () -> () +fileMode _ = () + +getFileStatus :: FilePath -> IO () +getFileStatus _ = return () + +setFileMode :: FilePath -> () -> IO () +setFileMode _ _ = return () + +#include +stdFileMode :: FileMode +stdFileMode = (#const S_IRUSR) .|. (#const S_IWUSR) + + + +getSymbolicLinkStatus :: FilePath -> IO FileStatus +getSymbolicLinkStatus fp = + do_stat (\p -> (fp `withCString` (`lstat` p))) + +#define _WIN32_WINNT 0x0500 +foreign import stdcall "winbase.h CreateHardLinkW" c_CreateHardLink :: CWString -> CWString -> Ptr a -> IO CInt + +createLink :: FilePath -> FilePath -> IO () +createLink old new = withCWString old $ \c_old -> withCWString new $ \c_new -> + throwErrnoPathIf_ (==0) "createLink" new $ + c_CreateHardLink c_new c_old nullPtr diff --git a/src/win32/System/Posix/IO.hsc b/src/win32/System/Posix/IO.hsc new file mode 100644 --- /dev/null +++ b/src/win32/System/Posix/IO.hsc @@ -0,0 +1,69 @@ +module System.Posix.IO where + +import Foreign.C.String ( withCString ) +import Foreign.C.Error ( throwErrnoIfMinus1, throwErrnoIfMinus1_ ) + +import GHC.Handle ( fdToHandle ) + +import System.Posix.Internals ( c_open, c_close, c_dup2 ) +import System.Posix.Types ( Fd(..), FileMode ) +import System.IO ( Handle ) + +import Data.Bits ( (.|.) ) + + +stdOutput :: Fd +stdOutput = Fd 1 + +stdError :: Fd +stdError = Fd 2 + +data OpenFileFlags = + OpenFileFlags { + append :: Bool, + exclusive :: Bool, + noctty :: Bool, + nonBlock :: Bool, + trunc :: Bool + } + + +-- Adapted from System.Posix.IO in ghc +#include + +openFd :: FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd +openFd name how maybe_mode off = do + withCString name $ \s -> do + fd <- throwErrnoIfMinus1 "openFd" (c_open s all_flags mode_w) + return (Fd fd) + where + all_flags = binary .|. creat .|. flags .|. open_mode + flags = + (if append off then (#const O_APPEND) else 0) .|. + (if exclusive off then (#const O_EXCL) else 0) .|. + (if trunc off then (#const O_TRUNC) else 0) + binary = (#const O_BINARY) + (creat, mode_w) = maybe (0,0) (\x->((#const O_CREAT),x)) maybe_mode + open_mode = case how of + ReadOnly -> (#const O_RDONLY) + WriteOnly -> (#const O_WRONLY) + ReadWrite -> (#const O_RDWR) + +closeFd :: Fd -> IO () +closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd) + + +fdToHandle :: Fd -> IO Handle +fdToHandle fd = GHC.Handle.fdToHandle (fromIntegral fd) + +dupTo :: Fd -> Fd -> IO Fd +dupTo (Fd fd1) (Fd fd2) = do + r <- throwErrnoIfMinus1 "dupTo" (c_dup2 fd1 fd2) + return (Fd r) + +data OpenMode = ReadOnly | WriteOnly | ReadWrite + +defaultFileFlags :: OpenFileFlags +defaultFileFlags = OpenFileFlags False False False False False + + diff --git a/src/win32/send_email.c b/src/win32/send_email.c new file mode 100644 --- /dev/null +++ b/src/win32/send_email.c @@ -0,0 +1,211 @@ + + +#include +#include +#include + +#include "send_email.h" + +typedef struct sMapiFuns { + LPMAPILOGON logon; + LPMAPISENDMAIL sendmail; + LPMAPIRESOLVENAME resolve; + LPMAPIFREEBUFFER free_buf; + LPMAPILOGOFF logoff; + HMODULE dll; +} MapiFuns; + + +int load_dll(const char* name, MapiFuns* funs); +void free_dll(MapiFuns* funs); + +void get_recipient(MapiFuns* funs, const char *name, ULONG recipClass, MapiRecipDesc *desc, lpMapiRecipDesc *desc_lookup); + +int send_email(const char *sendname, + const char *recvname, + const char *ccname, + const char *subj, + const char *body, + const char *path) +{ + FLAGS flags; + MapiMessage msg; + ULONG send_res; + MapiRecipDesc orig; + MapiRecipDesc recips[2]; + MapiRecipDesc *orig_lookup, *recip_lookup, *cc_lookup; + int num_recip = 1, return_code = -1; + MapiFileDesc attachment; + MapiFileTagExt file_type; + const char *filename; + char *attachment_path = 0; + MapiFuns funs; + + if(load_dll("mapistub.dll", &funs) || load_dll("mapi32.dll", &funs)) { + return_code=0; + } else { + fprintf(stderr, "Unable to load mapistub.dll or mapi32.dll: Bailing out. \n"); + return_code=-1; + } + + if(return_code==0) { + LHANDLE session; + /* logon seems to be necessary for outlook express, sometimes, + and doesn't seem to hurt, otherwise. + */ + funs.logon(0, 0, 0, MAPI_LOGON_UI, 0, &session); + + + orig_lookup = recip_lookup = cc_lookup = NULL; + + get_recipient(&funs, sendname, MAPI_ORIG, &orig, &orig_lookup); + get_recipient(&funs, recvname, MAPI_TO, &recips[0], &recip_lookup); + + if (ccname && strlen(ccname) > 0) { + get_recipient(&funs, ccname, MAPI_CC, &recips[1], &cc_lookup); + num_recip++; + } + + memset(&msg, 0, sizeof(msg)); + msg.lpOriginator = &orig; + msg.lpRecips = recips; + msg.lpszMessageType = "text/plain"; + msg.lpszNoteText = (LPSTR) body; + msg.lpszSubject = (LPSTR)subj; + msg.nRecipCount = num_recip; + msg.flFlags = 0; + + if (path) { + attachment_path = strdup(path); + /* convert / to \ (thunderbird doesn't like /) */ + char *p = attachment_path; + while ((p = strchr(p, '/'))) + *p = '\\'; + + /* find filename */ + filename = strrchr(attachment_path, '\\'); + if (filename == 0) + filename = attachment_path; + else + filename++; + + memset(&attachment, 0, sizeof(attachment)); + attachment.nPosition = -1; + attachment.lpszPathName = (LPTSTR)attachment_path; + attachment.lpszFileName = (LPTSTR)filename; + + attachment.lpFileType = &file_type; + + memset(&file_type, 0, sizeof(file_type)); + file_type.lpTag = "text/plain"; + file_type.cbTag = sizeof(file_type.lpTag); + + msg.nFileCount = 1; + msg.lpFiles = &attachment; + } + + flags = 0; + send_res = funs.sendmail(0, 0, &msg, flags, 0); + + if (send_res == SUCCESS_SUCCESS) + return_code = 0; + else { + return_code=-1; + if(send_res==MAPI_E_USER_ABORT) fprintf(stderr, "MAPI error: User aborted.\n"); + else if(send_res== MAPI_E_FAILURE) fprintf(stderr, "MAPI error: Generic error.\n"); + else if(send_res== MAPI_E_LOGIN_FAILURE) fprintf(stderr, "MAPI error: Login failure.\n"); + else if(send_res== MAPI_E_DISK_FULL) fprintf(stderr, "MAPI error: Disk full.\n"); + else if(send_res== MAPI_E_INSUFFICIENT_MEMORY) fprintf(stderr, "MAPI error: Insufficient memory.\n"); + else if(send_res== MAPI_E_ACCESS_DENIED) fprintf(stderr, "MAPI error: Access denied.\n"); + else if(send_res== MAPI_E_TOO_MANY_SESSIONS) fprintf(stderr, "MAPI error: Too many sessions\n"); + else if(send_res== MAPI_E_TOO_MANY_FILES) fprintf(stderr, "MAPI error: Too many files.\n"); + else if(send_res== MAPI_E_TOO_MANY_RECIPIENTS) fprintf(stderr, "MAPI error: Too many recipients.\n"); + else if(send_res== MAPI_E_ATTACHMENT_NOT_FOUND) fprintf(stderr, "MAPI error: Attachment not found.\n"); + else if(send_res== MAPI_E_ATTACHMENT_OPEN_FAILURE) fprintf(stderr, "MAPI error: Failed to open attachment.\n"); + else if(send_res== MAPI_E_ATTACHMENT_WRITE_FAILURE) fprintf(stderr, "MAPI error: Failed to write attachment.\n"); + else if(send_res== MAPI_E_UNKNOWN_RECIPIENT) fprintf(stderr, "MAPI error: Unknown recipient\n"); + else if(send_res== MAPI_E_BAD_RECIPTYPE) fprintf(stderr, "MAPI error: Bad type of recipent.\n"); + else if(send_res== MAPI_E_NO_MESSAGES) fprintf(stderr, "MAPI error: No messages.\n"); + else if(send_res== MAPI_E_INVALID_MESSAGE) fprintf(stderr, "MAPI error: Invalid message.\n"); + else if(send_res== MAPI_E_TEXT_TOO_LARGE) fprintf(stderr, "MAPI error: Text too large.\n"); + else if(send_res== MAPI_E_INVALID_SESSION) fprintf(stderr, "MAPI error: Invalid session.\n"); + else if(send_res== MAPI_E_TYPE_NOT_SUPPORTED) fprintf(stderr, "MAPI error: Type not supported.\n"); + else if(send_res== MAPI_E_AMBIGUOUS_RECIP) fprintf(stderr, "MAPI error: Ambigious recipient.\n"); + else if(send_res== MAPI_E_MESSAGE_IN_USE) fprintf(stderr, "MAPI error: Messag in use.\n"); + else if(send_res== MAPI_E_NETWORK_FAILURE) fprintf(stderr, "MAPI error: Network failure.\n"); + else if(send_res== MAPI_E_INVALID_EDITFIELDS) fprintf(stderr, "MAPI error: Invalid editfields\n"); + else if(send_res== MAPI_E_INVALID_RECIPS) fprintf(stderr, "MAPI error: Invalid recipient(s)\n"); + else if(send_res== MAPI_E_NOT_SUPPORTED) fprintf(stderr, "MAPI error: Operation not supported.\n"); + else fprintf(stderr, "MAPISendMail returned %ld\n", send_res); + } + + + if (orig_lookup) funs.free_buf(orig_lookup); + if (recip_lookup) funs.free_buf(recip_lookup); + if (cc_lookup) funs.free_buf(cc_lookup); + if (attachment_path) free(attachment_path); + + funs.logoff(session, 0, 0, 0); + } + free_dll(&funs); + return return_code; +} + +void get_recipient(MapiFuns* funs, const char *name, ULONG recipClass, MapiRecipDesc *desc, lpMapiRecipDesc *desc_lookup) { + ULONG ret = funs->resolve(0, 0, (LPSTR) name, 0, 0, desc_lookup); + if (ret == SUCCESS_SUCCESS) { + memcpy(desc, *desc_lookup, sizeof(MapiRecipDesc)); + } else { + /* Default to something sensible if MAPIResolveName is not supported + * by the mail client (thunderbird) + */ + memset(desc, 0, sizeof(MapiRecipDesc)); + desc->lpszName = (LPSTR)name; + desc->lpszAddress = (LPSTR)name; + desc->lpEntryID = 0; + desc->ulEIDSize = 0; + } + desc->ulRecipClass = recipClass; +} + + +int load_dll(const char* name, MapiFuns* funs) { + funs->dll = 0; + funs->dll = LoadLibrary(name); + if(funs->dll!=NULL) { + /* We try first loading by easy name, then by ordinal, and then by other names seen */ + funs->logon = (LPMAPILOGON) GetProcAddress(funs->dll, "MAPILogon"); + if(funs->logon==NULL) + funs->logon = (LPMAPILOGON) GetProcAddress(funs->dll, (LPCSTR)209); + + funs->logoff = (LPMAPILOGOFF) GetProcAddress(funs->dll, "MAPILogOff"); + if(funs->logoff==NULL) + funs->logoff = (LPMAPILOGOFF) GetProcAddress(funs->dll, (LPCSTR)210); + + funs->resolve = (LPMAPIRESOLVENAME) GetProcAddress(funs->dll, "MAPIResolveName"); + if(funs->resolve==NULL) + funs->resolve = (LPMAPIRESOLVENAME) GetProcAddress(funs->dll, (LPCSTR)219); + + funs->free_buf = (LPMAPIFREEBUFFER) GetProcAddress(funs->dll, "MAPIFreeBuffer"); + if(funs->free_buf==NULL) + funs->free_buf = (LPMAPIFREEBUFFER) GetProcAddress(funs->dll, (LPCSTR)16); + if(funs->free_buf==NULL) + funs->free_buf = (LPMAPIFREEBUFFER) GetProcAddress(funs->dll, "MAPIFreeBuffer@4"); + + funs->sendmail = (LPMAPISENDMAIL) GetProcAddress(funs->dll, "MAPISendMail"); + if(funs->sendmail==NULL) + funs->sendmail = (LPMAPISENDMAIL) GetProcAddress(funs->dll, (LPCSTR)211); + } + return + funs->dll!=NULL + && funs->logon!=NULL + && funs->logoff!=NULL + && funs->resolve!=NULL + && funs->free_buf!=NULL + && funs->sendmail!=NULL; +} +void free_dll(MapiFuns* funs) { + if(funs->dll!=NULL) FreeLibrary(funs->dll); + funs->dll=NULL; +} + diff --git a/src/win32/send_email.h b/src/win32/send_email.h new file mode 100644 --- /dev/null +++ b/src/win32/send_email.h @@ -0,0 +1,9 @@ + +int send_email(const char *sendname, + const char *recvname, + const char *ccname, + const char *subj, + const char *body, + const char *path); + + diff --git a/src/win32/sys/mman.h b/src/win32/sys/mman.h new file mode 100644 --- /dev/null +++ b/src/win32/sys/mman.h @@ -0,0 +1,7 @@ + +#include + +void *mmap(void *start, size_t length, int prot, int flags, int fd, off_t offset); +int munmap(void *start, size_t length); + + diff --git a/src/witnesses.hs b/src/witnesses.hs new file mode 100644 --- /dev/null +++ b/src/witnesses.hs @@ -0,0 +1,21 @@ +import Darcs.Patch.Real +import Darcs.Patch.Properties +import Darcs.Patch.Bundle +import Darcs.Patch +import Darcs.Repository.ApplyPatches +import Darcs.Patch.Match +import Darcs.Repository.HashedRepo +import Darcs.Resolution +import Darcs.Patch.Check +import Darcs.Repository.Pristine +import Darcs.Repository.DarcsRepo +import Darcs.Repository.Internal +import Darcs.Commands.Unrevert +import Darcs.Commands.WhatsNew +import Darcs.Commands.Show +import Darcs.Commands.Unrecord +import Darcs.Commands.Dist +import Darcs.Commands.TransferMode +import Darcs.Commands.GZCRCs + +main = return () diff --git a/tests/EXAMPLE.sh b/tests/EXAMPLE.sh new file mode 100644 --- /dev/null +++ b/tests/EXAMPLE.sh @@ -0,0 +1,38 @@ +#!/usr/bin/env bash +## Test for issueNNNN - +## +## Copyright (C) YEAR AUTHOR +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R S # Another script may have left a mess. +darcs init --repo R # Create our test repos. +darcs init --repo S +mkdir R/d/ R/e/ # Change the working tree. +echo 'Example content.' >R/d/f +darcs record --repo R -lam 'Add d/f and e.' +darcs mv --repo R d/f e/ +darcs record --repo R -am 'Move d/f to e/f.' +darcs push --repo R S -a # Try to push patches between repos. +darcs push --repo S R +rm -rf R/ S/ # Clean up after ourselves. diff --git a/tests/add-formerly-pl.sh b/tests/add-formerly-pl.sh new file mode 100644 --- /dev/null +++ b/tests/add-formerly-pl.sh @@ -0,0 +1,63 @@ +#!/usr/bin/env bash + +# Some tests for 'darcs add' + +. lib + +rm -rf temp1 temp2 + +# set up the repository +mkdir temp1 +cd temp1 +darcs init + +# Make sure that messages about directories call them directories +mkdir foo.d +mkdir oof.d +darcs add foo.d +darcs add oof.d +not darcs add foo.d 2> log +grep -i directory log +# Try adding the same directory when it's already in the repo +not darcs add foo.d oof.d 2> log +grep -i directories log + +# Make sure that messages about files call them files +touch bar +touch baz +darcs add bar +darcs add baz +not darcs add bar 2> log +grep -i 'following file is' log +not darcs add bar baz 2> log +grep -i 'following files are' log + +# Make sure that messages about both files and directories say so +not darcs add bar foo.d 2> log +grep -i 'files and directories' log + +# Make sure that parent directories are added for files +mkdir -p a.d/aa.d/aaa.d +mkdir -p b.d/bb.d +touch a.d/aa.d/aaa.d/baz +touch a.d/aa.d/aaa.d/bar +darcs add a.d/aa.d/aaa.d/bar a.d/aa.d/aaa.d/baz b.d/bb.d 2> log +test ! -s log # no output + +# Make sure that darcs doesn\'t complains about duplicate adds when adding parent dirs. +mkdir c.d +touch c.d/baz +darcs add c.d/baz c.d 2> log +test ! -s log # no output + +# Make sure that add output looks good when adding files in subdir +mkdir d.d +touch d.d/foo +darcs add -rv d.d | grep 'd.d/foo' + +# 'adding a non-existent dir and file gives the expected message +not darcs add notadir/notafile 2> log +grep -i 'does not exist' log + +cd .. +rm -rf temp1 diff --git a/tests/add.sh b/tests/add.sh new file mode 100644 --- /dev/null +++ b/tests/add.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch foo bar +darcs add foo bar + +for (( i=0 ; i < 5; i=i+1 )); do + echo $i >> file-$i; + darcs add file-$i +done + +cd .. + +rm -rf temp1 + diff --git a/tests/add_in_subdir.sh b/tests/add_in_subdir.sh new file mode 100644 --- /dev/null +++ b/tests/add_in_subdir.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +mkdir dir +echo zig > dir/foo +darcs add dir dir/foo +darcs record -a -m add_foo +# Create second repo inside the first +darcs init --repodir=temp2 +cd temp2 +darcs pull -a ../../temp1 +darcs changes -s | grep "A ./dir/foo" +# no differences +diff ../../temp1/dir/foo dir/foo +cd .. + +rm -rf temp1 diff --git a/tests/addexitval.sh b/tests/addexitval.sh new file mode 100644 --- /dev/null +++ b/tests/addexitval.sh @@ -0,0 +1,33 @@ +#!/usr/bin/env bash + +set -ev + +rm -rf tmp +mkdir tmp +cd tmp +darcs init + +empty='test ! -s' +nonempty='test -s' + +rm -f foo +darcs add foo >stdout 2>stderr && exit 1 || true +$empty stdout +$nonempty stderr + +>foo +darcs add foo >stdout 2>stderr +$empty stdout +$empty stderr + +darcs add foo >stdout 2>stderr && exit 1 || true +$empty stdout +$nonempty stderr + +rm foo +darcs add foo >stdout 2>stderr && exit 1 || true +$empty stdout +$nonempty stderr + +cd .. +rm -rf tmp diff --git a/tests/addmv.sh b/tests/addmv.sh new file mode 100644 --- /dev/null +++ b/tests/addmv.sh @@ -0,0 +1,20 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 +mkdir temp1 temp2 +cd temp1 +darcs init +touch foo bar +darcs add foo bar +darcs record -a -m add_foo_bar -A x +darcs mv foo zig +darcs mv bar foo +darcs mv zig bar +darcs record -a -m swap_foo_bar -A x +cd ../temp2 +darcs init +darcs pull -v -a ../temp1 +cd .. +rm -rf temp1 temp2 + diff --git a/tests/addrace.sh b/tests/addrace.sh new file mode 100644 --- /dev/null +++ b/tests/addrace.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 +mkdir temp1 temp2 +cd temp1 +darcs init +echo zig > foo +darcs add foo +#sleep 1 +darcs record -a -m add_foo -A x +cd ../temp2 +darcs init +darcs pull -a ../temp1 +cd .. +cmp temp1/foo temp2/foo +rm -rf temp1 temp2 + diff --git a/tests/addrm.sh b/tests/addrm.sh new file mode 100644 --- /dev/null +++ b/tests/addrm.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 +mkdir temp1 temp2 +cd temp1 +darcs init +touch foo +darcs add foo +darcs record -a -m add_foo -A x +darcs remove foo +darcs record -a -m del_foo -A x +cd ../temp2 +darcs init +darcs pull --all ../temp1 +cd .. +rm -rf temp1 temp2 + diff --git a/tests/amend-cancelling.sh b/tests/amend-cancelling.sh new file mode 100644 --- /dev/null +++ b/tests/amend-cancelling.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash +set -ev + +# This checks for a possible bug in patch selection where the no available +# patches case is hit. + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch A +darcs add A +darcs record -am A +echo 'l1' >> A +darcs record -am l1 +darcs amend-record -a --patch 'A' + +cd .. +rm -rf temp1 diff --git a/tests/amend-record.sh b/tests/amend-record.sh new file mode 100644 --- /dev/null +++ b/tests/amend-record.sh @@ -0,0 +1,49 @@ +#!/usr/bin/env bash + +# Testing amend-record. + +. lib + +rm -rf temp1 +# set up the repository +mkdir temp1 +cd temp1 +darcs init +cd .. + +# do some work here +cd temp1 +# Plain amend-record +touch foo +darcs add foo +darcs record -a -m add_foo +echo 'another line' > foo +echo y | darcs amend -a foo | grep -i 'amending changes' +darcs changes -v | grep 'another line' +# amend-record of removed file +touch bar1 +touch bar2 +cat > bar1 << FOO +a line +b line +FOO +darcs add bar1 bar2 +darcs record -a -m add_bars +rm -f bar2 +echo y | darcs amend -a | grep -i 'finished amending' +# Special case: patch is empty after amend +cp foo foo.old +echo 'another line' >> foo +darcs record -a -m add_line foo | grep -i 'finished recording' +mv foo.old foo +echo y | darcs amend -a foo | grep -i 'amending changes' +# Amend --author, -m, etc +echo "another line" >> foo +echo y | darcs amend -a -m new_name foo | grep -i 'amending changes' +darcs changes --last=1 | grep new_name +echo "another line" >> foo +echo y | darcs amend -a -m new_name -A new_author foo | grep -i 'amending changes' +darcs changes --last=1 | grep new_author +cd .. + +rm -rf temp1 diff --git a/tests/annotate.sh b/tests/annotate.sh new file mode 100644 --- /dev/null +++ b/tests/annotate.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp +mkdir temp +cd temp +darcs init +mkdir a b +touch a/a b/b +darcs add --rec . +darcs record -a -m ab -A test +darcs annotate a/a +# annotate --xml should encode angle brackets in user name +touch c +darcs add c +darcs record -a -m foo -A 'Mark Stosberg ' +darcs annotate --xml c | grep "<a\@b.com>" +cd .. +rm -rf temp diff --git a/tests/apply-hunks.sh b/tests/apply-hunks.sh new file mode 100644 --- /dev/null +++ b/tests/apply-hunks.sh @@ -0,0 +1,63 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp0 temp1 temp2 + +# step 1 +mkdir temp0 +cd temp0 +darcs init --darcs-2 +echo m1 > foo +darcs add foo +darcs record -a -m m1 -A moi --ignore-times +cd .. + +# step 2 +darcs get temp0 temp1 +cd temp1 +echo a1 > foo +darcs record foo -a -m a1 -A moi --ignore-times +cd .. + + +# step 3 +cd temp0 +echo m2 > foo +darcs record -a -m m2 -A moi --ignore-times +cd .. + + +# step 4 +cd temp1 +darcs pull -a +echo m2-a1 > foo +darcs record -a -m 'Fix conflict m2-a1' -A moi --ignore-times +cd .. + +#step 5 +cd temp0 +echo m3 > foo +darcs record -a -m m3 -A moi --ignore-times +cd .. + +#step 6 +darcs get temp0 temp2 +cd temp2 +echo b1 > foo +darcs record -a -m b1 -A moi --ignore-times +cd .. + +#step 7 +cd temp0 +echo m4 > foo +darcs record -a -m m4 -A moi --ignore-times +cd .. + +#step 8 +cd temp1 +darcs pull -a +echo m2-a1-m4 > foo +echo y | darcs mark-conflicts +cd .. + +rm -rf temp0 temp1 temp2 diff --git a/tests/ask_deps.sh b/tests/ask_deps.sh new file mode 100644 --- /dev/null +++ b/tests/ask_deps.sh @@ -0,0 +1,55 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp +mkdir temp +cd temp + +darcs init +cat > _darcs/prefs/defaults <<. +ALL author test +ALL ignore-times +ALL ask-deps +. + +# add three depending patches for file 'a' +# expect no dependency questions +# 'q' will abort and cause future failure if an unexpected dependency is asked +touch a +darcs add a +echo q | darcs rec -am a0 +darcs ann -p a0 +echo 1 > a +echo q | darcs rec -am a1 +darcs ann -p a1 +echo 2 > a +echo q | darcs rec -am a2 +darcs ann -p a2 + +# add some patches for file 'b' +# expect no dependency questions for file 'b', +# but every time expect questions for the three patches of file 'a' +# every 'n' should continue to ask about the next patch +# the first 'y' should make all following dependencies of 'a' implicit and stop asking +# 'q' will abort and cause future failure if an unexpected dependency is asked +touch b +darcs add b +# test 0 +echo n/n/n/q | tr / \\012 | darcs rec -am b0 +darcs ann -p b0 +# test 1 +echo 1 > b +echo n/n/y/q | tr / \\012 | darcs rec -am b1 +darcs ann -p b1 | grep '^\[a0' +# test 2 +echo 2 > b +echo n/y/q | tr / \\012 | darcs rec -am b2 +darcs ann -p b2 | grep '^\[a1' +# test 3 +echo 3 > b +echo y/q | tr / \\012 | darcs rec -am b3 +darcs ann -p b3 | grep '^\[a2' + +cd .. +rm -rf temp + diff --git a/tests/bad-format.sh b/tests/bad-format.sh new file mode 100644 --- /dev/null +++ b/tests/bad-format.sh @@ -0,0 +1,34 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs initialize --old-fashioned +echo A > foo +darcs add foo +darcs record -a -m AA -A x +echo '' > _darcs/format +cd .. + +# ensure that we successfully get repositories even if they have a bogus +# format file, as can happen if no _darcs/format is present (i.e. it's +# generated by an older darcs) and an http server fails to produce a 404 +# error code. This is issue757. + +darcs get temp1 temp2 + +echo intentional-error >> temp2/_darcs/format + +cat temp2/_darcs/format + +rm -rf temp1 + +not darcs get temp2 temp1 2> err + +cat err +grep intentional-error err +grep 'understand repository format' err + +rm -rf temp1 temp2 diff --git a/tests/bad-match-pattern.sh b/tests/bad-match-pattern.sh new file mode 100644 --- /dev/null +++ b/tests/bad-match-pattern.sh @@ -0,0 +1,38 @@ +#!/usr/bin/env bash + +# This is a test for issue761, which pointed out that we didn't check the +# syntax of --match patterns until after having spent considerable time +# doing considerable work. So here we construct a very invalid repository, +# and check that darcs fails *before* it notices that it's pulling from a +# bad repository. Thus we verify that we aren't doing any work prior to +# checking the flags. + +set -ev + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +touch foo bar +darcs add foo bar +darcs record -a -m 'add two files' +darcs tag -m tag +rm foo bar +darcs record -a -m 'rm two files' +darcs tag -m tag2 + +rm -rf _darcs/inventories/* +rm -rf _darcs/patches/* + +cd .. + +mkdir temp2 +cd temp2 +darcs init +! darcs pull --match 'foobar' ../temp1 2> error +cat error + +grep foobar error + +rm -rf temp1 temp2 + diff --git a/tests/bad_pending_after_pull.sh b/tests/bad_pending_after_pull.sh new file mode 100644 --- /dev/null +++ b/tests/bad_pending_after_pull.sh @@ -0,0 +1,51 @@ +#!/usr/bin/env bash + +set -ev + +rm -fr temp1 temp2 + +mkdir temp1 +cd temp1 +darcs init + +echo abc > A +darcs add A +echo def > B1 +darcs add B1 +# darcs record -all --patch-name patch1 # this way it doesn't trigger the bug +for i in 1 2 3 4 5 6 7 8 9 11; do echo y; done | darcs record --patch-name patch1 + +darcs mv B1 B2 +darcs record --all --patch-name patch2 +cd .. + +mkdir temp2 +cd temp2 +darcs init +darcs pull --all ../temp1 +darcs whatsnew | grep 'No changes' +cd .. + +rm -fr temp1 temp2 + +# issue494: note that in this test, we deliberately select filenames +# with a backwards sorting order +mkdir temp1 +cd temp1 +darcs init +echo abc > b +darcs add b +darcs record --all -m patch1 +darcs mv b a +echo def > a +darcs record --all -m patch2 +cd .. + +mkdir temp2 +cd temp2 +darcs init +darcs pull --all ../temp1 +darcs whatsnew | grep 'No changes' +cd .. + +rm -fr temp1 temp2 diff --git a/tests/binary.sh b/tests/binary.sh new file mode 100644 --- /dev/null +++ b/tests/binary.sh @@ -0,0 +1,29 @@ +#!/usr/bin/env bash +set -ve +binary=example_binary.png +function checkbinary(){ + cmp $binary ../temp1/$binary +} +rm -rf temp1 temp2 +mkdir temp1 temp2 +cd temp1 +darcs init +cp ../$binary . +darcs add $binary +darcs record -am P1 +cd ../temp2 +darcs init +test ! -e $binary +darcs pull ../temp1 -a +checkbinary +darcs obliterate -a +test ! -e $binary +darcs pull ../temp1 -a +checkbinary +darcs unrecord -a +checkbinary +darcs revert -a +test ! -e $binary +darcs unrevert -a +checkbinary +rm -rf temp1 temp2 diff --git a/tests/changes.sh b/tests/changes.sh new file mode 100644 --- /dev/null +++ b/tests/changes.sh @@ -0,0 +1,71 @@ +#!/usr/bin/env bash +set -ev + +# Some tests for 'darcs changes' + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init + +date >> date.t +darcs add date.t + +darcs record -A 'Mark Stosberg ' -a -m foo date.t + +#### + +darcs changes date.t > out # trivial case first +cat out +grep foo out + +darcs changes --last=1 date.t > out +cat out +grep foo out + +darcs changes --last 1 --summary date.t > out +cat out +grep foo out + +darcs changes --last=1 --xml > out +cat out +grep '<a@b.com>' out # check that --xml encodes < and > + +### + +# Add 6 records and try again +for i in 0 1 2 3 4 5; do + date >> date.t + darcs record -a -m "foo record num $i" date.t +done + +darcs changes date.t > out +cat out +grep foo out + +darcs changes --last=1 date.t > out +cat out +grep foo out + +darcs changes --last 1 --summary date.t > out +cat out +grep foo out + +### + +darcs changes --context --from-patch='num 1' --to-patch 'num 4' > out +cat out +grep 'num 4' out +grep 'num 3' out +grep 'num 2' out +grep 'num 1' out + +### + +date >> second_file.t +darcs add second_file.t + +darcs record -a -m adding_second_file second_file.t + +cd .. +rm -rf temp1 diff --git a/tests/changes_send_context.sh b/tests/changes_send_context.sh new file mode 100644 --- /dev/null +++ b/tests/changes_send_context.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash +set -ev + +# RT#544 using context created with 8-bit chars; +rm -rf temp1 + +mkdir temp1 + +cd temp1 +darcs init +touch foo +darcs record -la -m 'add\212 foo' | grep 'Finished record' +darcs changes --context >context +date > foo +darcs record -a -m 'date foo' | grep 'Finished record' +darcs send -a -o patch --context context . | grep 'Wrote patch to' +cd .. +rm -rf temp1 diff --git a/tests/changes_with_move.sh b/tests/changes_with_move.sh new file mode 100644 --- /dev/null +++ b/tests/changes_with_move.sh @@ -0,0 +1,40 @@ +#!/usr/bin/env bash + +# Some tests for the output of changes when combined with move. + +. lib + +rm -rf temp1 + +mkdir temp1 +cd temp1 +darcs init +date > foo +darcs add foo +darcs record -m 'add foo' -a +mkdir d +darcs add d +darcs record -m 'add d' -a +darcs mv foo d +darcs record -m 'mv foo to d' -a +darcs mv d directory +darcs record -m 'mv d to directory' -a +echo 'How beauteous mankind is' > directory/foo +darcs record -m 'modify directory/foo' -a +darcs changes directory/foo > log +grep 'add foo' log +grep 'mv foo to d' log +echo 'O brave new world' > directory/foo +# darcs should also take unrecorded moves into account +darcs mv directory/foo directory/bar +darcs changes directory/foo > log +grep 'mv foo to d' log +echo 'That has such people in it' > directory/foo +darcs add directory/foo +darcs record -m 'mv foo then add new foo' -a +darcs annotate directory/bar > log +grep 'How beauteous mankind is' log +grep 'O brave new world' log +cd .. + +rm -rf temp1 diff --git a/tests/check.sh b/tests/check.sh new file mode 100644 --- /dev/null +++ b/tests/check.sh @@ -0,0 +1,35 @@ +#!/usr/bin/env bash +## Ensure that "darcs check --test" succeeds when run in a complete +## repository with a dummy test that always succeeds. +## +## Copyright (C) 2008 David Roundy +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R +darcs setpref --repo R test true +darcs record --repo R -am 'true test' +touch R/f +darcs record --repo R -lam 'added foo' +darcs check --repo R --test +rm -rf R # Clean up after ourselves. diff --git a/tests/checkpoint.sh b/tests/checkpoint.sh new file mode 100644 --- /dev/null +++ b/tests/checkpoint.sh @@ -0,0 +1,42 @@ +#!/usr/bin/env bash + +# A test for unrecording checkpoint tags, inspired by issue517 + +set -ev + +darcs --version + +rm -rf temp temp1 temp2 +mkdir temp + +# This the last commands would blow up if the "--darcs-2" format wasn't used. +darcs init --darcs-2 --repodir temp +touch temp/x +darcs rec -lam xx --repodir temp +darcs tag -m yy --repodir temp +touch temp/z +darcs rec -lam zz --repodir temp +darcs optimize --checkpoint --repodir temp +darcs get --partial temp temp1 +echo 'y' | darcs unrec -p TAG --repodir temp1 + +# Now, the real tests. Do they return sensible results? +darcs get --partial temp1 temp2; +echo 'n' | darcs unrec --repodir temp1 -p 'zz' + +rm -rf temp temp1 temp2; +darcs init --darcs-2 --repodir temp +touch temp/x +darcs rec -lam xx --repodir temp +darcs tag -m yy --repodir temp +touch temp/z +darcs rec -lam zz --repodir temp +darcs optimize --checkpoint --repodir temp +darcs get --partial temp temp1 +echo 'y' | darcs unrec -p TAG --repodir temp1 + +# Now, the real tests. Do they return sensible results? +darcs get --partial temp1 temp2; +echo 'n' | darcs unrec --repodir temp1 -p 'zz' + +rm -rf temp temp1 temp2; diff --git a/tests/conflict-doppleganger.sh b/tests/conflict-doppleganger.sh new file mode 100644 --- /dev/null +++ b/tests/conflict-doppleganger.sh @@ -0,0 +1,225 @@ +#!/usr/bin/env bash + +. lib + +# Tests for the doppleganger conflict bug. + +# For Zooko, with love +# Also, for issue81. + +rm -rf temp +mkdir temp +cd temp + +# check that dopplegangers conflict in --old-fashioned +rm -rf tmp_dopple tmp_ganger +mkdir tmp_dopple +cd tmp_dopple +darcs init --old-fashioned + +darcs show repo | grep darcs-1.0 +touch a.txt +darcs add a.txt +darcs record -A base -am 'adding a.txt' +cd .. + +darcs get tmp_dopple tmp_ganger + +for repo in tmp_dopple tmp_ganger; do + echo working on $repo + cd $repo + echo "text which appears in both places at once" > a.txt + darcs record -A $repo -am "recording an identical change in $repo" + cd .. +done + +# Now that the conflict has been set up, try pull one patch from the other. +cd tmp_ganger +darcs pull -a ../tmp_dopple > out +cat out +grep 'conflict' out + +# check that dopplegangers conflict in --hashed +rm -rf tmp_dopple tmp_ganger +mkdir tmp_dopple +cd tmp_dopple +darcs init --hashed + +darcs show repo | grep hashed +touch a.txt +darcs add a.txt +darcs record -A base -am 'adding a.txt' +cd .. + +darcs get tmp_dopple tmp_ganger + +for repo in tmp_dopple tmp_ganger; do + echo working on $repo + cd $repo + echo "text which appears in both places at once" > a.txt + darcs record -A $repo -am "recording an identical change in $repo" + cd .. +done + +# Now that the conflict has been set up, try pull one patch from the other. +cd tmp_ganger +darcs pull -a ../tmp_dopple > out +cat out +grep 'conflict' out +cd .. + +# check that dopplegangers do not conflict in --darcs-2 +rm -rf tmp_dopple tmp_ganger +mkdir tmp_dopple +cd tmp_dopple +darcs init --darcs-2 + +darcs show repo | grep darcs-2 +touch a.txt +darcs add a.txt +darcs record -A base -am 'adding a.txt' +cd .. + +darcs get tmp_dopple tmp_ganger + +for repo in tmp_dopple tmp_ganger; do + echo working on $repo + cd $repo + echo "text which appears in both places at once" > a.txt + darcs record -A $repo -am "recording an identical change in $repo" + cd .. +done + +# Now that the conflict has been set up, try pull one patch from the other. +cd tmp_ganger +darcs pull -a ../tmp_dopple > out +cat out +not grep 'conflict' out +cd .. + +# Checking that resolution dopplegangers conflict in --old-fashioned-inventory +rm -rf temp0 temp1 temp2 tmp_dopple tmp_ganger +mkdir temp0 +cd temp0 +darcs init --old-fashioned-inventory +darcs show repo | grep darcs-1.0 +cd .. + +# Create a conflict +darcs get --old-fashioned-inventory temp0 temp1 +cd temp1 +darcs show repo +darcs show repo | grep darcs-1.0 +echo temp1 > a.txt +darcs add a.txt +darcs record -A base -am 'adding temp1 a.txt' +cd .. +darcs get temp0 temp2 +cd temp2 +echo temp2 > a.txt +darcs add a.txt +darcs record -A base -am 'adding temp2 a.txt' +cd .. + +# Resolve the conflict the same way on both sides +for repo in tmp_dopple tmp_ganger; do + echo working on $repo + darcs get temp1 $repo + cd $repo + darcs pull -a ../temp2 + echo "text which appears in both places at once" > a.txt + darcs record -A $repo -am "recording an identical change in $repo" + cd .. +done + +# Now that the conflict has been set up, try pull one patch from the other. +cd tmp_ganger +darcs pull -a ../tmp_dopple > out +cat out +grep conflict out +cd .. + +# Checking that resolution dopplegangers conflict in --hashed +rm -rf temp0 temp1 temp2 tmp_dopple tmp_ganger +mkdir temp0 +cd temp0 +darcs init --hashed +darcs show repo | grep hashed +cd .. + +# Create a conflict +darcs get temp0 temp1 +cd temp1 +echo temp1 > a.txt +darcs add a.txt +darcs record -A base -am 'adding temp1 a.txt' +cd .. +darcs get temp0 temp2 +cd temp2 +echo temp2 > a.txt +darcs add a.txt +darcs record -A base -am 'adding temp2 a.txt' +cd .. + +# Resolve the conflict the same way on both sides +for repo in tmp_dopple tmp_ganger; do + echo working on $repo + darcs get temp1 $repo + cd $repo + darcs pull -a ../temp2 + echo "text which appears in both places at once" > a.txt + darcs record -A $repo -am "recording an identical change in $repo" + cd .. +done + +# Now that the conflict has been set up, try pull one patch from the other. +cd tmp_ganger +darcs pull -a ../tmp_dopple > out +cat out +grep conflict out +cd .. + + +# Checking that resolution dopplegangers do not conflict in --darcs-2 +rm -rf temp0 temp1 temp2 tmp_dopple tmp_ganger +mkdir temp0 +cd temp0 +darcs init --darcs-2 +darcs show repo | grep darcs-2 +cd .. + +# Create a conflict +darcs get temp0 temp1 +cd temp1 +darcs show repo | grep darcs-2 +echo temp1 > a.txt +darcs add a.txt +darcs record -A base -am 'adding temp1 a.txt' +cd .. +darcs get temp0 temp2 +cd temp2 +echo temp2 > a.txt +darcs add a.txt +darcs record -A base -am 'adding temp2 a.txt' +cd .. + +# Resolve the conflict the same way on both sides +for repo in tmp_dopple tmp_ganger; do + echo working on $repo + darcs get temp1 $repo + cd $repo + darcs pull -a ../temp2 + echo "text which appears in both places at once" > a.txt + darcs record -A $repo -am "recording an identical change in $repo" + cd .. +done + +# Now that the conflict has been set up, try pull one patch from the other. +cd tmp_ganger +darcs pull -a ../tmp_dopple > out +cat out +not grep conflict out +cd .. + +cd .. +rm -rf temp diff --git a/tests/conflict-fight-failure.sh b/tests/conflict-fight-failure.sh new file mode 100644 --- /dev/null +++ b/tests/conflict-fight-failure.sh @@ -0,0 +1,54 @@ +#!/bin/env bash +# +# Test darcs conflict fight scenario. +# +# Set up two repos RA and RB. Create conflict in RB. +# After resolving conflict in RB, pull new patch from RA. +# Repeat, rinse. +# +# Author: Pekka Pessi +# + +set -ev + +record="record --ignore-time --all --author X" + +rm -rf RA RB +mkdir RA + +cd RA +echo 0 > file +darcs init +darcs add file +darcs $record -m0 file +cd .. + +darcs get RA RB + +# Create conflict in RB +cd RB +echo let it b > file +darcs $record -m B +cd .. + +for i in 1 2 3 4 5 # 6 7 8 9 10 11 12 +do + echo Create new patch A$i in RA + cd RA + echo a$i > file + darcs $record -m A$i + cd .. + + echo Pull patch A$i from RA and get a conflict + cd RB + time darcs pull ../RA --verbose --all --patch "^A$i\$" + cd .. + + echo Resolve conflict and start fighting by recording B$i + cd RB + echo let it b > file + darcs $record -m B$i + cd .. +done + +rm -rf RA RB diff --git a/tests/conflict-fight.sh b/tests/conflict-fight.sh new file mode 100644 --- /dev/null +++ b/tests/conflict-fight.sh @@ -0,0 +1,78 @@ +#!/usr/bin/env bash + +set -ev + +rm -rf temp0 temp1 temp2 + +# step 1 +mkdir temp0 +cd temp0 +darcs init --darcs-2 +echo temp0 > _darcs/prefs/author +echo m1 > foo +darcs add foo +darcs record -a -m m1 --ignore-times +cd .. + +# step 2 +darcs get temp0 temp1 +cd temp1 +echo temp1 > _darcs/prefs/author +echo a1 > foo +darcs record foo -a -m a1 --ignore-times +cd .. + + +# step 3 +cd temp0 +echo m2 > foo +darcs record -a -m m2 --ignore-times +cd .. + + +# step 4 +cd temp1 +darcs pull -a +echo m2-a1 > foo +darcs record -a -m 'Fix conflict m2-a1' --ignore-times +echo a2 > foo +darcs record -a -m a2 --ignore-times +cd .. + +#step 5 +cd temp0 +echo m3 > foo +darcs record -a -m m3 --ignore-times +cd .. + +#step 6 +darcs get temp0 temp2 +cd temp2 +echo temp2 > _darcs/prefs/author +echo b1 > foo +darcs record -a -m b1 --ignore-times + +cd .. + +#step 7 +cd temp0 +echo m4 > foo +darcs record -a -m m4 --ignore-times +cd .. + +#step 8 +cd temp1 +darcs pull -a +echo m2-a1-m4 > foo +darcs record -a -m 'Fix three-way m2/m2-a1/m4' --ignore-times +echo a3 > foo +darcs record -a -m a3 --ignore-times +cd .. + +#step 9 +cd temp1 +darcs pull -av ../temp2 +cd .. + +rm -rf temp0 temp1 temp2 + diff --git a/tests/diff.sh b/tests/diff.sh new file mode 100644 --- /dev/null +++ b/tests/diff.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp-$$ +mkdir temp-$$ +cd temp-$$ +set -e +darcs initialize +echo text > afile.txt +darcs add afile.txt +darcs record --author me --all --no-test --patch-name init +darcs diff +darcs diff -p . --store > diffinmem +darcs diff -p . > diffondisk +diff diffinmem diffondisk +cd .. + +rm -rf temp-$$ diff --git a/tests/directory_confusion.sh b/tests/directory_confusion.sh new file mode 100644 --- /dev/null +++ b/tests/directory_confusion.sh @@ -0,0 +1,23 @@ +#!/usr/bin/env bash +set -ev + +T=temp +rm -rf "$T" +mkdir "$T" +echo "$T" +cd "$T" +set -e +darcs initialize +echo text > afile.txt +darcs add afile.txt +darcs record --author me --all --no-test --patch-name init +mkdir d +darcs add d +mkdir d/e +darcs add d/e +darcs mv afile.txt d/e/afile.txt +echo altered_text > d/e/afile.txt +darcs record --author me --all --no-test --patch-name confusion +test ! -f _darcs/pristine/afile.txt +echo y/d/y | tr / \\012 | darcs unrecord +rm -rf "$T" diff --git a/tests/disable.sh b/tests/disable.sh new file mode 100644 --- /dev/null +++ b/tests/disable.sh @@ -0,0 +1,20 @@ +#!/usr/bin/env bash +. lib + +# Some tests for 'darcs whatsnew ' + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch look_summary.txt +# --disable works on command line +not darcs whatsnew -sl --disable 2> log +grep -i disable log +# --disable works from defaults +echo 'whatsnew --disable' > _darcs/prefs/defaults +not darcs whatsnew -sl 2> log +grep -i disable log +cd .. + +rm -rf temp1 diff --git a/tests/dist.sh b/tests/dist.sh new file mode 100644 --- /dev/null +++ b/tests/dist.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch foo +darcs add foo +darcs record -a -m add_foo | grep -i "finished recording" +darcs dist +cd .. + +rm -rf temp1 diff --git a/tests/double-unrevert.sh b/tests/double-unrevert.sh new file mode 100644 --- /dev/null +++ b/tests/double-unrevert.sh @@ -0,0 +1,29 @@ +#!/usr/bin/env bash +set -ev + +# This demonstrates a bug that happens if you revert followed by +# a partial unrevert and a full unrevert. It requires that +# the second unrevert is working with patches who's contents need +# to be modified by the commute in the first unrevert. + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo line1 >> A +echo line2 >> A +echo line3 >> A +echo line4 >> A +echo line5 >> A +echo line6 >> A +darcs add A +darcs record -am A +sed 's/line2/Line2/' A > A1; rm A; mv A1 A +sed '4d' A > A1; rm A; mv A1 A +sed 's/line6/Line6/' A > A1; rm A; mv A1 A +darcs revert -a +echo nyn | darcs unrev +darcs unrev -a + +cd .. +rm -rf temp1 diff --git a/tests/example_binary.png b/tests/example_binary.png new file mode 100644 Binary files /dev/null and b/tests/example_binary.png differ diff --git a/tests/external.sh b/tests/external.sh new file mode 100644 --- /dev/null +++ b/tests/external.sh @@ -0,0 +1,37 @@ +#!/usr/bin/env bash + +# Some tests for launching external commands + +. lib + +rm -rf temp1 + +touch_fakessh='./touch-fakessh' +if echo $OS | grep -i windows; then + touch_fakessh="touch_fakessh.bat" +fi +export DARCS_SSH=$touch_fakessh +export DARCS_SCP=$touch_fakessh +export DARCS_SFTP=$touch_fakessh +rm -rf 'fakessh' +rm -rf 'touch-fakessh' + +# make our ssh command one word only +echo 'echo hello > fakessh' > $touch_fakessh +chmod u+x $touch_fakessh +# first test the DARCS_SSH environment variable +not darcs get example.com:foo +grep hello fakessh +rm -f fakessh + +# now make sure that we don't launch ssh for nothing +mkdir temp1 +cd temp1 +darcs init +cd .. +darcs get temp1 > log +not grep fakessh log +not darcs get http://example.com/foo +not grep fakessh log +cd .. +rm -rf temp1 diff --git a/tests/filepath.sh b/tests/filepath.sh new file mode 100644 --- /dev/null +++ b/tests/filepath.sh @@ -0,0 +1,114 @@ +#!/usr/bin/env bash + +# Some tests for proper handling of filepaths + +. lib + +DIR=`pwd` + +rm -rf temp1 temp2 + +# Make sure that init works with --repodir +darcs init --repodir=temp1 +test -d temp1/_darcs + +# add some meat to that repository +cd temp1 +touch baz +darcs add baz +darcs record -m moo -a +cd .. + +# ---------------------------------------------------------------------- +# local vs remote filepaths +# ---------------------------------------------------------------------- + +# trick: OS-detection (if needed) +if echo $OS | grep -i windows; then + echo This test does not work on Windows +else + darcs get temp1 temp2 + cd temp2 + mkdir -p dir + darcs add dir + cd dir + touch foo:bar + darcs add --reserved-ok foo:bar + cd ../.. + rm -rf temp2 +fi + +# ---------------------------------------------------------------------- +# repodir stuff +# ---------------------------------------------------------------------- +mkdir -p temp1/non-darcs +# FIXME: This test does not seem to make much sense +# --repodir is not recursive +not darcs get temp1/non-darcs 2> log +grep "Not a repository" log +rm -rf temp1/non-darcs +rm -rf non-darcs + +# get accepts --repodir. +darcs get --repodir=temp2 temp1 | grep -i "Finished getting" +test -d temp2/_darcs +rm -rf temp2 +# get accepts absolute --repodir. +darcs get --repodir="${DIR}/temp2" temp1 | grep -i "Finished getting" +test -d temp2/_darcs + +# changes accepts --repodir. +darcs changes --repodir=temp1 | grep -i "moo" +# changes accepts absolute --repo. +darcs changes --repo="${DIR}/temp1" | grep -i "moo" +# changes accepts relative --repo. +darcs changes --repo=temp1 | grep -i "moo" +# [issue467] context --repodir +darcs changes --context --repodir=temp1 | grep 'Context:' + +# dist accepts --repodir. +darcs dist --repodir=temp1 | grep -i "Created dist" + +# optimize accepts --repodir. +darcs optimize --reorder-patches --repodir=temp1 | grep -i "done optimizing" + +# repair accepts --repodir. +darcs repair --repodir=temp1 | grep -i "already consistent" + +# replace accepts --repodir. +darcs replace --repodir=temp1 foo bar + +# setpref accepts --repodir. +darcs setpref --repodir=temp1 test echo | grep -i "Changing value of test" + +# trackdown accepts --repodir. +darcs trackdown --repodir=temp1 | grep -i "Success!" + +# ---------------------------------------------------------------------- +# converting between absolute and relative paths +# ---------------------------------------------------------------------- + +rm -rf temp3 +darcs get temp1 temp3 +cd temp3 +mkdir -p a/b +cd .. + +cd temp2 +echo hello 1 >> baz +darcs record -m hello1 -a +echo hello 2 >> baz +darcs record -m hello2 -a +cd .. + +# can handle .. path +cd temp3 +darcs pull ../temp2 -p1 --all | grep -i 'Finished pulling' +darcs pull --dry-run | grep hello2 +cd a/b +#[issue268] repodir with subdir +darcs pull --dry-run | grep hello2 +cd .. +cd .. + +rm -rf log temp1 temp2 temp3 diff --git a/tests/get.sh b/tests/get.sh new file mode 100644 --- /dev/null +++ b/tests/get.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch t.t +darcs add t.t +darcs record -am "initial add" +darcs changes --context > my_context +DIR=`pwd` +abs_to_context="${DIR}/my_context" +cd .. +rm -rf temp2 +darcs get temp1 --context="${abs_to_context}" temp2 +rm -rf temp1 temp2 diff --git a/tests/get_tag.sh b/tests/get_tag.sh new file mode 100644 --- /dev/null +++ b/tests/get_tag.sh @@ -0,0 +1,87 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs initialize +echo ALL ignore-times >> _darcs/prefs/defaults +echo A > foo +darcs add foo +darcs record -a -m AA -A x +echo B > foo +darcs record -a -m BB -A x +echo C > foo +darcs record -a -m CC -A x +darcs tag -m 1.0 -A x +cp foo foo_version_1.0 +echo D > foo +darcs record -a -m DD -A x +echo E > foo +darcs record -a -m EE -A x +echo F > foo +darcs record -a -m FF -A x + + +# Check that get store commuted patches +cd .. +darcs get --tag 1.0 --repo-name temp2 temp1 +cmp temp2/foo temp1/foo_version_1.0 +rm -rf temp1 temp2 temp3 + +mkdir temp1 +cd temp1 +darcs init +cat > file < file < file </dev/null; then + cat _darcs/patches/pending + exit 1 + fi +fi +cd .. +rm -rf temp1 temp2 diff --git a/tests/gzcrcs.sh b/tests/gzcrcs.sh new file mode 100644 --- /dev/null +++ b/tests/gzcrcs.sh @@ -0,0 +1,39 @@ +#!/usr/bin/env bash +## Test for gzcrcs command - check and repair corrupted CRCs on +## compressed files +## +## Copyright (C) 2009 Ganesh Sittampalam +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +# need to do this before loading lib as that sets -e +darcs gzcrcs --help > /dev/null +if [ $? == 2 ] ; then echo gzcrcs not supported by this darcs ; exit 0 ; fi + +. ../tests/lib # Load some portability helpers. +rm -rf maybench-crc +gunzip -c repos/maybench-crc.tgz | tar xf - +cd maybench-crc +not darcs gzcrcs --check +darcs gzcrcs --repair +darcs gzcrcs --check +cd .. +rm -rf maybench-crc diff --git a/tests/harness.sh b/tests/harness.sh new file mode 100644 --- /dev/null +++ b/tests/harness.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash + +set -ev + +# Print some stuff out for debugging if something goes wrong: +echo $HOME +echo $PATH +which darcs +command -v darcs + +# Check things that should be true when all the testscripts run + +test -f "$HOME"/harness.sh || { echo "HOME=\"$HOME\" is not the test suite directory"; exit 1; } + +homedirname=`dirname "$HOME"` +command -v darcs | grep "$homedirname" diff --git a/tests/hashed_inventory.sh b/tests/hashed_inventory.sh new file mode 100644 --- /dev/null +++ b/tests/hashed_inventory.sh @@ -0,0 +1,194 @@ +#!/usr/bin/env bash + +set -ev + +# We'd just use `diff -x _darcs -r' if -x was portable. +diffx () { + { find $1 -type f; find $2 -type f; } | + sed -e '/.*\/_darcs\//d' -e 's;^[^/]*;;' | grep -v darcs.tix | sort | uniq | + { + while read part; do + diff -c $1$part $2$part + done + } +} + +makepristine () { + rm -rf pristine + mkdir pristine + for i in `darcs show files --no-files --no-pending`; do + echo mkdir -p pristine/$i; + mkdir -p pristine/$i; + done + for i in `darcs show files --no-directories --no-pending`; do + echo darcs show contents $i ">" pristine/$i; + darcs show contents $i > pristine/$i; + cat pristine/$i; + done +} + + + +rm -rf temp1 temp2 temp3 temp4 temp5 +mkdir temp1 +cd temp1 +darcs init --hashed +touch foo +darcs add foo +darcs rec -m t1 -a -A tester +echo 1 >> foo +darcs what -s | grep -v No\ changes +darcs what -l | grep -v No\ changes +darcs what -sl | grep -v No\ changes +makepristine +cd .. + +darcs get temp1 temp2 +cd temp2 +darcs changes +makepristine +cd .. + +darcs get --hashed temp1 temp3 +cd temp3 +darcs changes +cp _darcs/hashed_inventory inv +darcs optimize +diff -c inv _darcs/hashed_inventory +rm inv +makepristine +cd .. +cat temp3/pristine/foo + +diffx temp2 temp3 +diff -rc temp1/pristine temp3/pristine +diff -rc temp2/pristine temp3/pristine + +cd temp1 +darcs record -a -A tester -m t2 +darcs push ../temp2 -a +darcs push ../temp3 -a +makepristine +cd .. + +cd temp3 +makepristine +cd .. +cd temp2 +makepristine +cd .. + +diffx temp2 temp3 +diff -rc temp1/pristine temp3/pristine +diff -rc temp2/pristine temp3/pristine + +cd temp1 +date > foo +darcs record -a -A tester -m t3 +makepristine +cd ../temp2 +darcs pull -a +makepristine +cd ../temp3 +darcs pull -a +darcs check +makepristine +cd .. + +diffx temp2 temp3 +diff -rc temp1/pristine temp3/pristine +diff -rc temp2/pristine temp3/pristine + +cd temp1 +darcs put --hashed ../temp4 +cd .. +cd temp4 +makepristine +cd .. + +diffx temp2 temp4 +diff -rc temp2/pristine temp4/pristine + +cd temp1 +darcs tag -A tagger -m atag +darcs check +darcs optimize +darcs check +darcs changes | grep t1 +cd .. + +cd temp3 +date > foobarpatch +darcs add foobarpatch +darcs record -a -A silly -m foobarpatch +darcs check +darcs optimize +darcs check +darcs pull -a ../temp1 +darcs check +darcs optimize --reorder-patches +darcs check +grep 'Starting with inventory' _darcs/hashed_inventory +cd .. + +cd temp1 +darcs pull -a ../temp3 +cd .. + +diff -c temp1/_darcs/hashed_inventory temp3/_darcs/hashed_inventory + +cd temp4 +darcs pull -p foobarpatch -a ../temp3 +darcs pull -a ../temp1 +darcs optimize --reorder +darcs check +darcs push ../temp1 +cd .. + +diff temp1/_darcs/hashed_inventory temp4/_darcs/hashed_inventory + +rm -rf temp3 +darcs get --old-fashioned temp1 temp3 + +rm -rf "$HOME"/.darcs/sources +echo cache:"$HOME"/.darcs/cache > "$HOME"/.darcs/sources +darcs get --hashed temp3 temp5 +rm -rf temp5 +# check that sources directory was created: +cd "$HOME"/.darcs/sources && cd - + +darcs get temp1 temp5 --hashed --old-fashioned +cd temp5 +darcs obliterate --last 3 -a +darcs pull ../temp1 -a +darcs obliterate --last 3 -a +darcs pull ../temp2 -a +darcs check +darcs obliterate --last 3 -a +darcs pull ../temp3 -a +darcs obliterate --last 3 -a +darcs pull ../temp4 -a +cd .. + +cd temp4 +darcs obliterate --last 3 -a +darcs pull ../temp5 -a +cd .. + +cd temp3 +darcs obliterate --last 3 -a +darcs pull ../temp5 -a +cd .. + +cd temp2 +darcs obliterate --last 3 -a +darcs pull ../temp5 -a +cd .. + +cd temp1 +darcs obliterate --last 3 -a +darcs pull ../temp5 -a +cd .. + +rm -rf temp1 temp2 temp3 temp4 temp5 + diff --git a/tests/haskell_policy.sh b/tests/haskell_policy.sh new file mode 100644 --- /dev/null +++ b/tests/haskell_policy.sh @@ -0,0 +1,59 @@ +#!/usr/bin/env bash + +RESULT=tmpfile +ROOT=.. +ERRORSTATUS=0 + +# lookfor ( $1=what, $2=reason, $3=source module exception ) +lookfor () { + rm -f "$RESULT" + darcs query manifest --repodir="$ROOT" | grep '\.l\?hs$' | while read f; do + grep -Hnwe "$1" "$ROOT/$f" | grep -v "$3\.$1" | \ + grep -v ":[0-9]\+:import " | grep -Fv "ratify $1: " >> "$RESULT" + done + if [ -s "$RESULT" ]; then + echo "Found the following unratified uses of $1:" + # ugly sed expresion to fix relative paths; think pretty cat + sed -e 's/[^:]*\/\.\///' "$RESULT" + echo "$2" + echo "Comment 'ratify $1: ' on the same line to allow it" + echo + ERRORSTATUS=1 + fi + rm -f "$RESULT" +} + +# On 2009-02-12 Petr Rockai explained this on darcs-users: +# The problem with Prelude readFile is that it's based on hGetContents, which +# is lazy by definition. This also means that unless you force consumption of +# the produced list, it will keep an fd open for the file, possibly +# indefinitely. This is called a fd leak. Other than being annoying and if done +# often, leading to fd exhaustion and failure to open any new files (which is +# usually fatal), it also prevents the file to be unlinked (deleted) on win32. +# +# On the other hand, *strict* bytestring version of readFile will read the whole +# file into a contiguous buffer, *close the fd* and return. This is perfectly +# safe with regards to fd leaks. Btw., this is *not* the case with lazy +# bytestring variant of readFile, so that one is unsafe. +lookfor readFile \ + "Prelude.readFile doesn't ensure the file is closed before it is deleted!\nConsider import Data.ByteString.Char8 as B (readFile), B.readFile instead." \ + B # importing readFile from Data.ByteString as B, is allowed + +lookfor hGetContents \ + "hGetContents doesn't ensure the file is closed before it is deleted!" + +# look for tabs in haskell source +rm -f "$RESULT" +darcs query manifest --repodir="$ROOT" | grep '\.l\?hs$' | while read f; do + grep -FHnwe " " "$ROOT/$f" >> "$RESULT" +done +if [ -s "$RESULT" ]; then + echo "Found the following lines with unwanted tabs:" + # ugly sed expresion to fix relative paths; think pretty cat + sed -e 's/[^:]*\/\.\///' "$RESULT" + echo + ERRORSTATUS=1 +fi +rm -f "$RESULT" + +exit "$ERRORSTATUS" diff --git a/tests/hidden_conflict.sh b/tests/hidden_conflict.sh new file mode 100644 --- /dev/null +++ b/tests/hidden_conflict.sh @@ -0,0 +1,32 @@ +#!/bin/sh + +set -ev + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init --darcs-2 +echo first > a +darcs add a +darcs record -am 'first' +cd .. +darcs get temp1 temp2 + +cd temp1 +echo second > a +darcs record -am 'first to second' +echo first > a +darcs record -am 'second back to first' +cd .. + +cd temp2 +echo third > a +darcs record -am 'first to third' +cd .. + +cd temp1 +darcs pull -a ../temp2 | grep conflict +grep third a +cd .. + +rm -rf temp1 temp2 diff --git a/tests/hidden_conflict2.sh b/tests/hidden_conflict2.sh new file mode 100644 --- /dev/null +++ b/tests/hidden_conflict2.sh @@ -0,0 +1,70 @@ +#!/usr/bin/env bash +set -ev + +# A test for a missed resolution, inspired by bug #10 in RT + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +cd .. +mkdir temp2 +cd temp2 +darcs init +cd .. + +# set up temp1 +cd temp1 +cat > A << FOO +i + +m +b +v +FOO +darcs add A +darcs record -m 'add' --all +cd .. + +# set up temp2 +cd temp2 +darcs pull --all ../temp1 +cat > A << FOO +J +i + +C2 + +m +D +b +v +FOO +darcs record -m 'change2' --all +cd .. + +# generate a conflict +cd temp1 +cat > A << FOO +I +i + +C1 + +m +b + +FOO +darcs record -m 'change1' --all +darcs pull --all ../temp2 +# we should have a marked conflict now. +grep 'v v' A +# we resolve it simply by removing conflict markers. +sed -e '/\^ \^|\*\*|v v/d' A > temp +mv temp A +darcs record -m resolution --all +# now mark-conflicts shouldn't find any unmarked conflicts +darcs mark-conflicts | grep "No conflicts to mark" +cd .. + +rm -rf temp1 temp2 diff --git a/tests/ignore-this.sh b/tests/ignore-this.sh new file mode 100644 --- /dev/null +++ b/tests/ignore-this.sh @@ -0,0 +1,38 @@ +#!/usr/bin/env bash + +. lib + + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init + +touch foo +darcs add foo + +cat > log < out +cat out +grep Proceed out + +darcs whatsnew + +echo y | darcs record -a --logfile log + +not darcs whatsnew + +darcs changes > out +cat out +not grep 'My private secret' out + +darcs changes --xml > out +cat out +grep 'My private secret' out + +cd .. +rm -rf temp1 diff --git a/tests/ignoretimes.sh b/tests/ignoretimes.sh new file mode 100644 --- /dev/null +++ b/tests/ignoretimes.sh @@ -0,0 +1,29 @@ +#!/usr/bin/env bash + +set -ev + +rm -rf temp1 + +mkdir temp1 +cd temp1 +darcs init +echo -e 'foo\nbar\nbaz' > f +darcs rec -Ax -alm p1 +echo -e 'foo\nbar\nwibble' > f +darcs rec -Ax -alm p2 +sleep 1 # ensure the timestamps would differ after this change alone +echo -e 'baz\nbar\nwibble' > f + +# check that wh (without --ignore-times) sees the change now +darcs wh > whatsnew +grep 'foo' whatsnew + +# the problematic unpull +darcs unpull --last 1 -a --ignore-times + +# whatsnew will now think there are no changes without --ignore-times +darcs wh > whatsnew +grep 'foo' whatsnew + +cd .. +rm -rf temp1 diff --git a/tests/illegal_mv.sh b/tests/illegal_mv.sh new file mode 100644 --- /dev/null +++ b/tests/illegal_mv.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp +mkdir temp +cd temp + +darcs initialize +echo text > afile.txt +darcs add afile.txt +darcs record --author me --all --no-test --patch-name init +mkdir d +echo The following mv should fail, since d isnt in the repo. +if darcs mv afile.txt d/afile.txt; then +false +fi + +# Now clean up. +cd .. +rm -rf temp + diff --git a/tests/impossible_unrevert.sh b/tests/impossible_unrevert.sh new file mode 100644 --- /dev/null +++ b/tests/impossible_unrevert.sh @@ -0,0 +1,33 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp +mkdir temp +cd temp +darcs init +echo ALL ignore-times > _darcs/prefs/defaults +echo a > foo +darcs add foo +darcs record -a -m aa -A test +echo b > foo +echo y | darcs revert -a +echo y/d/y | tr / \\012 | darcs unrecord +# since the unrevert is impossible, we should fail if it succeeds... +echo y | darcs unrevert && exit 1 || true + +# now let's try a possible unrevert, just for fun... +echo b >> foo +darcs record -a -m bb -A test +echo f/b | tr / \\012 > foo +darcs record -a -m 'aaa becomes f' -A test +date >> foo +echo y | darcs revert -a +echo y/d/y | tr / \\012 | darcs unpull +# Now add the date back on at the end: +echo y | darcs unrevert +echo 'M ./foo +1' > correct_summary +darcs whatsnew --dont-look-for-adds --summary > actual_summary +diff -c correct_summary actual_summary + +cd .. +rm -rf temp diff --git a/tests/init.sh b/tests/init.sh new file mode 100644 --- /dev/null +++ b/tests/init.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 temp2 + +mkdir temp1 +cd temp1 +darcs init +test -d _darcs +not darcs init +cd .. + +# Some tests for the repodir flag +mkdir temp2 +darcs init --repodir temp2 +test -d temp2/_darcs + +rm -rf temp1 temp2 diff --git a/tests/invalid_pending_after_mv_to_self.sh b/tests/invalid_pending_after_mv_to_self.sh new file mode 100644 --- /dev/null +++ b/tests/invalid_pending_after_mv_to_self.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash + +# A regression test for issue567 + +set -ev + +rm -rf temp +mkdir temp +cd temp +darcs init +mkdir dir +touch dir/t.t +darcs add dir +darcs add dir/t.t +darcs record -am 'initial add' + +# grand finale? Can we move the file to itself? +darcs mv dir/t.t dir/ + +cd .. + +rm -rf temp diff --git a/tests/issue1012_unrecord_remove.sh b/tests/issue1012_unrecord_remove.sh new file mode 100644 --- /dev/null +++ b/tests/issue1012_unrecord_remove.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash +set -ev +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs --version +darcs init +echo temp1 >File.hs +darcs add File.hs +darcs record File.hs -a -m "add File" +rm File.hs +darcs record -a -m "rm File" +darcs cha +darcs unrecord -p "rm File" -a +darcs cha +darcs record -a -m "re-rm File" +cd .. +rm -rf temp1 diff --git a/tests/issue1017_whatsnew_stack.sh b/tests/issue1017_whatsnew_stack.sh new file mode 100644 --- /dev/null +++ b/tests/issue1017_whatsnew_stack.sh @@ -0,0 +1,13 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +printf "File contents" > foo +darcs add foo +darcs record -a -m 'foo' foo +for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16; do cat foo foo > foo2; mv foo2 foo; done +darcs what +cd .. diff --git a/tests/issue1039.sh b/tests/issue1039.sh new file mode 100644 --- /dev/null +++ b/tests/issue1039.sh @@ -0,0 +1,68 @@ +#!/usr/bin/env bash + + +. lib + +# pull from not empty repo to empty repo +rm -rf temp1 temp2 +mkdir temp1 temp2 + +cd temp1 +darcs init +echo a > a +darcs add a +darcs record --all --patch-name=a +cd ../temp2 +darcs init +darcs pull --all --dont-allow-conflicts ../temp1 +test `darcs changes --count` = "1" +cd .. + +# push from not empty repo to empty repo +rm -rf temp1 temp2 +mkdir temp1 temp2 + +cd temp1 +darcs init +cd ../temp2 +darcs init +echo a > a +darcs add a +darcs record --all --patch-name=a +darcs push --all ../temp1 +cd ../temp1 +test `darcs changes --count` = "1" +cd .. + +# send from not empty repo to not empty repo +rm -rf temp1 temp2 +mkdir temp1 temp2 + +cd temp1 +darcs init +echo a > a +darcs add a +darcs record --all --patch-name=a + +for i in 1 2 3 4 5 6 7 8 9; do + echo Change number $i >> a + darcs record -a -m "change a $i" +done + +cd ../temp2 +darcs init +echo b > b +darcs add b +darcs record --all --patch-name=b + +for i in 1 2 3 4 5 6 7 8 9; do + echo Change number $i >> b + darcs record -a -m "change b $i" +done + +echo no | darcs send --all --to=random@random --sendmail-command=false ../temp1 +echo yes | not darcs send --all --to=random@random --sendmail-command=false ../temp1 +not darcs send --all --to=random@random --sendmail-command=false --allow-unrelated-repos ../temp1 +cd .. + +rm -rf temp1 temp2 diff --git a/tests/issue1041.sh b/tests/issue1041.sh new file mode 100644 --- /dev/null +++ b/tests/issue1041.sh @@ -0,0 +1,13 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 temp2 + +# this should fail, since temp1 doesn't exist... +not darcs get temp1 temp2 + +# verify that temp2 wasn't created +not cd temp2 + +rm -rf temp1 temp2 diff --git a/tests/issue1043_geteff_a.sh b/tests/issue1043_geteff_a.sh new file mode 100644 --- /dev/null +++ b/tests/issue1043_geteff_a.sh @@ -0,0 +1,67 @@ +#!/usr/bin/env bash + +set -ev +rm -rf temp1 temp2 + +# creating the fork point +mkdir temp1 +cd temp1 +darcs init +cat > foo << FOO +original - apple +original - banana +FOO +darcs add foo +darcs record -am init +cd .. +darcs get temp1 temp2 + +# do some work in the mainline +cd temp1 +cat > foo << FOO +conflict 1 - artichoke +original - banana +FOO +darcs record -am 'conflict 1a' +cat > foo << FOO +conflict 1 - artichoke +conflict 1 - brocolli +FOO +darcs record -am 'conflict 1b' +cd .. + +# do some work in the branch +cd temp2 +cat > foo << FOO +conflict 2 - aardvark +original - banana +conflict 2 - cougar +FOO +darcs record -am 'conflict 2' +cd .. + +# in the branch, pull from the mainline and resolve the conflict +cd temp2 +darcs pull -a ../temp1 --allow-conflicts +cat > foo << FOO +resolution +original - apple +original - banana +FOO +darcs record -am 'resolve conflicts 2,1a,1b' +cd .. + +# do some extra work in the mainline +cd temp1 +cat > foo << FOO +original - apple +FOO +darcs record -am 'conflict 1c' +cd .. + +# in the branch, pull from the mainline again +cd temp2 +darcs pull -a ../temp1 --allow-conflicts +cd .. + +rm -rf temp1 temp2 diff --git a/tests/issue1043_geteff_b.sh b/tests/issue1043_geteff_b.sh new file mode 100644 --- /dev/null +++ b/tests/issue1043_geteff_b.sh @@ -0,0 +1,67 @@ +#!/usr/bin/env bash + +set -ev +rm -rf temp1 temp2 + +# creating the fork point +mkdir temp1 +cd temp1 +darcs init +cat > foo << FOO +original - apple +original - banana +FOO +darcs add foo +darcs record -am init +cd .. +darcs get temp1 temp2 + +# do some work in the mainline +cd temp1 +cat > foo << FOO +original - apple +conflict 1 - brocolli +FOO +darcs record -am 'conflict 1b' +cat > foo << FOO +conflict 1 - artichoke +original - banana +FOO +darcs record -am 'conflict 1a' +cd .. + +# do some work in the branch +cd temp2 +cat > foo << FOO +conflict 2 - aardvark +original - banana +conflict 2 - cougar +FOO +darcs record -am 'conflict 2' +cd .. + +# in the branch, pull from the mainline and resolve the conflict +cd temp2 +darcs pull -a ../temp1 --allow-conflicts +cat > foo << FOO +resolution +original - apple +original - banana +FOO +darcs record -am 'resolve conflicts 2,1a,1b' +cd .. + +# do some extra work in the mainline +cd temp1 +cat > foo << FOO +original - apple +FOO +darcs record -am 'conflict 1c' +cd .. + +# in the branch, pull from the mainline again +cd temp2 +darcs pull -a ../temp1 --allow-conflicts +cd .. + +rm -rf temp1 temp2 diff --git a/tests/issue1057.sh b/tests/issue1057.sh new file mode 100644 --- /dev/null +++ b/tests/issue1057.sh @@ -0,0 +1,48 @@ +#!/usr/bin/env bash +## Test for issue1057 - when pulling from a symlink to the current +## repository, Darcs should detect that it *is* the current repo. +## +## Copyright (C) 2008 Thorkil Naur +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +rm -rf temp +mkdir temp +cd temp + +mkdir repo +cd repo +darcs init +cd .. + +ln -s repo srepo +cd srepo +DIR=`pwd` +echo $DIR +not darcs pull --debug -a "$DIR" 2> out +cat out +grep 'Can.t pull from current repository' out +cd .. + +cd .. +rm -rf temp diff --git a/tests/issue1078_symlink.sh b/tests/issue1078_symlink.sh new file mode 100644 --- /dev/null +++ b/tests/issue1078_symlink.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash + +. lib + +if echo $OS | grep -i windows; then + echo this test does not work on windows because + echo windows does not have symlinks + exit 0 +fi + +rm -rf temp1 temp2 +mkdir temp1 +ln -s temp1 temp2 +cd temp2 +darcs init +touch a b +DIR=`pwd` +darcs add "${DIR}/../temp1/a" # should work, just to contrast with the case below +darcs add "${DIR}/b" # this is the case we are testing for +cd .. +rm -rf temp1 temp2 diff --git a/tests/issue1101.sh b/tests/issue1101.sh new file mode 100644 --- /dev/null +++ b/tests/issue1101.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash +set -ev + +DARCS_EDITOR=echo +export DARCS_EDITOR +export SENDMAIL=`which true` + +rm -rf temp1 temp2 +mkdir temp1 temp2 + +cd temp2 +darcs init + +# setup test +cd ../temp1 +darcs init +touch foo bar +darcs add foo bar +darcs record -a -m add_foo_bar -A x + +# Test that --cc is also printed as recipient in case of success +darcs send --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com + +# Test that --cc is also printed as recipient in case of error +darcs send --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com + +cd .. +rm -rf temp1 temp2 diff --git a/tests/issue1105.sh b/tests/issue1105.sh new file mode 100644 --- /dev/null +++ b/tests/issue1105.sh @@ -0,0 +1,37 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp +mkdir temp +cd temp +darcs init +darcs changes + +echo changes summary > _darcs/prefs/defaults +darcs changes +echo changes summary arg > _darcs/prefs/defaults +not darcs changes +echo ALL summary > _darcs/prefs/defaults +darcs changes +echo ALL summary arg > _darcs/prefs/defaults +not darcs changes + +echo changes last 10 > _darcs/prefs/defaults +darcs changes +echo changes last > _darcs/prefs/defaults +not darcs changes +echo ALL last 10 > _darcs/prefs/defaults +darcs changes +echo ALL last > _darcs/prefs/defaults +not darcs changes + +echo changes author me > _darcs/prefs/defaults +not darcs changes +echo ALL author me > _darcs/prefs/defaults +darcs changes +echo ALL unknown > _darcs/prefs/defaults +not darcs changes + +cd .. +rm -rf temp diff --git a/tests/issue1110_get_hashed.sh b/tests/issue1110_get_hashed.sh new file mode 100644 --- /dev/null +++ b/tests/issue1110_get_hashed.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash +set -ev +rm -rf temp1 temp1-h +mkdir temp1 +cd temp1 +darcs init --old-fashioned-inventory +cd .. +darcs get --hashed temp1 temp1-h +test -e temp1-h/_darcs/hashed_inventory +rm -rf temp1 temp1-h diff --git a/tests/issue1110_get_old-fashioned.sh b/tests/issue1110_get_old-fashioned.sh new file mode 100644 --- /dev/null +++ b/tests/issue1110_get_old-fashioned.sh @@ -0,0 +1,30 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp0 temp1 +# sanity check +mkdir temp0 +cd temp0 +darcs init --old-fashioned +cd .. +darcs get --old-fashioned temp0 temp1 +test -e temp1/_darcs/inventory +rm -rf temp0 temp1 + +# get from hashed +mkdir temp0 +cd temp0 +darcs init --hashed +cd .. +darcs get --old-fashioned temp0 temp1 +test -e temp1/_darcs/inventory +rm -rf temp0 temp1 + +# get from darcs-2 +mkdir temp0 +cd temp0 +darcs init --darcs-2 +cd .. +darcs get --old-fashioned temp0 temp1 > log +grep 'Warning' log +rm -rf temp0 temp1 diff --git a/tests/issue1111-pull-intersection.sh b/tests/issue1111-pull-intersection.sh new file mode 100644 --- /dev/null +++ b/tests/issue1111-pull-intersection.sh @@ -0,0 +1,41 @@ +#!/usr/bin/env bash + +. lib +# This test script is in the public domain. + + +rm -rf temp1 temp2 temp3 + +mkdir temp1 +cd temp1 +darcs initialize +echo A > A +darcs add A +darcs record -a -m Aismyname +echo B > B +darcs add B +darcs record -a -m Bismyname + +cd .. +darcs get temp1 temp2 + +cd temp2 +darcs obliterate --last 1 -a +echo C > C +darcs add C +darcs record -a -m Cismyname +cd .. + +mkdir temp3 +cd temp3 +darcs init +darcs pull -a -v --intersection ../temp1 ../temp2 + +darcs changes > out +cat out +grep Aismyname out +not grep Bismyname out +not grep Cismyname out +cd .. + +rm -rf temp1 temp2 temp3 diff --git a/tests/issue1139-diff-last.sh b/tests/issue1139-diff-last.sh new file mode 100644 --- /dev/null +++ b/tests/issue1139-diff-last.sh @@ -0,0 +1,31 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp-$$ +mkdir temp-$$ +cd temp-$$ +set -e +darcs initialize +echo text > foo +darcs add foo +darcs rec -am 'add foo' +darcs annotate -p . + +echo newtext > foo +darcs record -am 'modify foo' + +darcs diff --store --last=1 > out1 +cat out1 +grep text out1 +grep foo out1 + +darcs diff --last=1 > out +cat out +grep text out +grep foo out + +diff -u out1 out + +cd .. + +rm -rf temp-$$ diff --git a/tests/issue1139-diff-with-no-args.sh b/tests/issue1139-diff-with-no-args.sh new file mode 100644 --- /dev/null +++ b/tests/issue1139-diff-with-no-args.sh @@ -0,0 +1,29 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp-$$ +mkdir temp-$$ +cd temp-$$ +set -e +darcs initialize +echo text > foo +darcs add foo +darcs record -am 'add foo' +echo newtext > foo +darcs wh + +darcs diff --store > out1 +cat out1 +grep text out1 +grep foo out1 + +darcs diff > out +cat out +grep text out +grep foo out + +diff out out1 + +cd .. + +rm -rf temp-$$ diff --git a/tests/issue1162_add_nonexistent_slash.sh b/tests/issue1162_add_nonexistent_slash.sh new file mode 100644 --- /dev/null +++ b/tests/issue1162_add_nonexistent_slash.sh @@ -0,0 +1,16 @@ +#!/bin/sh + +set -ev + +not () { "$@" && exit 1 || :; } + +rm -rf temp +mkdir temp +cd temp +darcs init +not darcs add a/ 2> err +cat err +grep 'does not exist (No such file or directory)' err +cd .. + +rm -rf temp diff --git a/tests/issue1248.sh b/tests/issue1248.sh new file mode 100644 --- /dev/null +++ b/tests/issue1248.sh @@ -0,0 +1,20 @@ +#!/usr/bin/env bash +## Test for issue1248 - darcs doesn't handle darcs 1 repos with compressed +## inventories +## +## Placed into the public domain by Ganesh Sittampalam, 2009 + +. lib +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init --old-fashioned +touch foo +darcs rec -a -m'foo' -l --author=me@me +darcs tag --author=me@me foo +darcs check +darcs optimize --reorder +darcs check +darcs optimize --compress +darcs check +rm -rf temp1 diff --git a/tests/issue1269_setpref_predist.sh b/tests/issue1269_setpref_predist.sh new file mode 100644 --- /dev/null +++ b/tests/issue1269_setpref_predist.sh @@ -0,0 +1,28 @@ +#!/bin/sh + +set -ev + +not () { "$@" && exit 1 || :; } + +rm -rf temp +rm -rf dist1269.tar.gz +mkdir temp +cd temp + +darcs init +printf "Line1\nLine2\nLine3\n" > foo +darcs record -alm Base + +darcs setpref predist false + +# It is a bug in darcs if the dist succeeds. It should +# fail with a non-zero exit code +not darcs dist -d dist1269 + +# It is a bug in darcs if the dist file has been created +# it should /not/ be created if the predist cmd returned +# a non-zero exit code +not test -f dist1269.tar.gz + +cd .. +rm -rf temp diff --git a/tests/issue1373_replace_token_chars.sh b/tests/issue1373_replace_token_chars.sh new file mode 100644 --- /dev/null +++ b/tests/issue1373_replace_token_chars.sh @@ -0,0 +1,49 @@ +#!/usr/bin/env bash +## Test for issue1373 - check that --token-chars [^ \t] is allowed. +## While we're at it, check some other things *aren't* allowed. +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +rm -rf temp # Another script may have left a mess. +darcs init --repodir temp +replace () { darcs replace --repodir temp --token-chars "$1" x y; } +## These are not well-formed tokens. +not replace '' +not replace 'a' +not replace ']a[' +not replace '[]' +not replace '[^]' +## These are well-formed, but allow tokens to contain whitespace. +not replace $'[ ]' +not replace $'[\t]' +not replace $'[\n]' +not replace $'[\r]' +not replace $'[\v]' +not replace $'[^ ]' +not replace $'[^\t]' +not replace $'[^\n]' +not replace $'[^\r]' +not replace $'[^\v]' +rm -rf temp # Clean up after ourselves. diff --git a/tests/issue1446.sh b/tests/issue1446.sh new file mode 100644 --- /dev/null +++ b/tests/issue1446.sh @@ -0,0 +1,53 @@ +#!/usr/bin/env bash +## Test for issue1446 - darcs amend-record -m foo destroys long description without warning +## +## Copyright (C) 2009 Dmitry Kurochkin +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repo. + +touch R/f +darcs add f --repo R +echo 'patch name' > R/patchinfo +echo 'patch description' >> R/patchinfo +darcs record -a --logfile=R/patchinfo --repo R +darcs changes --repo R | grep 'patch name' +darcs changes --repo R | grep 'patch description' + +echo 'y' | darcs amend-record -p 'patch name' -m 'new name' --repo R +darcs changes --repo R | grep 'new name' +darcs changes --repo R | grep 'patch description' + +echo content > R/f +echo 'another name' > R/patchinfo +echo 'another description' >> R/patchinfo +darcs record -a --logfile=R/patchinfo --repo R +darcs changes --repo R | grep 'another name' +darcs changes --repo R | grep 'another description' + +echo 'y' | darcs amend-record -p 'another name' -m 'one more name' --repo R +darcs changes --repo R | grep 'one more name' +darcs changes --repo R | grep 'another description' + +rm -rf R/ # Clean up after ourselves. diff --git a/tests/issue1465_ortryrunning.sh b/tests/issue1465_ortryrunning.sh new file mode 100644 --- /dev/null +++ b/tests/issue1465_ortryrunning.sh @@ -0,0 +1,42 @@ +#!/usr/bin/env bash +## Test for issue1465 - ortryrunning should try RHS if AND ONLY IF the +## LHS actually failed wasn't found or wasn't executable. +## +## Copyright (C) 2009 Trent W. Buck +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. ../tests/lib # Load some portability helpers. +rm -rf R # Another script may have left a mess. +darcs init --repo R # Create our test repo. +mkdir R/d # Change the working tree. + +# Set the editor to a program that just fails (VISUAL), make Darcs use +# it (--edit), and then make sure when it brokenly launches a fallback +# editor, that editor will exit because stdin isn't a tty (/dev/null). +not env -u TERM VISUAL=false R/log \ +darcs record --repo R -lam 'Initial commit.' --edit + +# If Darcs did the right thing, the output won't make any mention of +# the fallback editors. +not egrep -i 'not found|vi|emacs|nano|edit' R/log + +rm -rf R/ # Clean up after ourselves. diff --git a/tests/issue154_pull_dir_not_empty.sh b/tests/issue154_pull_dir_not_empty.sh new file mode 100644 --- /dev/null +++ b/tests/issue154_pull_dir_not_empty.sh @@ -0,0 +1,48 @@ +#!/usr/bin/env bash +## Test for issue154 - when applying a patch that removes a directory, +## don't remove the directory from the working tree unless it's empty. +## +## Copyright (C) 2008 Mark Stosberg +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +mkdir d +darcs add d +darcs record -a -m "Added directory d" +darcs get ./ puller +cd puller +touch d/moo +darcs add d/moo +cd .. +rm -rf d +darcs record -a -m "Remove directory d" +cd puller +echo y | darcs pull -a .. > log +grep -i "backing up" log +grep -i "finished pulling" log +cd .. +rm -rf temp1 diff --git a/tests/issue157_rollback_conflict.sh b/tests/issue157_rollback_conflict.sh new file mode 100644 --- /dev/null +++ b/tests/issue157_rollback_conflict.sh @@ -0,0 +1,44 @@ +#!/usr/bin/env bash + +# issue157: A test for how rollback handles dependencies and conflicts. + +. lib + +rm -rf temp1 temp2 + +# set up the repository +mkdir temp1 +cd temp1 +darcs init --darcs-2 +cd .. + +# do some work here +cd temp1 +echo a > foo +# Create three patches +darcs record -lam AA +echo b > foo +darcs record -lam BB +echo c > foo +darcs record -lam CC +# Rollback the last one +darcs rollback -a -p CC -m 'rollback CC' +grep b foo # reality check +cd .. + +# Now get just the first two patches into a new repo...ignoring the third patch and the rollback. +darcs get --to-patch BB temp1 temp2 +cd temp2 +# Now in the second repo, rollback the second patch. +darcs rollback -a -p BB -m 'rollback BB' +grep a foo # reality check +# Finally, pull the third patch and the rollback of it. +# Because the two patches should cancel each other other, there should be no change here. +darcs pull -a ../temp1 +# expect a conflict between the contents being 'a' or 'b' +grep "v v v" foo +grep a foo +grep b foo +cd .. + +rm -rf temp1 temp2 diff --git a/tests/issue174_obliterate_before_a_tag.sh b/tests/issue174_obliterate_before_a_tag.sh new file mode 100644 --- /dev/null +++ b/tests/issue174_obliterate_before_a_tag.sh @@ -0,0 +1,23 @@ +#!/usr/bin/env bash + +# issue174: behave better when we want to obliterate a patch that comes before a tag. +. lib + +rm -rf temp1 + +mkdir temp1 +cd temp1 +darcs init +# Setup: Create a patch, a tag and another patch. +touch a.txt +darcs add a.txt +darcs record -am 'adding a' a.txt +darcs tag "first tag"; +touch b.txt +darcs add b.txt +darcs record --ignore-time -a -m 'adding b' b.txt +darcs obliterate -p "adding a" -a > log +not grep "no patch" log +cd .. + +rm -rf temp1 diff --git a/tests/issue184_add.sh b/tests/issue184_add.sh new file mode 100644 --- /dev/null +++ b/tests/issue184_add.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +. lib + +# For issue184: recording files in directories that haven't explicity been added. + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +mkdir new +mkdir new/dir +touch new/dir/t.t +darcs add new/dir/t.t +darcs record -am test new/dir/t.t > log +not grep "don't want to record" log +cd .. + +rm -rf temp1 diff --git a/tests/issue194.sh b/tests/issue194.sh new file mode 100644 --- /dev/null +++ b/tests/issue194.sh @@ -0,0 +1,26 @@ +set -ev + +rm -rf temp1 temp2 + +mkdir temp1; cd temp1 ; darcs init ; cd .. +darcs get temp1 temp2 +cd temp2/ ; echo 'x' > _darcs/prefs/author ; cd .. +cd temp1/ ; echo 'x' > _darcs/prefs/author ; cd .. + +cd temp1/ +touch test ; darcs record +darcs add test ; darcs record -a -m 'test' +darcs mv test best ; darcs record -a -m 'test -> best' +darcs mv best test ; darcs record -a -m 'best -> test' +cd .. + +cd temp2/ +touch test2 +darcs add test2 ; darcs record -a -m 'test2' +darcs mv test2 best ; darcs record -a -m 'test2 -> best' +darcs mv best test2 ; darcs record -a -m 'best -> test2' + +darcs pull ../temp1/ -a +cd .. + +rm -rf temp1 temp2 diff --git a/tests/issue244_changes.sh b/tests/issue244_changes.sh new file mode 100644 --- /dev/null +++ b/tests/issue244_changes.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash +set -ev + +# Issue244 +# darcs changes should be able to pull up the history for a file +# using its moved and not-yet recorded new name + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch b +darcs add b +darcs record -am 11 +darcs mv b c +darcs changes c | grep 11 +cd .. +rm -rf temp1 diff --git a/tests/issue257.sh b/tests/issue257.sh new file mode 100644 --- /dev/null +++ b/tests/issue257.sh @@ -0,0 +1,23 @@ +#!/usr/bin/env bash +set -ev + +rm -rf tempc +mkdir tempc +cd tempc +darcs init +echo foo > foo.c +darcs rec -Ax -alm init +cd .. +rm -rf temps +darcs get tempc temps +cd temps +echo server >> foo.c +darcs rec -Ax -alm server +cd ../tempc +echo client >> foo.c +darcs rec -Ax -alm client +if darcs push -a ../temps; then + false +fi +cd .. +rm -rf tempc temps diff --git a/tests/issue279_get_extra.sh b/tests/issue279_get_extra.sh new file mode 100644 --- /dev/null +++ b/tests/issue279_get_extra.sh @@ -0,0 +1,42 @@ +#!/usr/bin/env bash + +# issue279: a conflict case resulting in "bug in get_extra" with old +# format repos and "Malformed patch bundle" with darcs-2 repos. + +. lib + +rm -rf temp1 temp_a temp_b temp_c temp_d +mkdir temp1 +cd temp1 +darcs init --darcs-2 +echo 0 > f +darcs add f +darcs record -am 00 +cd .. + +for r in a b c d; do + darcs put --repodir temp1 temp_$r + cd temp_$r; + echo $r > f + darcs record -am "patch:$r"; + cd .. +done + +cd temp_d +darcs pull -a ../temp_a +darcs pull -a ../temp_b +darcs pull -a ../temp_c +cd .. +cd temp_c +darcs pull -a ../temp_a +darcs pull -a ../temp_b +echo rc > f +darcs record -a -m rc +cd .. +cd temp_d +darcs pull -a ../temp_c > log +not grep -i "no remote changes" log +not grep -i get_extra log +cd .. + +rm -rf temp1 temp_a temp_b temp_c temp_d log diff --git a/tests/issue381.sh b/tests/issue381.sh new file mode 100644 --- /dev/null +++ b/tests/issue381.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +set -ev + +# for issue381: "darcs send -o message --edit-description doesn't work" + +DARCS_EDITOR=echo +export DARCS_EDITOR + +rm -rf temp1 temp2 +mkdir temp1 temp2 + +cd temp2 +darcs init +cd .. + +cd temp1 +darcs init +echo Hello world > foobar +darcs add foobar +darcs record -a -A me -m add_foobar + +# Test that editor is called when --output is used with --edit-description +echo This is a note > note +cat > editor <> \$1 +cat \$1-temp >> \$1 +echo >> \$1 +echo finished editing >> \$1 +echo I am done running the editor +EOF + +chmod +x editor + +DARCS_EDITOR='bash editor' darcs send --debug --author=me -a --output=bundle --edit-description ../temp2 + +echo === beginning of bundle > === +cat bundle +echo === end of bundle > === + +grep ' add_foobar' bundle +grep 'finished editing' bundle + +IFS=' ' darcs send --author=me -a --subject="it works" --to user@place.org --sendmail-command='grep "^Subject: it works$" %<' ../temp2 + +cd .. +rm -rf temp1 temp2 diff --git a/tests/issue436.sh b/tests/issue436.sh new file mode 100644 --- /dev/null +++ b/tests/issue436.sh @@ -0,0 +1,30 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +# this test fails in the darcs 1 format +darcs init --darcs-2 +echo A > f +darcs add f +darcs record --ignore-times -a -m A +cd .. + +darcs get temp1 temp2 + +cd temp1 +echo C > f +darcs record --ignore-times -a -m A-C +cd .. + +cd temp2 +echo B > f +darcs record --ignore-times -a -m A-B +echo A > f +darcs record --ignore-times -a -m B-A +(darcs push -a || :) 2> push-result +grep "Refusing to apply" push-result +cd .. + +rm -rf temp1 temp2 diff --git a/tests/issue458.sh b/tests/issue458.sh new file mode 100644 --- /dev/null +++ b/tests/issue458.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash +### http://bugs.darcs.net/issue458 +### darcs get --set-scripts-executable ignores umask +set -ev + +## Windows doesn't support proper permissions. + +if echo $OS | grep -i windows; then + echo Windows does not support posix permissions + exit 0 +fi + +rm -rf temp +mkdir temp +cd temp + +mkdir repo1 +darcs initialize --repodir repo1 +printf >repo1/x '#!/bin/sh\ntrue' # make a shebang'd script +darcs record --repodir repo1 -lam x x +umask 077 # DENY ALL access to group, all +darcs get --set-scripts-executable repo1 repo2 +ls -l repo2/x | cut -f 1 -d\ > mode +echo -rwx------ > desired-mode +diff -u desired-mode mode + +cd .. +rm -rf temp diff --git a/tests/issue525_amend_duplicates.sh b/tests/issue525_amend_duplicates.sh new file mode 100644 --- /dev/null +++ b/tests/issue525_amend_duplicates.sh @@ -0,0 +1,24 @@ +#!/bin/sh + +set -ev + +## I would use the builtin !, but that has the wrong semantics. +not () { "$@" && exit 1 || :; } + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo first > a +darcs add a +darcs record -am 'first' +echo replace first with something else > a +darcs record -am 'mistake' +echo first > a +echo on second thought >> a +echo ya | darcs amend-record -a +darcs changes --last=1 -v > output +cat output +not grep first output +cd .. +rm -rf temp1 diff --git a/tests/issue53.sh b/tests/issue53.sh new file mode 100644 --- /dev/null +++ b/tests/issue53.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash + + +. lib + +if echo $OS | grep -i windows; then + echo This test does not work under Windows + exit 0 +fi + +# pull from not empty repo to empty repo +rm -rf temp1 +mkdir temp1 + +cd temp1 +darcs init +echo a > Aux.hs +not darcs add Aux.hs +darcs add --reserved-ok Aux.hs +echo b > foo +darcs add foo +darcs record -am 'two files' +not darcs mv foo com1 +darcs mv --reserved-ok foo com1 +cd .. + +rm -rf temp1 diff --git a/tests/issue538.sh b/tests/issue538.sh new file mode 100644 --- /dev/null +++ b/tests/issue538.sh @@ -0,0 +1,117 @@ +#!/bin/env bash +# A test for issue 538 - that an executable test script will run successfully if +# it is recorded with --set-scripts-executable. + +set -ev + +if echo $OS | grep -i windows; then + echo I do not know how to run a test program under windows + exit 0 +fi + +function make_repo_with_test { + mkdir temp1 ; cd temp1 ; darcs init + echo "#!/bin/sh" > test.sh + echo "echo 'hello world'" >> test.sh + darcs add test.sh + darcs record --author=test@test -am test + darcs setpref test './test.sh' +} + +# test record with --set-scripts-executable +rm -rf temp1 +make_repo_with_test +touch blaat +darcs add blaat +if darcs record --set-scripts-executable -A test@test -am blaat ; then + echo "ok 1" +else + echo "not ok 1 recording second patch failed (because test failed?)" + exit 1 +fi +cd .. + +# test record without --set-scripts-executable +rm -rf temp1 +make_repo_with_test +touch blaat +darcs add blaat +if darcs record --dont-set-scripts-executable -A test@test -am blaat ; then + echo "not ok 2 recording second patch succeeded though test script should not be executable" + exit 1 +else + echo "ok 2" +fi +cd .. + +# test amend-record with --set-scripts-executable +rm -rf temp1 +make_repo_with_test +touch blaat +darcs add blaat +if echo y | darcs amend-record --set-scripts-executable -A test@test -a ; then + echo "ok 3" +else + echo "not ok 3 amending patch failed (because test failed?)" + exit 1 +fi +cd .. + +# test amend-record without --set-scripts-executable +rm -rf temp1 +make_repo_with_test +touch blaat +darcs add blaat +if echo y | darcs amend-record --dont-set-scripts-executable -A test@test -a /dev/null ; then + echo "not ok 4 amending patch succeeded even though --dont-set-scripts-executable specified" + exit 1 +else + echo "ok 4" +fi +cd .. + +# trackdown with --set-scripts-executable +rm -rf temp1 +make_repo_with_test +if darcs trackdown --set-scripts-executable | grep 'Success!' ; then + echo "ok 5" +else + echo "not ok 5 tracking down with --set-scripts-executable failed (because test failed?)" + exit 1 +fi +cd .. + +# trackdown without --set-scripts-executable +rm -rf temp1 +make_repo_with_test +if darcs trackdown --dont-set-scripts-executable | grep 'Noone passed the test!' ; then + echo "ok 6" +else + echo "not ok 6 tracking down did not find failure even though --dont-set-scripts-executable was given" + exit 1 +fi +cd .. + +# check trackdown with files that become scripts during trackdown +rm -rf temp1 +mkdir temp1 ; cd temp1 ; darcs init +echo "#!/bin/sh" > test.sh +echo "./helper.sh" >> test.sh +echo "#!/bin/sh" > helper.sh +echo "echo 'helper speaking'" >> helper.sh +darcs add test.sh +darcs add helper.sh +darcs record -am 'valid helper' -A test +echo 'this is definitely not a valid script' > helper.sh +darcs record -am 'invalid helper' -A test +darcs setpref test './test.sh' +darcs trackdown --set-scripts-executable > trackdown-out +if grep 'Test failed!' trackdown-out && grep 'Success!' trackdown-out ; then + echo "ok 7" +else + echo "not ok 7 either no failure or no success (both should occur)" + exit 1 +fi +cd .. + +rm -rf temp1 diff --git a/tests/issue588.sh b/tests/issue588.sh new file mode 100644 --- /dev/null +++ b/tests/issue588.sh @@ -0,0 +1,32 @@ +#!/usr/bin/env bash + +# For issue588, "amend-record --look-for-adds end up with two "addfile" entries" + +set -ev + +rm -rf temp1 +darcs init --repodir temp1 + +# Setup f with contents foo. +echo foo > temp1/f +darcs add --repodir temp1 f +darcs rec --repodir temp1 -am p1 + +# Remove f, and amend p1, but only the hunk not the rmfile. +# Here we use look-for-adds to trigger the bug +rm temp1/f +echo yyd | darcs amend-record --repodir temp1 --look-for-adds + +darcs changes --repodir temp1 --last 1 -v + +echo show the buggy pending +cat temp1/_darcs/patches/pending + +echo bar > temp1/f +echo y | darcs amend-record --repodir temp1 --all + +darcs changes --repodir temp1 --last 1 -v + +darcs check --repodir temp1 --no-test + +rm -rf temp1 diff --git a/tests/issue595_get_permissions.sh b/tests/issue595_get_permissions.sh new file mode 100644 --- /dev/null +++ b/tests/issue595_get_permissions.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash + +# Issue595 +# +# A test for running "darcs get" when the parent directory has restrictive +# permissions. The bug is that darcs trys to "chdir" to the current directory +# using the full path. The permissions on the parent directory prevent this +# from working, even though the current repo and the remote have sufficient +# permissions. +# +# The real-world case where this would happen would be a web-server with +# restrictive permissions on "/home", with a user running darcs within that. + +. lib + +abort_windows + +rm -rf temp1 temp2 + +# Set up a "remote" repo +mkdir tmp_remote +cd tmp_remote +darcs 'init' +cd .. + +DIR=`pwd` +# Set up a directory with restrictive permissions +mkdir -p tmp_restrictive/liberal +cd tmp_restrictive/liberal +chmod 0111 ../../tmp_restrictive +# sanity check that we can cd out and back +cd ../..; cd tmp_restrictive/liberal +# TODO: we avoid this test on Solaris because it seems we can't create +# anything in tmp_restrictive/liberal +touch can_touch +if [ -e can_touch ]; then + if hwpwd; then + darcs get "$DIR/tmp_remote" 2> log + not grep -i 'permission denied' log + else + echo "Apparently I can't do `basename $0` on this platform" + fi +else + echo "Can't do `basename $0` on this platform" +fi +cd "$DIR" +# We have to fix the permissions, just so we can delete it. +chmod 0755 tmp_restrictive + +rm -rf tmp_remote tmp_restrictive diff --git a/tests/issue612_repo_not_writeable.sh b/tests/issue612_repo_not_writeable.sh new file mode 100644 --- /dev/null +++ b/tests/issue612_repo_not_writeable.sh @@ -0,0 +1,42 @@ +#!/usr/bin/env bash + +# Test that darcs fails appropriately when the target repo inventory file is not writable. +# See issue612 + +. lib + +abort_windows + +if grep old-fashioned .darcs/defaults; then + echo This test does not work with old-fashioned inventories + exit 0 +fi + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +touch t.t +darcs add t.t +darcs record -am "initial add" +if [ -e _darcs/inventories ]; then + chmod 0555 _darcs/inventories/* + chmod 0555 _darcs/inventories +fi +if [ -e _darcs/inventory ]; then + chmod 0555 _darcs/inventory +fi +cd .. + +darcs get temp1 temp2 +cd temp2 +echo new >> t.t +darcs record -am "new patch" +not darcs push -a ../r1 2> log +grep failed log +cd .. + +chmod -R 0755 temp1 +rm -rf temp1 temp2 + + diff --git a/tests/issue691.sh b/tests/issue691.sh new file mode 100644 --- /dev/null +++ b/tests/issue691.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp +mkdir temp +cd temp +darcs init +echo 'record patch-name' > _darcs/prefs/defaults # patch-name requires an argument +echo 'ALL unified foobar' >> _darcs/prefs/defaults # unified takes no argument +darcs record && exit 1 +darcs whats && exit 1 +rm -rf temp diff --git a/tests/issue706.sh b/tests/issue706.sh new file mode 100644 --- /dev/null +++ b/tests/issue706.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash +set -ev + +# for issue706: "Filenames with spaces issue" + +DARCS_EDITOR=echo +export DARCS_EDITOR + +rm -rf temp +mkdir temp +cd temp +darcs init + +touch 'A B' + +darcs add 'A B' +darcs rec -a -m 'a b' -A me +ls +darcs check + +cd .. +rm -rf temp diff --git a/tests/issue709_pending_look-for-adds.sh b/tests/issue709_pending_look-for-adds.sh new file mode 100644 --- /dev/null +++ b/tests/issue709_pending_look-for-adds.sh @@ -0,0 +1,56 @@ +#!/bin/sh +set -ve + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init + +# Here we check whether recording just one of two --look-for-add +# addfiles causes any trouble (which it doesn't) + +date > f1 +date > f2 +echo yyd | darcs record -l -m ff + +cat _darcs/patches/pending + +not darcs wh +rm f2 + +# Try recording a file add without --look-for-adds, with a setpref +# patch present that we don't record. + +darcs setpref boringfile .boring + +echo bar > bar +darcs add bar +echo yyd | darcs record -mbar + +cat _darcs/patches/pending + +darcs whatsnew -s + +test -z "`darcs whatsnew -s`" + +# Now try the same thing using --look-for-adds + +echo foo > foo + +darcs wh -l + +# remove any files added by profiling or hpc... +rm -f darcs.tix darcs.prof + +echo yyd | darcs record --look-for-adds -mfoo + +cat _darcs/patches/pending + +darcs whatsnew -s + +test -z "`darcs whatsnew -s`" + +cd .. +rm -rf temp1 diff --git a/tests/issue70_setpref.sh b/tests/issue70_setpref.sh new file mode 100644 --- /dev/null +++ b/tests/issue70_setpref.sh @@ -0,0 +1,62 @@ +#!/usr/bin/env bash +## Test for issue70 - unrecorded (pending) changes to preferences +## should coalesce; if you set the same preference more than once in +## the same patch, only the last change should actually be recorded. +## +## Copyright (C) 2005 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +darcs setpref predist apple +darcs setpref predist banana +darcs setpref predist clementine +darcs record -a -m manamana +darcs changes --verbose > log +not grep apple log +not grep banana log +grep clementine log +cd .. +rm -rf temp1 + +# not sure what i'm going for here - if coalescing happens strictly +# before commuting, no problem, but what if patches are commuted +# before coalescing? +mkdir temp1 +cd temp1 +darcs init +darcs setpref predist apple +darcs setpref predist banana +darcs setpref predist apple +darcs setpref predist clementine +darcs setpref predist banana +darcs record -a -m manamana +darcs changes --verbose > log +not grep apple log +not grep clementine log +grep banana log +cd .. +rm -rf temp1 diff --git a/tests/issue803.sh b/tests/issue803.sh new file mode 100644 --- /dev/null +++ b/tests/issue803.sh @@ -0,0 +1,31 @@ +#!/usr/bin/env bash + +# http://bugs.darcs.net/issue803: Darcs 2.0 regression on manual renames + + +. lib + +rm -rf temp +mkdir temp +cd temp +darcs init + +touch a.txt +darcs add a.txt +darcs record -a -m "First" -A me + +mkdir subdir +darcs add subdir +darcs record -a -m "Second" -A me + +mv a.txt subdir/ +darcs mv a.txt subdir/a.txt +darcs record -a -m "Third" -A me + +darcs changes --last 1 -v > stdout +cat stdout + +not grep 'rmfile' stdout + +cd .. +rm -rf temp diff --git a/tests/issue844_gzip_crc.sh b/tests/issue844_gzip_crc.sh new file mode 100644 --- /dev/null +++ b/tests/issue844_gzip_crc.sh @@ -0,0 +1,20 @@ +#!/usr/bin/env bash +set -ev +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +echo > a +darcs add a +darcs record a -a -m "init" +cd .. + +mkdir temp2 +cd temp2 +darcs init +darcs pull ../temp1 -a +darcs optimize --compress +for f in _darcs/patches/*-*; do + gzip -t < "$f" +done +rm -rf temp1 temp2 diff --git a/tests/issue864_replace_in_moved.sh b/tests/issue864_replace_in_moved.sh new file mode 100644 --- /dev/null +++ b/tests/issue864_replace_in_moved.sh @@ -0,0 +1,57 @@ +#!/usr/bin/env bash + +# Issue 864 + +# darcs mv file1 file2 +# edit file2 +# darcs replace fails if new token includes some existing edits + +# Regression in darcs2 - it works in darcs1 1.0.9 + +set -ev + +rm -rf temp +mkdir temp +cd temp +darcs init +cat < file1 +aa +bb +cc +aa +bb +cc +EOF +darcs add file1 +darcs record -a -m "0" --author X + +cat < file1 +aaaa +bb +cc +aa +bb +cc +EOF + +darcs replace aa aaaa file1 > out +cat out +grep 'Skipping file' out && exit 1 + +darcs mv file1 file2 + +cat < file2 +aaaa +beebee +cc +aa +bb +cc +EOF + +darcs replace bb beebee file2 > out +cat out +grep 'Skipping file' out && exit 1 + +cd .. +rm -rf temp diff --git a/tests/issue885_get_to_match.sh b/tests/issue885_get_to_match.sh new file mode 100644 --- /dev/null +++ b/tests/issue885_get_to_match.sh @@ -0,0 +1,34 @@ +#!/bin/sh + +# Issue885: Regression: "darcs get --to-match" does not work anymore under 2.0 + + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo first > a +darcs add a +darcs record -am 'first' +firsthash=`darcs changes --xml | grep 'hash=' | sed -e "s/.*hash='//" -e "s/'>//"` +echo second > b +darcs add b +darcs record -am 'second' + +# Pulling that patch works ok +cd .. +rm -rf temp2 +mkdir temp2 +cd temp2 +darcs init +echo darcs pull -v -a --match "hash $firsthash" ../temp1 +darcs pull -v -a --match "hash $firsthash" ../temp1 + +# Getting up-to that patch does not +cd .. +rm -rf temp3 +echo darcs get -v --to-match "hash $firsthash" temp1 temp3 +darcs get -v --to-match "hash $firsthash" temp1 temp3 + diff --git a/tests/issue966_diff.sh b/tests/issue966_diff.sh new file mode 100644 --- /dev/null +++ b/tests/issue966_diff.sh @@ -0,0 +1,25 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp +mkdir temp; cd temp +darcs init +echo "aaa diff" > file +darcs add file +darcs record -a -m "aaa" +echo "bbb diff" >> file +darcs record -a -m "bbb" + +darcs diff --patch "aaa" | grep "aaa diff" +darcs diff --patch "bbb" | grep "bbb diff" + +darcs tag release-1 +darcs optimize + +echo "ccc diff" >> file +darcs record -a -m "ccc" +darcs diff --patch "ccc" | grep "ccc diff" + +# here is where we have a problem +darcs diff --patch "aaa" | grep "aaa diff" +darcs diff --patch "bbb" | grep "bbb diff" diff --git a/tests/justrm.sh b/tests/justrm.sh new file mode 100644 --- /dev/null +++ b/tests/justrm.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch foo +darcs add foo +darcs record -a -m add_foo -A x +rm foo +darcs whatsnew +cd .. +rm -rf temp1 + diff --git a/tests/lazy-optimize-reorder.sh b/tests/lazy-optimize-reorder.sh new file mode 100644 --- /dev/null +++ b/tests/lazy-optimize-reorder.sh @@ -0,0 +1,64 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 temp2 temp3 +mkdir temp1 +cd temp1 +darcs init + +# this test only applies to hashed formats +if cat _darcs/inventory; then exit 0; fi + +date > f1 +darcs add f1 +darcs record -am 'add f1' + +darcs tag -m 'tag f1' + +date > f2 +darcs add f2 +darcs record -am 'add f2' +cd .. + +darcs get --lazy temp1 temp2 + +darcs get --lazy temp2 temp3 + +cd temp2 + +# Run darcs changes so we pull in the inventories (but no the patches) +darcs changes + +# Remove original repository, so we have no references to changes f1 and f2. +rm -rf ../temp1 + +# Now we should be unable to read some of the history +darcs changes -s > out +cat out +grep unavailable out + +date > f3 +darcs add f3 +darcs record -am 'add f3' + +darcs tag -m 'tag 123' +cd .. + +cd temp3 +date > f4 +darcs add f4 +darcs record -am 'add f4' +darcs pull -av + +# Here's the point of this test: we should be able to optimize +# --reorder without being able to read all the patches in the +# repository. +darcs optimize --reorder + +# Just a double-check: we shouldn't be able to check in this case. +not darcs check + +cd .. + +rm -rf temp1 temp2 temp3 temp4 diff --git a/tests/lib b/tests/lib new file mode 100644 --- /dev/null +++ b/tests/lib @@ -0,0 +1,18 @@ +# This is a -*- sh -*- library. +set -ev + +## I would use the builtin !, but that has the wrong semantics. +not () { "$@" && exit 1 || :; } + +# trick: OS-detection (if needed) +abort_windows () { +if echo $OS | grep -i windows; then + echo This test does not work on Windows + exit 0 +fi +} + +pwd() { + ghc --make "$TESTS_WD/hspwd.hs" + "$TESTS_WD/hspwd" +} diff --git a/tests/look_for_add.sh b/tests/look_for_add.sh new file mode 100644 --- /dev/null +++ b/tests/look_for_add.sh @@ -0,0 +1,37 @@ +#!/usr/bin/env bash + +cat > empty_pending < dir/foo +echo zag > foo +mkdir dir2 +echo hi > dir2/foo2 +darcs record -a -m add_foo -A x --look-for-adds +check_empty_pending +cd ../temp2 +darcs init +darcs pull -a ../temp1 +cd .. +cmp temp1/dir2/foo2 temp2/dir2/foo2 +cmp temp1/dir/foo temp2/dir/foo +cmp temp1/foo temp2/foo +rm -rf temp1 temp2 + diff --git a/tests/mark-conflicts.sh b/tests/mark-conflicts.sh new file mode 100644 --- /dev/null +++ b/tests/mark-conflicts.sh @@ -0,0 +1,38 @@ +#!/usr/bin/env bash + +# Automated tests for "darcs mark-conflicts". + +# The builtin ! has the wrong semantics for not. +not () { "$@" && exit 1 || :; } + +mkdir temp1 +cd temp1 +darcs init +echo "Conflict, Base ." > child_of_conflict +darcs add child_of_conflict +darcs record -am 'Conflict Base' +cd .. +darcs get temp1 temp2 + +# Add and record differing lines to both repos +cd temp1 +echo "Conflict, Part 1." > child_of_conflict +darcs record -A author -am 'Conflict Part 1' +cd .. +cd temp2 +echo "Conflict, Part 2." > child_of_conflict +darcs record -A author -am 'Conflict Part 2' +cd .. + +cd temp1 +darcs pull -a ../temp2 > log +grep conflict log +grep finished log +grep 'v v' child_of_conflict +darcs revert -a +not grep 'v v' child_of_conflict +darcs mark-conflicts +grep 'v v' child_of_conflict +cd .. + +rm -rf temp1 temp2 diff --git a/tests/match-date.sh b/tests/match-date.sh new file mode 100644 --- /dev/null +++ b/tests/match-date.sh @@ -0,0 +1,196 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 +# Some tests for the '--match' flag, specifically the date-matching + +reset_repo () { + cd .. + rm -rf temp1 + mkdir temp1 + cd temp1 + darcs init + touch bar + darcs add bar +} + +create_entry () { + echo $1 >> bar + echo "$1/tester/a///" | tr / \\012 | darcs record -m "" --pipe bar +} + +create_entry_now () { + echo today >> bar + darcs record -m "" bar -a -A tester +} + +# parse_date just checks for parsing, while match_date checks for an actual match. +# It's better if we can use "match_date", but we have to be able to construct such a date +# based on a date dynamically generated by this test script. + +# alternately, it might be more useful to build a random date string generator +# using QuickCheck... for any n random CalendarTimes, have it generate some +# possible variants and roundtrip them to see if they match + +parse_date () { + darcs changes --match "date \"$1\"" > log + not grep fancy log +} + +match_date () { + darcs changes --match "date \"$1\"" > log + grep tester log + not grep fancy log +} + +nomatch_date () { + darcs changes --match "date \"$1\"" > log + not grep tester log + not grep fancy log +} + +mkdir temp1 +cd temp1 +reset_repo + +# this block of dates should all refer to the same thing +year=1973 +mm=02 +dd=04 +hhmmss="15:08" +create_entry "$year-$mm-$dd $hhmmss" +echo "/tester/a///" | tr / \\012 | darcs record -m "" --pipe bar +match_date "$year-$mm-$dd" +match_date "$year$mm$dd" +match_date "$year-$mm" +match_date "$year$mm" +match_date "$year" + +# week dates. note that 2007 was selected as it starts on Monday +reset_repo +create_entry "2007-01-04 15:00" +match_date '2007-W01-4' +nomatch_date '2007-W01-1' +match_date '2007W014' +match_date '2007-W01' +nomatch_date '2007-W02-1' +create_entry "2007-01-08 15:00" +match_date '2007-W02' +match_date '2007-W02-1' +create_entry "2007-05-20 15:00" +match_date '2007-W20' +nomatch_date '2007-W21' +nomatch_date '2007-W19' +# ordinal dates. eh... why not? +match_date '2007-004'; # fourth day of 2007 +match_date '2007004' +nomatch_date '2007-005' + +# midnight and zero +reset_repo +create_entry "1992-10-15 00:00" +match_date '1992-10-14 24:00' +match_date '1992-10-15 00:00' + +# all the same date/time +reset_repo +create_entry "1992-02-12T22:32:11" +match_date '1992-02-12T22:32:11' +match_date '1992-02-12 22:32:11' +match_date '1992-02-12T223211.0000' + +# english dates - the old hard coded from < darcs 1.0.6 +reset_repo +year=`date +%Y` +mm=`date +%m` +dd=`date +%d` +hhmmss=`date +%k:%M:%S` +tz=`date +%z` +create_entry "$(($year-1))-$mm-$dd" +nomatch_date 'today' +nomatch_date 'yesterday' +nomatch_date 'day before yesterday' +nomatch_date 'last week' +nomatch_date 'last month' +# note: this test might fail if you run it just before midnight +reset_repo +create_entry_now +match_date 'today' +nomatch_date 'yesterday' +nomatch_date 'day before yesterday' +match_date 'last week' +match_date 'last month' + +reset_repo +create_entry "$(($year-1))-$mm-$dd" +# english dates - new possibilities +nomatch_date 'yesterday at 14:00:00' +match_date 'last 3 years' +match_date 'last year' +nomatch_date '2 days ago' +nomatch_date 'last month 13:00' +nomatch_date '3 days before last week' +reset_repo +create_entry_now +match_date 'day after yesterday' +match_date 'week after last week' +create_entry "1992-10-02 00:15" +match_date '15 minutes after 1992-10-02' +reset_repo +create_entry "1992-10-02 00:15+05" +# note that earlier dates will always match +match_date '15 minutes after 1992-10-02 00:00+05'; # same time +match_date '15 minutes after 1992-10-01 23:00+04'; # same time +nomatch_date '15 minutes after 1992-10-02 01:00+05'; # 1 hour later +nomatch_date '15 minutes after 1992-10-02 00:00+04'; # 1 hour later +nomatch_date '1 hour, 15 minutes after 1992-10-02 00:00+05'; # 1 hour later +match_date '1 hour, 15 minutes after 1992-10-02 00:00+06'; # same time +match_date '1 hour, 15 minutes after 1992-10-01 23:00+05'; # same time + +reset_repo +create_entry_now +create_entry 1992-10-02 00:15 +# english intervals +nomatch_date 'between last fortnight and day before yesterday' +match_date 'between last fortnight and today' +match_date 'in the last 45 seconds' +match_date 'after 1992' + +# iso 8601 intervals +parse_date '1992-10-02 00:00Z/1992-10-02 00:16Z' +match_date '1992-10-02 00:00/1992-10-02 00:16' +match_date 'between 1992-10-02 00:00 and 1992-10-12 00:16' +parse_date 'P3YT3M/1992' +parse_date '1992/P3Y3M4DT5H3M2S' +parse_date '1992/P3Y3M' + +# stuff from the manual +reset_repo +create_entry_now +nomatch_date 'between 2004-03-12 and last week' +match_date 'last week' +parse_date 'yesterday' +parse_date 'today 14:00' +nomatch_date '3 days before last year at 17:00' +# We can't in general parse the raw date output by darcs. If we change the +# format to not include timezone information, this would be possible. But +# maybe that's not desireable. For now, we just won't test the raw date. +#match_date "$raw_date" +parse_date 'after 2005' +parse_date 'in the last 3 weeks' +parse_date 'P3M/2006-03-17' +parse_date '2004-01-02/2006-03-17' +parse_date 'P2M6D' + +# cvs dates +parse_date '2006/01/19 21:14:20 UTC' +# We can't handle all timezones in the old style dates +# so this test will not work everywhere +# match_date "$year/$mm/$dd $hhmmss $tz" + +reset_repo +create_entry '2038-01-01' +match_date 'after 2037' + +rm -rf temp1 temp2 diff --git a/tests/match.sh b/tests/match.sh new file mode 100644 --- /dev/null +++ b/tests/match.sh @@ -0,0 +1,97 @@ +#!/usr/bin/env bash + +# Some tests for the '--match' flag + +. lib + +# set up the repository +rm -rf temp1 # another script may have left a mess. +mkdir temp1 +cd temp1 +darcs init +cd .. + +# create three patches - the property we exploit to determine +# if a matcher does the right thing is that each patch has a +# different author +cd temp1 +touch bar +darcs add bar +darcs record -a -m "first patch" bar -A author1 +echo foo > bar +darcs record -a -m "\"second\" \\ patch" bar -A author2 +echo blop > bar +darcs record -a -m "second" bar -A author3 +cd .. + +# ------------------------------------------------------------------- +# single matchers +# ------------------------------------------------------------------- + +cd temp1 +# matching on author really matches on that, and not something else +darcs changes --match='author "first patch"' > log +not grep '.' log +# normal changes shows both authors and patch names +darcs changes > log +grep author1 log +grep author2 log +grep author3 log +grep 'first patch' log +grep '"second" \\ patch' log +grep -v patch log | grep second +# exact +darcs changes --match='exact second' > log +not grep author1 log +not grep author2 log +grep author3 log +# name +darcs changes --match='name second' > log +not grep author1 log +grep author2 log +grep author2 log +# author +darcs changes --match='author author1' > log +grep author1 log +not grep author2 log +not grep author3 log +#hash +darcs changes --xml-output --match='exact "\"second\" \ patch"' > log +hash=`grep hash log | sed -e "s/.*hash='//" -e "s/'.*//"` +echo $hash +darcs changes --match="hash $hash" +not grep author1 log +grep author2 log +not grep author3 log +cd .. + +# ------------------------------------------------------------------- +# matching on combinations +# +# uses the setup from the atomic patches +# ------------------------------------------------------------------- + +cd temp1 +# or +darcs changes --match='author author1 || author author2' > log +grep author1 log +grep author2 log +not grep author3 log +# and +darcs changes --match='name second && author author2' > log +not grep author1 log +grep author2 log +not grep author3 log +# not +darcs changes --match='not name second' > log +grep author1 log +not grep author2 log +not grep author3 log +# grouping +darcs changes --match='(not name second) || (author author3)' > log +grep author1 log +not grep author2 log +grep author3 log +cd .. + +rm -rf temp1 diff --git a/tests/merge_three_patches.sh b/tests/merge_three_patches.sh new file mode 100644 --- /dev/null +++ b/tests/merge_three_patches.sh @@ -0,0 +1,52 @@ +#!/usr/bin/env bash +set -ev + +rm -rf tempOld tempA tempB +mkdir tempOld tempA +cd tempOld +darcs initialize +echo record author me > _darcs/prefs/defaults +echo ALL all >> _darcs/prefs/defaults +#echo ALL verbose >> _darcs/prefs/defaults +echo ALL ignore-times >> _darcs/prefs/defaults +echo A > foo +echo B >> foo +echo C >> foo +echo D >> foo +echo E >> foo +echo F >> foo +echo G >> foo +echo H >> foo +darcs add foo +darcs record -m Old +cd .. + +cd tempA +darcs initialize +cp ../tempOld/_darcs/prefs/defaults _darcs/prefs +darcs pull ../tempOld +cp foo temp +cat temp | grep -v A | grep -v B | grep -v D | sed s/E/e/ \ + | grep -v G | sed s/H/h/ > foo +darcs record -m AA +cd .. + +darcs get tempOld tempB +cd tempB +cp ../tempOld/_darcs/prefs/defaults _darcs/prefs +echo 7 > foo +darcs record -m BB +darcs pull ../tempA +darcs record -m "conflict resolution" +cd .. + +cd tempA +darcs pull ../tempB +darcs annotate -p B +darcs annotate -p resolution +cd .. + +cmp tempA/foo tempB/foo + +rm -rf tempOld tempA tempB + diff --git a/tests/mergeresolved.sh b/tests/mergeresolved.sh new file mode 100644 --- /dev/null +++ b/tests/mergeresolved.sh @@ -0,0 +1,57 @@ +#!/usr/bin/env bash +set -ev + +rm -rf fooOld tempA tempB +mkdir fooOld tempA tempB +cd fooOld +darcs init +echo record author me > _darcs/prefs/defaults +echo ALL all >> _darcs/prefs/defaults +#echo ALL verbose >> _darcs/prefs/defaults +echo ALL ignore-times >> _darcs/prefs/defaults +echo Old > foo +darcs add foo +darcs record -m Old +cd .. + +cd tempA +darcs init +cp ../fooOld/_darcs/prefs/defaults _darcs/prefs +darcs pull ../fooOld +echo A > foo +darcs record -m AA +cd .. + +cd tempB +darcs init +cp ../fooOld/_darcs/prefs/defaults _darcs/prefs +darcs pull ../fooOld +echo B > foo +darcs record -m BB +darcs pull ../tempA +echo A > foo +darcs record -m "ok A's fine." +cd .. + +# At this point, tempB and tempA should agree--since the conflict was +# resolved in favor of tempA. +cmp tempB/foo tempA/foo + +cd tempA +echo AA > foo +darcs record -m "AA -- upping the ante." +cd .. + +cd tempB +darcs pull ../tempA +cd .. + +cd tempA +darcs pull ../tempB +cd .. + +# At this point, tempB and tempA should agree since we have pulled both ways. +cmp tempB/foo tempA/foo + +rm -rf fooOld tempA tempB + diff --git a/tests/merging_newlines.sh b/tests/merging_newlines.sh new file mode 100644 --- /dev/null +++ b/tests/merging_newlines.sh @@ -0,0 +1,40 @@ +#!/usr/bin/env bash + +# trick: requiring something to fail +. lib + +# A test for darcs resolve detecting a conflict, inspired by bug #152 in RT + +rm -rf temp1 temp2 + +# set up the repository +mkdir temp1 +cd temp1 +darcs init +cd .. + +cd temp1 +echo "apply allow-conflicts" > _darcs/prefs/defaults +# note: to make this pass, change echo to echo -n +# is that right? +echo "from temp1" > one.txt +darcs add one.txt +darcs record -A bar -am "add one.txt" +echo >> one.txt +darcs wh -u +cd .. + +darcs get temp1 temp2 +cd temp2 +# reality check +darcs show files | grep one.txt +echo "in tmp2" >> one.txt +darcs whatsnew -s | grep M +darcs record -A bar -am "add extra line" +darcs annotate -p . -u +darcs push -av > log +cat log +not grep -i conflicts log +cd .. + +rm -rf temp1 temp2 diff --git a/tests/mv-formerly-pl.sh b/tests/mv-formerly-pl.sh new file mode 100644 --- /dev/null +++ b/tests/mv-formerly-pl.sh @@ -0,0 +1,136 @@ +#!/usr/bin/env bash + +# Some tests for 'darcs mv' + +. lib + +rm -rf temp +mkdir temp +cd temp +darcs init + +### + +echo adding a directory with more than one .. in it should work. +mkdir foo.d +mkdir foo.d/second +mkdir foo.d/second/third +mkdir foo.d/other + + +touch ./foo.d/other/date.t +darcs add -r foo.d + +cd foo.d/second/third + +darcs mv ../../other/date.t ../../other/date_moved.t + +cd ../../.. +echo darcs refuses to move to an existing file +touch ping +touch pong +darcs add ping pong +not darcs mv ping pong &> out +cat out +grep 'already exists' out + +# case sensitivity series +# ----------------------- +# these are tests designed to check out darcs behave wrt to renames +# where the case of the file becomes important + +# are we on a case sensitive file system? +touch is_it_cs +rm -f IS_IT_CS + +if test -e is_it_cs; then + echo This is a case-sensitive file system. +else + echo This is NOT a case-sensitive file system. +fi + +# if the new file already exists - we don't allow it +# basically the same test as mv ping pong, except we do mv ping PING +# and both ping and PING exist on the filesystem +echo "case sensitivity - simply don't allow mv if new file exists" +touch 'cs-n-1'; touch 'CS-N-1'; +touch 'cs-y-1'; touch 'CS-Y-1'; +darcs add cs-n-1 cs-y-1 + +if test -e is_it_cs; then + # regardless of case-ok, we do NOT want this mv at all + not darcs mv cs-n-1 CS-Y-1 &> out + cat out + grep 'already exists' out + + not darcs mv --case-ok cs-n-1 CS-Y-1 &> out + cat out + grep 'already exists' out +fi + +# if the new file does not already exist - we allow it +echo "case sensitivity - the new file does *not* exist" +touch 'cs-n-2'; +touch 'cs-y-2'; +darcs add cs-n-2 cs-y-2 +# these mv's should be allowed regardless of flag or filesystem +darcs mv cs-n-2 CS-N-2 +darcs mv --case-ok cs-y-2 CS-Y-2 + +# parasites - do not accidentally overwrite a file just because it has a +# similar name and points to the same inode. We want to check if a file if the +# same NAME already exists - we shouldn't care about what the actual file is! +echo "case sensitivity - inode check"; +touch 'cs-n-3'; +touch 'cs-y-3'; +darcs add cs-n-3 cs-y-3 + +if ln cs-n-3 CS-N-3; then # checking if we support hard links + ln cs-y-3 CS-Y-3 + # regardless of case-ok, we do NOT want this mv at all + not darcs mv cs-n-3 CS-N-3 &> out + cat out + grep 'already exists' out + + not darcs mv --case-ok cs-y-3 CS-Y-3 &> out + cat out + grep 'already exists' out +fi + +# parasites - we don't allow weird stuff like mv foo bar/foo just because +# we opened up some crazy exception based on foo's name +echo 'refuses to move to an existing file with same name, different path' +touch 'cs-n-4'; touch 'foo.d/cs-n-4'; +touch 'cs-y-4'; touch 'foo.d/cs-y-4'; +darcs add cs-n-4 +# regardless of case-ok, we do NOT want this mv at all +not darcs mv cs-n-4 foo.d/cs-n-4 &> out +cat out +grep 'already exists' out + +not darcs mv --case-ok cs-y-4 foo.d/cs-y-4 &> out +cat out +grep 'already exists' out + +# --------------------------- +# end case sensitivity series + +touch abs_path.t +darcs add abs_path.t +REPO_ABS=`pwd` +darcs mv "$REPO_ABS/abs_path.t" abs_path_new.t +darcs mv abs_path_new.t "$REPO_ABS/abs_path.t" + + +# issue608 + + touch 'gonna_be_deleted'; + darcs add gonna_be_deleted + darcs record -am 'added doomed file' + rm gonna_be_deleted + darcs record -am 'deleted file' + touch 'new_file'; + darcs add new_file + darcs mv new_file gonna_be_deleted + + diff --git a/tests/mv-test-suite.sh b/tests/mv-test-suite.sh new file mode 100644 --- /dev/null +++ b/tests/mv-test-suite.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash + +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init + +date > foo +darcs record -a -m add_foo -A x --look-for-adds + +# add a test file +echo 'test ! -e foo' > test.sh +darcs add test.sh +darcs record -a -m add_test + +darcs setpref test 'ls && bash test.sh' +darcs record -a -m settest -A x --no-test + +darcs mv foo bar +darcs record --debug -a -m mvfoo -A x + +darcs check + +cd .. +rm -rf temp1 + diff --git a/tests/mv.sh b/tests/mv.sh new file mode 100644 --- /dev/null +++ b/tests/mv.sh @@ -0,0 +1,53 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp +mkdir temp +cd temp +darcs init +echo hi world > temp.c +darcs add temp.c +darcs record --all -A test --patch-name=hi +echo goodbye >> temp.c +darcs whatsnew +darcs record -a -A au -m bye +echo bar > bar.c +darcs add bar.c +darcs record -a -m one -A ex +darcs mv bar.c zig.c +darcs whatsnew +darcs record -a -m two -A ex +mkdir baz +darcs add baz +darcs whatsnew +darcs record -a -m three -A ex +darcs mv zig.c baz/bar.c +darcs whatsnew +darcs record -a -m four -A ex +darcs mv baz temp +darcs whatsnew +darcs record -a -m five -A ex + +darcs mv temp temp 1> stdout 2> stderr || true +grep 'Cannot rename a file or directory onto itself' stderr + +cd .. + +rm -rf temp +mkdir temp +cd temp +darcs init +echo hi world > a +darcs add a +darcs record --all -m lower +cd .. +darcs get temp temp1 +cd temp +darcs mv a A +echo goodbye > A +darcs record --all -m 'to upper' +cd ../temp1 +darcs pull -a + +cd .. +rm -rf temp temp1 diff --git a/tests/mv_and_remove_tests.sh b/tests/mv_and_remove_tests.sh new file mode 100644 --- /dev/null +++ b/tests/mv_and_remove_tests.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp +mkdir temp +cd temp + +darcs init +touch fee fi fo fum +darcs add f* +darcs record --author me --all --no-test --patch-name add +mkdir d +darcs add d +darcs mv f* d +darcs remove d/fi +cd d +darcs remove fo +echo let us have fun > fun +darcs add fun +darcs mv fun fum .. +darcs record --author me --all --no-test --patch-name mv +cd .. + +if darcs show files | egrep '^./fee$'; then false; else true; fi +test ! -f fee +darcs show contents d/fee | cmp d/fee - + +test ! -f fi +test -f d/fi +if darcs show files | egrep '^./fi$'; then false; else true; fi +if darcs show files | egrep '^./d/fi$'; then false; else true; fi + +test ! -f fo +test -f d/fo +if darcs show files | egrep '^./fo$'; then false; else true; fi +if darcs show files | egrep '^./d/fo$'; then false; else true; fi + +darcs show contents fun | cmp fun - +darcs show contents fum | cmp fum - + +darcs mv fun d +darcs record -A me -a --no-test -m "fun again" +darcs show content d/fun | cmp d/fun - +test ! -f fun +if darcs show files | egrep '^./fun$'; then false; else true; fi + +# Now clean up. +cd .. +rm -rf temp + diff --git a/tests/mv_then_add.sh b/tests/mv_then_add.sh new file mode 100644 --- /dev/null +++ b/tests/mv_then_add.sh @@ -0,0 +1,25 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp +mkdir temp +cd temp + +darcs init +touch fee fi fo fum +darcs add f* +darcs record --author me --all --no-test --patch-name add +darcs mv fee foo +touch fee +darcs add fee +darcs record --author me --all --no-test --patch-name newfee +darcs mv fi fib +darcs record --author me --all --no-test --patch-name mvfi +date > fi +darcs add fi +darcs record --author me --all --no-test --patch-name newfi + +cd .. + +rm -rf temp + diff --git a/tests/network/changes.sh b/tests/network/changes.sh new file mode 100644 --- /dev/null +++ b/tests/network/changes.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash +set -ev + +# Demonstrates issue385 +darcs changes --repo=http://darcs.net GNUmakefile --last 300 diff --git a/tests/network/get.sh b/tests/network/get.sh new file mode 100644 --- /dev/null +++ b/tests/network/get.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp temp2 temp3 + +#"$DARCS" get http://darcs.net temp + +darcs get --lazy http://darcs.net temp2 + +darcs get --lazy --tag . http://darcs.net temp3 + +cd temp2 +darcs obliterate --from-tag . -a +darcs pull --tag . -a +cd .. + +diff -u temp2/_darcs/hashed_inventory temp3/_darcs/hashed_inventory + +rm -rf temp temp2 temp3 diff --git a/tests/network/lazy-get.sh b/tests/network/lazy-get.sh new file mode 100644 --- /dev/null +++ b/tests/network/lazy-get.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp temp2 temp3 + +darcs get --lazy http://darcs.net/repos/franchise temp + +darcs get --lazy temp temp2 + +rm -rf temp + +cd temp2 + +test ! -f _darcs/patches/0000003700-fb09ec6a61b35ac7aa77e65388b1a0c182fddca9a908f1a08d0bc5653f2f2d2a + +darcs annotate -p 'initial minimal version' + +test -f _darcs/patches/0000003700-fb09ec6a61b35ac7aa77e65388b1a0c182fddca9a908f1a08d0bc5653f2f2d2a + +cd .. + +rm -rf temp temp2 temp3 diff --git a/tests/nodeps.sh b/tests/nodeps.sh new file mode 100644 --- /dev/null +++ b/tests/nodeps.sh @@ -0,0 +1,81 @@ +#!/usr/bin/env bash +set -ev + +# Test the --no-deps option with Send, Push, Pull, Obliterate and Unrecord. +# +# Create four patches with dependencies. +# file 'f': patch 'fa' and 'fb' +# file 'g': patch 'ga' and 'gb' +# The 'b' patches depend on the 'a' patches. + +rm -rf tmp1 +mkdir tmp1 +cd tmp1 +darcs init +echo 'record no-ask-deps' >> _darcs/prefs/defaults +echo 'record ignore-times' >> _darcs/prefs/defaults +echo 'a' > f +darcs add f +darcs rec -am 'fa' f +echo 'a' > g +darcs add g +darcs rec -am 'ga' g +echo 'b' > f +darcs rec -am 'fb' f +echo 'b' > g +darcs rec -am 'gb' g + + +mkdir d +darcs init --repodir d + + +# Try to Send all 'b' and 'g' patches. The two 'g' patches should succeed, +# but the 'fb' patch depends on the unselected 'fa' patch, an should be +# skipped. + +darcs send -o bundle -a -p '[bg]' --no-deps d +grep '^\[ga$' bundle +grep '^\[fb$' bundle && exit 1 + + +# Try to Push all 'b' and 'g' patches. Expect same result as for Send. + +darcs push -a -p '[bg]' --no-deps d +cd d +darcs changes | grep '^ \* ga$' +darcs changes | grep '^ \* fb$' && exit 1 +# stay in d !! + + +# Try to Pull all 'b' and 'g' patches. Expect same result as for Send. + +# already in d +rm -rf *; darcs init +darcs pull -a -p '[bg]' --no-deps .. +darcs changes | grep '^ \* ga$' +darcs changes | grep '^ \* fb$' && exit 1 +cd .. + + +# Try to Obliterate all 'a' and 'g' patches. The two 'g' patches should +# succeed, but the 'fa' patch depends on the unselected 'fb' patch, an +# should be skipped. + +darcs get . tmp; cd tmp +echo y/y/y/q | tr / \\012 | darcs obliterate -p '[ag]' --no-deps +darcs changes | grep '^ \* gb$' && exit 1 +darcs changes | grep '^ \* fa$' +cd .. + + +# Try to Unrecord all 'a' and 'g' patches. Expect same result as for +# Obliterate. + +# in "top" tmp repo -- destroys it! +echo y/y/y/q | tr / \\012 | darcs unrecord -p '[ag]' --no-deps +darcs changes | grep '^ \* gb$' && exit 1 +darcs changes | grep '^ \* fa$' + +cd .. +rm -rf tmp1 diff --git a/tests/nonewline.sh b/tests/nonewline.sh new file mode 100644 --- /dev/null +++ b/tests/nonewline.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 +mkdir temp1 temp2 +cd temp1 +darcs init +echo -n zig > foo +darcs add foo +sleep 1 +darcs record -a -m add_foo -A x +#sleep 1 +echo -n zag >> foo +darcs record --ignore-time -a -m mod_foo -A x +cd ../temp2 +darcs init +darcs pull -a ../temp1 +cd .. +cmp temp1/foo temp2/foo +rm -rf temp1 temp2 + diff --git a/tests/obliterate-add.sh b/tests/obliterate-add.sh new file mode 100644 --- /dev/null +++ b/tests/obliterate-add.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo foo > foo +darcs add foo + +darcs record -a -m 'addfoo' + +darcs obliterate -a + +not darcs whatsnew + +cd .. +rm -rf temp1 diff --git a/tests/obliterate-formerly-pl.sh b/tests/obliterate-formerly-pl.sh new file mode 100644 --- /dev/null +++ b/tests/obliterate-formerly-pl.sh @@ -0,0 +1,32 @@ +#!/usr/bin/env bash +# Some tests for 'darcs obliterate' + +. lib + +rm -rf temp1 + +# set up the repository +mkdir temp1 +cd temp1 +darcs init +cd .. + +cd temp1 +touch a.txt +darcs add a.txt +darcs record -a -m 'adding a' a.txt +touch b.txt +darcs add b.txt +darcs record -a -m 'adding b' b.txt +# extra confirmation for --all +echo an | darcs obliterate -p add | grep -i "really obliterate" +# --last=1 +echo n | darcs obliterate --last 1 | grep -i adding +# automatically getting dependencies +date >> a.txt +darcs record -a -m 'modifying a' a.txt +echo n | darcs obliterate -p 'adding a' > log +grep -i "modifying a" log +grep -i "No patches selected" log +cd .. +rm -rf temp1 diff --git a/tests/obliterate.sh b/tests/obliterate.sh new file mode 100644 --- /dev/null +++ b/tests/obliterate.sh @@ -0,0 +1,51 @@ +#!/usr/bin/env bash +set -ev + +rm -rf tempA +mkdir tempA +cd tempA +darcs initialize +echo hello world > foo +darcs add foo +darcs record -a -m hellofoo + +echo goodbye world >> foo +darcs record -a -m goodbyefoo + +darcs replace world bar foo +echo Hi there foo > bar +darcs add bar +darcs record -a -m addbar + +darcs mv bar baz +darcs replace bar baz foo +darcs record -a -m bar2baz + +echo Do not love the baz, or anything in the baz. >> foo +darcs record -a -m nolove + +darcs mv baz world +darcs replace baz world foo +darcs record -a -m baz2world + +darcs whatsnew | grep 'No changes' + +grep 'love the world' foo + +echo y | darcs obliterate -p baz2world + +darcs whatsnew | grep 'No changes' + +grep 'love the baz' foo + +echo y | darcs obliterate -p bar2baz + +grep 'love the bar' foo + +echo y | darcs obliterate -p nolove + +grep 'love' foo && exit 1 || true + +cd .. +rm -rf tempA + diff --git a/tests/optimize.sh b/tests/optimize.sh new file mode 100644 --- /dev/null +++ b/tests/optimize.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash +set -ev + +# tests for "darcs optimize" + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch foo +darcs add foo +darcs record -a -m add_foo +darcs optimize --reorder-patches| grep -i "done optimizing" +cd .. + +rm -rf temp1 diff --git a/tests/optimize_relink.sh b/tests/optimize_relink.sh new file mode 100644 --- /dev/null +++ b/tests/optimize_relink.sh @@ -0,0 +1,59 @@ + +#!/usr/bin/env bash + +# For issue600, testing optimize --relink + +set -ev + +## We don't support hard links on Windows. + +if echo $OS | grep -i windows; then + echo darcs does not support hard links on Windows + exit 0 +fi + +## compare succeeds if there are hard links +compare () { + echo 'use File::Basename; $res=0; while ($fn=<'$1'/*>) { $fn2="'$2'/" . basename($fn); @fd1=lstat($fn); @fd2=lstat($fn2); $res += ($fd1[1] != $fd2[1]);}; exit($res);' | perl +} + +rm -rf temp +mkdir temp +cd temp + +mkdir x +darcs init --repodir x +cd x +date > foo +darcs add foo +darcs record -a -A me -m 'addfoo' +cd .. + +## Does the filesystem support hard linking at all? +mkdir z1 +echo "hi" > z1/foo +mkdir z2 +if ! ln z1/foo z2/foo ; then + echo No ln command for `pwd` - assuming no hard links. + exit 0 +fi +if ! compare z1 z2 ; then + echo Filesystem for `pwd` does not support hard links. + exit 0 +fi +# workaround for SunOS cp which does not support `-a' option but also +# doesn't fail when it is encountered. +cp -r x y + +## Now try relinking using darcs. +rm -rf z +darcs optimize --verbose --relink --repodir x --sibling y +rm -rf x/_darcs/patches/pend* y/_darcs/patches/pend* +if compare x/_darcs/patches y/_darcs/patches +then echo darcs --relink is working, hard links were done. +else echo darcs --relink is not working, it did not make any hard links. + exit 2 +fi + +cd .. +rm -rf temp diff --git a/tests/output.sh b/tests/output.sh new file mode 100644 --- /dev/null +++ b/tests/output.sh @@ -0,0 +1,67 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 temp3 +mkdir temp2 +cd temp2 +darcs init +cd .. + +mkdir temp1 +cd temp1 +darcs init +touch foo bar +darcs add foo bar +darcs record -a -m foobar -A author +darcs send -a --dont-edit-description -o ../temp3 ../temp2 +test -f ../temp3 + +darcs send -a --dont-edit-description -o ../temp2/patchfile ../temp2 +test -f ../temp2/patchfile + +mkdir subdir +darcs send -a --dont-edit-description -o subdir/../../temp2/patchfile1 ../temp2 +test -f ../temp2/patchfile1 + +cp ../temp3 correct + +cd subdir +darcs send -a --dont-edit-description -o ../patchfile ../../temp2 +diff -u ../patchfile ../correct + +rm ../patchfile +darcs send -a --dont-edit-description -o - ../../temp2 > ../patchfile +grep -v Creating ../patchfile | diff -u ../correct - + +darcs apply --repodir=../../temp2 --dry-run ../patchfile > out +cat out +grep foobar out + +cd ../.. + +cd temp2 + +darcs apply --dry-run ../temp3 > out +cat out +grep foobar out + +darcs apply --dry-run ../temp1/correct > out +cat out +grep foobar out + +darcs apply --dry-run ../temp1/patchfile > out +cat out +grep foobar out + +darcs apply --dry-run ../temp3 > out +cat out +grep foobar out + +darcs apply --dry-run ../temp3 > out +cat out +grep foobar out + +cd .. + +rm -rf temp1 temp2 temp3 + diff --git a/tests/overriding-defaults.sh b/tests/overriding-defaults.sh new file mode 100644 --- /dev/null +++ b/tests/overriding-defaults.sh @@ -0,0 +1,61 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp +mkdir temp +cd temp +darcs init +darcs setpref test false +darcs record --no-test -a -m 'add failing test' + +# should pass with --no-test +darcs check --no-test + +# should fail when test is run +not darcs check --test + +# should pass with --no-test in defaults +echo check --no-test > _darcs/prefs/defaults +darcs check +not darcs check --test + +# should fail with --test in defaults +echo check --test > _darcs/prefs/defaults +not darcs check +darcs check --no-test + +# check global defaults +cp ~/.darcs/defaults defaults.backup +trap "cp defaults.backup ~/.darcs/defaults" EXIT +rm _darcs/prefs/defaults + +# --no-test works in global defaults +echo check --no-test > ~/.darcs/defaults +darcs check +not darcs check --test + +# --test works in global defaults +echo check --test > ~/.darcs/defaults +not darcs check +darcs check --no-test + +# Verify that per-repository defaults override global defaults + +# --no-test in repository defaults overrides global --test +echo check --test > ~/.darcs/defaults +echo check --no-test > _darcs/prefs/defaults +darcs check +not darcs check --test + +# --test in repository defaults overrides global --no-test +echo check --no-test > ~/.darcs/defaults +echo check --test > _darcs/prefs/defaults +not darcs check +darcs check --no-test + +trap - EXIT +cp defaults.backup ~/.darcs/defaults + +cd .. +rm -rf temp diff --git a/tests/partial.sh b/tests/partial.sh new file mode 100644 --- /dev/null +++ b/tests/partial.sh @@ -0,0 +1,60 @@ +#!/usr/bin/env bash + +# A partial get of a repo shall have the same _darcs/pristine as the original + +set -ev + +rm -rf temp +mkdir temp +cd temp + +# Create a development repo, do some work + +darcs initialize --darcs-2 +echo ALL ignore-times >> _darcs/prefs/defaults +touch a +darcs add a +darcs record -a -m aa -A x +touch b +darcs add b +darcs record -a -m bb -A x + +# Create a release repo, pull the good patches and tag it + +mkdir _rel +cd _rel +darcs initialize --darcs-2 +darcs pull -a --patch a .. +darcs tag -m tt -A x +cd .. + +# Pull the tag to the devel repo and continue developement + +darcs pull -a _rel +touch c +darcs add c +darcs record -a -m cc -A x + +# Create a checkpoint and get a partial temp repo + +darcs tag -A x --checkpoint first_checkpoint +darcs get --partial . _partial + +# We should have all our devel files + +cd _partial +cat a +cat b +cat c + +# This is a regression test for issue406 +darcs tag -A x --checkpoint checkpointing_a_partial + +cd .. + +# With the darcs-2 format, doing a get on a partial repo succeeds. +# With the darcs-1 format it would be required to add the --partial flag, or darcs would give an error. +darcs get _partial _second_partial + +cd .. +rm -rf temp diff --git a/tests/pending.sh b/tests/pending.sh new file mode 100644 --- /dev/null +++ b/tests/pending.sh @@ -0,0 +1,37 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp temp_0 +mkdir temp +cd temp +darcs init +date > bla +darcs add bla +darcs record -a --patch-name=11 +echo hello > world +darcs add world +darcs whatsnew --dont-look-for-adds > wn1 +cd .. +darcs get temp +cd temp_0 +date > bla2 +date >> bla +darcs add bla2 +darcs record -a --patch-name=22 +darcs push -a ../temp +cd .. +cd temp +darcs whatsnew --dont-look-for-adds > wn2 +diff wn1 wn2 + +darcs record -a -m 'cleaning up for new test.' +date > foo.jpg +darcs add foo.jpg +darcs whatsnew + +darcs remove foo.jpg +darcs whatsnew && exit 1 + +cd .. + +rm -rf temp temp0 diff --git a/tests/pending_has_conflicts.sh b/tests/pending_has_conflicts.sh new file mode 100644 --- /dev/null +++ b/tests/pending_has_conflicts.sh @@ -0,0 +1,62 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init + +date > date.t +date > date_moved.t + +write_buggy_pending () { +cat > _darcs/patches/pending < out +cat out +grep 'pending has conflicts' out + +echo pending should now be fixed but there are no changes +not darcs whatsnew + +write_buggy_pending + +darcs revert -a &> out +cat out +grep 'pending has conflicts' out + +echo pending should now be emptied +darcs revert -a + +write_buggy_pending + +darcs record -a -m foo &> out +cat out +grep 'pending has conflicts' out + +darcs record -a -m foo + +darcs changes -v + +darcs repair &> out +cat out +grep 'The repository is already consistent' out + +write_buggy_pending + +darcs repair &> out +cat out +grep 'The repository is already consistent' out + +cd .. +rm -rf temp1 diff --git a/tests/perms.sh b/tests/perms.sh new file mode 100644 --- /dev/null +++ b/tests/perms.sh @@ -0,0 +1,31 @@ +#!/usr/bin/env bash +set -ev + +uname | grep "MINGW" > /dev/null && exit 0 + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +echo record author me > _darcs/prefs/defaults +echo ALL all >> _darcs/prefs/defaults +echo ALL verbose >> _darcs/prefs/defaults +echo ALL ignore-times >> _darcs/prefs/defaults +touch foo +darcs add foo +darcs record -m add_foo +echo hello >> foo +darcs record -m mod_foo +cd .. +darcs get --repo-name temp2 temp1 +cd temp2 +cp ../temp1/_darcs/prefs/defaults _darcs/prefs +echo y/d/y | tr / \\012 | darcs unpull --interactive +test -f foo -a ! -s foo +chmod +x foo +test -x foo +darcs pull ../temp1 +test -x foo +cd .. +rm -rf temp1 temp2 + diff --git a/tests/posthook.sh b/tests/posthook.sh new file mode 100644 --- /dev/null +++ b/tests/posthook.sh @@ -0,0 +1,26 @@ +#!/usr/bin/env bash + +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch foo +darcs add foo + +# Check that posthook works... +darcs whatsnew -s --posthook 'touch posthook-ran' +test -f posthook-ran +rm posthook-ran + +# Check that posthook works with defaults... +echo ALL --posthook touch posthook-ran > _darcs/prefs/defaults +darcs whatsnew -s +test -f posthook-ran +rm posthook-ran + +echo Successful. + +cd .. +rm -rf temp1 diff --git a/tests/prefs.sh b/tests/prefs.sh new file mode 100644 --- /dev/null +++ b/tests/prefs.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs initialize --old-fashion +echo ALL ignore-times >> _darcs/prefs/defaults +cp _darcs/prefs/boring .boring +darcs add .boring +darcs setpref boringfile .boring +darcs record -a -m p1 -A me +cd .. +darcs get --hashed temp1 temp2 +cmp temp1/_darcs/prefs/prefs temp2/_darcs/prefs/prefs +rm -rf temp1 temp2 diff --git a/tests/prefs_binary.sh b/tests/prefs_binary.sh new file mode 100644 --- /dev/null +++ b/tests/prefs_binary.sh @@ -0,0 +1,23 @@ +#!/usr/bin/env bash + +# Test that _darcs/prefs/binaries +. lib +rm -rf temp1 + +mkdir temp1 +cd temp1 +darcs init +mkdir d +touch d/t.t +darcs add d/t.t +darcs record -am "initial record" +echo 'some change' >> d/t.t +echo n | darcs record --interactive > log +# pre-test: plain text files are not binary +not grep binary log +echo 'd/t' >> _darcs/prefs/binaries +echo n | darcs record --interactive > log +grep binary log +cd .. + +rm -rf temp1 diff --git a/tests/prehook.sh b/tests/prehook.sh new file mode 100644 --- /dev/null +++ b/tests/prehook.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash + +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch foo +darcs add foo + +# Check that prehook runs +darcs whatsnew -s --prehook 'touch prehook-ran' +test -f prehook-ran +rm prehook-ran + +# Check that --prehook works with defaults... +echo ALL --prehook touch prehook-ran > _darcs/prefs/defaults +darcs whatsnew -s +test -f prehook-ran +rm prehook-ran + + +echo Successful. + +cd .. +rm -rf temp1 diff --git a/tests/printer.sh b/tests/printer.sh new file mode 100644 --- /dev/null +++ b/tests/printer.sh @@ -0,0 +1,83 @@ +#!/usr/bin/env bash + +# Some tests for 'darcs printer (the output formating)' + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch a +darcs add a +darcs rec -a -m add + +env +# clear all output formating environment variables +for e in DARCS_DONT_ESCAPE_ISPRINT DARCS_USE_ISPRINT\ + DARCS_DONT_ESCAPE_8BIT\ + DARCS_DONT_ESCAPE_EXTRA DARCS_ESCAPE_EXTRA\ + DARCS_DONT_ESCAPE_TRAILING_SPACES\ + DARCS_DONT_COLOR DARCS_ALWAYS_COLOR DARCS_ALTERNATIVE_COLOR\ + DARCS_DONT_ESCAPE_ANYTHING; do + unset $e +done +env + +# make sure the locale is c +export LC_ALL=C + +test_line () { + rm -f a + echo $1 > a + darcs whatsnew | fgrep $2 +} + + +# First check escaping and coloring. Use whatsnew, since that is the +# most common use of escapes. + +# test the defaults +# - no color to pipe +# - don't escape 7-bit ASCII printables, \n,\t and space (we can't test \n) +# - escape control chars with ^ +# - escape other chars with \xXX +test_line " !#%&',-0123456789:;<=>"\ + " !#%&',-0123456789:;<=>" +test_line "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"\ + "ABCDEFGHIJKLMNOPQRSTUVWXYZ_" +test_line "\`abcdefghijklmnopqrstuvwxyz"\ + "\`abcdefghijklmnopqrstuvwxyz" +test_line "\t\"\$()*+./?\@[\\]^{|}"\ + "\t\"\$()*+./?\@[\\]^{|}" +# skip ^@ and ^Z since they make darcs treat the file as binary +# don't put any space control chars at end of line +# ascii control chars are escaped with ^ +test_line $(printf '\x01\x02\x03\x04\x05\x06\x07\x08\x0B\x0C\x0D\x0E')\ + '[_^A_][_^B_][_^C_][_^D_][_^E_][_^F_][_^G_][_^H_][_^K_][_^L_][_^M_][_^N_]' +test_line $(printf '\x0F\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19')\ + '[_^O_][_^P_][_^Q_][_^R_][_^S_][_^T_][_^U_][_^V_][_^W_][_^X_][_^Y_]' +test_line $(printf '\x1B') '[_^[_]' +test_line $(printf '\x1C') '[_^\_]' +test_line $(printf '\x1D') '[_^]_]' +test_line $(printf '\x1E') '[_^^_]' +test_line $(printf '\x1F') '[_^__]' +test_line $(printf '\x7F') '[_^?_]' +# other chars are escaped with \xXX +test_line $(printf '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F')\ + '[_\80_][_\81_][_\82_][_\83_][_\84_][_\85_][_\86_][_\87_][_\88_][_\89_][_\8a_][_\8b_][_\8c_][_\8d_][_\8e_][_\8f_]' +test_line $(printf '\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F')\ + '[_\90_][_\91_][_\92_][_\93_][_\94_][_\95_][_\96_][_\97_][_\98_][_\99_][_\9a_][_\9b_][_\9c_][_\9d_][_\9e_][_\9f_]' +test_line $(printf '\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF')\ + '[_\a0_][_\a1_][_\a2_][_\a3_][_\a4_][_\a5_][_\a6_][_\a7_][_\a8_][_\a9_][_\aa_][_\ab_][_\ac_][_\ad_][_\ae_][_\af_]' +test_line $(printf '\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF')\ + '[_\b0_][_\b1_][_\b2_][_\b3_][_\b4_][_\b5_][_\b6_][_\b7_][_\b8_][_\b9_][_\ba_][_\bb_][_\bc_][_\bd_][_\be_][_\bf_]' +test_line $(printf '\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF')\ + '[_\c0_][_\c1_][_\c2_][_\c3_][_\c4_][_\c5_][_\c6_][_\c7_][_\c8_][_\c9_][_\ca_][_\cb_][_\cc_][_\cd_][_\ce_][_\cf_]' +test_line $(printf '\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF')\ + '[_\d0_][_\d1_][_\d2_][_\d3_][_\d4_][_\d5_][_\d6_][_\d7_][_\d8_][_\d9_][_\da_][_\db_][_\dc_][_\dd_][_\de_][_\df_]' +test_line $(printf '\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF')\ + '[_\e0_][_\e1_][_\e2_][_\e3_][_\e4_][_\e5_][_\e6_][_\e7_][_\e8_][_\e9_][_\ea_][_\eb_][_\ec_][_\ed_][_\ee_][_\ef_]' +test_line $(printf '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF')\ + '[_\f0_][_\f1_][_\f2_][_\f3_][_\f4_][_\f5_][_\f6_][_\f7_][_\f8_][_\f9_][_\fa_][_\fb_][_\fc_][_\fd_][_\fe_][_\ff_]' +rm -rf temp1 diff --git a/tests/pull-dont-prompt-deps.sh b/tests/pull-dont-prompt-deps.sh new file mode 100644 --- /dev/null +++ b/tests/pull-dont-prompt-deps.sh @@ -0,0 +1,31 @@ +#!/usr/bin/env bash + +set -ev + +# Check that the right patches get pulled using --dont-prompt-for-dependencies + +rm -rf temp1 +rm -rf temp2 +mkdir temp2 +mkdir temp1 +cd temp2 +darcs init +cd .. +cd temp1 +darcs init +echo foo > f +darcs record -Ax -alm foo1 +echo bar > b +darcs rec -Ax -alm bar1 +echo foo2 > f +darcs record -Ax -alm foo2 +echo bar2 > b +darcs record -Ax -alm bar2 +cd ../temp2 +echo y | darcs pull ../temp1 --dont-prompt-for-dependencies -p foo2 --dry-run > toto +#on the previous line, we don't get asked about foo1. +grep foo toto | wc -l | grep 2 +#but we send it anyway. +grep bar toto | wc -l | grep 0 +cd .. +rm -rf temp1 temp2 diff --git a/tests/pull-union.sh b/tests/pull-union.sh new file mode 100644 --- /dev/null +++ b/tests/pull-union.sh @@ -0,0 +1,42 @@ +#!/usr/bin/env bash + +. lib + +# This test script is in the public domain. + + +rm -rf temp1 temp2 temp3 + +mkdir temp1 +cd temp1 +darcs initialize +echo A > A +darcs add A +darcs record -a -m A +echo B > B +darcs add B +darcs record -a -m B + +cd .. +darcs get temp1 temp2 + +cd temp2 +darcs obliterate --last 1 -a +echo C > C +darcs add C +darcs record -a -m C +cd .. + +mkdir temp3 +cd temp3 +darcs init +darcs pull -a -v ../temp1 ../temp2 + +darcs changes > out +cat out +grep A out +grep B out +grep C out +cd .. + +rm -rf temp1 temp2 temp3 diff --git a/tests/pull.sh b/tests/pull.sh new file mode 100644 --- /dev/null +++ b/tests/pull.sh @@ -0,0 +1,154 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 temp2 + +mkdir temp1 +cd temp1 +darcs init + +cd .. +mkdir temp2 +cd temp2 +darcs init + +mkdir one +cd one +mkdir two +cd two +echo darcs pull should work relative to the current directory +darcs pull -a ../../../temp1 | grep -i 'No remote changes to pull in' + +echo -- darcs pull should pull into repo specified with --repo +cd ../.. # now in temp2 +darcs add one; +darcs record --patch-name uno --all +cd .. # now outside of any repo +darcs pull --repodir temp1 --all temp2 | grep -i 'Finished pulling.' # temp2 is not relative to temp1 + +# set up server repo +date > temp2/one/date.t +darcs add --repodir ./temp2 one/date.t +darcs record --repodir ./temp2 -a -m foo + +# set up client repo for failure +if echo $OS | grep -i windows; then + echo this test does not work on windows because it + echo is not possible to chmod -r +elif whoami | grep root; then + echo root never gets permission denied +else + chmod a-rwx ./temp1/one # remove all permissions + not darcs pull --repodir ./temp1 -a 2> err + chmod u+rwx temp1/one # restore permission + cat err + grep 'permission denied' err + rm -rf temp1/one +fi + +cd temp1 + +echo Before trying to pull from self, defaultrepo is something else +not grep temp1 _darcs/prefs/defaultrepo + +#return special message when you try to pull from yourself +DIR="`pwd`" +not darcs pull --debug -a "$DIR" 2> out +cat out +grep 'Can.t pull from current repository' out + +not darcs pull --debug -a . 2> out +cat out +grep 'Can.t pull from current repository' out + +# and do not update the default repo to be the current di +not grep temp1 _darcs/prefs/defaultrepo + +rm -f _darcs/prefs/defaultrepo +not darcs pull 2> err +grep 'please specify one' err +echo . > _darcs/prefs/defaultrepo +not darcs pull --debug 2> err +grep 'Can.t pull from current repository' err + +not darcs pull --debug ../* 2> out +cat out +not grep 'Can.t pull from current repository' out +cd .. # now outside of any repo + +cd temp1 +echo a > foo +darcs record -lam AA +echo b > foo +darcs record -lam BB +echo c > foo +darcs record -lam CC +darcs rollback -p CC -a -m unC +cd .. +rm -rf temp2 +darcs get --to-patch B temp1 temp2 +cd temp2 +sleep 1 # So that rollback won't have same timestamp as get. +darcs rollback -p BB -a -m unB +darcs revert -a +darcs pull -a ../temp1 2> err2 +not grep 'Error applying patch' err2 +cd .. + +cd temp1 +echo -n foo > baz +darcs add baz +darcs record -am newbaz +cd ../temp2 +darcs pull -a | grep Finished +echo -n bar > baz +darcs record -am bazbar +cd ../temp1 +darcs pull ../temp2 -a +echo -n bar > correct_baz +diff baz correct_baz +cd .. + +# my $test_name = "when a patch creating a directory is attempted to be applied +# while a directory with that name already exists, a warning is raised, but +# the pull succeeds."; +mkdir temp1/newdir +cd temp1 +darcs add newdir +darcs record -am newdir +cd ../temp2 +mkdir newdir +darcs pull -a ../temp1 &> out2 +cat out +grep Backing out2 +grep 'Finished pulling' out2 +grep newdir out2 +cd .. + +rm -rf temp1 temp2 + + +# A test for issue662, which triggered: +# darcs failed: Error applying hunk to file ./t.t +# Error applying patch to the working directory. + +rm -rf tmp; +darcs init --hashed --repodir=tmp +touch tmp/t.t +cd tmp +darcs add t.t +echo 'content'>t.t +darcs record -am 'initial add' --ignore +echo 'content: remote change'>t.t +darcs record -am 'remote change' --ignore +darcs put tmp2 +cd tmp2 +darcs obliterate --last 1 --all; +echo 'content: local change'> t.t +darcs pull -a ../ +darcs w -s +darcs revert -a + +cd ../.. +rm -rf tmp diff --git a/tests/pull_binary.sh b/tests/pull_binary.sh new file mode 100644 --- /dev/null +++ b/tests/pull_binary.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash + +# This test script, originally written by David Roundy and Ian Lynagh is in +# the public domain. + +set -ev + +rm -rf temp1 temp2 + +mkdir temp1 +cd temp1 +darcs init +printf "%01048576d" 0 > foo +darcs record -l -a -A author -m xx +rm foo +darcs record -a -A author -m yy +cd .. + +mkdir temp2 +cd temp2 +darcs init +echo yn | darcs pull ../temp1 +rm foo +darcs pull -a +cd .. + +rm -rf temp1 temp2 diff --git a/tests/pull_compl.sh b/tests/pull_compl.sh new file mode 100644 --- /dev/null +++ b/tests/pull_compl.sh @@ -0,0 +1,121 @@ +#!/usr/bin/env bash + +# This test script is in the public domain. + +set -ev + +rm -rf temp1 temp2 temp3 temp4 temp5 + +mkdir temp1 +cd temp1 +cat > foo < foo.tmp + mv foo.tmp foo + darcs record -a --ignore-times -m "$2" +} + +cd temp1 +chgrec 's/line2/line2\nline2.1\nline2.2/' inssub2 +chgrec 's/line4/Line 4/' Line4 + +darcs changes | grep ' \*' +echo done with changes on temp1 > /dev/null + +cd .. +darcs get temp1 temp2 +darcs get temp1 temp3 +cd temp1 + +chgrec 's/line1/line0\nline1/' line0 +chgrec 's/Line 4/LINE FOUR/' LINE4 +chgrec 's/line7/line7\nLastLine/' LastLine +chgrec 's/LINE FOUR/LINE FOUR\nline4.1/' line4.1 + +darcs changes | grep ' \*' +echo done with changes on temp1 > /dev/null + +cd ../temp3 +darcs pull -p LastLine -av +chgrec 's/line1$/FirstLine/' FirstLine + +cd ../temp4 + +darcs changes | grep ' \*' +echo done with changes on temp4 > /dev/null + +darcs pull ../temp1 --dry-run | grep ' \*' +darcs pull ../temp1 --dry-run | grep ' \*' > p1.out +cat > p1.req < p2.out +diff p1.out p2.out + +darcs pull --dry-run --complement ../temp1 ../temp2 | grep ' \*' > p3.out +cat > p3.req < p4.out +cat > p4.req < p5.out +diff p4.out p5.out + +darcs pull --dry-run --complement ../temp1 ../temp2 ../temp3 ../temp2 ../temp2 ../temp3 ../temp3 ../temp2 | grep ' \*' > p6.out +diff p4.out p6.out + +darcs pull --dry-run --complement ../temp3 ../temp2 | grep ' \*' > p7.out +cat > p7.req < p8.out +grep "No remote changes to pull in!" p8.out + +# because duplicates are stripped before performing action, +# this is the same as: darcs pull ../temp1 +darcs pull --dry-run --complement ../temp1 ../temp1 > fooout +cat fooout +grep ' \*' fooout > p9.out +diff p1.req p9.out + +# so the "null" pull must be tested this way: +darcs get ../temp1 ../temp5 +darcs pull --dry-run --complement ../temp1 ../temp5 > p9.out +grep "No remote changes to pull in!" p9.out + +darcs pull -av --complement ../temp1 ../temp3 +darcs check + +cd .. +rm -rf temp1 temp2 temp3 temp4 temp5 diff --git a/tests/pull_many_files.sh b/tests/pull_many_files.sh new file mode 100644 --- /dev/null +++ b/tests/pull_many_files.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 + +if grep old-fashioned .darcs/defaults; then +format=old-fashioned-inventory +elif grep darcs-2 .darcs/defaults; then +format=darcs-2 +else format=hashed; fi + +mkdir temp2 +cd temp2 +gunzip -c ../repos/many-files--${format}.tgz | tar xf - +cd .. + +mkdir temp1 +cd temp1 +darcs init +darcs pull -a ../temp2/many-files--${format} > log +grep -i 'finished pulling' log +cd .. +rm -rf temp1 + +# put things back how we found them. + +rm -rf temp1 temp2 diff --git a/tests/pull_two.sh b/tests/pull_two.sh new file mode 100644 --- /dev/null +++ b/tests/pull_two.sh @@ -0,0 +1,34 @@ +#!/usr/bin/env bash + +# This test script, originally written by David Roundy is in the public +# domain. + +set -ev + +rm -rf temp1 temp2 + +mkdir temp1 +cd temp1 +echo foo > bar +darcs initialize +echo record author me > _darcs/prefs/defaults +darcs add bar +darcs record -a -m addbar + +cd .. +darcs get temp1 temp2 +cd temp1 +date > bar +darcs record -a -m datebar + +cd ../temp1 +echo aack >> bar +darcs record -a -m aackbar + +cd ../temp2 + +darcs pull -av +darcs check + +cd .. +rm -rf temp1 temp2 diff --git a/tests/push-dont-prompt-deps.sh b/tests/push-dont-prompt-deps.sh new file mode 100644 --- /dev/null +++ b/tests/push-dont-prompt-deps.sh @@ -0,0 +1,30 @@ +#!/usr/bin/env bash + +set -ev + +# Check that the right patches get pushed using --dont-prompt-for-dependencies + +rm -rf temp1 +rm -rf temp2 +mkdir temp2 +mkdir temp1 +cd temp2 +darcs init +cd .. +cd temp1 +darcs init +echo foo > f +darcs record -Ax -alm foo1 +echo bar > b +darcs rec -Ax -alm bar1 +echo foo2 > f +darcs record -Ax -alm foo2 +echo bar2 > b +darcs record -Ax -alm bar2 +echo y | darcs push ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run > toto +#on the previous line, we don't get asked about foo1. +grep foo toto | wc -l | grep 2 +#but we send it anyway. +grep bar toto | wc -l | grep 0 +cd .. +rm -rf temp1 temp2 diff --git a/tests/push-dry-run.sh b/tests/push-dry-run.sh new file mode 100644 --- /dev/null +++ b/tests/push-dry-run.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash +set -ev + +# For issue855: wish: avoid taking lock if using --dry-run +chmod -R u+w temp2 || : +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +cd .. +mkdir temp2 +cd temp2 +darcs init +touch x +darcs add x +darcs record -am "test" +cd .. +chmod -R u-w temp2 +cd temp2 +# need to capture this failure so that we can still +# chmod -R u+w the directory even if we fail +darcsexit=0 +darcs push --dry-run ../temp1 || darcsexit=$? +cd .. +chmod -R u+w temp2 # so that other scripts can cleanup +if [ $darcsexit -ne 0 ]; then + exit $darcsexit +fi diff --git a/tests/push-formerly-pl.sh b/tests/push-formerly-pl.sh new file mode 100644 --- /dev/null +++ b/tests/push-formerly-pl.sh @@ -0,0 +1,49 @@ +#!/usr/bin/env bash + +# Some tests for 'darcs push' + +. lib + +DIR="`pwd`" + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +cd .. +mkdir temp2 +cd temp2 +darcs init +cd .. + +# push without a repo gives an error +cd temp1 +not darcs push -p 123 2> log +grep -i 'missing argument' log +cd .. + +mkdir -p temp2/one/two +cd temp2/one/two +# darcs push should work relative to the current directory +darcs push -a ../../../temp1 | grep -i 'No recorded local changes to push' +cd ../../../ + +# darcs push should push into repo specified with --repo +cd temp2 +darcs add one +darcs record --patch-name uno --all +cd .. + +darcs push --repodir temp2 --all temp1 | grep -i 'Finished apply' + +cd temp1 +# Before trying to pull from self, defaultrepo does not exist +test ! -e _darcs/prefs/defaultrepo +# return special message when you try to push to yourself +not darcs push -a "$DIR/temp1" 2> log +grep -i "cannot push from repository to itself" log +# and don't update the default repo to be the current dir +test ! -e _darcs/prefs/defaultrepo +cd .. + +rm -rf temp1 temp2 diff --git a/tests/push.sh b/tests/push.sh new file mode 100644 --- /dev/null +++ b/tests/push.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp temp_0 +mkdir temp +cd temp +darcs init +echo tester > _darcs/prefs/author +date > bla +darcs add bla +darcs record -a --patch-name=11 +cd .. +darcs get temp +cd temp +date > bla2 +darcs add bla2 +darcs record -a --patch-name=22 +darcs push -a ../temp_0 +cd .. + +rm -rf temp temp_0 diff --git a/tests/push_lock.sh b/tests/push_lock.sh new file mode 100644 --- /dev/null +++ b/tests/push_lock.sh @@ -0,0 +1,26 @@ +#!/usr/bin/env bash + +# For issue257: push => incorrect return code when couldn't get lock + +set -ev + +rm -rf tempc +mkdir tempc +cd tempc +darcs init +echo foo > foo.c +darcs rec -Ax -alm init +cd .. +rm -rf temps +darcs get tempc temps +cd temps +echo server >> foo.c +darcs rec -Ax -alm server +cd ../tempc +echo client >> foo.c +darcs rec -Ax -alm client +if darcs push -a ../temps; then + false +fi +cd .. +rm -rf tempc temps diff --git a/tests/put.sh b/tests/put.sh new file mode 100644 --- /dev/null +++ b/tests/put.sh @@ -0,0 +1,31 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +cd .. + +# put should set default repo +cd temp1 +touch 1.txt +darcs add 1.txt +darcs record -a -m foo 1.txt +darcs put ../temp2 +test -e _darcs/prefs/defaultrepo +grep temp2 _darcs/prefs/defaultrepo +cd .. + +# put to self +cd temp1 +not grep temp1 _darcs/prefs/defaultrepo +DIR=`pwd` +# return special message when you try to put put yourself +not darcs put "$DIR" 2> log +not grep temp1 _darcs/prefs/defaultrepo +grep -i "Can't put.*current repository" log +cd .. + +rm -rf temp1 temp2 diff --git a/tests/query_manifest.sh b/tests/query_manifest.sh new file mode 100644 --- /dev/null +++ b/tests/query_manifest.sh @@ -0,0 +1,90 @@ +#!/usr/bin/env bash +set -ev + +check_manifest () { + : > files.tmp + echo . > dirs.tmp + echo . > files-dirs.tmp + for x in $1 ; do + echo "./$x" >> files.tmp + echo "./$x" >> files-dirs.tmp + done + for x in $2 ; do + echo "./$x" >> dirs.tmp + echo "./$x" >> files-dirs.tmp + done + darcs query manifest $3 --files --no-directories | sort > darcs-files.tmp + darcs query manifest $3 --no-files --directories | sort > darcs-dirs.tmp + darcs query manifest $3 --files --directories | sort > darcs-files-dirs.tmp + for x in files dirs files-dirs ; do + sort $x.tmp >sorted-$x.tmp + diff sorted-$x.tmp darcs-$x.tmp + done } + +rm -rf temp +mkdir temp +cd temp +darcs init + +check_manifest "" "" "--no-pending" +check_manifest "" "" "--pending" +touch a b +darcs add a +check_manifest "" "" "--no-pending" +check_manifest "a" "" "--pending" +darcs add b +mkdir c +check_manifest "" "" "--no-pending" +check_manifest "a b" "" "--pending" +darcs add c +touch c/1 c/2 +check_manifest "" "" "--no-pending" +check_manifest "a b" "c" "--pending" +darcs add c/1 c/2 +check_manifest "" "" "--no-pending" +check_manifest "a b c/1 c/2" "c" "--pending" +mkdir d +touch d/3 d/4 +darcs add d/3 d/4 +check_manifest "" "" "--no-pending" +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending" +darcs record -A test --all --patch-name "patch 1" --skip-long-comment +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending" + +darcs mv d e +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" +check_manifest "a b c/1 c/2 e/3 e/4" "c e" "--pending" +rm c/1 +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" +check_manifest "a b c/1 c/2 e/3 e/4" "c e" "--pending" +darcs remove c/1 +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" +check_manifest "a b c/2 e/3 e/4" "c e" "--pending" +darcs mv c/2 c/1 +check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending" +check_manifest "a b c/1 e/3 e/4" "c e" "--pending" +darcs record -A test --all --patch-name "patch 2" --skip-long-comment +check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending" +check_manifest "a b c/1 e/3 e/4" "c e" "--pending" + +darcs remove c/1 +check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending" +check_manifest "a b e/3 e/4" "c e" "--pending" +darcs remove c +check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending" +check_manifest "a b e/3 e/4" "e" "--pending" +darcs record -A test --all --patch-name "patch 3" --skip-long-comment +check_manifest "a b e/3 e/4" "e" "--no-pending" +check_manifest "a b e/3 e/4" "e" "--pending" + +darcs mv b b2 +darcs mv b2 b3 +check_manifest "a b e/3 e/4" "e" "--no-pending" +check_manifest "a b3 e/3 e/4" "e" "--pending" +darcs record -A test --all --patch-name "patch 3" --skip-long-comment +check_manifest "a b3 e/3 e/4" "e" "--no-pending" +check_manifest "a b3 e/3 e/4" "e" "--pending" + +cd .. +rm -rf temp diff --git a/tests/record-interactive.sh b/tests/record-interactive.sh new file mode 100644 --- /dev/null +++ b/tests/record-interactive.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash + +. lib + + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init + +touch foo +darcs add foo +darcs record -a -m addfoo + +darcs replace one two foo +darcs replace three four foo +darcs replace five six foo + +echo sa | darcs record -m cancelled + +darcs whatsnew + +darcs changes > ch +not grep cancelled ch + +cd .. +rm -rf temp1 diff --git a/tests/record.sh b/tests/record.sh new file mode 100644 --- /dev/null +++ b/tests/record.sh @@ -0,0 +1,53 @@ +#!/usr/bin/env bash + +# Some tests for 'darcs record ' + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init + +# issue308 - no patches and no deps for record should abort +darcs record -am foo --ask-deps | grep -i "Ok, if you don't want to record anything, that's fine!" + +# RT#476 - --ask-deps works when there are no patches +if echo $OS | grep -i windows; then + echo This test does not work on Windows +else + touch t.f + darcs add t.f + darcs record -am add + echo a | darcs record -am foo --ask-deps | grep -i 'finished recording' +fi + +# RT#231 - special message is given for nonexistent directories +not darcs record -am foo not_there.txt > log +grep -i 'non existent' log + +# RT#231 - a nonexistent file before an existing file is handled correctly +touch b.t +darcs record -am foo a.t b.t > log +grep -i 'non existent files or directories: "a.t"' log + +DIR="`pwd`" +touch date.t +darcs add date.t +darcs record -a -m foo "$DIR/date.t" | grep -i 'finished recording' + +# issue396 - record -l "" +touch 'notnull.t' +darcs record -am foo -l "" notnull.t | grep -i 'finished recording' + +# basic record +date >> date.t +darcs record -a -m basic_record date.t | grep -i 'finished recording' + +# testing --logfile +date >> date.t +echo "second record\n" >> log.txt +darcs record -a -m 'second record' --logfile=log.txt date.t | grep -i 'finished recording' + +cd .. +rm -rf temp1 diff --git a/tests/record_editor.sh b/tests/record_editor.sh new file mode 100644 --- /dev/null +++ b/tests/record_editor.sh @@ -0,0 +1,59 @@ +#!/usr/bin/env bash + +# Some tests for 'darcs rec --edit-long-comment' + +. lib + +abort_windows + +rm -rf temp1 + +export DARCS_EDITOR="/bin/cat -n" +# editor: space in command +mkdir temp1 +cd temp1 +darcs init +touch file.t +darcs add file.t +echo y | darcs record --edit-long-comment -a -m foo file.t | grep '2.*END OF DESCRIPTION' +cd .. +rm -rf temp1 + +# editor: space in path +mkdir temp2\ dir +cd temp2\ dir +darcs init +touch file.t +darcs add file.t +echo y | darcs record --edit-long-comment -a -m foo file.t | grep '2.*END OF DESCRIPTION' +cd .. +rm -rf temp2\ dir + +export DARCS_EDITOR='grep "END OF"' +# editor: quoting in command +mkdir temp1 +cd temp1 +darcs init +touch file.t +darcs add file.t +echo y | darcs record --edit-long-comment -a -m foo file.t | grep 'END OF' +cd .. +rm -rf temp1 + +export DARCS_EDITOR='/bin/echo' +# editor: evil filename +mkdir temp1 +cd temp1 +darcs init +touch file.t +darcs add file.t +touch '; test-command' +echo > test-command << FOO +#!/bin/sh +echo EVIL +FOO +chmod u+x test-command +echo y | darcs record --logfile='; test-command' --edit-long-comment -a -m foo file.t > log +not grep EVIL log +cd .. +rm -rf temp1 diff --git a/tests/recordrace.sh b/tests/recordrace.sh new file mode 100644 --- /dev/null +++ b/tests/recordrace.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash +set -ev + +rm -rf foo1 foo2 +mkdir foo1 foo2 +cd foo1 +darcs init +echo zig > foo +darcs add foo +sleep 1 +darcs record -a -m add_foo -A x +#sleep 1 +echo zag >> foo +darcs record --ignore-time -a -m mod_foo -A x +cd ../foo2 +darcs init +darcs pull -a ../foo1 +cd .. +cmp foo1/foo foo2/foo +rm -rf foo1 foo2 + diff --git a/tests/repair-clean.sh b/tests/repair-clean.sh new file mode 100644 --- /dev/null +++ b/tests/repair-clean.sh @@ -0,0 +1,25 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 + +darcs init +touch baz +darcs add baz +darcs record -m moo -a + +cat _darcs/patches/pending + +darcs changes -v + +darcs check + +# check that repair doesn't do anything to a clean repository +darcs repair > out +cat out +grep 'already consistent' out + +cd .. +rm -rf temp1 diff --git a/tests/repair-corrupt.sh b/tests/repair-corrupt.sh new file mode 100644 --- /dev/null +++ b/tests/repair-corrupt.sh @@ -0,0 +1,53 @@ +. lib + +rm -rf bad +mkdir bad +cd bad +darcs init + +echo foo > bar +darcs add bar +darcs rec -a -m 'foo' + +echo hey > foo +darcs add foo +darcs rec -a -m 'more foo' + +hashed=false +test -e _darcs/hashed_inventory && hashed=true + +# produce a corrupt patch +echo 'rmfile foo' > _darcs/patches/pending +$hashed || echo -n > _darcs/pristine/foo +darcs rec -a -m 'remove foo' + +not darcs check # unapplicable patch! + +# stash away contents of _darcs +cp -R _darcs/ _backup_darcs + +echo here > bar +darcs rec -a -m 'here' + +# corrupt pristine content +$hashed && inv=`grep ^pristine _darcs/hashed_inventory` +cp _backup_darcs/patches/* _darcs/patches/ +cp _backup_darcs/*inventory* _darcs/ +$hashed && { + cp _darcs/hashed_inventory hashed.tmp + sed -e "s,^pristine:.*$,$inv," < hashed.tmp > _darcs/hashed_inventory + rm hashed.tmp +} + +not darcs check # just a little paranoia + +darcs repair # repair succeeds +darcs check # and the resulting repo is consistent + +# *AND* it contains what we expect... +darcs show contents bar > foobar +echo foo > foobar1 +diff foobar foobar1 + +cd .. +rm -rf bad diff --git a/tests/repair.sh b/tests/repair.sh new file mode 100644 --- /dev/null +++ b/tests/repair.sh @@ -0,0 +1,30 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs initialize +echo ALL ignore-times >> _darcs/prefs/defaults +echo A1 > foo +mkdir d +echo A2 > d/bar +darcs add foo +darcs add d +darcs add d/bar +darcs record -a -m AA -A x +echo B > foo +darcs record -a -m BB -A x +echo C > foo +darcs record -a -m CC -A x + +for i in _darcs/pristine*; do + echo Empty the pristine directory: $i + rm -rf $i + mkdir $i +done + +darcs repair + +cd .. +rm -rf temp1 diff --git a/tests/replace.sh b/tests/replace.sh new file mode 100644 --- /dev/null +++ b/tests/replace.sh @@ -0,0 +1,61 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp +mkdir temp +cd temp + +darcs init + +echo "X X X" > foo +echo $'A A,A\tA,A\vA' >> foo +darcs rec -alm "Added" + +# These should fail until replace handles tokens and +# token-chars with leteral spaces in them +darcs replace ' X ' ' XX ' --token-chars '[ X]' foo && exit 1 || true +darcs replace $'A A' 'aaa' --token-chars '[^,]' foo && exit 1 || true +darcs replace $'A\tA' 'aaa' --token-chars '[^,]' foo && exit 1 || true +darcs replace $'A\vA' 'aaa' --token-chars '[^,]' foo && exit 1 || true + +# Check that replace is not fooled by duplicate file names +# (i.e. not trying to performe the replace twice in the same file) +darcs replace X Y foo foo +darcs replace Y Z foo ../temp/foo +darcs replace Z Q foo foo --repodir=../temp/ +darcs rec -am "xyzq" + + +# Try to "overwrite" a hunk with a replace. +# +# v1.0.8 accepts this without error or warning, +# but should perhaps require the --force option? +# +# current unstable sometimes(!) fails with bug: invalid pending +# which is surely a bug. + +# this succeeds +echo "x" > foo +darcs rec -am xx +echo "y" > foo +darcs replace --ignore-times x y foo + +# this fails +echo "hej" > foo +darcs rec -am hej +echo "hopp" > foo +darcs replace hej hopp foo + +darcs whatsnew + +echo "src" > foo +echo "dst" >> foo +darcs rec -am hop +darcs replace src dst foo || true +darcs replace --force src dst foo + +darcs whatsnew +darcs whatsnew -ls + +cd .. +rm -rf temp diff --git a/tests/replace_after_pending_add.sh b/tests/replace_after_pending_add.sh new file mode 100644 --- /dev/null +++ b/tests/replace_after_pending_add.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash + +set -ev + +rm -fr temp1 + +mkdir temp1 +cd temp1 +darcs --version + +darcs init + +echo a b a b a b > A +darcs add A +if darcs replace a c A | grep Skipping; then + exit 1 +fi +cd .. + +rm -fr temp1 + diff --git a/tests/replace_after_pending_mv.sh b/tests/replace_after_pending_mv.sh new file mode 100644 --- /dev/null +++ b/tests/replace_after_pending_mv.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash + +set -ev + +rm -fr temp1 + +mkdir temp1 +cd temp1 +darcs init + +echo a b a b a b > A +darcs add A +darcs record --all --patch-name=p1 +darcs mv A B +if darcs replace a c B | grep Skipping; then + exit 1 +fi +cd .. + +rm -fr temp1 + diff --git a/tests/repodir.sh b/tests/repodir.sh new file mode 100644 --- /dev/null +++ b/tests/repodir.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash +### http://bugs.darcs.net/issue496 +### _darcs/prefs/defaults ignored when using --repodir + +## All these commands SHOULD fail (hence leading NOTs). +. lib + +rm -rf temp +mkdir temp +cd temp + +mkdir repo +darcs initialize --repodir repo +cd repo +date > foo +darcs add foo +darcs record -a -m auth + +echo > _darcs/prefs/defaults ALL disable # try to disable all +not darcs changes +not darcs changes --repodir "`pwd`" + +cd .. + +not darcs changes --repodir repo +not darcs changes --repodir "`pwd`/repo" + +rm -rf temp diff --git a/tests/repoformat.sh b/tests/repoformat.sh new file mode 100644 --- /dev/null +++ b/tests/repoformat.sh @@ -0,0 +1,14 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +echo gobbledygook > _darcs/format +cd .. + +not darcs get temp1 temp2 2> log +grep -i "can't understand repository format" log +rm -rf temp1 temp2 log diff --git a/tests/repos/README b/tests/repos/README new file mode 100644 --- /dev/null +++ b/tests/repos/README @@ -0,0 +1,4 @@ + +Larger or more complex pre-built repos are stored here for testing. They are +stored as archives for space efficiency, and to emphasize that they are meant +to be read-only. diff --git a/tests/repos/many-files--darcs-2.tgz b/tests/repos/many-files--darcs-2.tgz new file mode 100644 Binary files /dev/null and b/tests/repos/many-files--darcs-2.tgz differ diff --git a/tests/repos/many-files--hashed.tgz b/tests/repos/many-files--hashed.tgz new file mode 100644 Binary files /dev/null and b/tests/repos/many-files--hashed.tgz differ diff --git a/tests/repos/many-files--old-fashioned-inventory.tgz b/tests/repos/many-files--old-fashioned-inventory.tgz new file mode 100644 Binary files /dev/null and b/tests/repos/many-files--old-fashioned-inventory.tgz differ diff --git a/tests/repos/maybench-crc.tgz b/tests/repos/maybench-crc.tgz new file mode 100644 Binary files /dev/null and b/tests/repos/maybench-crc.tgz differ diff --git a/tests/revert_interactive.sh b/tests/revert_interactive.sh new file mode 100644 --- /dev/null +++ b/tests/revert_interactive.sh @@ -0,0 +1,67 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo hello world > foo +darcs add foo +darcs record -a -m add -A x +echo goodbye world >> foo +echo y/y | tr / \\012 | darcs revert +darcs show contents foo | cmp foo - + +# Now let's test a trickier revert where changes commute nontrivially. + +cat > foo < foo + +echo "nyy" | darcs revert + +DARCS_DONT_COLOR=1 darcs wh > whatsnew +cat > correct < bar +echo hello world > foo +darcs add bar +darcs replace hello goodbye bar foo + +echo "cnnnyy/y" | tr / \\012 | darcs revert + +DARCS_DONT_COLOR=1 darcs wh > whatsnew +cat > correct < foo +darcs add foo + +darcs revert -a diff --git a/tests/rmconflict.sh b/tests/rmconflict.sh new file mode 100644 --- /dev/null +++ b/tests/rmconflict.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash +set -ev + +rm -rf tempA tempB +mkdir tempA tempB +cd tempA +darcs init +touch foo +darcs add foo +darcs record -a -m addA -A x +cd ../tempB +darcs init +darcs pull -a ../tempA +darcs remove foo +# rm foo +darcs record -a -m rmB -A x +cd ../tempA +darcs remove foo +darcs record -a -m rmA -A x +cd ../tempB +darcs pull -a ../tempA +cd .. +rm -rf tempA tempB + diff --git a/tests/rmdir-formerly-pl.sh b/tests/rmdir-formerly-pl.sh new file mode 100644 --- /dev/null +++ b/tests/rmdir-formerly-pl.sh @@ -0,0 +1,32 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +mkdir foo +echo hello world > foo/bar +echo hello world > foo/baz +mkdir foo/dir +darcs add foo foo/bar foo/dir foo/baz +darcs record -a -m add +rm -rf foo +darcs show files --no-pending --no-dir > log +grep 'foo/baz' log +grep 'foo/bar' log +darcs show files --no-pending --no-fil > log +grep 'foo/dir' log +grep 'foo$' log +# now without... +darcs record -a -m del +darcs show files --no-pending --no-dir > log +not grep 'foo/baz' log +not grep 'foo/bar' log +darcs show files --no-pending --no-fil > log +not grep 'foo/dir' log +not grep 'foo$' log +cd .. + +rm -rf temp1 diff --git a/tests/rmdir.sh b/tests/rmdir.sh new file mode 100644 --- /dev/null +++ b/tests/rmdir.sh @@ -0,0 +1,71 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 temp3 + +# initialise temp1 +mkdir temp1 +cd temp1 +darcs initialize +mkdir foo +echo hello world > foo/bar +darcs add foo foo/bar +darcs record -a -m add +cd .. + +# get temp1 into temp2 +darcs get temp1 temp2 +cd temp2 +echo hello world > foo/baz +cd .. + +# remove a directory from temp1 and record +cd temp1 +rm -rf foo +darcs record -a -m del +cd .. + +cd temp2 +test -e foo/baz +test -e foo/bar +test -d foo + +darcs show files --no-pending --no-dir >> files +grep foo/bar files +darcs show files --no-pending --no-fil >> dirs +grep foo dirs +cd .. + +darcs pull -a --repodir=temp2 > pullresult +cat pullresult +grep 'Warning: .ot deleting' pullresult + +# get temp1 into temp3 +darcs get temp1 temp3 +cd temp3 +darcs obliterate --last 1 -a +echo hello world > foo/baz +cd .. + +# remove a directory from temp1 and record +cd temp1 +rm -rf foo +darcs record -a -m del +cd .. + +cd temp3 +test -e foo/baz +test -e foo/bar +test -d foo + +darcs show files --no-pending --no-dir >> files +grep foo/bar files +darcs show files --no-pending --no-fil >> dirs +grep foo dirs +cd .. + +darcs pull -q -a --repodir=temp3 > pullresult +cat pullresult +test ! -s pullresult + +rm -rf temp1 temp2 temp3 diff --git a/tests/rollback-nothing.sh b/tests/rollback-nothing.sh new file mode 100644 --- /dev/null +++ b/tests/rollback-nothing.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash + +set -ev + +rm -rf temp +mkdir temp +cd temp +darcs init +date > file1 +darcs add file1 +darcs record -am "test" +rm file1 +darcs record -am "rm" +echo yd | darcs rollback --last=1 -m 'oops' | grep 'No changes selected' +cd .. +rm -rf temp diff --git a/tests/rollback.sh b/tests/rollback.sh new file mode 100644 --- /dev/null +++ b/tests/rollback.sh @@ -0,0 +1,34 @@ +#!/bin/bash + +set -ev + +range="0 1 2" + +rm -rf temp1 temp2 # clean up when previous run crashed +mkdir temp1 && cd temp1 && darcs init +touch f && darcs add f +for i in $range +do + echo $i > f && darcs record -A me --ignore-time -m p$i --all f +done + +cd .. && mkdir temp2 && cd temp2 && darcs init + +set -x + +: Demonstrate problem with regrem +for i in $range +do + darcs pull --patch p$i ../temp1 --all + if darcs whatsnew ; then + : Resolve conflict - rollback our patch + darcs revert --all + darcs rollback -a --patch-name x0 + darcs revert --all + fi + : Create local change and record it + echo X$i > f && darcs record -A me --ignore-time -m x$i --all f +done + +cd .. +rm -rf temp1 temp2 diff --git a/tests/sametwice.sh b/tests/sametwice.sh new file mode 100644 --- /dev/null +++ b/tests/sametwice.sh @@ -0,0 +1,30 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +echo record author me > _darcs/prefs/defaults +echo ALL all >> _darcs/prefs/defaults +echo ALL verbose >> _darcs/prefs/defaults +echo ALL ignore-times >> _darcs/prefs/defaults +touch foo +darcs add foo +darcs whatsnew +darcs record -m add_foo +echo hello >> foo +darcs record -m mod_foo +cd .. +darcs get --repo-name temp2 temp1 +cd temp2 +cp ../temp1/_darcs/prefs/defaults _darcs/prefs +echo y/d/y | tr / \\012 | darcs unpull --interactive +test -f foo -a ! -s foo +echo hello >> foo +darcs record -m mod_foo_again +darcs pull ../temp1 +test -s foo +cd .. +rm -rf temp1 temp2 + diff --git a/tests/send-dont-prompt-deps.sh b/tests/send-dont-prompt-deps.sh new file mode 100644 --- /dev/null +++ b/tests/send-dont-prompt-deps.sh @@ -0,0 +1,30 @@ +#!/usr/bin/env bash + +set -ev + +# Check that the right patches get sent using --dont-prompt-for-dependencies + +rm -rf temp1 +rm -rf temp2 +mkdir temp2 +mkdir temp1 +cd temp2 +darcs init +cd .. +cd temp1 +darcs init +echo foo > f +darcs record -Ax -alm foo1 +echo bar > b +darcs rec -Ax -alm bar1 +echo foo2 > f +darcs record -Ax -alm foo2 +echo bar2 > b +darcs record -Ax -alm bar2 +echo y | darcs send ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run > toto +#on the previous line, we don't get asked about foo1. +grep foo toto | wc -l | grep 2 +#but we send it anyway. +grep bar toto | wc -l | grep 0 +cd .. +rm -rf temp1 temp2 diff --git a/tests/send-external.sh b/tests/send-external.sh new file mode 100644 --- /dev/null +++ b/tests/send-external.sh @@ -0,0 +1,54 @@ +#!/usr/bin/env bash +set -ev + +DARCS_EDITOR=echo +export DARCS_EDITOR + +rm -rf temp1 temp2 +mkdir temp1 temp2 + +cd temp2 +darcs init +cd .. + +cd temp1 +darcs init +date > foobar +darcs add foobar +darcs rec -a -m add-foobar + +cat > saveit.sh <>saved.out +echo \$6 contains: >>saved.out +ls -ltr >>saved.out +cat "\$6" >>saved.out +echo End of \$6 contents >>saved.out +grep add-foobar \$6 +CNT=0 +while [ "\$#" != "0" ]; do + CNT=`expr \$CNT + 1` + echo \$0: arg[\$CNT] = \"\$1\" >>saved.out + shift +done +echo \$0: Total \$CNT arguments >>saved.out +echo \$0: Input: >>saved.out +cat >>saved.out +echo \$0: End of input: >>saved.out +EOF + +chmod +x saveit.sh + +# foobar +darcs send --author=me -a --to=random@random \ + --sendmail-command='bash ./saveit.sh %s %t %c %b %f %a %S %t %C %B %F %A something' ../temp2 + +cat saved.out +grep add-foobar saved.out +grep 'addfile ./foobar' saved.out + +cd .. +rm -rf temp1 temp2 diff --git a/tests/send.sh b/tests/send.sh new file mode 100644 --- /dev/null +++ b/tests/send.sh @@ -0,0 +1,52 @@ +#!/usr/bin/env bash +set -ev + +DARCS_EDITOR=echo +export DARCS_EDITOR + +rm -rf temp1 temp2 +mkdir temp1 temp2 + +cd temp2 +darcs init + +# setup test +cd ../temp1 +darcs init +touch foo bar +darcs add foo bar +darcs record -a -m add_foo_bar -A x + +# Test that a default preference value is not needed to send +darcs send --author=me -a --to=random@random --sendmail-command='grep "^To: random@random$" %<' ../temp2 + +# Test that a default preference will be used when no --to value is specified +echo "default@email" > ../temp2/_darcs/prefs/email +darcs send --author=me -a --sendmail-command='grep "^To: default@email$" %<' ../temp2 + +# Test that the --to parameter overrides the default value in the repository +darcs send --author=me -a --to=override@default --sendmail-command='grep "^To: override@default$" %<' ../temp2 +darcs send --author=me -a --in-reply-to=some-thread-id --sendmail-command='grep "^In-Reply-To: some-thread-id$" %<' ../temp2 +darcs send --author=me -a --in-reply-to=some-thread-id --sendmail-command='grep "^References: some-thread-id$" %<' ../temp2 + +# Test that the --subject parameter sets the subject + +# Test that the --output-auto-name parameter outputs what we expect +darcs send --author=me -a --subject="it works" --output test1.dpatch ../temp2 +darcs send --author=me -a --subject="it works" --output-auto-name ../temp2 +cmp test1.dpatch add_foo_bar.dpatch + +# test --output-auto-name works with optional argument. +mkdir patchdir +darcs send --author=me -a --subject="it works" --output-auto-name=patchdir ../temp2 +cmp test1.dpatch patchdir/add_foo_bar.dpatch + +# checking --output-auto-name=dir when run in different directory +cd patchdir +rm add_foo_bar.dpatch +darcs send --author=me -a --subject="it works" --output-auto-name=. ../../temp2 +cmp ../test1.dpatch add_foo_bar.dpatch +cd .. + +cd .. +rm -rf temp1 temp2 diff --git a/tests/send_apply.sh b/tests/send_apply.sh new file mode 100644 --- /dev/null +++ b/tests/send_apply.sh @@ -0,0 +1,38 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 +mkdir temp1 temp2 + +cd temp2 +darcs init + +cd ../temp1 +darcs init +touch foo bar +darcs add foo bar +darcs record -a -m add_foo_bar -A x +darcs mv foo zig +darcs mv bar foo +darcs mv zig bar +darcs record -a -m swap_foo_bar -A x +darcs send --author=me --output=funpatch --dont-sign -a ../temp2 +cd ../temp2 +darcs apply ../temp1/funpatch +cd .. +cmp temp1/bar temp2/bar +rm -rf temp2 + +mkdir temp2 +cd temp2 +darcs init +darcs apply ../temp1/funpatch +## Also test that "darcs apply" can accept a patch on stdin. +darcs obl -a +darcs apply < ../temp1/funpatch +cd .. +cmp temp1/bar temp2/bar + + +rm -rf temp1 temp2 + diff --git a/tests/set_scripts_executable.sh b/tests/set_scripts_executable.sh new file mode 100644 --- /dev/null +++ b/tests/set_scripts_executable.sh @@ -0,0 +1,68 @@ +#!/usr/bin/env bash + +# Some tests for the --set-scripts-executable option. + +. lib + +abort_windows + +rm -rf temp1 temp2 + +mkdir temp1 +cd temp1 +darcs init +cat > script.pl << FOO +#!/usr/bin/env perl +print "Hello\n"; +FOO +chmod 0644 script.pl +date > nonscript +# pre-tests +test -r script.pl +test -r nonscript +test ! -x script.pl +test ! -x nonscript +darcs add script.pl nonscript +darcs record --patch-name 'uno' --all +cd .. + +# sans --set-scripts-executable (should not be executable) +mkdir temp2 +cd temp2 +darcs init +darcs pull -a ../temp1 +# sanity check +test -r script.pl +test -r nonscript +# nothing should be executable +test ! -x script.pl +test ! -x nonscript +cd .. +rm -rf temp2 + +# with --set-scripts-executable +mkdir temp2 +cd temp2 +darcs init +darcs pull -a ../temp1 --set-scripts-executable +# sanity check +test -r script.pl +test -r nonscript +# script should be executable +test -x script.pl +test ! -x nonscript +cd .. +rm -rf temp2 + +# now let's try the same thing with get +darcs get --set-scripts-executable temp1 temp2 +cd temp2 +# sanity check +test -r script.pl +test -r nonscript +# script should be executable +test -x script.pl +test ! -x nonscript +cd .. + +rm -rf temp1 temp2 diff --git a/tests/setpref.sh b/tests/setpref.sh new file mode 100644 --- /dev/null +++ b/tests/setpref.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash + + +. lib + +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +echo 'test file 1' > foo +darcs record --look-for-adds --all -m"Patch 1" +echo 'test boringfile' > bar +darcs setpref boringfile bar +darcs record --look-for-adds --all -m"Patch 2" +echo 'test file 3' > baz +# there should be no -R +darcs record --look-for-adds --all -m"Patch 3" > ../temp2 +cat ../temp2 +not grep R ../temp2 + +cd .. + +rm -rf temp1 +rm -f temp2 diff --git a/tests/several_commands.sh b/tests/several_commands.sh new file mode 100644 --- /dev/null +++ b/tests/several_commands.sh @@ -0,0 +1,25 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo hello world > foo +darcs add foo +darcs record -a -m add -A x +echo goodbye world >> foo +darcs diff +darcs diff -u +darcs whatsnew +darcs whatsnew --summary +echo y | darcs revert -a +darcs show contents foo | cmp foo - +mkdir d +darcs add d +darcs record -a -m 'add dir' -A x +rmdir d +darcs revert -a d +cd .. +rm -rf temp1 + diff --git a/tests/show-authors.sh b/tests/show-authors.sh new file mode 100644 --- /dev/null +++ b/tests/show-authors.sh @@ -0,0 +1,30 @@ +#!/usr/bin/env bash +set -ev + +rm -rf test +mkdir test +cd test +darcs init +echo zig > foo +darcs add foo +darcs record -a -m add_foo -A x +echo zag >> foo +darcs record -a -m mod_foo -A y +echo bar > foo +darcs record -a -m mod2 -A y + +darcs show authors > authors +grep x authors +grep y authors + +head -1 authors > first-author +grep y first-author + +darcs show authors --verbose +darcs show authors --verbose | grep y | wc -l > num-patches +cat num-patches +grep 2 num-patches + +cd .. +rm -rf test + diff --git a/tests/show-bug.sh b/tests/show-bug.sh new file mode 100644 --- /dev/null +++ b/tests/show-bug.sh @@ -0,0 +1,30 @@ +#!/usr/bin/env bash + +## All these commands SHOULD fail (hence leading NOTs). +. lib + +rm -rf test +mkdir test +cd test + +darcs show bug --debug 1> stdout 2> stderr || true + +cat stdout +cat stderr + +echo The following test will fail if this version of darcs is marked as +echo obsolete. +echo ================================================================== + +not grep 'please do not' stderr + +# The following test fails if HTTP isn't present, but would be a nice test +# to have in place. + +#not grep unable stderr + +grep 'fake bug' stderr + +cd .. +rm -rf test + diff --git a/tests/show_contents.sh b/tests/show_contents.sh new file mode 100644 --- /dev/null +++ b/tests/show_contents.sh @@ -0,0 +1,26 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch foo +darcs add foo +echo first > foo +darcs record -a -m "first edit" -A author1 +echo second > foo +darcs record -a -m "second edit" -A author2 +darcs tag t1 -A moi +echo third > foo +darcs record -a -m "third edit" -A author3 +echo fourth > foo +darcs record -a -m "fourth edit" -A author4 +echo unrecorded > foo +darcs show contents foo | grep fourth +darcs show contents foo -p third | grep third +darcs show contents foo --match="author author1" first | grep first +darcs show contents foo --tag t1 | grep second +cd .. + +rm -rf temp1 diff --git a/tests/show_tags.sh b/tests/show_tags.sh new file mode 100644 --- /dev/null +++ b/tests/show_tags.sh @@ -0,0 +1,35 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs initialize +echo ALL ignore-times >> _darcs/prefs/defaults +echo A > foo +darcs add foo +darcs record -a -m AA -A x +echo B > foo +darcs record -a -m BB -A x +echo C > foo +darcs record -a -m CC -A x +darcs tag -m 1.0 -A x +echo D > foo +darcs record -a -m DD -A x +echo E > foo +darcs record -a -m EE -A x +echo F > foo +darcs record -a -m FF -A x +darcs tag -m 2.0 -A x + +darcs show tags > my +cat my +cat > ref < foo +darcs add foo +darcs record -a --author=me -m "First patch" +i=1 +while test $i -le 100; do + echo foo $i > foo; + darcs record --ignore-times -a --author=me -m "Patch $i" > bar + i=`expr $i + 1` +done +darcs tag --author=me -m 'silly tag' +i=1000 +while test $i -le 1096; do + echo foo $i > foo; + darcs record --ignore-times -a --author=me -m "Patch $i" > bar + i=`expr $i + 1` +done + +darcs --version +darcs changes | head + +cd .. +# rm -rf temp1 diff --git a/tests/ssh.sh b/tests/ssh.sh new file mode 100644 --- /dev/null +++ b/tests/ssh.sh @@ -0,0 +1,143 @@ +#!/usr/bin/env bash +set -ev + +if [ x${REMOTE_DIR} = x ]; then + REMOTE_DIR=sshtest +fi + +if [ x"${USE_PUTTY}" != x ]; then + DARCS_SSH=plink + export DARCS_SSH + DARCS_SCP=pscp + export DARCS_SCP + DARCS_SFTP=psftp + export DARCS_SFTP +fi + +if [ x"${USE_CONTROL_MASTER}" != x ]; then + DARCS_SSH_FLAGS="--ssh-cm" + export DARCS_SSH_FLAGS +fi + +if [ x"${DARCS_SSH}" = x ]; then + SSH=ssh +else + SSH=${DARCS_SSH} +fi + +rm -rf tempssh +mkdir tempssh +cd tempssh + +cleanup () { + cd .. + rm -rf tempssh +} + +if [ x${REMOTE} = x ]; then + echo + echo "Note: to enable full SSH testing, set REMOTE to some SSH path first," + echo " e.g. REMOTE=you@server.org $0" + cleanup + exit 0 # exit normally in case we are being run from the shell harness +fi + +# ================ Setting up remote repositories =============== +${SSH} ${REMOTE} "\ +rm -rf ${REMOTE_DIR}; \ +mkdir ${REMOTE_DIR}; \ +cd ${REMOTE_DIR}; \ +\ +mkdir testrepo; cd testrepo; \ +darcs init; \ +echo moi > _darcs/prefs/author; \ +touch a; darcs add a; darcs record a --ignore-times -am 'add file a'; \ +echo 'first line' > a; darcs record a --ignore-times -am 'add first line to a'; \ +cd ..; \ +\ +darcs get testrepo testrepo-pull; \ +cd testrepo-pull; \ +echo moi > _darcs/prefs/author; \ +touch b; darcs add b; darcs record b --ignore-times -am 'add file b'; \ +echo 'other line' > b; darcs record b --ignore-times -am 'add other line to b'; \ +cd ..; \ +\ +darcs get testrepo testrepo-push; \ +darcs get testrepo testrepo-send; \ +" + +# ================ Settings =============== +echo ${DARCS_SSH_FLAGS} +echo ${DARCS_SSH} +echo ${DARCS_SCP} +echo ${DARCS_SFTP} + +# ================ Checking darcs get ================== +${DARCS} get ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo ${DARCS_SSH_FLAGS} +# check that the test repo made it over +[ -d testrepo ] +[ -d testrepo/_darcs ] +[ -f testrepo/a ] + +# if the above test is disabled we just init a blank repo +# so that the other tests can continue +if [ ! -d testrepo ]; then + mkdir testrepo + cd testrepo + darcs init + cd .. +fi + +# ================ Checking darcs pull ================= +${DARCS} get ${DARCS_SSH_FLAGS} testrepo testrepo-pull +cd testrepo-pull +echo yy | ${DARCS} pull ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-pull +# see if the changes got pulled over +grep "other line" b + +cd .. + +# ================ Checking darcs push and send =================" +${DARCS} get ${DARCS_SSH_FLAGS} testrepo testrepo-push +cd testrepo-push +echo moi > _darcs/prefs/author +echo "second line" >> a; ${DARCS} record a --ignore-times -am "add second line to a" +touch c; ${DARCS} add c +${DARCS} record --ignore-times -am "add file c" c +echo yy | ${DARCS} push ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-push +# check that the file c got pushed over +${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/testrepo-push/c ]" +echo yy | ${DARCS} send ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-send -o mybundle.dpatch +# check that the bundle was created +grep "add file c" mybundle.dpatch +cd .. + +# ================ Checking darcs put ==================" +cd testrepo +${DARCS} put ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-put +# check that the put was successful +${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/testrepo-put/_darcs ]" +${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/testrepo-put/a ]" +cd .. + +# ======== Checking push over ssh with a conflict =========" +${SSH} ${REMOTE} "echo apply no-allow-conflicts >> ${REMOTE_DIR}/testrepo-put/_darcs/prefs/defaults" + +cd testrepo +echo 'change for remote' > a +darcs record --ignore-times -am 'change for remote' +darcs push -a +darcs ob --last 1 -a +echo 'change for local' > a +darcs record --ignore-times -am 'change for local' + +if darcs push -a 2>&1 | grep -q 'conflicts options to apply' ; then + # do nothing. + echo "OK"; +else + exit 1; +fi + +cd .. + +cleanup diff --git a/tests/steve_and_monica_rollback.sh b/tests/steve_and_monica_rollback.sh new file mode 100644 --- /dev/null +++ b/tests/steve_and_monica_rollback.sh @@ -0,0 +1,38 @@ +#!/bin/bash + +# Issue578: A conflict rollback case for Darcs2 + +set -ev + +rm -rf tmp_steve tmp_monica + +mkdir tmp_steve +mkdir tmp_monica + +cd tmp_steve +darcs init --darcs-2 +echo A >foo +darcs add foo +darcs record -Asteve -am 'Anote' + +echo B >foo +darcs record -Asteve -am 'Bnote' + +# Show the history as Steve sees it. +darcs changes -s +echo "######" + +cd ../tmp_monica +darcs init --darcs-2 +echo A>foo +darcs add foo +echo Z>bar +darcs add bar +darcs record -Amonica -am 'AZnote' +darcs pull -a ../tmp_steve +darcs changes +echo "######" +darcs rollback -a -m newpatch -A me --match 'exact Anote' + +# previous failure result: darcs failed: cannot roll back a 'rollback' patch. + diff --git a/tests/tag.sh b/tests/tag.sh new file mode 100644 --- /dev/null +++ b/tests/tag.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash +. lib + +# Some tests for 'darcs tag' + +rm -rf temp1 log +mkdir temp1 +cd temp1 +darcs init +touch one +darcs add one +darcs record --patch-name 'uno' --all +darcs tag soup > log +not grep failed log +grep TAG log +darcs changes --last 1 > log +grep tagged log +cd .. +rm -rf temp1 log diff --git a/tests/three_way_conflict.sh b/tests/three_way_conflict.sh new file mode 100644 --- /dev/null +++ b/tests/three_way_conflict.sh @@ -0,0 +1,34 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 temp2 temp3 +mkdir -p temp1 temp2 temp3 +cd temp1 +darcs init +cd ../temp2 +darcs init +cd ../temp3 +darcs init + +touch foo +darcs add foo +darcs record -a -A author -m add +darcs push -a ../temp2 +darcs push -a ../temp1 + +echo A > foo +darcs record -a -A author -m AA +cd ../temp2 +echo B > foo +darcs record -a -A author -m BB +cd ../temp1 +echo C > foo +darcs record -a -A author -m CC + +darcs pull -a ../temp2 +darcs pull -a ../temp3 + +cd ../temp2 +darcs pull -a ../temp3 +darcs pull -a ../temp1 +rm -rf temp1 temp2 temp3 diff --git a/tests/toolbox.sh b/tests/toolbox.sh new file mode 100644 --- /dev/null +++ b/tests/toolbox.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +. lib + +DIR="`pwd`" + +abort_windows + +# set up the repository +rm -rf temp1 # another script may have left a mess. +mkdir temp1 +cd temp1 +darcs init +touch foo +darcs add foo +# trick: hitting 'enter' in interactive darcs record +echo n/ | tr / \\012 | darcs record +cd .. +rm -rf temp1 diff --git a/tests/tricky_unrecord.sh b/tests/tricky_unrecord.sh new file mode 100644 --- /dev/null +++ b/tests/tricky_unrecord.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp +mkdir temp +cd temp +darcs init +date > temp.c +darcs add temp.c +darcs record --all -A test --patch-name=hi + +mkdir d +darcs add d +darcs mv temp.c d/ +darcs record --all -A test --patch-name=mvetc +darcs show contents d/temp.c | cmp d/temp.c - + +echo y/d/y | tr / \\012 | darcs unrecord +darcs whatsnew +# darcs show contents d/temp.c | cmp d/temp.c - + +darcs record --all -A test --patch-name=again +darcs show contents d/temp.c | cmp d/temp.c - + +cd .. +rm -rf temp + diff --git a/tests/uniqueoptions.sh b/tests/uniqueoptions.sh new file mode 100644 --- /dev/null +++ b/tests/uniqueoptions.sh @@ -0,0 +1,33 @@ +#!/usr/bin/env bash +echo +echo Checking that each command expects each option only once +echo + +set -ev + +if echo $OS | grep -i windows; then + echo Noone knows how to handle newlines under cygwin, so we skip this test + exit 0 +fi + +rm -rf temp1 +mkdir temp1 +cd temp1 + +for i in `darcs --commands | grep -v -- -- | xargs echo`; do + echo -n Checking $i... ' ' + # only output actual command options, i.e. lines that contain a -- + darcs $i --help | grep -- "--" | sort > $i + uniq $i > uni$i + if cmp $i uni$i; then + echo passed. + else + echo failed! + diff -c uni$i $i + exit 1 + fi +done + +cd .. +rm -rf temp1 + diff --git a/tests/unpull-formerly-pl.sh b/tests/unpull-formerly-pl.sh new file mode 100644 --- /dev/null +++ b/tests/unpull-formerly-pl.sh @@ -0,0 +1,51 @@ +#!/usr/bin/env bash +set -ev + +rm -rf tempA +mkdir tempA +cd tempA +darcs initialize +echo hello world > foo +darcs add foo +darcs record -a -m hellofoo + +echo goodbye world >> foo +darcs record -a -m goodbyefoo + +darcs replace world bar foo +echo Hi there foo > bar +darcs add bar +darcs record -a -m addbar + +darcs mv bar baz +darcs replace bar baz foo +darcs record -a -m bar2baz + +echo Do not love the baz, or anything in the baz. >> foo +darcs record -a -m nolove + +darcs mv baz world +darcs replace baz world foo +darcs record -a -m baz2world + +darcs whatsnew | grep 'No changes' + +grep 'love the world' foo + +echo y | darcs unpull -p baz2world + +darcs whatsnew | grep 'No changes' + +grep 'love the baz' foo + +echo y | darcs unpull -p bar2baz + +grep 'love the bar' foo + +echo y | darcs unpull -p nolove + +grep 'love' foo && exit 1 || true + +cd .. +rm -rf tempA + diff --git a/tests/unpull.sh b/tests/unpull.sh new file mode 100644 --- /dev/null +++ b/tests/unpull.sh @@ -0,0 +1,23 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +cat > f < f < foo +darcs add foo +darcs whatsnew > correct +cat correct + +darcs record -a -m 'addfoo' + +darcs unrecord -a + +darcs whatsnew > unrecorded +cat unrecorded + +diff -u correct unrecorded + +cd .. +rm -rf temp1 diff --git a/tests/unrecord-dont-prompt.sh b/tests/unrecord-dont-prompt.sh new file mode 100644 --- /dev/null +++ b/tests/unrecord-dont-prompt.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash + +set -ev + +# Check that the right patches get unrecorded using --dont-prompt-for-dependencies + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo foo > f +darcs record -Ax -alm foo1 +echo bar > b +darcs rec -Ax -alm bar1 +echo foo2 > f +darcs record -Ax -alm foo2 +echo bar2 > b +darcs record -Ax -alm bar2 +darcs unrec --no-deps -p foo1 +darcs changes -p foo --count | grep 2 +#foo1 is depended upon, we don't unpull it +echo y | darcs unrec --dont-prompt-for-dependencies -p foo1 +#on the previous line, we don't get asked about foo2. +darcs changes -p foo --count | grep 0 +#yet, it is unrecorded. +darcs changes -p bar --count | grep 2 +cd .. +rm -rf temp1 diff --git a/tests/unrecord-remove.sh b/tests/unrecord-remove.sh new file mode 100644 --- /dev/null +++ b/tests/unrecord-remove.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo foo > foo +darcs add foo + +darcs record -a -m 'addfoo' + +darcs remove foo + +darcs whatsnew > correct +cat correct + +darcs record -a -m 'rmfoo' + +darcs unrecord -a --last 1 + +darcs whatsnew > unrecorded +cat unrecorded + +diff -u correct unrecorded + +cd .. +rm -rf temp1 diff --git a/tests/unrecord-setpref.sh b/tests/unrecord-setpref.sh new file mode 100644 --- /dev/null +++ b/tests/unrecord-setpref.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init + +darcs setpref boringfile foobar + +darcs whatsnew > correct +cat correct + +darcs record -a -m 'boringfoobar' + +darcs unrecord -a + +darcs whatsnew > unrecorded +cat unrecorded + +diff -u correct unrecorded + +cd .. +rm -rf temp1 diff --git a/tests/unrecord.sh b/tests/unrecord.sh new file mode 100644 --- /dev/null +++ b/tests/unrecord.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash + +set -ev + +# Check that checkpoints are removed when tags are unrecorded + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo foo > f +darcs rec -Ax -alm init +darcs tag -Ax --checkpoint t +echo y | darcs unrec -t t +# the complete inventory has only one patch to check +darcs check --complete > out +# The following test fails because the new progress code only +# prints out information on slow commands. +#grep '1 of 1' out >/dev/null + +# the checkpoint (if left) has two patches to check +# but it should have been removed +darcs check --partial > out +# The following test fails because the new progress code only +# prints out information on slow commands. +#grep '1 of 1' out >/dev/null +cd .. +rm -rf temp1 diff --git a/tests/unrevert-add.sh b/tests/unrevert-add.sh new file mode 100644 --- /dev/null +++ b/tests/unrevert-add.sh @@ -0,0 +1,26 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo foo > foo +darcs add foo +darcs whatsnew > correct +cat correct + +darcs revert -a + +not darcs whatsnew + +darcs unrevert -a + +darcs whatsnew > unrecorded +cat unrecorded + +diff -u correct unrecorded + +cd .. +rm -rf temp1 diff --git a/tests/unrevert-replace-moved.sh b/tests/unrevert-replace-moved.sh new file mode 100644 --- /dev/null +++ b/tests/unrevert-replace-moved.sh @@ -0,0 +1,36 @@ +#!/usr/bin/env bash + +. lib + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo hello world > foo +darcs add foo + +darcs record -a -m 'addfoo' + +darcs replace hello goodbye foo + +darcs revert -a + +not darcs whatsnew + +darcs mv foo bar + +echo hello my good friends >> bar + +darcs unrevert -a + +darcs whatsnew > unrecorded +cat unrecorded + +grep 'bar .* hello goodbye' unrecorded + +cat bar +grep 'goodbye world' bar +grep 'goodbye my good friends' bar + +cd .. +rm -rf temp1 diff --git a/tests/unrevert.sh b/tests/unrevert.sh new file mode 100644 --- /dev/null +++ b/tests/unrevert.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +echo hello world > foo +darcs add foo +darcs record -a -m add -A x +echo goodbye world >> foo +cp foo bar +darcs revert -a +darcs show contents foo | cmp foo - + +darcs unrevert -a +cmp foo bar + +cd .. +rm -rf temp1 + diff --git a/tests/unrevert_cancel.sh b/tests/unrevert_cancel.sh new file mode 100644 --- /dev/null +++ b/tests/unrevert_cancel.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash + +# From issue366 bug report + +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch a +touch b +darcs add * +darcs record -A moi -am init +echo plim >> a +echo plim >> b +echo y/y/y/ | tr / \\012 | darcs revert +echo ploum >> a +echo nyy | tr / \\012 | darcs unrevert + +cd .. +rm -rf temp1 diff --git a/tests/what_sl.sh b/tests/what_sl.sh new file mode 100644 --- /dev/null +++ b/tests/what_sl.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +set -ev + +rm -rf temp1 +mkdir temp1 +cd temp1 +darcs init +touch foo +darcs add foo +darcs rec -m t1 -a -A tester +echo 1 >> foo +darcs what -s | grep -v No\ changes +darcs what -l | grep -v No\ changes +darcs what -sl | grep -v No\ changes + +cd .. +rm -rf temp1 + diff --git a/tests/whatsnew-file.sh b/tests/whatsnew-file.sh new file mode 100644 --- /dev/null +++ b/tests/whatsnew-file.sh @@ -0,0 +1,61 @@ +#!/usr/bin/env bash + +. lib + +# Some tests for 'darcs whatsnew ' + +rm -rf temp1 + +mkdir temp1 +cd temp1 + +darcs init +date > foo +mkdir bar +echo hello world > bar/baz + +darcs record -la -m "add foo" + +echo goodbye world >> bar/baz + +# goodbye should show up precisely once + +darcs wh > out +cat out +grep goodbye out | wc -l | grep 1 + +darcs wh bar bar/baz > out +cat out +grep goodbye out | wc -l | grep 1 + +darcs mv foo bar +echo not date > bar/foo + +darcs wh bar bar/baz > out +cat out +grep date out | wc -l | grep 1 + +darcs wh foo > out +cat out +grep date out | wc -l | grep 1 + +darcs wh foo foo foo > out +cat out +grep date out | wc -l | grep 1 + +darcs wh foo ./foo ../temp1/foo > out +cat out +grep date out | wc -l | grep 1 + +darcs wh foo bar/../foo > out +cat out +grep date out | wc -l | grep 1 + +# This one fails actually, but it's not my fault. Filed as issue1196. +#darcs wh foo foo/../foo/. > out +#cat out +#grep date out | wc -l | grep 1 + +cd .. + +rm -rf temp1 diff --git a/tests/whatsnew.sh b/tests/whatsnew.sh new file mode 100644 --- /dev/null +++ b/tests/whatsnew.sh @@ -0,0 +1,53 @@ +#!/usr/bin/env bash + +. lib + +# Some tests for 'darcs whatsnew ' + +rm -rf temp1 temp2 + +mkdir temp1 +cd temp1 + +# RT#505 whatsnew -s after removal of file without a newline +darcs init +echo -n foobar > foo +darcs record -la -m "add foo" | grep "Finished record" +rm -f foo +darcs whatsnew -s | grep R +darcs record -a -m "remove foo" + +# RT#245 --look-for-adds implies --summary +touch look_summary.txt +darcs whatsnew -l | grep -i "a ./look_summary.txt" + +#whatsnew works with uncommon file names +if echo $OS | grep -i windows; then + echo test does not work on windows + exit 0; +else + echo foo > \\ + darcs add \\ + darcs whatsnew | tee log + grep 'hunk ./\\92\\' log +fi + +echo foo > "foo bar" +darcs add "foo bar" +darcs wh | tee log +grep 'hunk ./foo\\32\\bar' log + +# check that filename encoding does not botch up the index +darcs rec -am "weird filenames" +not darcs wh + +# whatsnew works with absolute paths +DIR="`pwd`" +echo date.t > date.t +touch date.t +darcs add date.t +darcs whatsnew "$DIR/date.t" | grep hunk + +cd .. + +rm -rf temp1 diff --git a/tests/workingdir.sh b/tests/workingdir.sh new file mode 100644 --- /dev/null +++ b/tests/workingdir.sh @@ -0,0 +1,92 @@ +#!/usr/bin/env bash + +. lib + +# test for working dir woes + +# the setup... +rm -rf temp1 temp2 +mkdir temp1 +cd temp1 +darcs init +mkdir a +echo temp0 > a/x +darcs add a +darcs add a/x +darcs record -am "aa" +darcs mv a/x a/y +darcs record -am "x to y" +echo temp1 > b +darcs add b +darcs record -am "bb" +mkdir d +darcs add d +darcs record -am "dd" +darcs tag 1 +echo 1-b2 > b +darcs record -am "b2" +cd .. + +# try to move a file that we don't have the right to do +darcs get temp1 temp2 --to-patch aa +cd temp2 +chmod u-w a +darcs pull -a +test -e b +chmod u+w a +cd .. +rm -rf temp2 + +# [issue319] try to overwrite file(s) in our working dir +darcs get temp1 temp2 --to-patch aa +cd temp2 +echo temp2 > b +echo temp2 > d +darcs pull -a -t 1 +grep temp1 b +grep temp2 b-darcs-backup0 +grep temp2 d-darcs-backup0 +# now make sure we didn't overdo it +darcs pull -a +grep '1-b2' b +test -e b-darcs-backup0 +test ! -e b-darcs-backup1 +cd .. +rm -rf temp2 + +# [issue298] backup working dir files with conflicts +darcs get temp1 temp2 --tag 1 +cd temp2 +echo 2-b2 > b +darcs pull -a +grep "v v v" b +grep "2-b2" b-darcs-backup0 +not grep "v v v" b-darcs-backup0 +cd .. +rm -rf temp2 + +# [issue440] a) try to overwrite a file in our working dir +darcs get temp1 temp2 --to-patch a +cd temp2 +echo temp2 > a/y +echo old-bak > a/y-darcs-backup0 +darcs pull -a +grep temp0 a/y +grep old-bak a/y-darcs-backup0 +grep temp2 a/y-darcs-backup1 +cd .. +rm -rf temp2 + +# [issue440] b) try to overwrite a directory in our working dir +darcs get temp1 temp2 --to-patch a +cd temp2 +mkdir a/y +echo old-bak > a/y-darcs-backup0 +darcs pull -a +grep temp0 a/y +grep old-bak a/y-darcs-backup0 +test -d a/y-darcs-backup1 +cd .. +rm -rf temp2 + +rm -rf temp1