vcswrapper (empty) → 0.0.1
raw patch · 21 files changed
+1948/−0 lines, 21 filesdep +MissingHdep +basedep +directorysetup-changed
Dependencies added: MissingH, base, directory, filepath, haddock, haskell98, hxt, mtl, parsec, process
Files
- LICENSE +339/−0
- README +2/−0
- Setup.lhs +6/−0
- src/Main.hs +88/−0
- src/VCSWrapper/Common.hs +22/−0
- src/VCSWrapper/Common/Process.hs +124/−0
- src/VCSWrapper/Common/TemporaryFiles.hs +42/−0
- src/VCSWrapper/Common/Types.hs +145/−0
- src/VCSWrapper/Git.hs +158/−0
- src/VCSWrapper/Git/Parsers.hs +86/−0
- src/VCSWrapper/Git/Process.hs +56/−0
- src/VCSWrapper/Git/Types.hs +30/−0
- src/VCSWrapper/Mercurial.hs +132/−0
- src/VCSWrapper/Mercurial/Parsers.hs +144/−0
- src/VCSWrapper/Mercurial/Process.hs +51/−0
- src/VCSWrapper/Mercurial/Types.hs +20/−0
- src/VCSWrapper/Svn.hs +192/−0
- src/VCSWrapper/Svn/Parsers.hs +134/−0
- src/VCSWrapper/Svn/Process.hs +93/−0
- src/VCSWrapper/Svn/Types.hs +24/−0
- vcswrapper.cabal +60/−0
+ LICENSE view
@@ -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.++ <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.,+ 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.++ <signature of Ty Coon>, 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.
+ README view
@@ -0,0 +1,2 @@+This repository contains haskell wrappers for using various version control+systems. Currently only git and svn are implemented.
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ src/Main.hs view
@@ -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+-}
+ src/VCSWrapper/Common.hs view
@@ -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++
+ src/VCSWrapper/Common/Process.hs view
@@ -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)
+ src/VCSWrapper/Common/TemporaryFiles.hs view
@@ -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+ )
+ src/VCSWrapper/Common/Types.hs view
@@ -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++
+ src/VCSWrapper/Git.hs view
@@ -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 \<branchname\>@ 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++++++
+ src/VCSWrapper/Git/Parsers.hs view
@@ -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 ()
+ src/VCSWrapper/Git/Process.hs view
@@ -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 ()+
+ src/VCSWrapper/Git/Types.hs view
@@ -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
+ src/VCSWrapper/Mercurial.hs view
@@ -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+
+ src/VCSWrapper/Mercurial/Parsers.hs view
@@ -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)+
+ src/VCSWrapper/Mercurial/Process.hs view
@@ -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"]+
+ src/VCSWrapper/Mercurial/Types.hs view
@@ -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++
+ src/VCSWrapper/Svn.hs view
@@ -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++++
+ src/VCSWrapper/Svn/Parsers.hs view
@@ -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
+ src/VCSWrapper/Svn/Process.hs view
@@ -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"]+++++++
+ src/VCSWrapper/Svn/Types.hs view
@@ -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+++++
+ vcswrapper.cabal view
@@ -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