diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,2 @@ +This repository contains haskell wrappers for using various version control +systems. Currently only git and svn are implemented. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,88 @@ +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : +-- License : AllRightsReserved +-- +-- Maintainer : +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Main ( + main +) where + +import qualified VCSWrapper.Svn as Svn +import qualified VCSWrapper.Mercurial as Mercurial + +import VCSWrapper.Mercurial.Parsers + +--main = do +-- return() +-- parseDocument "out.xml" +-- logEntries <- runWithConfig $ simpleLog +-- putStrLn $ "LogEntries :"++show logEntries +-- stats <- runWithConfig $ status [] +-- putStrLn $ "Status :"++show stats +-- runWithConfig $ commit ["file1"] "Enter commit message here." [] Nothing +-- stats <- runWithConfig $ status [] +-- putStrLn $ "Status :"++show stats +-- where +-- runWithConfig = runVcs curConfig +-- curConfig = makeConfig (Just cwd) Nothing Nothing +-- cwd = "/home/n0s/project1_work4" +-- url = "file:///home/n0s/svnrep/project1/trunk" +-- putStrLn "Starting!" +---- runWithConfig $ checkout (Just "hans") [(url, Nothing)] (Just targetDirectory) [] +---- runWithConfig $ add ["file10"] [] +---- runWithConfig $ commit [] "hansi" "commit" [] +---- runWithConfig $ update +---- runWithConfig $ unlock ["file10"] +-- files <- runWithConfig $ status [] +-- putStrLn $ "Files:" +-- ++(concat $ +-- map (\x -> "\n"++show x) +-- files) +-- putStrLn "Done!" +---- runWithConfig $ add ["file5"] +---- runWithConfig $ commit ["file5"] "hansi" "first haskell commit" [] + +cwdMercurial = "/home/forste/tmp/testvcs/hgreps/repo1" + +{- +main = do + o <- runWithConfig $ Mercurial.status + putStrLn $ "Status:" ++ show o + return() + where + runWithConfig = Mercurial.runVcs $ Mercurial.makeConfig (Just cwdMercurial) Nothing Nothing +-} + +{- +main = do + o <- runWithConfig $ Mercurial.commit ["test/test1"] "Commit via Main1" [] + putStrLn $ "Status:" ++ show o + return() + where + runWithConfig = Mercurial.runVcs $ Mercurial.makeConfig (Just cwdMercurial) Nothing Nothing +-} + + +--{- +main = do + o <- runWithConfig $ Mercurial.simpleLog Nothing + putStrLn $ "Log:" ++ show o + return() + where + runWithConfig = Mercurial.runVcs $ Mercurial.makeConfig (Just cwdMercurial) Nothing Nothing +---} + +{- +main = do + o <- parseLogFile "/home/forste/tmp/testvcs/hgreps/fprog/test.log" + putStrLn $ "Log:" ++ show o +-} diff --git a/src/VCSWrapper/Common.hs b/src/VCSWrapper/Common.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Common.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSWrapper.Common +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | This module exports types and functions common to all VCS. +-- +----------------------------------------------------------------------------- + +module VCSWrapper.Common ( + module VCSWrapper.Common.Types + ,module VCSWrapper.Common.Process +) where +import VCSWrapper.Common.Types +import VCSWrapper.Common.Process + + diff --git a/src/VCSWrapper/Common/Process.hs b/src/VCSWrapper/Common/Process.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Common/Process.hs @@ -0,0 +1,124 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSWrapper.Common.Process +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Functions to execute external processes and run VCS. +-- +----------------------------------------------------------------------------- + +module VCSWrapper.Common.Process ( + vcsExec + ,vcsExecThrowingOnError + ,exec + ,runVcs +) where + +import System.Process +import System.Exit +import System.IO (Handle, hFlush, hClose, hGetContents, hPutStr) +import Control.Concurrent +import Control.Monad.Reader +import qualified Control.Exception as Exc +import VCSWrapper.Common.Types +import Data.Maybe + +{-| + Run a VCS 'Ctx' from a 'Config' and returns the result + -} +runVcs :: Config -- ^ 'Config' for a VCS + -> Ctx t -- ^ An operation running in 'Ctx' + -> IO t +runVcs config (Ctx a) = runReaderT a config + +-- | Internal function to execute a VCS command. Throws an exception if the command fails. +vcsExecThrowingOnError :: String -- ^ VCS shell-command, e.g. git + -> String -- ^ VCS command, e.g. checkout + -> [String] -- ^ options + -> [(String, String)] -- ^ environment variables + -> Ctx String +vcsExecThrowingOnError vcsName cmd opts menv = do + o <- vcsExec vcsName cmd opts menv + case o of + Right out -> return out + Left exc -> Exc.throw exc + +-- | Internal function to execute a VCS command +vcsExec :: String -- ^ VCS shell-command, e.g. git + -> String -- ^ VCS command, e.g. checkout + -> [String] -- ^ options + -> [(String, String)] -- ^ environment variables + -> Ctx (Either VCSException String) +vcsExec vcsName cmd opts menv = exec cmd opts menv vcsName configPath + +-- | Internal function to execute a VCS command +exec :: String -- ^ VCS command, e.g. checkout + -> [String] -- ^ options + -> [(String, String)] -- ^ environment variables + -> String -- ^ VCS shell-command, e.g. git + -> (Config -> Maybe FilePath) -- ^ variable getter applied to content of Ctx + -> Ctx (Either VCSException String) +exec cmd opts menv fallBackExecutable getter = do + cfg <- ask + let args = cmd : opts + let pathToExecutable = fromMaybe fallBackExecutable (getter cfg) + (ec, out, err) <- liftIO $ readProc (configCwd cfg) pathToExecutable args menv "" + case ec of + ExitSuccess -> return $ Right out + ExitFailure i -> return $ Left $ + VCSException i out err (fromMaybe "cwd not set" $ configCwd cfg ) (cmd : opts) + +{- | + Same as 'System.Process.readProcessWithExitCode' but having a configurable working directory and + environment. +-} +readProc :: Maybe FilePath --working directory or Nothing if not set + -> String --command + -> [String] --arguments + -> [(String, String)] --environment can be empty + -> String --input can be empty + -> IO (ExitCode, String, String) +readProc mcwd command args menv input = do + putStrLn $ "Executing process, mcwd: "++show mcwd++", command: "++command++ + ",args: "++show args++",menv: "++show menv++", input"++input + (inh, outh, errh, pid) <- execProcWithPipes mcwd command args menv + + outMVar <- newEmptyMVar + + out <- hGetContents outh + _ <- forkIO $ Exc.evaluate (length out) >> putMVar outMVar () + + err <- hGetContents errh + _ <- forkIO $ Exc.evaluate (length err) >> putMVar outMVar () + + when (length input > 0) $ do hPutStr inh input; hFlush inh + hClose inh + + takeMVar outMVar + takeMVar outMVar + hClose outh + hClose errh + + ex <- waitForProcess pid + return (ex, out, err) + + +{- | + Setting pipes as in 'System.Process.readProcessWithExitCode' in ' but having a configurable working directory and + environment. +-} +execProcWithPipes :: Maybe FilePath -> String -> [String] -> [(String, String)] + -> IO (Handle, Handle, Handle, ProcessHandle) +execProcWithPipes mcwd command args menv = do + (Just inh, Just outh, Just errh, pid) <- createProcess (proc command args) + { std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe, + cwd = mcwd, + env = Just menv } + return (inh, outh, errh, pid) diff --git a/src/VCSWrapper/Common/TemporaryFiles.hs b/src/VCSWrapper/Common/TemporaryFiles.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Common/TemporaryFiles.hs @@ -0,0 +1,42 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSWrapper.Common.TemporaryFiles +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Helper for temporary files. +-- +----------------------------------------------------------------------------- + +module VCSWrapper.Common.TemporaryFiles ( + withTempFile +) where + +import System.IO +import System.Directory(getTemporaryDirectory, removeFile) +import System.IO.Error(catch) +import Control.Exception(finally) + +{- | + Executes given function using a tempory file. + -} +withTempFile :: String -- ^ Filename + -> (FilePath -- 'FilePath' to temporary file + -> Handle -- 'Handle' for temporary file + -> IO a) -- ^ Fn to be called + -> IO a +withTempFile pattern func = + do + tempdir <- catch (getTemporaryDirectory) (\_ -> return ".") + putStrLn $ "Obtained temporary directory: "++tempdir + (file, handle) <- openTempFile tempdir pattern + putStrLn $ "Opened file: "++file++", handle: "++show handle + + finally (func file handle) + (do hClose handle + removeFile file + ) diff --git a/src/VCSWrapper/Common/Types.hs b/src/VCSWrapper/Common/Types.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Common/Types.hs @@ -0,0 +1,145 @@ +----------------------------------------------------------------------------- +-- +-- Module : Common.Types +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Defines all types and their associated accessorfunctions. +-- +----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} +module VCSWrapper.Common.Types ( + VCSType(..) + ,IsLocked + ,LogEntry (..) + ,Ctx(..) + ,Config(..) + ,Author(..) + ,VCSException(..) + ,Status(..) + ,Modification(..) + ,makeConfig + ,makeConfigWithEnvironment + ,filePath + ,modification + ,isLocked +) where + +import Control.Monad.Reader +import Data.Typeable (Typeable) +import Control.Exception (Exception) + +-- | Available VCS types implemented in this package. +data VCSType = SVN | GIT | Mercurial + deriving (Show,Read, Eq) + +-- | Status of a file managed by the respective VCS. +data Status = SVNStatus FilePath Modification IsLocked + | GITStatus FilePath Modification + deriving (Show,Read) + +-- | Retrieve the 'FilePath' of any VCS 'Status'. +filePath :: Status -> FilePath +filePath (SVNStatus fp _ _) = fp +filePath (GITStatus fp _) = fp + +-- | Retrieve the 'Modification' of any VCS 'Status'. +modification :: Status -> Modification +modification (SVNStatus _ m _) = m +modification (GITStatus _ m) = m + +-- | Retrieve the 'IsLocked' of any VCS 'Status'. For Git, this returns always 'False'. +isLocked :: Status -> IsLocked +isLocked (SVNStatus _ _ l) = l +isLocked _ = False + +-- | Flags to describe the state of a file. +data Modification = None | -- ^ File hasn't been modified. + Added | -- ^ File has been selected to be managed by the respective VCS. + Conflicting | -- ^ File is in conflicting state. Manually resolving the conflict may be necessary. + Deleted | -- ^ File has been deleted. + Modified | -- ^ File has been modified since last commit. + Replaced | -- ^ File has been replaced by a different file. + Untracked | -- ^ File is currently not known by the VCS. + Unknown | -- ^ State of file is unknown. + Ignored | -- ^ File is ignored by VCS. + Missing -- ^ File is missing. + deriving (Eq,Show,Read) + +-- | Represents a log entry in the history managed by the VCS. +data LogEntry = LogEntry { + mbBranch :: Maybe String -- ^ Maybe Branchname + , commitID :: String -- ^ Commit identifier + , author :: String -- ^ Author of this commit. + , email :: String -- ^ Email address of the author. + , date :: String -- ^ Date this log entry was created. + , subject :: String -- ^ Short commit message. + , body :: String -- ^ Long body of the commit message. +} deriving (Show) + +-- | 'True', if this file is locked by the VCS. +type IsLocked = Bool + +-- | Configuration of the 'Ctx' the VCS commands will be executed in. +data Config = Config + { configCwd :: Maybe FilePath -- ^ Path to the main directory of the repository. E.g. for Git: the directory of the repository containing the @.git@ config directory. + , configPath :: Maybe FilePath -- ^ Path to the vcs executable. If 'Nothing', the PATH environment variable will be search for a matching executable. + , configAuthor :: Maybe Author -- ^ Author to be used for different VCS actions. If 'Nothing', the default for the selected repository will be used. + , configEnvironment :: [(String, String)] -- ^ List of environment variables mappings passed to the underlying VCS executable. + } deriving (Show, Read) + +-- | Author to be passed to VCS commands where applicable. +data Author = Author + { authorName :: String -- ^ Name of the author. + , authorEmail :: Maybe String -- ^ Email address of the author. + } deriving (Show, Read) + +{- | Context for all VCS commands. + + E.g. to create a new Git repository use something like this: + + >import VCSWrapper.Git + >myInitRepoFn = do + > let config = makeConfig "path/to/repo" Nothing Nothing + > runVcs config $ initDB False +-} +newtype Ctx a = Ctx (ReaderT Config IO a) + deriving (Monad, MonadIO, MonadReader Config) + +-- | Creates a new 'Config' with a list of environment variables. +makeConfigWithEnvironment :: Maybe FilePath -- ^ Path to the main directory of the repository. E.g. for Git: the directory of the repository containing the @.git@ config directory. + -> Maybe FilePath -- ^ Path to the vcs executable. If 'Nothing', the PATH environment variable will be search for a matching executable. + -> Maybe Author -- ^ Author to be used for different VCS actions. If 'Nothing', the default for the selected repository will be used. + -> [(String, String)] -- ^ List of environment variables mappings passed to the underlying VCS executable. + -> Config +makeConfigWithEnvironment repoPath executablePath author environment = Config { + configCwd = repoPath + ,configPath = executablePath + ,configAuthor = author + ,configEnvironment = environment + } +-- | Creates a new 'Config'. +makeConfig :: Maybe FilePath -- ^ Path to the main directory of the repository. E.g. for Git: the directory of the repository containing the @.git@ config directory. + -> Maybe FilePath -- ^ Path to the vcs executable. If 'Nothing', the PATH environment variable will be search for a matching executable. + -> Maybe Author -- ^ Author to be used for different VCS actions. If 'Nothing', the default for the selected repository will be used. + -> Config +makeConfig repoPath executablePath author = Config { + configCwd = repoPath + ,configPath = executablePath + ,configAuthor = author + ,configEnvironment = [] + } + +-- | This 'Exception'-type will be thrown if a VCS command fails unexpectedly. +data VCSException + -- | Exit code -> stdout -> errout -> 'configCwd' of the 'Config' -> List containing the executed command and its options + = VCSException Int String String String [String] + deriving (Show, Typeable) + +instance Exception VCSException + + diff --git a/src/VCSWrapper/Git.hs b/src/VCSWrapper/Git.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Git.hs @@ -0,0 +1,158 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSWrapper.Git +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Provides high-level Git functions like @commit@, @checkout@, @status@, @log@,... +-- +-- All functions of this module run in the 'Ctx' monad, common to all VCS. +-- On unexpected behavior, these functions will throw a 'VCSException'. +----------------------------------------------------------------------------- + +module VCSWrapper.Git ( + initDB + , add + , rm + , commit + , checkout + , status + , simpleLog + , localBranches + , revparse + , remote + , pull + , push + -- , clone + + -- reexport from VCSWrapper.Git.Process + , runVcs + + , module VCSWrapper.Git.Types +) where + +import System.Directory + +import Control.Monad.Trans +import qualified Control.Exception as Exc + +import Data.List.Utils + +import VCSWrapper.Git.Parsers +import VCSWrapper.Git.Process +import VCSWrapper.Git.Types + +import Data.Maybe +import qualified Data.List +import Data.String.Utils (strip) + + +{- | Initialize a new git repository. Executes @git init@. -} +initDB :: Bool -- ^ if 'True', this repository will be initialized as a bare repository (appends @--bare@ to the git command) + -> Ctx () +initDB bare = do + let opts = if bare then ["--bare"] else [] + gitExecWithoutResult "init-db" opts [] + +{- | Add files to the index. Executes @git add@. -} +add :: [ FilePath ] -- ^ 'FilePath's to add to the index. + -> Ctx () +add paths = do + let opts = "--" : paths + gitExecWithoutResult "add" opts [] + +{- | Remove files from the index and the working directory. Executes @git rm@. -} +rm :: [ FilePath ] -- ^ 'FilePath's to remove. + -> Ctx () +rm paths = do + let opts = "--" : paths + gitExecWithoutResult "rm" opts [] + +{- | Commit the current index or the specified files to the repository. Executes @git commit@. -} +commit :: [ FilePath ] -- ^ 'FilePath's to be commited instead of the current index. Leave empty to commit the index. + -> Maybe (String, String) -- ^ (Author name, email) + -> String -- ^ Commit message. Don't leave this empty. + -> [String] -- ^ Options to be passed to the git executable. + -> Ctx () +commit rsrcs mbAuthor logmsg extraopts = do + case mbAuthor of + Just (author, author_email) -> + commit' rsrcs logmsg extraopts ["--author", author ++ " <" ++ author_email ++ ">"] + Nothing -> + commit' rsrcs logmsg extraopts [] + where + commit' files logmsg extraopts authopts = do + let msgopts = [ "-m", logmsg ] + let opts = authopts ++ msgopts ++ extraopts ++ [ "--" ] ++ files + gitExecWithoutResult "commit" opts [] + +{- | Checkout the index to some commit ID. Executes @git checkout@. -} +checkout :: Maybe String -- ^ Commit ID + -> Maybe String -- ^ Branchname. If specified, @git checkout -b \@ will be executed. + -> Ctx () +checkout rev branch = do + let bopt = maybe [] (\b -> [ "-b", b ]) branch + let copt = maybeToList rev + gitExecWithoutResult "checkout" (bopt ++ copt) [] + +{- | Return status of the repository as a list of 'Status'. Executes @git status@. -} +status :: Ctx [Status] +status = do + o <- gitExec "status" ["--porcelain"] [] + return $ parseStatus o + +{- | Get all commit messages. Executes @git log@. -} +simpleLog :: Maybe String -- ^ The branch from which to get the commit messages. (If 'Nothing', the current branch will be used). + -> Ctx [LogEntry] +simpleLog mbBranch = do + -- double dash on end prevent crash if branch and filename are equal + o <- gitExec "log" ((branch mbBranch) ++ ["--pretty=tformat:commit:%H%n%an%n%ae%n%ai%n%s%n%b%x00", "--"]) [] + return $ parseSimpleLog o + where + branch Nothing = [] + branch (Just b) = [b] + + +{- | Get all local branches. Executes @git branch@. -} +localBranches :: Ctx (String, [String]) -- ^ (currently checked out branch, list of all other branches) +localBranches = do + o <- gitExec "branch" [] [] + return $ parseBranches o + +{- | Get all remotes. Executes @git remote@. -} +remote :: Ctx [String] +remote = do + o <- gitExec "remote" [] [] + return $ parseRemotes o + +{- | Push changes to the remote as configured in the git configuration. Executes @git push@. -} +push :: Ctx () +push = gitExecWithoutResult "push" [] [] + +{- | Pull changes from the remote as configured in the git configuration. If a merge conflict + is detected, the error message is returned, otherwise 'Right ()' is returned. + Executes @git pull@. -} +pull :: Ctx (Either String ()) +pull = do + o <- gitExec' "pull" [] [] + case o of + Right _ -> return $ Right () + Left exc@(VCSException _ out _ _ _) -> if (parsePullMergeConflict out) then return $ Left out + else Exc.throw exc + +{- | Rev-parse a revision. Executes @git rev-parse@. -} +revparse :: String -- ^ Revision to pass to rev-parse. + -> Ctx (String) +revparse commit = do + o <- gitExec "rev-parse" [commit] [] + return $ strip o + + + + + + diff --git a/src/VCSWrapper/Git/Parsers.hs b/src/VCSWrapper/Git/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Git/Parsers.hs @@ -0,0 +1,86 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSWrapper.Git.Parsers +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Provides functions to parse the output of certain Git commands. +-- +----------------------------------------------------------------------------- + +module VCSWrapper.Git.Parsers ( + parseStatus + , parseBranches + , parseRemotes + , parseSimpleLog + , parsePullMergeConflict +) where + +import Data.List.Utils +import Data.List + +import Text.ParserCombinators.Parsec + +import VCSWrapper.Common.Types + +-- | Parse the status of a Git repo. Expects command @git status --porcelain@. +parseStatus :: String -- ^ Output of @git status --porcelain@. + -> [Status] -- ^ 'Status' for each file. +parseStatus status = [ GITStatus filepath Modified | (_:x:_:filepath) <- lines, x == 'M'] -- M only displayed in second column + ++ [ GITStatus filepath Untracked | (x:_:_:filepath) <- lines, x == '?'] + ++ [ GITStatus filepath Added | (x:_:_:filepath) <- lines, x == 'A'] -- A only displayed in second column + ++ [ GITStatus filepath Deleted | (x:y:_:filepath) <- lines, x == 'D' || y == 'D'] -- D flag depends on index state (both columns) + where + lines = split "\n" status + +-- | Parse the output of @git branch@. +parseBranches :: String -> (String, [String]) -- ^ (currently checked out branch, list of all other branches) +parseBranches string = (head [branchname | ('*':_:branchname) <- lined], + [branchname | (' ':' ':branchname) <- lined]) + where + lined = lines string + +-- | Parse @git remote@. +parseRemotes :: String -> [String] +parseRemotes = split "\n" + +-- | Parse output of @git pull@ and return if the repository is in conflict state. +parsePullMergeConflict :: String -> Bool +parsePullMergeConflict s = isPrefixOf "CONFLICT" s -- TODO improve this implementation, conflict after attemted automerge is not detected. + +-- | Parse output of @git log --pretty=tformat:commit:%H%n%an%n%ae%n%ai%n%s%n%b%x00@. +parseSimpleLog :: String -> [LogEntry] +parseSimpleLog log = + case parsed of + Right entries -> entries + Left _ -> [] + where parsed = parse logEntries "" log + +-- | Parse a single log entry. Expects @git log --pretty=tformat:commit:%H%n%an%n%ae%n%ai%n%s%n%b%x00@ +logEntry :: Parser LogEntry +logEntry = do + string "commit:" + commitID <- wholeLine + author <- wholeLine + email <- wholeLine + date <- wholeLine + subject <- wholeLine + body <- bodyLines + char '\n' + return $ LogEntry Nothing commitID author email date subject body + +bodyLines = manyTill anyChar (nullChar) + +logEntries :: Parser [LogEntry] +logEntries = manyTill logEntry eof + +--------------------- +-- parsing helpers +--------------------- +wholeLine = manyTill anyChar newline + +nullChar = satisfy (=='\0') >> return () diff --git a/src/VCSWrapper/Git/Process.hs b/src/VCSWrapper/Git/Process.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Git/Process.hs @@ -0,0 +1,56 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSWrapper.Git.Process +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Functions to execute git commands. +-- +----------------------------------------------------------------------------- + +module VCSWrapper.Git.Process ( + gitExec + , gitExec' + , gitExecWithoutResult + , module VCSWrapper.Common.Process + +) where + +import VCSWrapper.Common.Process +import VCSWrapper.Common.Types + +import Control.Monad.Reader.Class (asks) +import qualified Control.Exception as Exc + + +-- | Internal function to execute a git command +gitExec :: String -- ^ git command, e.g. checkout, commit + -> [String] -- ^ options + -> [(String, String)] -- ^ environment + -> Ctx String +gitExec cmd opts env = do + cfgEnv <- asks configEnvironment + vcsExecThrowingOnError "git" cmd opts (cfgEnv ++ env) + + +-- | Internal function to execute a git command. Doesn't throw an exception if the command failes, +-- but returns an Either with exit information. +gitExec' :: String -- ^ git command, e.g. checkout, commit + -> [String] -- ^ options + -> [(String, String)] -- ^ environment + -> Ctx (Either VCSException String) +gitExec' cmd opts env = do + cfgEnv <- asks configEnvironment + vcsExec "git" cmd opts (cfgEnv ++ env) + + +gitExecWithoutResult :: String -- ^ git command to execute, e.g. checkout, commit + -> [String] -- ^ options + -> [(String, String)] -- ^ environment + -> Ctx () +gitExecWithoutResult cmd opts env = gitExec cmd opts env >> return () + diff --git a/src/VCSWrapper/Git/Types.hs b/src/VCSWrapper/Git/Types.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Git/Types.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSWrapper.Git.Types +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | All types defined and used by git +-- +----------------------------------------------------------------------------- + +module VCSWrapper.Git.Types ( + module VCSWrapper.Common.Types +) where +import VCSWrapper.Common.Types + +--import qualified SCM.Interface as IF + + + +--instance IF.ScmOperations GitRepo where +-- commit = commit +-- checkout = checkout +-- getLocalPath (GitRepo path) = path +-- getModifiedFiles repo = do +-- status <- getStatus repo +-- return $ extractModifiedFiles status diff --git a/src/VCSWrapper/Mercurial.hs b/src/VCSWrapper/Mercurial.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Mercurial.hs @@ -0,0 +1,132 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSWrapper.Mercurial +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL Nothing +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module VCSWrapper.Mercurial ( + -- mercurial commands + addremove + ,commit + ,pull + ,push + ,simpleLog + ,update + ,status + + ,runVcs + + ,module VCSWrapper.Mercurial.Types +) where + +import VCSWrapper.Mercurial.Process +import VCSWrapper.Mercurial.Parsers +import VCSWrapper.Mercurial.Types +import VCSWrapper.Common.TemporaryFiles + +import System.IO +import Control.Monad.Reader +import Maybe + +{- | + Add all new files, delete all missing files. Executes @hg addremove@. +-} +addremove :: [FilePath] -- ^ files to add + -> Ctx () +addremove files = hgExecNoEnv "addremove" files + +{- | + Update the repository's working directory to the specified changeset. If + no changeset is specified, update to the tip of the current named branch. + Executes @hg checkout@. +-} +checkout :: Maybe String -- ^ optional changeset + -> [String] -- ^ options + -> Ctx () +checkout mbChangeset options = hgExecNoEnv "checkout" opts + where + changeSet = [fromMaybe "" mbChangeset] + opts = options++changeSet + +{- | + Commit the specified files or all outstanding changes. Executes @hg commit@. +-} +commit :: [FilePath] -- ^ files to commit. List may be empty - if not only specified files will be commited + -> String -- ^ message, can be empty + -> [String] -- ^ options + -> Ctx () +commit filesToCommit logMsg options = hgExecNoEnv "commit" opts + where + msgOpt = [ "--message", logMsg ] + opts = msgOpt ++ options ++ filesToCommit + +{- | Get all local branches. Executes @hg branches@. -} +localBranches :: Ctx (String, [String]) -- ^ (currently checked out branch, list of all other branches) +localBranches = do + currentBranch <- hgExec "branch" [] [] + o <- hgExec "branches" ["-q"] [] + let otherBranches = filter (\b -> not $ b == currentBranch) $ parseBranches o + return (currentBranch, otherBranches) + +{- | + Pull changes from a remote repository to a local one. If a merge conflict is detected, the error + message is returned, otherwise 'Right ()' is returned. Executes @hg pull@. +-} +pull :: Ctx () +pull = do + hgExecNoEnv "pull" [] + hgExecNoEnv "update" [] -- calling update here and not using the --update option for pull to force exception + +{- | + Push changesets from the local repository to the default destination. +-} +push :: Ctx () +push = do + hgExecNoEnv "push" [] + +{- | + Show revision history of entire repository or files. Executes @hg log@. +-} +simpleLog :: Maybe String -- ^ Show the specified revision or range or branch + -> Ctx[LogEntry] +simpleLog mbRev = do + o <- hgExec "log" opts [] + logEntries <- liftIO $ withTempFile "log.xml" (parseLog o) + return logEntries + where + rev Nothing = [""] + rev (Just revision) = ["-r",revision] + opts = ["--style", "xml"] ++ (rev mbRev) + parseLog out path handle = do + hPutStrLn handle out + hClose handle -- closing handle so parseDocument can open one + parseLogFile path + + + +{- | Show changed files in the working directory as a list of 'Status'. Executes @hg status@. -} +status :: Ctx [Status] +status = do + o <- hgExec "status" [] [] + return $ parseStatusOut o + +{- | + Update the repository's working directory to the specified changeset. If + no changeset is specified, update to the tip of the current named branch. +-} +update :: Maybe String + -> Ctx () +update mbRev = hgExecNoEnv "update" opts + where + rev Nothing = [""] + rev (Just revision) = ["-r",revision] + opts = rev mbRev + diff --git a/src/VCSWrapper/Mercurial/Parsers.hs b/src/VCSWrapper/Mercurial/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Mercurial/Parsers.hs @@ -0,0 +1,144 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSWrapper.Mercurial.Parsers +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL Nothing +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module VCSWrapper.Mercurial.Parsers ( + parseStatusOut + ,parseLogFile + ,parseBranches +) where + +import qualified VCSWrapper.Mercurial.Types as Common +import Data.List.Utils +import Text.XML.HXT.Core + + +{- | + Parses given 'String' and returns a list of 'Status'. +-} +parseStatusOut :: String -- ^ String which is required to have same format as output from @svn status@ + -> [Common.Status] +parseStatusOut out = parseRows rows + where + rows = init' splitRows + splitRows = split "\n" out :: [String] + +-- | Parse the output of @hg branch -q@. +parseBranches :: String -> [String] -- ^ list of all branches +parseBranches string = lines string + +{- | + Attempts to parse given file and returns a list of 'Common.LogEntry'. +-} +parseLogFile :: FilePath -- ^ File which must be the same format as the one of @hg log --style xml@. + -> IO [Common.LogEntry] +parseLogFile document = + do + logs <- runX (xunpickleDocument xpLog [ withRemoveWS yes, withValidate no] document) + putStrLn $ "Logs: " ++ show logs + let log = head logs + let entries = map (\(LogEntry rev node mbBranch (email, aut) dat msg) -> Common.LogEntry mbBranch node aut email dat msg msg) + (logEntries log) + return entries + +-- HELPERS +init' :: [a] -> [a] +init' [] = [] +init' ls = init ls + +-- parses given rows from @hg status@. Supports only first seven columns and filename so far +parseRows :: [String] -> [Common.Status] +parseRows rows = map mapRow rows + where + mapRow = \row -> Common.GITStatus (getFileName row) (getModification row) +-- { +-- file=(getFileName row) +-- ,modification=(getModification row) +-- ,isLocked=(getLockStatus row) +-- } + getFileName = (\row -> nFunc tail 2 row) :: String -> FilePath + getModification = (\row -> parseFirstCol $ row!!0) :: String -> Common.Modification + + + +nFunc :: (a -> a) -> Int -> a -> a +nFunc _ 0 = id +nFunc f n = f . nFunc f (n-1) + +parseFirstCol :: Char -> Common.Modification +parseFirstCol 'C' = Common.None +parseFirstCol 'A' = Common.Added +parseFirstCol 'R' = Common.Deleted +parseFirstCol 'M' = Common.Modified +parseFirstCol '?' = Common.Untracked +parseFirstCol '!' = Common.Missing +parseFirstCol 'I' = Common.Ignored +parseFirstCol _ = Common.Unknown + +-- LogFile Helpers + +data Log = Log { + logEntries :: LogEntries + } deriving (Show, Read) + +instance XmlPickler Log where + xpickle = xpLog + +type LogEntries = [LogEntry] + +data LogEntry = LogEntry { + revision :: Int + ,node :: String + ,branch :: Maybe String + ,author :: Author + , date :: Date + , message :: Message + } deriving (Show, Read) + +type Author = (String, String) +type Date = String +type Message = String + +xpLog :: PU Log +xpLog = xpWrap (\l -> Log l, \l -> (logEntries l)) + $ xpElem "log" + $ xpLogEntries + +xpLogEntries :: PU LogEntries +xpLogEntries = xpList + $ xpLogEntry + + +xpLogEntry :: PU LogEntry +xpLogEntry = xpWrap (\(rev,nod,bra,par,tag,aut,dat,msg) -> + LogEntry { revision = rev, node = nod, branch = bra, author = aut, date = dat, message = msg}, + \e -> (revision e, node e, branch e, Nothing, Nothing, author e, date e, message e)) + $ xpElem "logentry" + $ xp8Tuple (xpAttr "revision" xpInt) + (xpAttr "node" xpText0) + (xpOption $ xpElemWithText "branch") + (xpOption $ xpElemWithText "parent") + (xpOption $ xpElemWithText "tag") + (xpAuthor) + (xpElemWithText "date") + (xpElemWithText "msg") + where + xpElemWithText elem = xpElem elem $ xpText0 + + +xpAuthor :: PU Author +xpAuthor = xpWrap (id, id) + $ xpElem "author" + $ xpPair (xpAttr "email" xpText0) + (xpText0) + diff --git a/src/VCSWrapper/Mercurial/Process.hs b/src/VCSWrapper/Mercurial/Process.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Mercurial/Process.hs @@ -0,0 +1,51 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSWrapper.Mercurial.Process +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL Nothing +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module VCSWrapper.Mercurial.Process ( + hgExecNoEnv + , hgExec + + , module VCSWrapper.Common.Process +) where + +import VCSWrapper.Common.Process +import VCSWrapper.Mercurial.Types +import Control.Monad.Reader(ask) + +hgExecNoEnv :: String -- ^ cmd + -> [String] -- ^ opts + -> Ctx() +hgExecNoEnv cmd options = do + config <- ask + let mbAuthor = configAuthor config + let opts = (authopts mbAuthor)++options + hgExec cmd opts [] + return() + where + authopts Nothing = [] + authopts (Just a) = ["--username", authorName a] + +{- | + Execute given hg command with given options and environment. +-} +hgExec :: String -- ^ hg command, e.g. checkout + -> [String] -- ^ options + -> [(String, String)] -- ^ environment + -> Ctx String +hgExec cmd opts = do + let extOpts = opts++globalOpts + vcsExecThrowingOnError "hg" cmd extOpts + where + globalOpts = ["--noninteractive"] + diff --git a/src/VCSWrapper/Mercurial/Types.hs b/src/VCSWrapper/Mercurial/Types.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Mercurial/Types.hs @@ -0,0 +1,20 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSWrapper.Mercurial.Types +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL Nothing +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module VCSWrapper.Mercurial.Types ( + module VCSWrapper.Common.Types +) where +import VCSWrapper.Common.Types + + diff --git a/src/VCSWrapper/Svn.hs b/src/VCSWrapper/Svn.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Svn.hs @@ -0,0 +1,192 @@ +----------------------------------------------------------------------------- +-- +-- Module : Svn +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Provides high level SVN functions like @commit@, @checkout@, @update@ and others. +-- +-- All functions of this module run in the 'Ctx' monad, common to all VCS. +-- On unexpected behavior, these functions will throw a 'VCSException'. +-- All functions will be executed with options @--non-interactive@ and @--no-auth-cache@ set. +----------------------------------------------------------------------------- +{-# LANGUAGE ScopedTypeVariables #-} +module VCSWrapper.Svn ( + -- svn commands + add + ,checkout + ,commit + ,lock + ,mergeHeadToRevision + ,resolved + ,simpleLog + ,unlock + ,update + ,status + -- exposed svn helpers + ,getFilesInConflict + -- runner + ,runVcs + + --types + ,module VCSWrapper.Svn.Types +) where + +import VCSWrapper.Svn.Parsers +import VCSWrapper.Svn.Process +import VCSWrapper.Svn.Types + +import VCSWrapper.Common.TemporaryFiles +import Control.Monad.Reader +import Maybe +import System.IO + +import Data.List.Utils(startswith) +import Monad (filterM) +import System.Directory(doesFileExist, getDirectoryContents) +import System.FilePath(combine, splitFileName) + +-- +-- SVN COMMANDS +-- + +{- | + Put files and directories under version control, scheduling them for addition to repository. + They will be added in next commit.. Executes @svn add@. +-} +add :: [FilePath] -- ^ files to add + -> Maybe String -- ^ optional password + -> [String] -- ^ options + -> Ctx () +add files = svnExec_ "add" files + +{- | + Checkout out a working copy from a repository. Executes @svn checkout@. +-} +checkout :: [(String, Maybe String)] -- ^ list of (url, 'Maybe' revision). List must not be empty, however revision need not to be set + -> Maybe String -- ^ optional path + -> Maybe String -- ^ optional password + -> [String] -- ^ options + -> Ctx () +checkout repos path = svnExec_ "checkout" opts + where + realPath = [fromMaybe "" path] + urls = map (\(x,y) -> x + ++ (if (isNothing y) then "" else "@") + ++ fromMaybe "" y) + repos + opts = urls++realPath + +{- | + Send changes from your working copy to the repository. Executes @svn commit@. +-} +commit :: [FilePath] -- ^ files to commit. List may be empty - if not only specified files will be commited + -> String -- ^ message, can be empty + -> Maybe String -- ^ optional password + -> [String] -- ^ options + -> Ctx () +commit filesToCommit logMsg = svnExec_ "commit" opts + where + msgopts = [ "--message", logMsg ] + opts = msgopts ++ filesToCommit + +{- | + Lock working copy paths or URLs in the repository, so that no other user can commit changes to + them. Executes @svn lock@. +-} +lock :: [FilePath] -- ^ Files to lock, must not be empty + -> Maybe String -- ^ optional password + -> [String] -- ^ options + -> Ctx () +lock files = svnExec_ "lock" files + + + + +{- | + Reverts working copy to given revision. Executes @svn merge -rHEAD:$revision .@. +-} +mergeHeadToRevision :: Integer -- ^ revision, e.g. 3 + -> Maybe String -- ^ optional password + -> [String] -- ^ options + -> Ctx() +mergeHeadToRevision revision = svnExec_ "merge" ["-rHEAD:"++show revision,"."] + +{- | + Remove @conflicted@ state on working copy files or directories. Executes @svn resolved@. + -} +resolved :: [FilePath] -- ^ files or directories to mark resolved + -> Maybe String -- ^ optional password + -> [String] -- ^ options + -> Ctx() +resolved files = svnExec_ "resolved" files + +{- | + Get the log messages for the current working copy. Executes @svn log@. + -} +simpleLog :: Ctx [LogEntry] +simpleLog = do + o <- svnExec "log" ["--xml"] [] + logEntries <- liftIO $ withTempFile "log.xml" (parseLog o) + return logEntries + where + parseLog out path handle = do + hPutStrLn handle out + hClose handle -- closing handle so parseDocument can open one + parseLogFile path + +{- | + Get the status of working copy files and directories. Executes @svn status@. +-} +status :: Ctx [Status] +status = do + o <- svnExec "status" [] [] + return $ parseStatusOut o + +{- | + Unlock working copy paths or URLs. Executes @svn unlock@. +-} +unlock :: [FilePath] -- ^ Files to unlock, must not be empty + -> Maybe String -- ^ optional password + -> [String] -- ^ options + -> Ctx () +unlock files = svnExec_ "unlock" files + +{- | + Bring changes from the repository into the working copy. Executes @svn update@. +-} +update :: Maybe String -- ^ optional password + -> [String] -- ^ options + -> Ctx() +update = svnExec_ "update" [] + + +-- +-- Exposed SVN Helpers +-- + +{- | + Returns all files of a conflict indicated by its associated filename. E.g. for file "Types.hs" + this might be "Types.hs", "Types.hs.r1", "Types.hs.r2" and "Types.hs.mine" +-} +getFilesInConflict :: FilePath -- ^ 'FilePath' to file of conflict. + -> Ctx [FilePath] +getFilesInConflict fp = do + config <- ask + let cwd = configCwd config + liftIO $ do + let file = combine (fromMaybe "" cwd) fp + let (fileD,fileN) = splitFileName file + content <- getDirectoryContents fileD + let contentWithD = map (\cN -> combine fileD cN) content + files <- filterM doesFileExist contentWithD + let filesToResolve = [f | f <- files, (startswith (file++".r") f) || (f == (file++".mine"))]++[file] + return filesToResolve + + + + diff --git a/src/VCSWrapper/Svn/Parsers.hs b/src/VCSWrapper/Svn/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Svn/Parsers.hs @@ -0,0 +1,134 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSWrapper.Svn.Parsers +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Various parsers for output of svn commands. +-- +----------------------------------------------------------------------------- + +module VCSWrapper.Svn.Parsers ( + parseLogFile + ,parseStatusOut +) where +import Data.Maybe +import System.Exit +import Text.XML.HXT.Core +import Data.List.Utils + +import qualified VCSWrapper.Common.Types as Common + +instance XmlPickler Log where + xpickle = xpLog + +{- | + Attempts to parse given file and returns a list of 'Common.LogEntry'. +-} +parseLogFile :: FilePath -- ^ File which must be the same format as the one of @svn log --xml@. + -> IO [Common.LogEntry] +parseLogFile document = + do + logs <- runX (xunpickleDocument xpLog [ withRemoveWS yes, withValidate no] document) + let log = head logs + let entries = map (\(LogEntry rev aut dat msg) -> Common.LogEntry Nothing (show rev) aut "" dat msg msg) + (logEntries log) + return entries + +{- | + Parses given 'String' and returns a list of 'Common.Status'. +-} +parseStatusOut :: String -- ^ String which is required to have same format as output from @svn status@ + -> [Common.Status] +parseStatusOut out = parseRows rows + where + rows = init' splitRows + splitRows = split "\n" out :: [String] + + +-- +-- HELPERS +-- + +-- LogFile Helpers + +data Log = Log { + logEntries :: LogEntries + } deriving (Show, Read) + +type LogEntries = [LogEntry] + +data LogEntry = LogEntry { + revision :: Int + ,author :: Author + , date :: Date + , message :: Message + } deriving (Show, Read) + +type Author = String +type Date = String +type Message = String + +xpLog :: PU Log +xpLog = xpWrap (\l -> Log l, \l -> (logEntries l)) $ + xpElem "log" $ + xpLogEntries + +xpLogEntries :: PU LogEntries +xpLogEntries = xpList $ + xpLogEntry + + +xpLogEntry :: PU LogEntry +xpLogEntry = xpWrap (\(rev,aut,dat,msg) -> LogEntry { revision = rev, author = aut, date = dat, message = msg}, + \e -> (revision e, author e, date e, message e)) $ + xpElem "logentry" $ + xp4Tuple (xpAttr "revision" xpInt) + (xpElemWithText "author") + (xpElemWithText "date") + (xpElemWithText "msg") + where + xpElemWithText elem = xpElem elem $ xpText0 + +-- StatusOut Helpers + +init' :: [a] -> [a] +init' [] = [] +init' ls = init ls + +-- parses given rows from @svn status@. Supports only first seven columns and filename so far +parseRows :: [String] -> [Common.Status] +parseRows rows = map mapRow rows + where + mapRow = \row -> Common.SVNStatus (getFileName row) (getModification row) (getLockStatus row) +-- { +-- file=(getFileName row) +-- ,modification=(getModification row) +-- ,isLocked=(getLockStatus row) +-- } + getFileName = (\row -> nFunc tail 8 row) :: String -> FilePath + getModification = (\row -> parseFirstCol $ row!!0) :: String -> Common.Modification + getLockStatus = (\row -> parseSixthCol $ row!!5) :: String -> Common.IsLocked + +nFunc :: (a -> a) -> Int -> a -> a +nFunc _ 0 = id +nFunc f n = f . nFunc f (n-1) + +parseFirstCol :: Char -> Common.Modification +parseFirstCol ' ' = Common.None +parseFirstCol 'A' = Common.Added +parseFirstCol 'C' = Common.Conflicting +parseFirstCol 'D' = Common.Deleted +parseFirstCol 'M' = Common.Modified +parseFirstCol 'R' = Common.Replaced +parseFirstCol '?' = Common.Untracked +parseFirstCol '!' = Common.Missing +parseFirstCol _ = Common.Unknown + +parseSixthCol :: Char -> Common.IsLocked +parseSixthCol 'K' = True +parseSixthCol _ = False diff --git a/src/VCSWrapper/Svn/Process.hs b/src/VCSWrapper/Svn/Process.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Svn/Process.hs @@ -0,0 +1,93 @@ +----------------------------------------------------------------------------- +-- +-- Module : Process +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Functions to execute svn commands. +-- +----------------------------------------------------------------------------- + +module VCSWrapper.Svn.Process ( + svnExec + , svnExec_ + , svnExec' + , svnExecNoEnvir + , svnExecNoEnvirNoOpts + + , module VCSWrapper.Common.Process +) where + +import VCSWrapper.Common.Process +import VCSWrapper.Common.Types + +import Control.Monad.Reader(ask) + +import qualified Control.Exception as Exc + +svnExec_ :: String -- ^ cmd + -> [String] -- ^ cmd specific opts + -> Maybe String -- ^ optional password + -> [String] -- ^ additional arguments + -> Ctx() +svnExec_ cmd cmdOpts pw opts = do + config <- ask + let mbAuthor = configAuthor config + let builtOpts = (pwopts pw)++(authopts mbAuthor)++opts + svnExecNoEnvir cmd $ builtOpts ++ cmdOpts + return() + where + useropts Nothing = [] + useropts (Just u) = ["--username",u] + pwopts Nothing = [] + pwopts (Just p) = ["--password",p] + authopts Nothing = [] + authopts (Just a) = ["--username", authorName a] +{- | Execute given svn command with given options. +-} +svnExecNoEnvirNoOpts :: String -- ^ svn command, e.g. checkout + -> Ctx String +svnExecNoEnvirNoOpts cmd = svnExecNoEnvir cmd [] + + +{- | Execute given svn command with given options. +-} +svnExecNoEnvir :: String -- ^ svn command, e.g. checkout + -> [String] -- ^ options + -> Ctx String +svnExecNoEnvir cmd opts = svnExec cmd opts [] + +{- | Execute given svn command with given options and environment. +-} +svnExec :: String -- ^ svn command, e.g. checkout + -> [String] -- ^ options + -> [(String, String)] -- ^ environment + -> Ctx String +svnExec cmd opts = do + let extOpts = opts++globalOpts + vcsExecThrowingOnError "svn" cmd extOpts + where + globalOpts = ["--non-interactive"]++["--no-auth-cache"] + +-- | Internal function to execute a svn command. Doesn't throw an exception if the command failes, +-- but returns an Either with exit information. +svnExec' :: String -- ^ svn command, e.g. checkout, commit + -> [String] -- ^ options + -> [(String, String)] -- ^ environment + -> Ctx (Either VCSException String) +svnExec' cmd opts = do + let extOpts = opts++globalOpts + vcsExec "svn" cmd extOpts + where + globalOpts = ["--non-interactive"]++["--no-auth-cache"] + + + + + + + diff --git a/src/VCSWrapper/Svn/Types.hs b/src/VCSWrapper/Svn/Types.hs new file mode 100644 --- /dev/null +++ b/src/VCSWrapper/Svn/Types.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- +-- Module : Types +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | All types defined and used by SVN. +-- +----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-} +module VCSWrapper.Svn.Types ( + module VCSWrapper.Common.Types +) where + +import VCSWrapper.Common.Types + + + + + diff --git a/vcswrapper.cabal b/vcswrapper.cabal new file mode 100644 --- /dev/null +++ b/vcswrapper.cabal @@ -0,0 +1,60 @@ +name: vcswrapper +version: 0.0.1 +cabal-version: >= 1.8 +build-type: Simple +license: GPL +license-file: LICENSE +copyright: 2011 Stephan Fortelny, Harald Jagenteufel +maintainer: stephanfortelny at gmail.com, h.jagenteufel at gmail.com +homepage: https://github.com/forste/haskellVCSWrapper +bug-reports: https://github.com/forste/haskellVCSWrapper/issues +synopsis: Wrapper for source code management systems +description: + Provides simple haskell functions to call external source code management systems. + Currently git and SVN are supported. +category: Development +author: Stephan Fortelny, Harald Jagenteufel +tested-with: GHC == 7.0 +data-files: LICENSE README +data-dir: "" + +library + build-depends: MissingH >=1.1.0.3 && <1.2, + base >=4.0.0.0 && <4.5, + directory >=1.1.0.0 && <1.2, + haddock >=2.9.0 && <2.10, + haskell98 >=1.1.0.1 && <2.1, + hxt >=9.1.2 && <9.2, + mtl >=2.0.1.0 && <2.1, + parsec >=3.1.1 && <3.2, + process >=1.0.1.5 && <1.2, + filepath >=1.2.0.0 && < 1.3 + exposed-modules: VCSWrapper.Common VCSWrapper.Git VCSWrapper.Svn VCSWrapper.Mercurial + other-modules: + VCSWrapper.Svn.Types VCSWrapper.Svn.Process VCSWrapper.Svn.Parsers + VCSWrapper.Git.Types VCSWrapper.Git.Parsers VCSWrapper.Common.Types VCSWrapper.Git.Process + VCSWrapper.Mercurial.Process VCSWrapper.Mercurial.Types VCSWrapper.Mercurial.Parsers + VCSWrapper.Common.Process VCSWrapper.Common.TemporaryFiles + exposed: True + buildable: True + hs-source-dirs: src + +executable vcswrapper + main-is: Main.hs + build-depends: MissingH >=1.1.0.3 && <1.2, + base >=4.0.0.0 && <4.5, + directory >=1.1.0.0 && <1.2, + haddock >=2.9.0 && <2.10, + haskell98 >=1.1.0.1 && <2.1, + hxt >=9.1.2 && <9.2, + mtl >=2.0.1.0 && <2.1, + parsec >=3.1.1 && <3.2, + process >=1.0.1.5 && <1.2, + filepath >=1.2.0.0 && < 1.3 + buildable: True + hs-source-dirs: src + other-modules: + VCSWrapper.Svn.Types VCSWrapper.Svn.Process VCSWrapper.Svn.Parsers + VCSWrapper.Git.Types VCSWrapper.Git.Parsers VCSWrapper.Common.Types + VCSWrapper.Mercurial.Process VCSWrapper.Mercurial.Types VCSWrapper.Mercurial.Parsers + VCSWrapper.Common.Process VCSWrapper.Common.TemporaryFiles