darcswatch 0.2 → 0.3
raw patch · 31 files changed
+1669/−1348 lines, 31 filesdep +mime-stringdep +old-localedep +processnew-component:exe:darcswatch-convert-datanew-component:exe:darcswatch-generatenew-component:exe:darcswatch-import-bundlenew-component:exe:darcswatch-import-mailnew-component:exe:darcswatch-pull-reposnew-component:exe:darcswatch-update-data
Dependencies added: mime-string, old-locale, process, regex-compat, time
Files
- darcswatch.cabal +38/−17
- documentation.html +5/−1
- example/config +5/−0
- example/keyring binary
- example/mails/patchBEbWYh +0/−156
- example/mails/patchInvTest +0/−147
- example/mails/patchOKsIKA +0/−79
- example/mails/patch_1f03d40fbe9d0593a9eb7fbefc3bfa85 +0/−332
- example/mails/patch_a963212153b4f5e3f1777daa562dd989 +0/−35
- example/mails/patchsmaJcF +0/−130
- mailfilter.sh +0/−131
- src/ByteStringUtils.hs +87/−0
- src/CachedGet.hs +23/−16
- src/ConvertData-Main.hs +77/−0
- src/Darcs.hs +70/−41
- src/Darcs/Watch/Data.hs +65/−0
- src/Darcs/Watch/GenerateOutput.hs +185/−0
- src/Darcs/Watch/ImportMail.hs +149/−0
- src/Darcs/Watch/PullRepos.hs +71/−0
- src/Darcs/Watch/Roundup.hs +61/−0
- src/Darcs/Watch/Storage.hs +122/−0
- src/Darcs/Watch/UpdateRepoData.hs +103/−0
- src/Generate-Main.hs +63/−0
- src/HTML.hs +102/−65
- src/ImportBundle-Main.hs +48/−0
- src/ImportMail-Main.hs +47/−0
- src/Main.hs +0/−198
- src/PullRepos-Main.hs +66/−0
- src/SHA1.hs +206/−0
- src/UpdateRepoData-Main.hs +61/−0
- src/Zip.hs +15/−0
darcswatch.cabal view
@@ -1,5 +1,5 @@ Name: darcswatch-version: 0.2+version: 0.3 Category: Distribution name: darcswatch author: Joachim Breitner@@ -25,22 +25,13 @@ Cabal-Version: >= 1.6 License: GPL License-File: LICENSE-extra-source-files: mailfilter.sh data-files: documentation.html, README, example/config- example/keyring,- example/mails/patchInvTest,- example/mails/patch_1f03d40fbe9d0593a9eb7fbefc3bfa85,- example/mails/patchsmaJcF,- example/mails/patchBEbWYh,- example/mails/patchOKsIKA,- example/mails/patch_a963212153b4f5e3f1777daa562dd989 Build-Type: Simple -Executable darcswatch- Executable: darcswatch- Main-Is: Main.hs+Executable darcswatch-generate+ Main-Is: Generate-Main.hs hs-source-dirs: src Other-modules: HTML , MultiMap@@ -49,6 +40,16 @@ , StringCrypto , CachedGet , LockRestart+ , SHA1+ , ByteStringUtils+ , Zip+ , Darcs.Watch.Roundup+ , Darcs.Watch.GenerateOutput+ , Darcs.Watch.Data+ , Darcs.Watch.PullRepos+ , Darcs.Watch.ImportMail+ , Darcs.Watch.UpdateRepoData+ , Darcs.Watch.Storage Build-Depends: base > 3 && < 4 , network , HTTP >= 4000@@ -64,12 +65,32 @@ , filepath , bytestring , concurrentoutput+ , time+ , old-locale+ , process+ , mime-string+ , regex-compat -source-repository head- type: darcs- location: http://darcs.nomeata.de/darcswatch/+Executable darcswatch-import-mail+ Main-Is: ImportMail-Main.hs+ hs-source-dirs: src -source-repository this+Executable darcswatch-import-bundle+ Main-Is: ImportBundle-Main.hs+ hs-source-dirs: src++Executable darcswatch-convert-data+ Main-Is: ConvertData-Main.hs+ hs-source-dirs: src++Executable darcswatch-pull-repos+ Main-Is: PullRepos-Main.hs+ hs-source-dirs: src++Executable darcswatch-update-data+ Main-Is: UpdateRepoData-Main.hs+ hs-source-dirs: src++source-repository head type: darcs location: http://darcs.nomeata.de/darcswatch/- tag: v0.2
documentation.html view
@@ -21,6 +21,7 @@ <li>Link to the submitting mail on gmane.org, if Message-ID is known.</li> <li>Knows about inverse and amend-recorded patches and uses them to consider patches obsolete.</li> <li>Knows about tagged repositories and reads the old patches as well.</li>+<li>Integrates into a roundup bug tracker (at the moment, this feature is hardcoded with the instance on <a href="http://bugs.darcs.net/">http://bugs.darcs.net/</a>.</li> </ul> <h2>How can i use DarcsWatch?</h2>@@ -33,12 +34,15 @@ <p>To have your patch submissions tracked, you have to send them to <tt>darcswatch@nomeata.de</tt>. The easiest way to achieve this is by adding the line <tt>send cc darcswatch@nomeata.de</tt> to <tt>~/.darcs/defaults</tt>.</p> <p>If the repositories you are submitting to are not yet tracked, you have to drop a note to <a href="mailto:mail@joachim-breitner.de">Joachim Breitner</a> with the repository URL, and it will be added.</p> - <h3>...as a project maintainer with a mailing list?</h3> <p>If you receive patches on a mailing list and want to have them tracked by DarcsWatch, just subscribe <tt>darcswatch@nomeata.de</tt> to the list, and drop <a href="mailto:mail@joachim-breitner.de">Joachim Breitner</a> a note with the darcs repository URL.</p> <h3>...as a project maintainer without a mailing list?</h3> <p>If you receive patches directly, but want them tracked by DarcsWatch, you should set up an email address somewhere that forwards all mails to both yourself and <tt>darcswatch@nomeata.de</tt>. If you can not do that. get in touch with <a href="mailto:mail@joachim-breitner.de">Joachim Breitner</a>, he might be able to set something up for you.</p>++<h3>...as developer on the darcs.net codebase?</h3>+<p>If a patch is submitted to the Darcs project, a ticket in their roundup instance is created. DarcsWatch notices this and links the entries both ways. When DarcsWatch detects that the patch bundle is completely appiled in a repository, it will close the ticket as “accepted”.+</p> <h2>Other questions.</h2>
example/config view
@@ -5,7 +5,12 @@ , "http://code.haskell.org/XMonadContrib" , "http://code.haskell.org/lambdabot" , "http://darcs.nomeata.de/darcswatch/"+ , "http://darcs.net/" ]+ , cData = "/home/jojo/projekte/programming/haskell/darcswatch/example/data" , cOutput = "/home/jojo/projekte/programming/haskell/darcswatch/example/output" , cMails = "/home/jojo/projekte/programming/haskell/darcswatch/example/mails"+ , cDarcsWatchURL = "http://darcswatch.nomeata.de/"+ , cDarcsWatchAddress = "darcswatch@nomeata.de"+ , cSendRoundupMails = False }
− example/keyring
binary file changed (76620 → absent bytes)
− example/mails/patchBEbWYh
@@ -1,156 +0,0 @@------BEGIN PGP SIGNED MESSAGE------Hash: SHA1---New patches:--[Fix window order in EWMH-Joachim Breitner <mail@joachim-breitner.de>**20080411134411- For pagers to draw the stacking order correctly, the focused window has to- be the last in the list. Thus put an appropriate implementation of allWindows- into the Module.- This does not work perfectly with floating windows.-] {-hunk ./XMonad/Hooks/EwmhDesktops.hs 62-- - let wins = W.allWindows s-hunk ./XMonad/Hooks/EwmhDesktops.hs 76-+ -- all windows, with focused windows last-+ let wins = nub . concatMap (maybe [] (\(W.Stack x l r)-> reverse l ++ r ++ [x]) . W.stack) $ ws-}--Context:--[remove myself as maintainer of CopyWindow.-David Roundy <droundy@darcs.net>**20080409144333- I'm not sure who's maintaining this, but it's not me.-] -[XMonad.Util.WindowProperties: add WM_WINDOW_ROLE as Role-Roman Cheplyaka <roma@ro-che.info>**20080409174935] -[Generalize copyWindow, minor style change-Spencer Janssen <sjanssen@cse.unl.edu>**20080408210050] -[XMonad.Actions.CopyWindow: added copyToAll and killAllOtherCopies functions-Ivan N. Veselov <veselov@gmail.com>**20080408195111] -[XMonad.Actions.UpdatePointer: doc fix-Lukas Mai <l.mai@web.de>**20080407152741] -[XMonad.Util.Font: minor reformatting-Lukas Mai <l.mai@web.de>**20080406020935] -[DynamicLog: resolve merge conflict-Lukas Mai <l.mai@web.de>**20080406020527] -[Encode the entire DynamicLog output, instead of just window title.-lithis <xmonad@selg.hethrael.org>**20080329031537] -[DynamicLog: add support for UTF-8 locales when compiled with XFT or UFT-8 support-Andrea Rossato <andrea.rossato@unibz.it>**20080313102643] -[XMonad.Util.Font: don't call setlocale; core does it for us-Lukas Mai <l.mai@web.de>**20080406013123] -[XMonad.Util.NamedWindows: fix imports-Lukas Mai <l.mai@web.de>**20080326172745] -[Changed getName to use locale-aware functions-Mats Jansborg <mats@jansb.org>**20070819132104- Rewrote getName using getTextProperty and wcTextPropertyToTextList.-] -[Added next-window versions of the raise* functions.-Ian Zerny <ian@zerny.dk>**20080405182900] -[XMonad.Layout.Master: initial import-Lukas Mai <l.mai@web.de>**20080404220734] -[update contrib for applySizeHints changes-Lukas Mai <l.mai@web.de>**20080404220558] -[XMonad.Hooks.ManageDocks: haddock fix-Lukas Mai <l.mai@web.de>**20080404220532] -[MultiToggle/Instances: ghc 6.6 can't parse LANGUAGE pragma-Brent Yorgey <byorgey@gmail.com>**20080404200157] -[onstart=lower, solves floating dzen issue-Don Stewart <dons@galois.com>**20080403203425] -[some bang patterns-Don Stewart <dons@galois.com>**20080403172246] -[have 'dzen' use autoStruts to detect the gaps-Don Stewart <dons@galois.com>**20080403003130] -[Actions/Search.hs: add dictionary.com search-Brent Yorgey <byorgey@gmail.com>**20080402150521] -[HintedGrid: guesstimate window flexibility and layout rigid windows first-Lukas Mai <l.mai@web.de>**20080402042846] -[HintedGrid: try both bottom-up/top-down window placement to minimize unused space-Lukas Mai <l.mai@web.de>**20080402012538] -[Grid/HintedGrid: use an ncolumns formula inspired by dwm's "optimal" mode-Lukas Mai <l.mai@web.de>**20080402012126] -[XMonad.Layout.Gaps: new contrib module for manual gap support, in the few cases where ManageDocks is not appropriate (dock apps that don't set STRUTS properly, adjusting for a display that is cut off on one edge, etc.)-Brent Yorgey <byorgey@gmail.com>**20080402003742] -[improve WindowGo.hs Haddock formatting-gwern0@gmail.com**20080401023130] -[forgot a haddock for getEditor in Shell.hs-gwern0@gmail.com**20080401022012] -[WindowGo.hs: +raiseBrowser, raiseEditor-gwern0@gmail.com**20080401021740- Specialize runOrRaise in the same way as with Actions.Search, for one's browser and one's editors.-] -[RunOrRaise.hs: FF 3 doesn't use the "Firefox-bin" classname-gwern0@gmail.com**20080401015049] -[Search.hs: remove an argument from selectSearch and promptSearch-gwern0@gmail.com**20080401013947- The new getBrowser function allows us to mv the old selectSearch and promptSearch aside as too-general functions, and replace them with new versions, which employ getBrowser to supply one more argument. This allows us to replace the tedious 'selectSearch google "firefox"; selectSearch yahoo "firefox"...' with shorter 'selectSearch google' and so on. One less argument.- - Also, update the docs.-] -[Shell.hs: +getBrowser, getEditor, helper function-gwern0@gmail.com**20080401013447- The helper function asks the shell for the value of a variable, else returns the second argument.- getBrowser and getEditor obviously specialize it for two particular possibly queries-] -[XMonad.Layout.HintedGrid: initial import-Lukas Mai <l.mai@web.de>**20080401231722] -[Documentation improvement.-Roman Cheplyaka <roma@ro-che.info>**20080401134305] -[Remove broken link to screenshot.-Roman Cheplyaka <roma@ro-che.info>**20080331210854] -[MultiToggle: add new XMonad.Layout.MultiToggle.Instances module for common instances of Transformer, update MultiToggle docs accordingly-Brent Yorgey <byorgey@gmail.com>**20080331201739] -[XMonad.Actions.CycleRecentWS: initial import-Michal Janeczek <janeczek@gmail.com>**20080331111906] -[XMonad.Hooks.ManageDocks: export checkDoc-Lukas Mai <l.mai@web.de>**20080331012911] -[XMonad.Layout.Grid: fix indentation-Lukas Mai <l.mai@web.de>**20080330004859] -[move Direction type from WindowNavigation to ManageDocks (ManageDocks will move into the core, taking Direction with it)-Brent Yorgey <byorgey@gmail.com>**20080331010127] -[ManageDocks: clean up + add more documentation-Brent Yorgey <byorgey@gmail.com>**20080331002929] -[Util.Run, Hooks.DynamicLog: re-export hPutStrLn and hPutStr from Util.Run for convenience, and update DynamicLog documentation to show proper imports-Brent Yorgey <byorgey@gmail.com>**20080328205446] -[ManageDocks: add avoidStrutsOn, for covering some docks and not others by default.-Brent Yorgey <byorgey@gmail.com>**20080327203940] -[ManageDocks: add ability to toggle individual gaps independently-Brent Yorgey <byorgey@gmail.com>**20080327111722] -[PerWorkspace: add modWorkspace(s) combinators, for selectively applying layout modifiers to certain workspaces but not others-Brent Yorgey <byorgey@gmail.com>**20080326214351] -[Haddock fix-Roman Cheplyaka <roma@ro-che.info>**20080330134435] -[Remove stale status gaps code-Spencer Janssen <sjanssen@cse.unl.edu>**20080329230737] -[Document _NET_ACTIVE_WINDOW behaviour more exactly-Joachim Breitner <mail@joachim-breitner.de>**20080404072944] -[_NET_ACTIVE_WINDOW moves windows if necessary-Joachim Breitner <mail@joachim-breitner.de>*-20080402143811- This makes EWMH behave a bit more like metacity: If _NET_ACTIVE_WINDOW is- received and the window is not on the current worspace, it is brought here - (instead of the workspace switched to the other one). So for example, if you- click on the pidgin icon in the panel and the buddy list is already open some- where it is moved here.-] -[_NET_ACTIVE_WINDOW moves windows if necessary-Joachim Breitner <mail@joachim-breitner.de>**20080402143811- This makes EWMH behave a bit more like metacity: If _NET_ACTIVE_WINDOW is- received and the window is not on the current worspace, it is brought here - (instead of the workspace switched to the other one). So for example, if you- click on the pidgin icon in the panel and the buddy list is already open some- where it is moved here.-] -[TAG 0.7-Spencer Janssen <sjanssen@cse.unl.edu>**20080329202416] -Patch bundle hash:-ab26456486b1f248e095142caf4024e933dc010a------BEGIN PGP SIGNATURE------Version: GnuPG v1.4.6 (GNU/Linux)--iD8DBQFH/2vF9ijrk0dDIGwRAptwAJ9n0lgCRYVBsC99ADebFthaUf8wXwCgwD/+-UvLM4JSNTaZgd6MhA+Y7BYk=-=2Nz3------END PGP SIGNATURE-----
− example/mails/patchInvTest
@@ -1,147 +0,0 @@------BEGIN PGP SIGNED MESSAGE------Hash: SHA1---New patches:--[Dummy commit-Joachim Breitner <mail@joachim-breitner.de>**20080416213715] {-hunk ./README 50-+Dummy commit-+-}--[Dummy commit-Joachim Breitner <mail@joachim-breitner.de>*-20080416213715] {-hunk ./README 50-- -Dummy commit-- --}--Context:--[MultiMap.fromList-Joachim Breitner <mail@joachim-breitner.de>**20080416213440] -[Multimap lookup with default-Joachim Breitner <mail@joachim-breitner.de>**20080416200945] -[TODO: Documentation-mail@joachim-breitner.de**20080416193846] -[unTODO Cabal and Caching-mail@joachim-breitner.de**20080416193826] -[add License-File header-Joachim Breitner <mail@joachim-breitner.de>**20080416193135] -[basic cabal support - please check that you like the contents-marco-oweber@gmx.de**20080416191953] -[strict reading of tagFile-Joachim Breitner <mail@joachim-breitner.de>**20080416191500] -[Force an update from the mail script-Joachim Breitner <mail@joachim-breitner.de>**20080416150644] -[Only regenerate pages if there is something new.-Joachim Breitner <mail@joachim-breitner.de>**20080416150525] -[pass up-to-dateness to caller in getInventory-Joachim Breitner <mail@joachim-breitner.de>**20080416144419] -[Add UserAgent Header to requests-Joachim Breitner <mail@joachim-breitner.de>**20080416143833] -[Pass cache directory to getInventory-Joachim Breitner <mail@joachim-breitner.de>**20080416143402] -[Use CachedGet in Darcs.hs-Joachim Breitner <mail@joachim-breitner.de>**20080416142626] -[CachedGet module for Cached HTTP-Joachim Breitner <mail@joachim-breitner.de>**20080416142301] -[Enable receiving mails from the darcs list-Joachim Breitner <mail@joachim-breitner.de>**20080416135921] -[Use MultiMap-Joachim Breitner <mail@joachim-breitner.de>**20080416135024] -[Some helpers for Map k [v] or Map k (Set v)-Joachim Breitner <mail@joachim-breitner.de>**20080416135006] -[Describe Darcs.hs separation-Joachim Breitner <mail@joachim-breitner.de>**20080415225608] -[Put the rest under the GPL-Joachim Breitner <mail@joachim-breitner.de>**20080415225151] -[Put Darcs.hs and StringCrypto.hs under the GPL-Joachim Breitner <mail@joachim-breitner.de>**20080415225137] -[Add GPL licence-Joachim Breitner <mail@joachim-breitner.de>**20080415225118] -[unTODO diff view-Joachim Breitner <mail@joachim-breitner.de>**20080415222355] -[Add toggle button for diffs-Joachim Breitner <mail@joachim-breitner.de>**20080415222114] -[Liberal inventory parsing, also works with hashed-Joachim Breitner <mail@joachim-breitner.de>**20080415215043] -[Add darcs.net to example file-Joachim Breitner <mail@joachim-breitner.de>**20080415213149] -[Use getInventory from Darcs.hs-Joachim Breitner <mail@joachim-breitner.de>**20080415213128] -[Move getInventory to darcs.hs, stub for hashed-Joachim Breitner <mail@joachim-breitner.de>**20080415212944] -[Use pure parseInventory-Joachim Breitner <mail@joachim-breitner.de>**20080415212126] -[Make parseInventory pure-Joachim Breitner <mail@joachim-breitner.de>**20080415212101] -[Make Darcs.hs accept darcs2.0 submissions without '{'-Joachim Breitner <mail@joachim-breitner.de>**20080415211235] -[Improve bash code quality slightly-Joachim Breitner <mail@joachim-breitner.de>**20080415210005] -[Use the md5sum for the patch file to avoid duplicates-Joachim Breitner <mail@joachim-breitner.de>**20080415202850] -[unTODO download link-Joachim Breitner <mail@joachim-breitner.de>**20080415201447] -[Document dependencies-Joachim Breitner <mail@joachim-breitner.de>**20080415201439] -[Factor out common page footer-Joachim Breitner <mail@joachim-breitner.de>**20080415200819] -[Refactor patchlists, add crosslinks and links to dpatch files-Joachim Breitner <mail@joachim-breitner.de>**20080415200401] -[Create symlinks to the dpatch files-Joachim Breitner <mail@joachim-breitner.de>**20080415194550] -[patchBasename function for Darcs.hs-Joachim Breitner <mail@joachim-breitner.de>**20080415193016] -[HTML.hs uses StringCrypto-Joachim Breitner <mail@joachim-breitner.de>**20080415192014] -[OldDate module stolen from darcs-Joachim Breitner <mail@joachim-breitner.de>**20080415191533] -[Use the crypto library, create wrapper module for md5,sha1-Joachim Breitner <mail@joachim-breitner.de>**20080415191246] -[typo-Joachim Breitner <mail@joachim-breitner.de>**20080415100920] -[Add footer with current date-Joachim Breitner <mail@joachim-breitner.de>**20080415100517] -[Factor out repo/user statistics-Joachim Breitner <mail@joachim-breitner.de>**20080415095612] -[Add lambdabot to example (large repository)-Joachim Breitner <mail@joachim-breitner.de>**20080414225332] -[Newest patches first-Joachim Breitner <mail@joachim-breitner.de>**20080414225311] -[Also work on untagged repositories (lambdabot)-Joachim Breitner <mail@joachim-breitner.de>**20080414225251] -[List unmatched patches separately-Joachim Breitner <mail@joachim-breitner.de>**20080414224435] -[Split patches in the per-user view-Joachim Breitner <mail@joachim-breitner.de>**20080414214504] -[Added README-Joachim Breitner <mail@joachim-breitner.de>**20080414213958] -[Adding the rest of the files for the very alpha release-Joachim Breitner <mail@joachim-breitner.de>**20080414213500] -[Actually add Igloos MD5.lhs file-Joachim Breitner <mail@joachim-breitner.de>**20080414212717] -[Mailfilter helper script-Joachim Breitner <mail@joachim-breitner.de>**20080414212622] -[More examples-Joachim Breitner <mail@joachim-breitner.de>**20080414212513] -[Darcs glue code: Parsing mails and inventories-Joachim Breitner <mail@joachim-breitner.de>**20080414201515] -[Igloos MD5 script, with glue-Joachim Breitner <mail@joachim-breitner.de>**20080414191343- Changes made so that it runs without cpp.-] -[Example files-Joachim Breitner <mail@joachim-breitner.de>**20080414105511] -Patch bundle hash:-36530b7ca0867608c190be96207c3589c20a73c0------BEGIN PGP SIGNATURE------Version: GnuPG v1.4.6 (GNU/Linux)--iD8DBQFIBnG59ijrk0dDIGwRAl0mAJ9B71aQ/8YqM1DPiOPgij5y2WZ0ugCdGDsq-Zd1DG512xTXedFmTwKYrQFw=-=VF6v------END PGP SIGNATURE-----
− example/mails/patchOKsIKA
@@ -1,79 +0,0 @@------BEGIN PGP SIGNED MESSAGE------Hash: SHA1---New patches:--[Add rqUri field to Record-Joachim Breitner <mail@joachim-breitner.de>**20080403110245- This makes sure the exact Uri is not lost (otherwise a trailing slash would be- lost to the rest of the HAppS code). This makes it possible to write a handler- like this:- - addSlash :: Monad m => ServerPartT m Response- addSlash = ServerPartT $ \rq -> do- case last (rqUri rq) of- '/' -> noHandle- _ -> seeOther (rqUri rq ++ "/" ++ rqQuery rq) $- toResponse "Missing trainling slash"- - which ensures that all paths end with a trailing slash, or of course a similar- removeSlash handler, to make relative paths in HTML links behave nicely.- More on this issue at http://groups.google.com/group/HAppS/browse_frm/thread/4065c842b1cfe7c7-] {-hunk ./src/HAppS/Server/HTTP/Handler.hs 69-- - rqTmp = Request m (pathEls (path u)) (query u) -+ rqTmp = Request m (pathEls (path u)) (path u) (query u) -hunk ./src/HAppS/Server/HTTP/Types.hs 94-+ rqUri :: String,-}--Context:--[Fix typo in runTests.sh-lemmih <lemmih@vo.com>**20080314160613] -[Fix haddock annotation and bump version.-Lemmih <lemmih@vo.com>**20080229152550] -[Cabal wibble.-Lemmih <lemmih@vo.com>**20080222232935] -[Cabal wibble.-Lemmih <lemmih@vo.com>**20080222232730] -[TAG 0.9.2-Lemmih <lemmih@vo.com>**20080222225514] -[Bump version to 0.9.2-Lemmih <lemmih@vo.com>**20080222225151] -[Update snippet in package-info.xml-Lemmih <lemmih@vo.com>**20080222223603] -[Don't rely on Xml for serialization.-Lemmih <lemmih@vo.com>**20080222223302] -[Match changes in HAppS-State.-Lemmih <lemmih@vo.com>**20080218201437] -[fix conflicts-alex@happs.org**20080216004432] -[Match development in HAppS-State.-Lemmih <lemmih@vo.com>**20080215010026] -[Match changes in HAppS-State.-Lemmih <lemmih@vo.com>**20080215004016] -[Comment for AllIn.hs-Lemmih <lemmih@vo.com>**20080214234424] -[Don't use Xml for serialization.-Lemmih <lemmih@vo.com>**20080214233742] -[Don't export Cron from SimpleHTTP.-Lemmih <lemmih@vo.com>**20080212154505] -[Remove ServerPart.hs-Lemmih <lemmih@vo.com>**20080212154312] -[Update examples to match development in HAppS-State.-Lemmih <lemmih@vo.com>**20080212142058] -[Show usage of componentInit in AllIn.hs-Lemmih <lemmih@vo.com>**20080212011338] -[TAG 0.9.1.5-Lemmih <lemmih@vo.com>**20080209112439] -Patch bundle hash:-2cfe23050f9e12a183d2bdf2a397e838784bfe47------BEGIN PGP SIGNATURE------Version: GnuPG v1.4.6 (GNU/Linux)--iD8DBQFH9Ll99ijrk0dDIGwRAocCAKC+7c5MEvlsUVPGNe5y3S8qitrHcgCcCzZ9-Fw7xAlKqKaaml0NAiSkTO7E=-=vZHQ------END PGP SIGNATURE-----
− example/mails/patch_1f03d40fbe9d0593a9eb7fbefc3bfa85
@@ -1,332 +0,0 @@-New patches:--[Little style change (avoid a bind+return).-Nicolas Pouillard <nicolas.pouillard@gmail.com>**20080413142318] hunk ./src/Darcs/Commands/MarkConflicts.lhs 76- markconflicts_cmd opts [] = withRepoLock opts $- \repository -> do- pend <- get_unrecorded_unsorted repository- Sealed r <- read_repo repository-- Sealed res <- return $ patchset_conflict_resolutions r-+ let (Sealed res) = patchset_conflict_resolutions r- case res of NilFL -> do putStrLn "No conflicts to mark."- exitWith ExitSuccess- _ -> return ()-[Extend a little color printing, and prettify hunks with mangenta and cyan.-nicolas.pouillard@gmail.com**20080414214559] hunk ./src/Darcs/ColourPrinter.lhs 9- import System.IO ( stderr )- import Darcs.External (getTermNColors)- import Printer (Printer, Printers, Printers'(..), Printable(..), Color(..),-- invisiblePrinter, (<>), Doc(..), unDoc, unsafeBoth, simplePrinter, hcat,-- unsafeText, unsafeChar, space, unsafePackedString,-- renderStringWith )-+ invisiblePrinter, (<>), Doc(Doc,unDoc), unsafeBoth, unsafeBothStr,-+ simplePrinter, hcat, unsafeText, unsafeChar, space,-+ unsafePackedString, renderStringWith )- import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr, intToDigit )- import Data.Bits ( bit, xor )- import System ( getEnv )-hunk ./src/Darcs/ColourPrinter.lhs 99- -- printers- - fancyPrinters :: Printers--fancyPrinters h = Printers { colorP = colorPrinter (getPolicy h),-+fancyPrinters h = Printers { colorP = color (getPolicy h),- invisibleP = invisiblePrinter,- hiddenP = colorPrinter (getPolicy h) Green,- userchunkP = userchunkPrinter (getPolicy h),-hunk ./src/Darcs/ColourPrinter.lhs 197- in ['\\', intToDigit q, intToDigit r]- - ---- make colours and highlightings-+-- make colors and highlightings- - mark_escape :: Policy -> Doc -> Doc- mark_escape po | poAltColor po = make_invert-hunk ./src/Darcs/ColourPrinter.lhs 209- | otherwise = make_color- - make_color :: Color -> Doc -> Doc--make_color Blue = make_blue--make_color Red = make_red--make_color Green = make_green-+make_color Blue = make_blue-+make_color Red = make_red-+make_color Green = make_green-+make_color Cyan = make_cyan-+make_color Magenta = make_magenta- - make_asciiart :: Doc -> Doc-hunk ./src/Darcs/ColourPrinter.lhs 216--make_asciiart x = unsafeBoth "[_" (packString "[_")-- <> x-- <> unsafeBoth "_]" (packString "_]")-+make_asciiart x = unsafeBothStr "[_" <> x <> unsafeBothStr "_]"- -hunk ./src/Darcs/ColourPrinter.lhs 218--make_bold :: Doc -> Doc--make_bold x = unsafeBoth "\x1B[01m" (packString "\x1B[01m")-- <> x-- <> reset_colour-+set_bold, set_invert, set_blue, set_red, set_green, set_magenta, set_cyan, reset_color :: Doc-+set_bold = unsafeBothStr "\x1B[01m"-+set_invert = unsafeBothStr "\x1B[07m"-+set_blue = unsafeBothStr "\x1B[01;34m" -- bold blue-+set_red = unsafeBothStr "\x1B[01;31m" -- bold red-+set_green = unsafeBothStr "\x1B[01;32m" -- bold green-+set_magenta = unsafeBothStr "\x1B[35m" -- light magenta-+set_cyan = unsafeBothStr "\x1B[36m" -- light cyan-+reset_color = unsafeBothStr "\x1B[00m"- -hunk ./src/Darcs/ColourPrinter.lhs 228--make_invert :: Doc -> Doc--make_invert x = unsafeBoth "\x1B[07m" (packString "\x1B[07m")-- <> x-- <> reset_colour-+set_color :: Doc -> Doc -> Doc-+set_color set_some_color = \x -> set_some_color <> x <> reset_color- -hunk ./src/Darcs/ColourPrinter.lhs 231--make_blue :: Doc -> Doc--make_blue x = unsafeBoth "\x1B[01;34m" (packString "\x1B[01;34m")-- <> x-- <> reset_colour----make_red :: Doc -> Doc--make_red x = unsafeBoth "\x1B[01;31m" (packString "\x1B[01;31m")-- <> x-- <> reset_colour----make_green :: Doc -> Doc--make_green x = unsafeBoth "\x1B[01;32m" (packString "\x1B[01;32m")-- <> x-- <> reset_colour----reset_colour :: Doc--reset_colour = unsafeBoth "\x1B[00m" (packString "\x1B[00m")-+make_bold, make_invert, make_blue, make_red, make_green, make_magenta, make_cyan :: Doc -> Doc-+make_bold = set_color set_bold-+make_invert = set_color set_invert-+make_blue = set_color set_blue-+make_red = set_color set_red-+make_green = set_color set_green-+make_cyan = set_color set_cyan-+make_magenta = set_color set_magenta- - \end{code}-hunk ./src/Darcs/Patch/Prim.lhs 66- import Darcs.Utils ( nubsort )- import Lcs ( getChanges )- import RegChars ( regChars )--import Printer ( Doc, vcat, packedString,-+import Printer ( Doc, vcat, packedString, Color(Cyan,Magenta), colorDoc,- text, userchunk, invisibleText, invisiblePS, blueText,- ($$), (<+>), (<>), prefix, userchunkPS,- )-hunk ./src/Darcs/Patch/Prim.lhs 400- showHunk :: FileNameFormat -> FileName -> Int -> [PackedString] -> [PackedString] -> Doc- showHunk x f line old new =- blueText "hunk" <+> formatFileName x f <+> text (show line)-- $$ prefix "-" (vcat $ map userchunkPS old)-- $$ prefix "+" (vcat $ map userchunkPS new)-+ $$ colorDoc Magenta (prefix "-" (vcat $ map userchunkPS old))-+ $$ colorDoc Cyan (prefix "+" (vcat $ map userchunkPS new))- \end{code}- - \paragraph{Token replace}-hunk ./src/Darcs/Patch/Viewing.lhs 32- import FastPackedString ( nullPS, linesPS )- import FileName ( FileName, fp2fn, fn2fp )- import Printer ( Doc, empty, vcat,-- text, blueText,-+ text, blueText, Color(Cyan,Magenta), colorDoc,- minus, plus, ($$), (<+>), (<>),- prefix, renderString,- userchunkPS,-hunk ./src/Darcs/Patch/Viewing.lhs 130- post = take numpost $ drop (max 0 $ l+length o-1) cleanedls- in blueText "hunk" <+> formatFileName OldFormat f <+> text (show l)- $$ prefix " " (vcat $ map userchunkPS pre)-- $$ prefix "-" (vcat $ map userchunkPS o)-- $$ prefix "+" (vcat $ map userchunkPS n)-+ $$ colorDoc Magenta (prefix "-" $ vcat $ map userchunkPS o)-+ $$ colorDoc Cyan (prefix "+" $ vcat $ map userchunkPS n)- $$ prefix " " (vcat $ map userchunkPS post)- coolContextHunk _ _ _ _ = impossible- \end{code}-hunk ./src/Printer.lhs 41- - This code was made generic in the element type by Juliusz Chroboczek.- \begin{code}--module Printer (Printable(..), Doc(..), unDoc, Printers, Printers'(..), Printer, Color(..),-+module Printer (Printable(..), Doc(Doc,unDoc), Printers, Printers'(..), Printer, Color(..),- hPutDoc, hPutDocLn, putDoc, putDocLn,- hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith,- renderString, renderStringWith, renderPS, renderPSWith,-hunk ./src/Printer.lhs 47- renderPSs, renderPSsWith,- prefix, colorText, invisibleText, hiddenText, hiddenPrefix, userchunk, text,-- printable, wrap_text,-- blueText, redText, greenText,-- unsafeText, unsafeBoth, unsafeChar,-+ printable, wrap_text, colorDoc,-+ blueText, redText, greenText, magentaText, cyanText,-+ unsafeText, unsafeBoth, unsafeBothStr, unsafeChar,- invisiblePS, packedString, unsafePackedString, userchunkPS,- simplePrinters, invisiblePrinter, simplePrinter,- doc, empty, (<>), (<+>), ($$), vcat, vsep, hcat,-hunk ./src/Printer.lhs 112- hPrintPrintable h (PS ps) = hPutPS h ps- hPrintPrintable h (Both _ ps) = hPutPS h ps- --newtype Doc = Doc (Reader St Document)--unDoc :: Doc -> Reader St Document--unDoc (Doc d) = d-+newtype Doc = Doc { unDoc :: Reader St Document }- - data St = St { printers :: !Printers', current_prefix :: !DocumentInternals }- type Printers = Handle -> Printers'-hunk ./src/Printer.lhs 116--data Printers' = Printers {colorP :: !(Color -> Printer),-+data Printers' = Printers {colorP :: !(Color -> Doc -> Doc),- invisibleP :: !Printer,- hiddenP :: !Printer,- userchunkP :: !Printer,-hunk ./src/Printer.lhs 124- }- type Printer = Printable -> Reader St Document- --data Color = Blue | Red | Green-+data Color = Blue | Red | Green | Cyan | Magenta- - type DocumentInternals = [Printable] -> [Printable]- data Document = Document DocumentInternals-hunk ./src/Printer.lhs 184- unsafeBoth :: String -> PackedString -> Doc- unsafeBoth s ps = Doc $ simplePrinter (Both s ps)- -+unsafeBothStr :: String -> Doc-+unsafeBothStr s = Doc $ simplePrinter (Both s (packString s))-+- packedString, unsafePackedString, invisiblePS, userchunkPS :: PackedString -> Doc- packedString = printable . PS- unsafePackedString = Doc . simplePrinter . PS-hunk ./src/Printer.lhs 196- unsafeChar :: Char -> Doc- unsafeChar = unsafeText . return- --text, unsafeText, invisibleText, hiddenText, userchunk, blueText, redText, greenText :: String -> Doc-+text, unsafeText, invisibleText, hiddenText, userchunk, blueText, redText, greenText, magentaText, cyanText :: String -> Doc- text = printable . S- unsafeText = Doc . simplePrinter . S- invisibleText = invisiblePrintable . S-hunk ./src/Printer.lhs 205- blueText = colorText Blue- redText = colorText Red- greenText = colorText Green-+magentaText = colorText Magenta-+cyanText = colorText Cyan- - colorText :: Color -> String -> Doc-hunk ./src/Printer.lhs 209--colorText c = mkColorPrintable c . S-+colorText c = colorDoc c . printable . S-+-+colorDoc :: Color -> Doc -> Doc-+colorDoc c d = Doc $ do st <- ask-+ unDoc $ colorP (printers st) c d- - wrap_text :: Int -> String -> Doc- wrap_text n s =-hunk ./src/Printer.lhs 226- printable, invisiblePrintable, hiddenPrintable, userchunkPrintable :: Printable -> Doc- printable x = Doc $ do st <- ask- defP (printers st) x--mkColorPrintable :: Color -> Printable -> Doc--mkColorPrintable c x = Doc $ do st <- ask-- colorP (printers st) c x- invisiblePrintable x = Doc $ do st <- ask- invisibleP (printers st) x- hiddenPrintable x = Doc $ do st <- ask-hunk ./src/Printer.lhs 237- simplePrinters _ = simplePrinters'- - simplePrinters' :: Printers'--simplePrinters' = Printers { colorP = \_ -> simplePrinter,-+simplePrinters' = Printers { colorP = const id,- invisibleP = simplePrinter,- hiddenP = invisiblePrinter,- userchunkP = simplePrinter,--Context:--[roll back implementation of joke oops command.-David Roundy <droundy@darcs.net>**20080414133342- Apparently it didn't actually work...- - rolling back:- - Tue Apr 8 07:58:56 PDT 2008 David Roundy <droundy@darcs.net>- * resolve issue786: implement oops command.- - M ./src/Darcs/Commands/Tag.lhs -5 +47- M ./src/Darcs/TheCommands.lhs -1 +2-] -[just remove concatLenPS-David Roundy <droundy@darcs.net>**20080411205303- It is never used in a performance-critical situation, so I'm voting to just- trash it. I'd rather have fewer unsafe operations.-] -[FastPackedString.hs: simplify concatLenPS, although this removes its strictness properties-**20080411035327] -[FastPackedString.hs: remove wfindPS-**20080411035046- With better imports from bytestring, I believe it to be superfluous, and dangerous to leave around.-] -[FastPackedString.hs: grmmr/sp-**20080411034730] -[FastPackedString.hs: rw linesPS using ByteString split-**20080411032229] -[doc updates-gwern0@gmail.com**20080409170824- Convert all uses of 'http://darcs.net/repos/stable' to just darcs.net, since unstable and stable were merged together, and the old URL is a 404 for darcs getting. This is a real problem, see for example <http://reddit.com/info/6ewbq/comments/c03o6d5>.-] -[fix typo in show_bug_help-Matyas Janos <mjanos5@gmail.com>**20080408232600] -[Raise a configure error when no Text.Regex module can be found.-nicolas.pouillard@gmail.com**20080409085522] -[update README url links-gwern0@gmail.com**20080407201333] -[add a bit more debugging info to repository identification.-David Roundy <droundy@darcs.net>**20080408151912] -[resolve issue385: don't worry if we can't get local changes.-David Roundy <droundy@darcs.net>**20080408151823] -[add test for issue385.-David Roundy <droundy@darcs.net>**20080408151808] -[resolve issue786: implement oops command.-David Roundy <droundy@darcs.net>**20080408145856] -[fix URL in network test.-David Roundy <droundy@darcs.net>**20080408145407] -[fix manual bug.-David Roundy <droundy@darcs.net>**20080407191736] -[add new show bug command (hidden) to see what darcs will report if we encounter a bug.-David Roundy <droundy@darcs.net>**20080407175410] -[automatically work out the version of the stable release.-David Roundy <droundy@darcs.net>**20080407171850] -[set prefs again (they got lost on convert).-David Roundy <droundy@darcs.net>**20080407171559] -[update darcs repository URL.-David Roundy <droundy@darcs.net>**20080407164601] -[fix up website for new release.-David Roundy <droundy@darcs.net>**20080407164010] -[simplify determine_release_state.pl.-David Roundy <droundy@darcs.net>**20080407153000] -[make determine_release_state.pl use changes --count.-David Roundy <droundy@darcs.net>**20080407152347] -[add --count output option to changes.-David Roundy <droundy@darcs.net>**20080407151825] -[TAG 2.0.0-David Roundy <droundy@darcs.net>**20080407150638] -Patch bundle hash:-45247877729e0cfc5f1be0417f1d8c7deb8e740f----=_
− example/mails/patch_a963212153b4f5e3f1777daa562dd989
@@ -1,35 +0,0 @@------BEGIN PGP SIGNED MESSAGE------Hash: SHA1---New patches:--[_NET_ACTIVE_WINDOW moves windows if necessary-Joachim Breitner <mail@joachim-breitner.de>**20080402143811- This makes EWMH behave a bit more like metacity: If _NET_ACTIVE_WINDOW is- received and the window is not on the current worspace, it is brought here - (instead of the workspace switched to the other one). So for example, if you- click on the pidgin icon in the panel and the buddy list is already open some- where it is moved here.-] {-hunk ./XMonad/Hooks/EwmhDesktops.hs 103-- --- * _NET_ACTIVE_WINDOW (activate another window)-+-- * _NET_ACTIVE_WINDOW (activate another window, possibly moving to the current desktop)-hunk ./XMonad/Hooks/EwmhDesktops.hs 136-- - windows $ W.focusWindow w-+ windows $ W.focusWindow w . W.shiftWin (W.tag (W.workspace (W.current s))) w-}--Context:--[TAG 0.7-Spencer Janssen <sjanssen@cse.unl.edu>**20080329202416] -Patch bundle hash:-f36c5831faf5b9da4034c203bd52fd22d1ba67bb------BEGIN PGP SIGNATURE------Version: GnuPG v1.4.6 (GNU/Linux)--iD8DBQFH85t89ijrk0dDIGwRAvt7AJ0UMm4M/tISQqG6zXn1kLqt28becACggtU6-fjpKiTWI0EyGvJJYmY1bmZQ=-=Orgm------END PGP SIGNATURE-----
− example/mails/patchsmaJcF
@@ -1,130 +0,0 @@------BEGIN PGP SIGNED MESSAGE------Hash: SHA1---New patches:--[instance MonadError e m => MonadError e (WebT m)-Joachim Breitner <mail@joachim-breitner.de>**20080411224837- This makes it easier to use throwError inside a ErrorT inside WebT,- maybe together with errorHandlerSP-] {-hunk ./src/HAppS/Server/SimpleHTTP.hs 106-+import Control.Monad.Error-hunk ./src/HAppS/Server/SimpleHTTP.hs 169-+instance MonadError e m => MonadError e (WebT m) where-+ throwError err = WebT $ throwError err-+ catchError action handler = WebT $ catchError (unWebT action) (unWebT . handler)-+-}--[errorHandling functions-Joachim Breitner <mail@joachim-breitner.de>**20080411230330- Adds errorHanderSP and simpleErrorHander, which allows the use of the- ErrorT transformer in WebT.-] {-hunk ./src/HAppS/Server/SimpleHTTP.hs 90-+ -- * Error Handlng-+ , errorHandlerSP-+ , simpleErrorHandler-hunk ./src/HAppS/Server/SimpleHTTP.hs 606-+---------------------------------------------------------------+-- Error Handling-+---------------------------------------------------------------+-+-- | This ServerPart modifier enables the use of throwError and catchError inside the-+-- WebT actions, by adding the ErrorT monad transformer to the stack.-+---+-- You can wrap the complete second argument to 'simpleHTTP' in this function.-+---+-- See 'simpleErrorHandler' for an example error handler.-+errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> [ServerPartT (ErrorT e m) a] -> [ServerPartT m a] -+errorHandlerSP handler sps = [ ServerPartT $ \req -> WebT $ do-+ eer <- runErrorT $ unWebT $ unServerPartT (multi sps) req-+ case eer of-+ Left err -> unWebT (handler req err)-+ Right res -> return res-+ ]-+-+-- | An example error Handler to be used with 'errorHandlerSP', which returns the-+-- error message as a plain text message to the browser.-+---+-- Another possibility is to store the error message, e.g. as a FlashMsg, and-+-- then redirect the user somewhere.-+simpleErrorHandler :: (Monad m) => Request -> String -> WebT m Response-+simpleErrorHandler _ err = ok $ toResponse $ ("An error occured: " ++ err)-+-}--Context:--[Add rqUri field to Record-Joachim Breitner <mail@joachim-breitner.de>**20080403110245- This makes sure the exact Uri is not lost (otherwise a trailing slash would be- lost to the rest of the HAppS code). This makes it possible to write a handler- like this:- - addSlash :: Monad m => ServerPartT m Response- addSlash = ServerPartT $ \rq -> do- case last (rqUri rq) of- '/' -> noHandle- _ -> seeOther (rqUri rq ++ "/" ++ rqQuery rq) $- toResponse "Missing trainling slash"- - which ensures that all paths end with a trailing slash, or of course a similar- removeSlash handler, to make relative paths in HTML links behave nicely.- More on this issue at http://groups.google.com/group/HAppS/browse_frm/thread/4065c842b1cfe7c7-] -[Distributed chat example.-lemmih <lemmih@vo.com>**20080318144925] -[Add a signature to 'debugFilter'. Haddock doesn't show it otherwise.-lemmih <lemmih@vo.com>**20080314162252] -[Multimaster example.-lemmih <lemmih@vo.com>**20080314162014] -[Fix typo in runTests.sh-lemmih <lemmih@vo.com>**20080314160613] -[Fix haddock annotation and bump version.-Lemmih <lemmih@vo.com>**20080229152550] -[Cabal wibble.-Lemmih <lemmih@vo.com>**20080222232935] -[Cabal wibble.-Lemmih <lemmih@vo.com>**20080222232730] -[TAG 0.9.2-Lemmih <lemmih@vo.com>**20080222225514] -[Bump version to 0.9.2-Lemmih <lemmih@vo.com>**20080222225151] -[Update snippet in package-info.xml-Lemmih <lemmih@vo.com>**20080222223603] -[Don't rely on Xml for serialization.-Lemmih <lemmih@vo.com>**20080222223302] -[Match changes in HAppS-State.-Lemmih <lemmih@vo.com>**20080218201437] -[fix conflicts-alex@happs.org**20080216004432] -[Match development in HAppS-State.-Lemmih <lemmih@vo.com>**20080215010026] -[Match changes in HAppS-State.-Lemmih <lemmih@vo.com>**20080215004016] -[Comment for AllIn.hs-Lemmih <lemmih@vo.com>**20080214234424] -[Don't use Xml for serialization.-Lemmih <lemmih@vo.com>**20080214233742] -[Don't export Cron from SimpleHTTP.-Lemmih <lemmih@vo.com>**20080212154505] -[Remove ServerPart.hs-Lemmih <lemmih@vo.com>**20080212154312] -[Update examples to match development in HAppS-State.-Lemmih <lemmih@vo.com>**20080212142058] -[Show usage of componentInit in AllIn.hs-Lemmih <lemmih@vo.com>**20080212011338] -[TAG 0.9.1.5-Lemmih <lemmih@vo.com>**20080209112439] -Patch bundle hash:-6579a6aeca01a58d2845d04ea5fe1c1d4b26f8f2------BEGIN PGP SIGNATURE------Version: GnuPG v1.4.6 (GNU/Linux)--iD8DBQFH/+8c9ijrk0dDIGwRAuK7AJ9oCvypMMyHlNmyGq9YKja18EykXQCePZC1-eg+57CyqIz4VNbwrS3BKx9Q=-=qqvc------END PGP SIGNATURE-----
− mailfilter.sh
@@ -1,131 +0,0 @@-#!/bin/bash--# Example usage in a alias file:-# darcswatch: |/opt/darcswatch/mailfilter.sh /opt/darcswatch/real/mails/ /opt/darcswatch/real/keyring /opt/darcswatch/darcswatch /opt/darcswatch/real/-# -# Note that $HOME has to be set, otherwise gpg will complain.--DIR=$1-KEYRING=$2-DARCSWATCH=$3-CONFIG=$4---test -n "$DIR" || { echo "Missing directory parameter"; exit 1; }-test -d "$DIR" || { echo "Not a directory: $DIRMissing"; exit 1; }-test -n "$KEYRING" || { echo "Missing keyring parameter"; exit 1; }-test -n "$DARCSWATCH" || { echo "Missing darcswatch parameter"; exit 1; }-test -n "$CONFIG" || { echo "Missing config parameter"; exit 1; }--function grep_dpatch { perl -n -e 'print if (/^New patches:/.../^--=_/)'; }-function grep_gpg {- perl -n -e 'print if (/^-----BEGIN PGP SIGNED MESSAGE-----/.../^-----END PGP SIGNATURE-----/)';- }-function md5 { md5sum - |cut -c-32 ; }-function update {- echo "Updateing darcswatch web view"- $DARCSWATCH $CONFIG new ;- }--FILE=$(tempfile --prefix patch)-mimedecode > "$FILE"--echo "Looking for a state"--STATE=none-if formail -z -x "Subject:" < "$FILE" | fgrep -q '[OBSOLETE]'-then- STATE=obsolete-fi-if formail -z -x "Subject:" < "$FILE" | fgrep -q '[REJECTED]'-then- STATE=rejected-fi-# More polite style, for xmonad :-)-if fgrep -q -i 'DarcsWatch: rejected' < "$FILE"-then- STATE=rejected-fi-if fgrep -q -i 'DarcsWatch: obsolete' < "$FILE"-then- STATE=obsolete-fi-echo "Found state $STATE"--echo "Looking for the sender"-FROM=$(formail -z -x "From:" < "$FILE")---MSGID="$(formail -z -x "Message-ID:" < "$FILE")"--echo "Looking for a patch"--if fgrep -q 'Content-Type: text/x-darcs-patch;' "$FILE" ||- fgrep -q 'Content-Type: text/x-patch;' "$FILE" ||- fgrep -q 'New patches:' "$FILE" -then-- echo "Patch ok, adding to patch directory"-- if fgrep -q -- '-----BEGIN PGP SIGNED MESSAGE-----' "$FILE"- then-- MD5SUM=$(grep_gpg < "$FILE" | md5)- grep_gpg < "$FILE" > "$DIR/patch_$MD5SUM"-- else- MD5SUM=$(grep_dpatch < "$FILE" | md5)- grep_dpatch < "$FILE" > "$DIR/patch_$MD5SUM"- fi-- if [ -n "$MSGID" ]- then- if test -e "$DIR/mid-mapping" && fgrep -q "$MSGID" "$DIR/mid-mapping"- then- echo "Seen this mail before"- else- echo "$MSGID $MD5SUM" >> "$DIR/mid-mapping"- fi- fi-- if [ "STATE" = "none" ]- then- STATE=add- fi--else- echo "No patch contained, it seems"-fi--if [ -n "$MSGID" -a "$STATE" != "none" ]-then- if [ -z "$MD5SUM" ]- then- # No referred bundle yet- REPLY=$(formail -z -x "In-Reply-To:" < "$FILE") - if [ -n "$REPLY" ] && test -e "$DIR/mid-mapping"- then- MD5SUM=$(fgrep "$REPLY" "$DIR/mid-mapping" | cut -f2 -d\ )- fi- fi-- if [ -n "$MD5SUM" ]- then- # Got something to mark- if test -e "$DIR/states" && fgrep -q "$MSGID" "$DIR/states"- then- echo "Seen this mail before"- else- echo "Marking patch $MD5SUM as $STATE"- echo "$MD5SUM $STATE $MSGID $FROM" >> "$DIR/states"- fi- fi-fi--if [ -n "$MD5SUM" ]-then- update-fi--rm "$FILE"-exit 0
+ src/ByteStringUtils.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP, ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : ByteStringUtils+-- Copyright : (c) The University of Glasgow 2001,+-- David Roundy 2003-2005+-- License : GPL (I'm happy to also license this file BSD style but don't+-- want to bother distributing two license files with darcs.+--+-- Maintainer : droundy@abridgegame.org+-- Stability : experimental+-- Portability : portable+--+-- GZIp and MMap IO for ByteStrings, and miscellaneous functions for Data.ByteString+--++module ByteStringUtils (+ unsafeWithInternals,+ linesPS+ ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Internal as BI+++import Data.Word ( Word8 )++import Foreign.Ptr ( plusPtr, Ptr )+import Foreign.ForeignPtr ( withForeignPtr )+++-- -----------------------------------------------------------------------------+-- unsafeWithInternals++-- | Do something with the internals of a PackedString. Beware of+-- altering the contents!+unsafeWithInternals :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a+unsafeWithInternals ps f+ = case BI.toForeignPtr ps of+ (fp,s,l) -> withForeignPtr fp $ \p -> f (p `plusPtr` s) l+++-- TODO: rename+{-# INLINE linesPS #-}+linesPS :: B.ByteString -> [B.ByteString]+linesPS ps+ | B.null ps = [B.empty]+ | otherwise = BC.split '\n' ps++{- QuickCheck property:++import Test.QuickCheck+import qualified Data.ByteString.Char8 as BC+import Data.Char+instance Arbitrary BC.ByteString where+ arbitrary = fmap BC.pack arbitrary+instance Arbitrary Char where+ arbitrary = chr `fmap` choose (32,127)+deepCheck = check (defaultConfig { configMaxTest = 10000})+testLines = deepCheck (\x -> (linesPS x == linesPSOld x))+linesPSOld ps = case BC.elemIndex '\n' ps of+ Nothing -> [ps]+ Just n -> B.take n ps : linesPS (B.drop (n+1) ps) -}++{-| This function acts exactly like the "Prelude" unlines function, or like+"Data.ByteString.Char8" 'unlines', but with one important difference: it will+produce a string which may not end with a newline! That is:++> unlinesPS ["foo", "bar"]++evaluates to \"foo\\nbar\", not \"foo\\nbar\\n\"! This point should hold true for+'linesPS' as well.++TODO: rename this function. -}+unlinesPS :: [B.ByteString] -> B.ByteString+unlinesPS [] = BC.empty+unlinesPS x = BC.init $ BC.unlines x+{-# INLINE unlinesPS #-}+{- QuickCheck property:++testUnlines = deepCheck (\x -> (unlinesPS x == unlinesPSOld x))+unlinesPSOld ss = BC.concat $ intersperse_newlines ss+ where intersperse_newlines (a:b:s) = a : newline : intersperse_newlines (b:s)+ intersperse_newlines s = s+ newline = BC.pack "\n" -}
src/CachedGet.hs view
@@ -31,13 +31,15 @@ import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) --- | Given a directory to be used for caching the result, and--- an URL to download, it will return the content of the URL.--- The boolean return value is true when the file was updated,--- and False if it is the same as in the cache.-get :: (String -> IO ()) -> FilePath -> String -> IO (Maybe (ByteString, Bool))-get write dir' uri = flip catch (\e -> write ("Error downloading uri: " ++ show e++ "\n")- >> return Nothing) $ do+-- | Given a output message function, a boolean indicate whether the presence+-- of the cached file is sufficient (i.e. for hash-based urls), a directory to be+-- used for caching the result, and an URL to download, it will return the+-- content of the URL. The boolean return value is true when the file was+-- updated, and False if it is the same as in the cache.+get :: (String -> IO ()) -> Bool -> FilePath -> String -> IO (Maybe (ByteString, Bool))+get write trustCache dir' uri =+ flip catch (\e -> write ("Error downloading uri: " ++ show e++ "\n")+ >> return Nothing) $ do write $ "Getting URL " ++ uri ++ " ... " e_cache <- doesFileExist cacheFile e_tag <- doesFileExist tagFile@@ -60,20 +62,25 @@ then do oldFile <- B.readFile cacheFile return $ Just (oldFile, False)- else if e_cache && e_tag- then do- oldTag <- slurpFile tagFile- mbNewTag <- head' uri- maybe'' mbNewTag (return Nothing) $ \newTag -> do+ else if e_cache && trustCache+ then do + write "cached (unchecked).\n"+ oldFile <- B.readFile cacheFile+ return $ Just (oldFile, False)+ else if e_cache && e_tag+ then do+ oldTag <- slurpFile tagFile+ mbNewTag <- head' uri+ maybe'' mbNewTag (return Nothing) $ \newTag -> do if oldTag == newTag- then do+ then do write "cached.\n" oldFile <- B.readFile cacheFile return $ Just (oldFile, False)- else do+ else do update- else do- update+ else do+ update where hash = md5 uri cacheFile = dir ++ hash ++ ".cache"
+ src/ConvertData-Main.hs view
@@ -0,0 +1,77 @@+{-+Copyright (C) 2009 Joachim Breitner++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}++import Darcs+import qualified Data.Map as M+import Data.Digest.OpenSSL.MD5 (md5sum)+import Data.List+import System.Environment+import System.Directory+import Control.Monad+import qualified Data.ByteString.Char8 as B++import Darcs.Watch.Data+import Darcs.Watch.Storage+import Data.Maybe++main = do+ args <- getArgs+ let confdir = case args of+ [confdir] -> (addSlash confdir)+ _ -> error "Use convert confdir/"+ putStrLn "Reading configuration..."+ config <- read `fmap` readFile (confdir ++ "config")++ putStrLn "Reading emails..."+ mailFiles' <- getDirectoryFiles (cMails config)+ let mailFiles = filter ((addSlash (cMails config) ++ "patch") `isPrefixOf`) mailFiles'++ putStrLn "Reading bundle states..."+ states <- readFile (addSlash (cMails config) ++ "states")+ let readStateLine string =+ let (checksum: stateString : _ : rest) = words string+ sender = unwords rest+ state = case stateString of+ "add" -> New+ "obsolete" -> Obsoleted+ "rejected" -> Rejected+ unknown -> error $ "Unknown state " ++ show unknown+ in M.insert checksum state+ let p2s = foldl (flip readStateLine) M.empty (lines states) :: M.Map String BundleState++ forM_ mailFiles $ \mailFile -> do+ putStrLn $ "Reading mail " ++ mailFile ++ " ..."+ mail <- B.readFile mailFile+ let bundle = parseMail mail+ let hash = md5sum mail+ putStrLn $ "State is " ++ maybe "Unknown" show (M.lookup hash p2s)+ let state = fromMaybe New (M.lookup hash p2s)+ bhash <- addBundle (cData config) bundle+ changeBundleState (cData config) bhash ManualImport state++addSlash filename | last filename == '/' = filename+ | otherwise = filename ++ "/"++getDirectoryFiles dir' = getDirectoryContents dir >>=+ return . (map (dir++)) >>=+ return . filter ((/= '.') . head) >>=+ filterM doesFileExist >>=+ filterM ((readable `fmap`) . getPermissions)+ where dir = addSlash dir'+
src/Darcs.hs view
@@ -19,10 +19,16 @@ module Darcs ( PatchInfo(..)+ , PatchBundle , getInventory , parseMail , patchBasename , inversePatch+ , make_bundle+ , scan_bundle+ , hash_bundle+ , make_context+ , scan_context ) where import OldDate@@ -32,10 +38,16 @@ import CachedGet import Zip +import Printer+import SHA1+ import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) import Data.List +import Darcs.Watch.Data++ -- | The defining informtion of a Darcs patch. data PatchInfo = PatchInfo { piDate :: ByteString@@ -45,6 +57,8 @@ , piInverted :: Bool } deriving (Eq,Ord,Show) +-- | A patch bundle (e.g. a mail)+type PatchBundle = ([(PatchInfo,ByteString)],[PatchInfo]) -- | Toggles the 'piInverted' flag of a 'PatchInfo' inversePatch :: PatchInfo -> PatchInfo@@ -53,22 +67,23 @@ -- | Given a directory used for caching, and an URL of a Darcs repository, -- it will return the list of patches in the repository, and whether the -- repository as changed since the last run.-getInventory :: (String -> IO ()) -> FilePath -> String -> IO ([PatchInfo], Bool)+getInventory :: (String -> IO ()) -> FilePath -> RepositoryURL -> IO ([PatchInfo], Bool) getInventory write cDir repo = do- format <- get write cDir formatUrl+ format <- get write False cDir formatUrl case format of Nothing -> getInventory1 write cDir repo Just (f,_) | f == B.pack "hashed\ndarcs-2\n" -> getInventory2 write cDir repo | f == B.pack "darcs-1.0\n" -> getInventory1 write cDir repo- | otherwise -> error $ "Unkown repository format: " ++ B.unpack f+ | f == B.pack "hashed\n" -> getInventory2 write cDir repo+ | otherwise -> error $ "Unkown repository format: " ++ B.unpack f ++ " in repo " ++ repo where formatUrl = addSlash repo ++ "_darcs/format" -- | Gets called when old style format was detected-getInventory1 :: (String -> IO ()) -> FilePath -> String -> IO ([PatchInfo],Bool)-getInventory1 write cDir repo = getInventoryFile (addSlash repo ++ "_darcs/inventory")+getInventory1 :: (String -> IO ()) -> FilePath -> RepositoryURL -> IO ([PatchInfo],Bool)+getInventory1 write cDir repo = getInventoryFile False (addSlash repo ++ "_darcs/inventory") where maybe' m f d = maybe d f m- getInventoryFile url = do- inv <- get write cDir url+ getInventoryFile trustCache url = do+ inv <- get write trustCache cDir url maybe' inv parseBody $ do write $ "Repository " ++ repo ++ " not found.\n" return ([],False)@@ -79,16 +94,16 @@ (l1,r) | l1 == B.pack "Starting with tag:" -> do let p = head patches let filename = addSlash repo ++ "_darcs/inventories/" ++ patchBasename p ++ ".gz"- (prev_p,prev_u) <- getInventoryFile filename+ (prev_p,prev_u) <- getInventoryFile True filename return (prev_p ++ patches, prev_u || updated) _ -> return (patches, updated) -- | Gets called when new style format was detected-getInventory2 :: (String -> IO ()) -> FilePath -> String -> IO ([PatchInfo],Bool)-getInventory2 write cDir repo = getInventoryFile (addSlash repo ++ "_darcs/hashed_inventory")+getInventory2 :: (String -> IO ()) -> FilePath -> RepositoryURL -> IO ([PatchInfo],Bool)+getInventory2 write cDir repo = getInventoryFile False (addSlash repo ++ "_darcs/hashed_inventory") where maybe' m f d = maybe d f m- getInventoryFile url = do- inv <- get write cDir url+ getInventoryFile trustCache url = do+ inv <- get write trustCache cDir url maybe' inv parseBody $ do write $ "Repository " ++ repo ++ " not found.\n" return ([],False)@@ -99,7 +114,7 @@ case breakOn '\n' (skip_pristine body) of (l,r) | l == B.pack "Starting with inventory:" -> do case breakOn '\n' $ B.tail r of- (h,r'') -> do prev <- getInventoryFile (addSlash repo ++ "_darcs/inventories/" ++ B.unpack h)+ (h,r'') -> do prev <- getInventoryFile True (addSlash repo ++ "_darcs/inventories/" ++ B.unpack h) return (prev,B.tail r'') --_ -> putStrLn "Broken inventory start line" >> return (([],False),body) _ -> return (([],False),body)@@ -166,40 +181,46 @@ Nothing -> Nothing Just n -> Just (B.take n p, B.drop (n+1) p) +showPatchInfo :: PatchInfo -> Doc+showPatchInfo pi =+ blueText "[" <> packedString (piName pi)+ $$ packedString (piAuthor pi) <> text inverted <> packedString (piDate pi)+ <> myunlines (piLog pi) <> blueText "] "+ where inverted = if piInverted pi then "*-" else "**"+ myunlines [] = empty+ myunlines xs = mul xs+ where mul [] = text "\n"+ mul (s:ss) = text "\n " <> packedString s <> mul ss -- | Given the content of a patch bundle, it returns a list of submitted patches with -- their diff, and the list of patches in the context.-parseMail :: ByteString -> ([(PatchInfo,ByteString)],[PatchInfo])-parseMail content = do case eesc of +parseMail :: ByteString -> PatchBundle+parseMail content = do case scan_bundle content of Left err -> ([],[]) -- putStrLn $ "Parse error: "++ err Right res -> if res == res then res else res- where demime = readMail content- eesc = scan_bundle demime- -readMail :: ByteString -> ByteString-readMail s = s--- We already strip the relevant part in the mail filter------ case betweenLines--- ("Content-Description: A darcs patch for your repository!")--- ("--=_--") s of--- Nothing -> s -- if it wasn't an email in the first place, just pass along.--- Just s' -> qpdecode s'------qpdecode :: String -> String---qpdecode s = s -- FIXME------betweenLines :: String -> String -> String -> Maybe (String)---betweenLines start end s--- = case break (start ==) (lines s) of--- (_, _:rest) ->--- case break (end ==) (reverse rest) of--- (_,_:rres) -> Just (unlines (reverse rres))--- _ -> Nothing--- _ -> Nothing+showPatch :: (PatchInfo,ByteString) -> Doc+showPatch (pi,d) = showPatchInfo pi <> packedString d -scan_bundle :: ByteString -> Either String ([(PatchInfo,ByteString)],[PatchInfo])+make_bundle :: PatchBundle -> ByteString+make_bundle bundle@(to_be_sent, common) = renderPS $+ text ""+ $$ text "New patches:"+ $$ text ""+ $$ (vsep $ map showPatch to_be_sent)+ $$ text ""+ $$ text "Context:"+ $$ text ""+ $$ (vcat $ map showPatchInfo common)+ $$ text "Patch bundle hash:"+ $$ text (hash_bundle bundle)+ $$ text ""++hash_bundle :: PatchBundle -> String+hash_bundle (to_be_sent,_) = sha1PS $ renderPS $ vcat (map showPatch to_be_sent) <> newline+++scan_bundle :: ByteString -> Either String PatchBundle scan_bundle ps | B.null ps = Left "Bad patch bundle!" | otherwise =@@ -240,6 +261,13 @@ silly_lex ps = (B.unpack $ B.takeWhile (/='\n') $ dropWhite ps, B.dropWhile (/='\n') $ dropWhite ps) +make_context :: [PatchInfo] -> ByteString+make_context = renderPS . vcat . map showPatchInfo+++scan_context :: ByteString -> [PatchInfo]+scan_context = fst . get_context+ get_context :: ByteString -> ([PatchInfo],ByteString) get_context ps = case readPatchInfo ps of@@ -261,7 +289,8 @@ readDiff :: ByteString -> Maybe (ByteString, ByteString) readDiff s | B.null (dropWhite s) = Nothing readDiff s = find (\(p,r) -> B.pack "\n\n" `B.isPrefixOf` r || B.pack "\n[" `B.isPrefixOf` r)- (zip (B.inits s) (B.tails s))+ (zip (B.inits s') (B.tails s'))+ where s' = dropWhite s patchFilename :: PatchInfo -> String patchFilename pi = patchBasename pi ++ ".gz"
+ src/Darcs/Watch/Data.hs view
@@ -0,0 +1,65 @@+{-+Copyright (C) 2009 Joachim Breitner++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}++module Darcs.Watch.Data where++import Data.Time++type BundleHash = String++-- | the path to the storage directory+type StorageConf = String++-- | A history entry is a state change+type BundleHistory = (UTCTime, Source, BundleState)++data BundleState+ = New+ | Applicable+ | Rejected+ | Obsoleted+ | Applied -- ^ Repository URL+ deriving (Read, Show, Ord, Eq)+ +data Source+ = ManualImport+ | ViaEMail String String String (Maybe String) -- ^ From, To, Subject, Message-Id + | ViaBugtracker String -- ^ URL+-- | ViaWeb String -- ^ OpenID Username+ | ViaRepository RepositoryURL -- ^ Repository-URL+ deriving (Read, Show)++type RepositoryURL = String++data RepositoryInfo = RepositoryInfo + { lastCheck :: Maybe UTCTime+ , lastUpdate :: Maybe UTCTime+ }+ deriving (Read, Show)++data DarcsWatchConfig = DarcsWatchConfig {+ cRepositories :: [RepositoryURL],+ cData :: String,+ cOutput :: String,+ cMails :: String,+ cDarcsWatchURL :: String,+ cDarcsWatchAddress :: String,+ cSendRoundupMails :: Bool+ } deriving (Show, Read)+
+ src/Darcs/Watch/GenerateOutput.hs view
@@ -0,0 +1,185 @@+{-+Copyright (C) 2008 Joachim Breitner++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}++module Darcs.Watch.GenerateOutput where++import Control.Monad+import Control.Concurrent+import Control.Applicative+import System.Environment (getArgs)+import System.Directory+import System.Posix.Files+import System.Time+import System.IO+import System.Terminal.Concurrent++import qualified Data.Map as M+import qualified Data.Set as S+import qualified MultiMap as MM+import MultiMap ((!!!!))+import Data.Char+import Data.List+import Data.Time+import System.FilePath++import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 (ByteString)++-- Darcs stuff+import Darcs+import Darcs.Watch.Storage+import Darcs.Watch.Data+-- Web ouput+import HTML++import Data.Digest.OpenSSL.MD5 (md5sum)+import Data.Maybe++generateOutput config patchNew = do+ nowStamp <- getCurrentTime+ let outputStampFile = cData config </> "output.stamp"+ ex <- doesFileExist outputStampFile+ lastStamp <- if ex then read . B.unpack <$> B.readFile outputStampFile+ else return $ UTCTime (ModifiedJulianDay 0) 0++ putStrLn "Reading repositories..."+ let loadInv rep = do+ putStr $ "Reading " ++ rep ++ " ...\n"+ ps <- readRepository (cData config) rep+ repoInfo <- getRepositoryInfo (cData config) rep+ let thisNew = maybe True (>= lastStamp) (lastUpdate repoInfo)+ putStr (if thisNew then "Repostory is new.\n" else "Repository is cached.\n")+ return (rep, ps, repoInfo, thisNew)+ readInv (p2r,r2p,r2ri,new) (rep, ps, repoInfo, thisNew) = do+ let p2r' = foldr (\p -> MM.append p rep) p2r ps+ r2p' = MM.extend rep ps r2p :: M.Map RepositoryURL (S.Set PatchInfo)+ r2ri' = M.insert rep repoInfo r2ri+ return (p2r', r2p', r2ri', new || thisNew)+ (p2r,r2p, r2ri, new) <- foldM readInv (MM.empty, MM.empty, M.empty, patchNew) =<<+ sequence (map loadInv (cRepositories config))++ putStrLn "Reading emails..."+ bundleHashes <- listBundles (cData config)++ let sortInBundle (u2p, u2rn, p2pe, new) bundleHash = do+ putStrLn $ "Reading mail " ++ bundleHash ++ " ..."+ bundle <- getBundle (cData config) bundleHash+ let bundleFileName = getBundleFileName (cData config) bundleHash+ history <- getBundleHistory (cData config) bundleHash+ + let thisNew = any (\(d,_,_) -> d >= lastStamp) history++ let (patches,context) = bundle+ let u2p' = foldr (\(p,_) -> MM.append (normalizeAuthor (piAuthor p)) p) u2p patches+ let u2rn' = foldr (\(p,_) ->+ M.insertWith (maxBy B.length) (normalizeAuthor (piAuthor p)) (piAuthor p)+ ) u2rn patches+ let p2pe' = foldr (\(p,d) ->+ let pe = PatchExtras d context bundleFileName history+ -- The patch with the smaller context is the more useful+ in M.insertWith (minBy (length.peContext)) p pe+ ) p2pe patches+ return (u2p', u2rn', p2pe', new || thisNew)+ (u2p, u2rn, p2pe, new') <- foldM sortInBundle (MM.empty, M.empty, M.empty, new) bundleHashes+ let patches = M.keys p2pe -- Submitted patches+ let repos = M.keys r2p -- Repos with patches+ let users = M.keys u2p -- Known users+ + if not new' then putStrLn "Nothing new, exiting" else do+++ -- Clonsider patches as belonging to a repository when either+ -- * it is already applied+ -- * all its context is in the repository+ -- * at least 10 patches of the context are in the repository+ let addables = do -- List monad+ patch <- patches+ repo <- repos+ present <- maybeToList $ M.lookup repo r2p+ if patch `S.member` present+ then return (patch,repo)+ else do+ pe <- maybeToList $ M.lookup patch p2pe+ case partition (`S.member` present) (peContext pe) of+ (_,[]) -> return (patch,repo) + (m,_) | length m >= 10 -> return (patch,repo) + _ -> []++ -- Patch to possible repos+ -- Repo to possible patch+ let p2pr = foldr (\(p,r) -> MM.append p r) MM.empty addables+ let r2mp = foldr (\(p,r) -> MM.append r p) MM.empty addables++ -- Unmatched patches+ let unmatched = S.fromList $+ -- filter (\p -> M.findWithDefault Unmatched p p2s == Unmatched) $+ filter (\p -> not (M.member p p2pr)) patches++ now <- getClockTime >>= toCalendarTime+ let resultData = ResultData p2r r2p u2p p2pe p2pr r2mp r2ri unmatched now u2rn+ + {-+ putStrLn "Evalutating data"+ putStrLn (show (length (show (resultData))))+ -}++ putStrLn "Writing output..."+ writeFile (cOutput config ++ "/index.html") (mainPage resultData)++ forM_ users $ \u ->+ writeFile (cOutput config ++ "/" ++ userFile u) (userPage resultData u)++ forM_ repos $ \r ->+ writeFile (cOutput config ++ "/" ++ repoFile r) (repoPage resultData r)++ forM_ patches $ \p ->+ B.writeFile (cOutput config ++ "/" ++ patchDiffFile p) (peDiff (p2pe M.! p))++ writeFile (cOutput config ++ "/" ++ "unmatched.html") (unmatchedPage resultData)++ putStrLn "Linking patches"+ let patchLink (p,pe) = do+ let link = cOutput config ++ "/" ++ patchBasename p ++ ".dpatch"+ ex <- fileExist link+ unless ex $ do+ -- There might be a broken symlink here:+ catch (removeFile link) (const (return ()))+ createSymbolicLink (peBundleFile pe) link+ mapM_ patchLink $ M.toList p2pe++ B.writeFile outputStampFile (B.pack (show nowStamp))++getDirectoryFiles dir' = getDirectoryContents dir >>=+ return . (map (dir++)) >>=+ return . filter ((/= '.') . head) >>=+ filterM doesFileExist >>=+ filterM ((readable `fmap`) . getPermissions)+ where dir = addSlash dir'++maxBy f v1 v2 = if f v1 >= f v2 then v1 else v2+minBy f v1 v2 = if f v1 <= f v2 then v1 else v2+++addSlash filename | last filename == '/' = filename+ | otherwise = filename ++ "/"++-- not in ghc6.6+infixl 0 `on`+on :: (b -> b -> c) -> (a -> b) -> a -> a -> c+(*) `on` f = \x y -> f x * f y
+ src/Darcs/Watch/ImportMail.hs view
@@ -0,0 +1,149 @@+{-+Copyright (C) 2009 Joachim Breitner++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}++module Darcs.Watch.ImportMail where++import Darcs+import qualified Data.Map as M+import Data.Digest.OpenSSL.MD5 (md5sum)+import Data.List+import System.Environment+import System.Directory+import Control.Monad+import qualified Data.ByteString.Char8 as B+import Data.Maybe+import System.FilePath+import Codec.MIME.String as MIME+import Text.Regex+import Data.Monoid+import Data.Char+import Control.Applicative++import Darcs.Watch.Data+import Darcs.Watch.Storage++importMail :: DarcsWatchConfig -> IO Bool+importMail config = do+ mail <- getContents+ let message = MIME.parse mail+ mpatch = findDarcsBundle message+ state = getStateFromMessage message+ mi = m_message_info message+ references = getReferredMails mi+ from = maybe "" (showFrom) (mi_from mi)+ to = maybe "" (showTo) (mi_to mi)+ subject = maybe "" (\(Subject s) -> s) (mi_subject mi)+ mid = get_header (mi_headers mi) "message-id:"+ (Just . stripWhitespace )+ emailSource = ViaEMail from to subject mid+ case mpatch of+ Just bundleData -> do+ let Right bundle = scan_bundle (B.pack bundleData)+ roundupURL = findRoundupURL message+ bhash <- addBundle (cData config) bundle+ case roundupURL of+ Nothing -> return ()+ Just url -> do+ changeBundleState (cData config) bhash+ (ViaBugtracker url) New+ changeBundleState (cData config) bhash emailSource state+ return True++ Nothing -> if (state == New || null references) then return False else do+ -- Maybe this mail refers to another mail?+ bundleHashes <- listBundles (cData config)+ changes <- forM bundleHashes $ \bundleHash -> do+ history <- getBundleHistory (cData config) bundleHash+ let seenInMail = findSubmittingMail history+ if null (intersect references seenInMail)+ then return False+ else do changeBundleState (cData config) bundleHash+ emailSource state + return True+ return (or changes)++findSubmittingMail = mapMaybe isSubmittingMail++isSubmittingMail (_,ViaEMail _ _ _ (Just mid), New) = Just mid+isSubmittingMail _ = Nothing++darcsTrackerRegex = mkRegex "\\<(http://bugs.darcs.net/patch[0-9]+)\\>"++getStateFromMessage msg | "OBSOLETE" `isInfixOf` subject = Obsoleted+ | "REJECTED" `isInfixOf` subject = Rejected+ | otherwise = fromMaybe New (findDarcsWatchTag msg)+ where mi = m_message_info msg+ subject = maybe "" (\(Subject s) -> s) (mi_subject mi)++getReferredMails :: MessageInfo -> [String]+getReferredMails mi = fromMaybe [] $ mconcat+ [ get_header (mi_headers mi) "in-reply-to:" (Just . (:[]) . stripWhitespace)+ , get_header (mi_headers mi) "references:" (Just . map stripWhitespace . words) ]++stripWhitespace = reverse . dropWhile isSpace . reverse . dropWhile isSpace++findRoundupURL :: Message -> Maybe String+findRoundupURL = findInBody $ fmap concat . matchRegex darcsTrackerRegex++findDarcsWatchTag :: Message -> Maybe BundleState+findDarcsWatchTag = findInBody $ \body -> case () of + () | "DarcsWatch: rejected" `isInfixOf` body -> Just Rejected+ | "DarcsWatch: obsolete" `isInfixOf` body -> Just Obsoleted+ | otherwise -> Nothing++findInBody :: (String -> Maybe a) -> Message -> Maybe a+findInBody query (Message _ _ (Body _ _ msg)) = query msg+findInBody query (Message _ _ (Mixed (Multipart _ msgs _ ))) = msum (map (findInBody query) msgs)+findInBody query (Message _ _ (Alternative (Multipart _ msgs _ ))) = msum (map (findInBody query) msgs)+findInBody query (Message _ _ (Parallel (Multipart _ msgs _ ))) = msum (map (findInBody query) msgs)+findInBody query (Message _ _ (Digest (Multipart _ msgs _ ))) = msum (map (findInBody query) msgs)+findInBody query _ = Nothing+++findDarcsBundle :: Message -> Maybe String+findDarcsBundle (Message _ _ (Data _ (ContentType "text" "x-darcs-patch" _) _ msg)) = Just msg+findDarcsBundle (Message _ _ (Body (ContentType "text" "x-darcs-patch" _) _ msg)) = Just msg+findDarcsBundle (Message _ _ (Data _ _ filename msg))+ | ".dpatch" `isSuffixOf` filename = Just msg+findDarcsBundle (Message _ _ (Mixed (Multipart _ msgs _ ))) = msum (map findDarcsBundle msgs)+findDarcsBundle (Message _ _ (Alternative (Multipart _ msgs _ ))) = msum (map findDarcsBundle msgs)+findDarcsBundle (Message _ _ (Parallel (Multipart _ msgs _ ))) = msum (map findDarcsBundle msgs)+findDarcsBundle (Message _ _ (Digest (Multipart _ msgs _ ))) = msum (map findDarcsBundle msgs)+findDarcsBundle _ = Nothing++showFrom (From []) = ""+showFrom (From (mb:_)) = showMailbox mb++showTo (To []) = ""+showTo (To (mb:_)) = showAddress mb++showAddress (Address mbox) = showMailbox mbox+showAddress (Group _ []) = "" +showAddress (Group _ (mb:_)) = showMailbox mb++showMailbox (Mailbox (Just name) mail) = name ++ " <" ++ showRoutedEmailAddress mail ++ ">"+showMailbox (Mailbox Nothing mail) = showRoutedEmailAddress mail++showRoutedEmailAddress (NormalEmailAddress mail) = showEmailAddress mail+showRoutedEmailAddress (RoutedEmailAddress _ mail) = showEmailAddress mail++showEmailAddress (EmailAddress local domain) = local ++ "@" ++ showDomain domain++showDomain (Domain s) = s+showDomain (LiteralDomain s) = s
+ src/Darcs/Watch/PullRepos.hs view
@@ -0,0 +1,71 @@+{-+Copyright (C) 2008 Joachim Breitner++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}++module Darcs.Watch.PullRepos where++import Control.Monad+import Control.Concurrent+import Control.Applicative+import System.Environment (getArgs)+import System.Directory+import System.Posix.Files+import System.Time+import System.IO+import System.Terminal.Concurrent++import qualified Data.Map as M+import qualified Data.Set as S+import qualified MultiMap as MM+import MultiMap ((!!!!))+import Data.Char+import Data.List++import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 (ByteString)+import Data.Digest.OpenSSL.MD5 (md5sum)+import Data.Maybe+import System.FilePath++-- Darcs stuff+import Darcs+import Darcs.Watch.Storage+import Darcs.Watch.Data+-- Web ouput+import HTML+--import LockRestart+++pullRepos :: DarcsWatchConfig -> IO Bool+pullRepos config = do+ writeC <- getConcurrentOutputter++ putStrLn "Updating repositories..."+ let updateRepo rep = do+ writeC $ "Updating " ++ rep ++ ":\n"+ thisNew <- updateRepository (cData config) writeC rep+ writeC (if thisNew then "Repostory is new.\n" else "Repository is cached.\n")+ return thisNew+ new <- or <$> forkSequence (map updateRepo (cRepositories config))++ unless new $ putStrLn "Nothing new found"+ return new++{- forkSequence = sequence -}+-- Enable for parallel downloads+forkSequence acts = mapM (\act -> newEmptyMVar >>= \mvar -> forkIO (act >>= putMVar mvar) >> return mvar) acts >>= mapM takeMVar
+ src/Darcs/Watch/Roundup.hs view
@@ -0,0 +1,61 @@+module Darcs.Watch.Roundup where++import Codec.MIME.String as MIME+import Data.List+import System.IO+import System.Exit+import System.Process+import Control.Monad++import Darcs.Watch.Data+import Darcs+import HTML++tellRoundup :: DarcsWatchConfig -> String -> RepositoryURL -> PatchBundle -> BundleState -> IO ()+tellRoundup _ _ _ _ status | status `notElem` [Applied, Applicable] = return ()+tellRoundup _ url _ _ _ | not $ "http://bugs.darcs.net/" `isPrefixOf` url = return ()+tellRoundup config url repo bundle status = do+ message <- flatten [mk_header ["From: " ++ from]+ ,mk_header ["To: " ++ to]+ ,mk_header ["Subject: " ++ subject]+ ] body Nothing []+ if cSendRoundupMails config+ then do sendMail message+ else do hPutStrLn stderr "Would send this message:"+ hPutStrLn stderr message+ where from = cDarcsWatchAddress config+ to = "bugs@darcs.net"+ subject = case status of+ Applicable -> "This patch is being tracked by DarcsWatch [" ++ roundupId ++ "]"+ Applied -> "This patch has been applied [" ++ roundupId ++ "] [status=accepted]"+ body = case status of+ Applicable -> "This patch bundle (with " ++ show numPatches ++ " patch" +++ (if numPatches == 1 then "" else "es") ++ "), which can be " +++ " applied to the repository " ++ repo ++ " is now tracked " +++ " on DarcsWatch at " +++ cDarcsWatchURL config ++ repoFile repo+ Applied -> "This patch bundle (with " ++ show (length (fst bundle)) +++ " patches) was just applied to the repository " ++ repo ++".\n" +++ "This message was brought to you by " +++ "DarcsWatch\n" +++ cDarcsWatchURL config ++ repoFile repo+ numPatches = length (fst bundle)++ roundupId = drop (length "http://bugs.darcs.net/") url++sendMail :: String -> IO ()+sendMail text = do+ (inh, outh, errh, ph) <- runInteractiveProcess "/usr/sbin/sendmail" ["-t"] Nothing Nothing+ hClose outh+ hPutStr inh text+ hClose inh+ err <- hGetContents errh+ hPutStr stderr err+ ec <- waitForProcess ph+ return ()+ ++haveRoundupURL = msum . map fromRoundup ++fromRoundup (_,ViaBugtracker r,_) = Just r+fromRoundup _ = Nothing
+ src/Darcs/Watch/Storage.hs view
@@ -0,0 +1,122 @@+{-+Copyright (C) 2008 Joachim Breitner++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}++module Darcs.Watch.Storage where++import Darcs+import Darcs.Watch.Data++import Data.Time+import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 (ByteString)+import System.FilePath+import System.Directory+import Data.List+import Control.Applicative+import System.Directory+import Control.Monad+import Data.Char+++-- | Adds a new patch bundle to the stogare+addBundle :: StorageConf -> PatchBundle -> IO BundleHash+addBundle path bundle = do+ let hash = hash_bundle bundle+ let dataFile = bundleDir path </> hash <.> "data"+ ex <- doesFileExist dataFile+ unless ex $ B.writeFile dataFile (B.pack "[]")+ B.writeFile (bundleDir path </> hash <.> "bundle")+ (make_bundle bundle)+ return hash+++-- | Retrieves a new patch bundle from the storage+getBundle :: StorageConf -> BundleHash -> IO PatchBundle+getBundle path hash = + either error id . scan_bundle <$> B.readFile (bundleDir path </> hash <.> "bundle")++-- | Retrieves the meta information for the handle+getBundleHistory :: StorageConf -> BundleHash -> IO [BundleHistory]+getBundleHistory path hash =+ read <$> B.unpack <$> B.readFile (bundleDir path </> hash <.> "data")++-- | Adds a new entry to the bundle history (stamped with the current time)+changeBundleState :: StorageConf -> BundleHash -> Source -> BundleState -> IO ()+changeBundleState path hash source state = do+ history <- getBundleHistory path hash+ now <- getCurrentTime+ B.writeFile (bundleDir path </> hash <.> "data") $ B.pack $ show $+ (now, source, state) : history+ ++listBundles :: StorageConf -> IO [BundleHash]+listBundles path = do+ items <- getDirectoryContents (bundleDir path)+ return $ map dropExtension+ $ filter ( (".bundle" == ) .takeExtension )+ $ items++++updateRepository :: StorageConf -> (String -> IO ()) -> RepositoryURL -> IO Bool+updateRepository path write repo = do+ let infoFile = repoDir path </> safeName repo <.> "data"+ let repoFile = repoDir path </> safeName repo <.> "inventory"+ ex <- doesFileExist infoFile+ info <- if ex then read . B.unpack <$> B.readFile infoFile+ else return (RepositoryInfo Nothing Nothing)+ now <- getCurrentTime+ (ps,changed) <- getInventory write (cacheDir path) repo+ when changed $ B.writeFile repoFile (make_context ps)+ B.writeFile infoFile $ B.pack $ show $ RepositoryInfo+ { lastCheck = Just now+ , lastUpdate = if changed then Just now else lastUpdate info+ }+ return changed++readRepository :: StorageConf -> RepositoryURL -> IO [PatchInfo]+readRepository path repo = do+ let repoFile = repoDir path </> safeName repo <.> "inventory"+ ex <- doesFileExist repoFile+ if ex then scan_context `fmap` B.readFile repoFile+ else return []++getRepositoryInfo :: StorageConf -> RepositoryURL -> IO RepositoryInfo+getRepositoryInfo path repo = do+ let infoFile = repoDir path </> safeName repo <.> "data"+ ex <- doesFileExist infoFile+ if ex then read . B.unpack <$> B.readFile infoFile+ else return (RepositoryInfo Nothing Nothing)++bundleDir :: StorageConf -> FilePath+bundleDir path = path </> "bundles"++getBundleFileName :: StorageConf -> BundleHash -> FilePath+getBundleFileName path hash = bundleDir path </> hash <.> "bundle"++repoDir :: StorageConf -> FilePath+repoDir path = path </> "repos"++cacheDir :: StorageConf -> FilePath+cacheDir path = path </> "cache"++safeName n = map s n+ where s c = if isSafeFileChar c then c else '_'++isSafeFileChar c = isAlpha c || isDigit c || c `elem` "-_.@:"
+ src/Darcs/Watch/UpdateRepoData.hs view
@@ -0,0 +1,103 @@+{-+Copyright (C) 2008 Joachim Breitner++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}++module Darcs.Watch.UpdateRepoData where++import Control.Monad+import Control.Concurrent+import Control.Applicative+import System.Environment (getArgs)+import System.Directory+import System.Posix.Files+import System.Time+import System.IO+import System.Terminal.Concurrent++import qualified Data.Map as M+import qualified Data.Set as S+import qualified MultiMap as MM+import MultiMap ((!!!!))+import Data.Char+import Data.List++import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 (ByteString)+import Data.Digest.OpenSSL.MD5 (md5sum)+import Data.Maybe+import System.FilePath++-- Darcs stuff+import Darcs+import Darcs.Watch.Storage+import Darcs.Watch.Data+import Darcs.Watch.Roundup++updateRepoData config = do+ let readRepo rep = do+ inv <- readRepository (cData config) rep+ return (rep, S.fromList inv)+ repos <- mapM readRepo (cRepositories config)++ bundleHashes <- listBundles (cData config)+ forM_ bundleHashes $ \bundleHash -> do+ bundle <- getBundle (cData config) bundleHash+ history <- getBundleHistory (cData config) bundleHash++ let context = snd bundle+ let patches = map fst (fst bundle)+ + forM repos $ \(repo, inv) -> do+ let statusQuoAnte =+ fromMaybe New $+ listToMaybe $+ map (\(_,_,s) -> s) $+ filter (aboutRepo repo) $+ history+ + let statusQuo = + if all (`S.member` inv) patches then Applied+ else if applicable inv context then Applicable+ else New++ when (statusQuo /= statusQuoAnte) $ do+ putStrLn $ "Marking bundle " ++ bundleHash +++ " as " ++ show statusQuo +++ " with regard to " ++ repo+ changeBundleState (cData config)+ bundleHash+ (ViaRepository repo)+ statusQuo+ + case haveRoundupURL history of+ Nothing -> return ()+ Just url -> + tellRoundup config url repo bundle statusQuo+++-- Clonsider patches as applicable to a repository when either+-- * all its context is in the repository+-- * at least 10 patches of the context are in the repository+applicable inv context = + case partition (`S.member` inv) context of+ (_,[]) -> True+ (m,_) | length m >= 10 -> True+ _ -> False++aboutRepo repo (_,ViaRepository r,_) = repo == r+aboutRepo _ _ = False
+ src/Generate-Main.hs view
@@ -0,0 +1,63 @@+{-+Copyright (C) 2008 Joachim Breitner++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}+++import Control.Monad+import Control.Concurrent+import Control.Applicative+import System.Environment (getArgs)+import System.Directory+import System.Posix.Files+import System.Time+import System.IO+import System.Terminal.Concurrent++import qualified Data.Map as M+import qualified Data.Set as S+import qualified MultiMap as MM+import MultiMap ((!!!!))+import Data.Char+import Data.List+import Data.Time+import System.FilePath++import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 (ByteString)++-- Darcs stuff+import Darcs+import Darcs.Watch.GenerateOutput+import Darcs.Watch.Data+import LockRestart++import Data.Digest.OpenSSL.MD5 (md5sum)+import Data.Maybe+++main = do+ hSetBuffering stdout NoBuffering+ args <- getArgs+ let (confdir, patchNew) = case args of+ [confdir] -> (addSlash confdir, False)+ [confdir, "new"] -> (addSlash confdir, True)+ _ -> error "Use darcswatch confdir/"+ putStrLn "Reading configuration..."+ config <- read `fmap` readFile (confdir ++ "config")++ lockRestart (cOutput config) patchNew or True (generateOutput config)
src/HTML.hs view
@@ -26,8 +26,8 @@ , unmatchedPage , userFile , repoFile+ , patchDiffFile , normalizeAuthor- , PatchState(..) ) where import Text.XHtml hiding ((!))@@ -41,12 +41,16 @@ import Data.List import Data.Ord import Data.Char+import Data.Maybe+import Data.Time import System.Time+import System.Locale import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) import Darcs+import Darcs.Watch.Data -- not in ghc6.6@@ -55,14 +59,13 @@ (*) `on` f = \x y -> f x * f y data ResultData = ResultData- { p2r :: M.Map PatchInfo (S.Set String)- , r2p :: M.Map String (S.Set PatchInfo)- , u2p :: M.Map ByteString (S.Set PatchInfo)- , p2pe:: M.Map PatchInfo PatchExtras- , p2pr :: M.Map PatchInfo (S.Set String)- , r2mp :: M.Map String (S.Set PatchInfo)- , p2s :: M.Map PatchInfo (PatchState)- , p2mid:: M.Map PatchInfo (String)+ { p2r :: M.Map PatchInfo (S.Set RepositoryURL)+ , r2p :: M.Map RepositoryURL (S.Set PatchInfo)+ , u2p :: M.Map ByteString (S.Set PatchInfo)+ , p2pe:: M.Map PatchInfo (PatchExtras)+ , p2pr :: M.Map PatchInfo (S.Set String)+ , r2mp :: M.Map RepositoryURL (S.Set PatchInfo)+ , r2ri :: M.Map RepositoryURL (RepositoryInfo) , unmatched :: (S.Set PatchInfo) , date :: CalendarTime , u2rn :: M.Map ByteString ByteString@@ -71,7 +74,8 @@ data PatchExtras = PatchExtras { peDiff :: ByteString , peContext :: [PatchInfo]- , peMailFile :: String+ , peBundleFile :: FilePath+ , peStateHistory :: [BundleHistory] } deriving (Show) @@ -111,14 +115,32 @@ calendarTimeToString (date d) +++ "." )-myHeader d = script !!! [thetype "text/javascript"] << (- " function toggle_diff(id) { "++- " elem = document.getElementById(id); "++- " if (elem) {if (elem.style.display == 'none') {elem.style.display = 'block';} else {elem.style.display = 'none'} }"++ - " }"- ) +myHeader d = script !!! [thetype "text/javascript", src "/javascript/jquery/jquery.js"] << noHtml+ ++++ script !!! [thetype "text/javascript"] << "\+ \$(document).ready(function () { \+ \ $('.diffshower').click(function () { \+ \ var diffid = this.id.replace(/^diffshower_/,''); \+ \ $('#diff_' + diffid).toggle(); \+ \ $('#diff_' + diffid + ' pre:visible').each(function () {\+ \ diffelem = this;\+ \ if (!($(diffelem).text())) {\+ \ $(diffelem).text('Diff is being loaded...');\+ \ jQuery.get('diff_' + diffid + '.txt',\+ \ callback=function(text) {\+ \ $(diffelem).text(text);\+ \ }\+ \ ,type='text');\+ \ }});\+ \ })})\+ \"+ ++++ style !!! [thetype "text/css" ] << "\+ \span[title] { border-bottom: dotted 1px black; } \+ \" + userPage d u = showHtml $ header << ( thetitle << ("DarcsWatch overview for " +++ u2rn d ! u) +++@@ -127,10 +149,10 @@ body << ( h1 << ("DarcsWatch overview for " +++ u2rn d ! u) +++ p << hotlink "." << "Return to main page" +++- patchList d (sps !!!! NotApplied) "Unapplied patches" True +++- patchList d (sps !!!! Unmatched) "Unmatched patches" True ++++ patchList d (sps !!!! Applicable) "Unapplied patches" True ++++ patchList d (sps !!!! New) "Unmatched patches" True +++ patchList d (sps !!!! Rejected) "Rejected patches" True +++- patchList d (sps !!!! Obsolete) "Obsolete patches" True ++++ patchList d (sps !!!! Obsoleted) "Obsoleted patches" True +++ patchList d (sps !!!! Applied) "Applied patches" True +++ footer d )@@ -144,10 +166,16 @@ body << ( h1 << ("DarcsWatch overview for " +++ r) +++ p << hotlink "." << "Return to main page" +++- patchList d (sps !!!! NotApplied) "Unapplied patches" False ++++ patchList d (sps !!!! Applicable) "Unapplied patches" False +++ patchList d (sps !!!! Applied) "Applied patches" False +++- patchList d (sps !!!! Obsolete) "Obsolete patches" False ++++ patchList d (sps !!!! Obsoleted) "Obsoleted patches" False +++ patchList d (sps !!!! Rejected) "Rejected patches" True ++++ thediv << (+ "Last change in repository at " ++++ maybe (toHtml "No idea when") toHtml (lastUpdate (r2ri d ! r)) ++++ ", last check of repository at " ++++ maybe (toHtml "No idea when") toHtml (lastCheck (r2ri d ! r)) +++ "."+ ) +++ footer d ) where (ps, sps) = repoData r d@@ -168,6 +196,29 @@ patchList d ps title userCentric = h2 << title +++ (unordList $ map (patchView d userCentric) ps) +patchHistoryView d p = + unordList $ flip map (reverse $ peStateHistory $ p2pe d ! p) $ \(date,source,state) ->+ date +++ ": " +++ showState state +++ " " +++ showSource source++showSource (ViaRepository repo) = " in repo " +++ hotlink (repoFile repo) << repo+showSource (ViaBugtracker url) = " in bug tracker ticket " +++ hotlink url << url+showSource (ViaEMail from to subject mmid) = " via " ++++ thespan !!! [ title $+ "From: " ++ from ++ "\n" +++ "Subject: " ++ subject+ ] << "e-mail" +++ " to " ++++ hotlink ("mailto:" ++ to) << to ++++ maybe noHtml (\mid ->+ " " +++ hotlink ("http://mid.gmane.org/" ++ mid) + (image !!!+ [ src "http://gmane.org/favicon.ico"+ , title "Search this mail on gmane.org"+ , border 0+ ])+ ) mmid++showSource ManualImport = toHtml "via a manual import"+ patchView d userCentric p = piDate p +++ ": " +++ strong << ( (if piInverted p then stringToHtml "UNDO: " else noHtml) +++@@ -181,47 +232,31 @@ ) ) +++ pre << B.unlines (piLog p) +++- (if userCentric- then (unordList $ flip map (S.toList (p2pr d !!!! p)) $ \r ->- hotlink (repoFile r) << r +++ ": "+++ viewState d p r- )- else noHtml- ) +++- thediv !!! [identifier diffId, thestyle "display:none"] << (- actions +++- pre << peDiff (p2pe d ! p)- ) +++- actions+ patchHistoryView d p ++++ actions ++++ thediv !!! [identifier diffId, thestyle "display:none"] << pre noHtml where pid = patchBasename p+ diffShowerId = "diffshower_"++pid diffId = "diff_"++pid actions = paragraph << ( strong << "Actions: " +++ hotlink (pid ++ ".dpatch") << "Download .dpatch" +++ " "+++ - anchor !!! [href $ "javascript:toggle_diff('"++diffId++"')"]- << "Show/Hide diff" +++- case p `M.lookup` p2mid d of- Nothing -> noHtml- Just mid -> " " +++- anchor !!! [href $ "http://mid.gmane.org/" ++ mid ]- << "Search submitting mail"+ anchor !!! [identifier diffShowerId, theclass "diffshower", href "javascript:"]+ << "Show/Hide diff" ) --- The order defines what state a patch should be considered if it is--- in sevaral repositories-data PatchState = Unmatched | Applied | NotApplied | Rejected | Obsolete | Obsoleting deriving (Eq, Ord)- state d p r | p `S.member` ps = Applied | ip `S.member` ps = explicit_state- | amend_obsoleted = Obsolete- | ip `S.member` subs && not (piInverted p) = Obsolete- | ip `S.member` subs && piInverted p = Obsoleting+ | amend_obsoleted = Obsoleted+ | ip `S.member` subs && not (piInverted p) = Obsoleted | otherwise = explicit_state where context = peContext (p2pe d ! p)+ history = peStateHistory (p2pe d ! p) ps = r2p d ! r ip = inversePatch p subs = M.keysSet (p2pe d)- explicit_state = max NotApplied (M.findWithDefault Unmatched p (p2s d))+ explicit_state = maximum $ New : map (\(_,_,s) -> s) history amend_obsoleted = any (`laterThan` p) $ S.toList (u2p d ! (normalizeAuthor (piAuthor p))) p1 `laterThan` p2 = piAuthor p1 == piAuthor p2@@ -230,34 +265,32 @@ && piInverted p1 == piInverted p2 && piDate p1 > piDate p2 -instance Show PatchState where- show Unmatched = "Unmatched"- show Applied = "Applied"- show NotApplied = "Not yet applied"- show Rejected = "Marked rejected"- show Obsolete = "Marked obsolete"- show Obsoleting = "Marking patch as obsolete"+showState New = "Seen bundle"+showState Applicable = "Not yet fully applied bundle"+showState Rejected = "Bundle marked rejected"+showState Obsoleted = "Bundle marked obsolete"+showState Applied = "Bundle fully applied" -stateColor Applied = "green"-stateColor NotApplied = "red"-stateColor Obsolete = "gray"+stateColor New = "black"+stateColor Applicable = "red"+stateColor Obsoleted = "gray" stateColor Rejected = "brown"-stateColor Obsoleting = "gray"-stateColor Unmatched = "black"+stateColor Applied = "green" inColor c = thespan !!! [thestyle ("color:"++c)] -viewState d p r = inColor (stateColor s) << (show s)+viewState d p r = inColor (stateColor s) << (showState s) where s = state d p r +(!!!) :: ADDATTRS a => a -> [HtmlAttr] -> a (!!!) = (Text.XHtml.!) userStats u d = " " +++ show (length ps) +++ " tracked patches, "+++- count NotApplied "unapplied" +++- count Obsolete "obsolete" ++++ count Applicable "unapplied" ++++ count Obsoleted "obsolete" +++ count Rejected "rejected" where (ps, sps) = userData u d count s t = case sps !!!! s of@@ -269,8 +302,8 @@ show (S.size (r2p d !!!! r)) +++ " patches in inventory "+++ count Applied "tracked" +++- count NotApplied "applicable" +++- count Obsolete "obsolete" ++++ count Applicable "applicable" ++++ count Obsoleted "obsolete" +++ count Rejected "rejected" where (ps, sps) = repoData r d count s t = case sps !!!! s of@@ -285,12 +318,13 @@ userData u d = (ps, sorted) where ps = patchSort $ S.toList $ u2p d !!!! u sorted = MM.fromList $ map (\p -> (state' p, p)) ps- state' p | S.null repos = Unmatched+ state' p | S.null repos = New | otherwise = S.findMax (S.map (state d p) repos) where repos = p2pr d !!!! p userFile u = "user_" ++ B.unpack (normalizeAuthor u) ++ ".html" repoFile r = "repo_" ++ safeName r ++ ".html"+patchDiffFile p = "diff_" ++ patchBasename p ++ ".txt" normalizeAuthor name | not (B.null r') && valid = email | otherwise = safeNameB name@@ -312,3 +346,6 @@ instance HTML ByteString where toHtml = toHtml . B.unpack++instance HTML UTCTime where+ toHtml = toHtml . formatTime defaultTimeLocale "%c"
+ src/ImportBundle-Main.hs view
@@ -0,0 +1,48 @@+{-+Copyright (C) 2009 Joachim Breitner++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}++import Darcs+import qualified Data.Map as M+import Data.Digest.OpenSSL.MD5 (md5sum)+import Data.List+import System.Environment+import System.Directory+import Control.Monad+import qualified Data.ByteString.Char8 as B+import Data.Maybe+import System.FilePath++import Darcs.Watch.Data+import Darcs.Watch.Storage++main = do+ args <- getArgs+ let (confdir, file) = case args of+ [confdir, file] -> (confdir, file)+ _ -> error "Use convert confdir/ patchfile"+ putStrLn "Reading configuration..."+ config <- read `fmap` readFile (confdir </> "config")++ putStrLn "Reading patch bundle..."+ mail <- B.readFile file+ let bundle = parseMail mail+ bhash <- addBundle (cData config) bundle+ changeBundleState (cData config) bhash ManualImport New+ putStrLn $ "Sucessfully added " ++ bhash+
+ src/ImportMail-Main.hs view
@@ -0,0 +1,47 @@+{-+Copyright (C) 2009 Joachim Breitner++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}++import qualified Data.Map as M+import System.Environment+import Control.Monad+import Data.Maybe+import System.FilePath+import System.Posix.IO++import Darcs.Watch.Data+import Darcs.Watch.ImportMail+import Darcs.Watch.UpdateRepoData+import Darcs.Watch.GenerateOutput+import LockRestart++main = do+ args <- getArgs+ let (confdir) = case args of+ [confdir] -> (confdir)+ _ -> error "Use import-mail confdir/ and pipe mail to it"+ config <- read `fmap` readFile (confdir </> "config")+ foundMail <- importMail config+ when foundMail $ do+ -- We do not want output here+ nullFd <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags + dupTo nullFd stdOutput+ + lockRestart (cData config) False or False $ \new -> do+ updateRepoData config+ generateOutput config new
− src/Main.hs
@@ -1,198 +0,0 @@-{--Copyright (C) 2008 Joachim Breitner--This program is free software; you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation; either version 2, or (at your option)-any later version.--This program is distributed in the hope that it will be useful,-but WITHOUT ANY WARRANTY; without even the implied warranty of-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the-GNU General Public License for more details.--You should have received a copy of the GNU General Public License-along with this program; see the file COPYING. If not, write to-the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,-Boston, MA 02110-1301, USA.--}---import Control.Monad-import Control.Concurrent-import System.Environment (getArgs)-import System.Directory-import System.Posix.Files-import System.Time-import System.IO-import System.Terminal.Concurrent--import qualified Data.Map as M-import qualified Data.Set as S-import qualified MultiMap as MM-import MultiMap ((!!!!))-import Data.Char-import Data.List--import qualified Data.ByteString.Char8 as B-import Data.ByteString.Char8 (ByteString)---- Darcs stuff-import Darcs--- Web ouput-import HTML-import LockRestart--import Data.Digest.OpenSSL.MD5 (md5sum)--data DarcsWatchConfig = DarcsWatchConfig {- cRepositories :: [String],- cOutput :: String,- cMails :: String- } deriving (Show, Read)---main = do- hSetBuffering stdout NoBuffering- args <- getArgs- let (confdir, patchNew) = case args of- [confdir] -> (addSlash confdir, False)- [confdir, "new"] -> (addSlash confdir, True)- _ -> error "Use darcswatch confdir/"- putStrLn "Reading configuration..."- config <- read `fmap` readFile (confdir ++ "config")-- lockRestart (cOutput config) patchNew or True (do_work config)--do_work config patchNew = do- writeC <- getConcurrentOutputter-- putStrLn "Reading repositories..."- let loadInv rep = do- writeC $ "Reading " ++ rep ++ ":\n"- (ps,thisNew) <- getInventory writeC (cOutput config ++ "/cache/") rep- writeC (if thisNew then "Repostory is new.\n" else "Repository is cached.\n")- return (rep, ps, thisNew)- readInv (p2r,r2p,new) (rep, ps,thisNew) = do- let p2r' = foldr (\p -> MM.append p rep) p2r ps- r2p' = MM.extend rep ps r2p :: M.Map String (S.Set PatchInfo)- return (p2r', r2p', new || thisNew)- (p2r,r2p, new) <- foldM readInv (MM.empty, MM.empty, patchNew) =<<- forkSequence (map loadInv (cRepositories config))-- if not new then putStrLn "Nothing new, exiting" else do-- putStrLn "Reading emails..."- mailFiles' <- getDirectoryFiles (cMails config)- let mailFiles = filter ((addSlash (cMails config) ++ "patch") `isPrefixOf`) mailFiles'-- let readMail (u2p, u2rn, p2pe, md2p) mailFile = do- putStrLn $ "Reading mail " ++ mailFile ++ " ..."- mail <- B.readFile mailFile- let checksum = md5sum mail- let (new,context) = parseMail mail- let u2p' = foldr (\(p,_) -> MM.append (normalizeAuthor (piAuthor p)) p) u2p new- let u2rn' = foldr (\(p,_) ->- M.insertWith (maxBy B.length) (normalizeAuthor (piAuthor p)) (piAuthor p)- ) u2rn new- let p2pe' = foldr (\(p,d) ->- let pe = PatchExtras d context mailFile- -- The patch with the smaller context is the more useful- in M.insertWith (minBy (length.peContext)) p pe- ) p2pe new- let md2p' = MM.extend checksum (map fst new) md2p- return (u2p', u2rn', p2pe', md2p')- (u2p, u2rn, p2pe, md2p) <- foldM readMail (MM.empty, M.empty, M.empty, MM.empty) mailFiles-- putStrLn "Reading bundle states..."- states <- readFile (addSlash (cMails config) ++ "states")- let readStateLine string =- let (checksum: stateString : _ : rest) = words string- sender = unwords rest- state = case stateString of- "add" -> Unmatched- "obsolete" -> Obsolete- "rejected" -> Rejected- unknown -> error $ "Unknown state " ++ show unknown- in flip (foldr (\p -> M.insert p state)) (md2p !!!! checksum)- p2s = foldl (flip readStateLine) M.empty (lines states)-- putStrLn "Reading mid to patch mapping..."- midmappings <- readFile (addSlash (cMails config) ++ "mid-mapping")- let readMidLine string =- let [mid,checksum] = words string- in flip (foldr (\p -> M.insert p mid)) (md2p !!!! checksum)- p2mid = foldl (flip readMidLine) M.empty (lines midmappings)-- let patches = M.keys p2pe -- Submitted patches- let repos = M.keys r2p -- Repos with patches- let users = M.keys u2p -- Known users-- let addables = do -- List modad- patch <- patches- repo <- repos- pe <- M.lookup patch p2pe- present <- M.lookup repo r2p- guard $ all (`S.member` present) (peContext pe)- return (patch, repo)- -- Patch to possible repos- -- Repo to possible patch- let p2pr = foldr (\(p,r) -> MM.append p r) MM.empty addables- let r2mp = foldr (\(p,r) -> MM.append r p) MM.empty addables-- -- Unmatched patches- let unmatched = S.fromList $ filter (\p -> not (M.member p p2pr)) patches-- now <- getClockTime >>= toCalendarTime- let resultData = ResultData p2r r2p u2p p2pe p2pr r2mp p2s p2mid unmatched now u2rn- - {-- putStrLn "Evalutating data"- putStrLn (show (length (show (resultData))))- -}-- putStrLn "Writing output..."- writeFile (cOutput config ++ "/index.html") (mainPage resultData)-- forM_ users $ \u ->- writeFile (cOutput config ++ "/" ++ userFile u) (userPage resultData u)-- forM_ repos $ \r ->- writeFile (cOutput config ++ "/" ++ repoFile r) (repoPage resultData r)-- writeFile (cOutput config ++ "/" ++ "unmatched.html") (unmatchedPage resultData)-- putStrLn "Linking patches"- let patchLink (p,pe) = do- let link = cOutput config ++ "/" ++ patchBasename p ++ ".dpatch"- ex <- fileExist link- unless ex $ do- -- There might be a broken symlink here:- catch (removeFile link) (const (return ()))- createSymbolicLink (peMailFile pe) link- mapM_ patchLink $ M.toList p2pe-- return ()--getDirectoryFiles dir' = getDirectoryContents dir >>=- return . (map (dir++)) >>=- return . filter ((/= '.') . head) >>=- filterM doesFileExist >>=- filterM ((readable `fmap`) . getPermissions)- where dir = addSlash dir'--maxBy f v1 v2 = if f v1 >= f v2 then v1 else v2-minBy f v1 v2 = if f v1 <= f v2 then v1 else v2---addSlash filename | last filename == '/' = filename- | otherwise = filename ++ "/"---- not in ghc6.6-infixl 0 `on`-on :: (b -> b -> c) -> (a -> b) -> a -> a -> c-(*) `on` f = \x y -> f x * f y--{- forkSequence = sequence -}--- Enable for parallel downloads-forkSequence acts = mapM (\act -> newEmptyMVar >>= \mvar -> forkIO (act >>= putMVar mvar) >> return mvar) acts >>= mapM takeMVar
+ src/PullRepos-Main.hs view
@@ -0,0 +1,66 @@+{-+Copyright (C) 2008 Joachim Breitner++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}+++import Control.Monad+import Control.Concurrent+import Control.Applicative+import System.Environment (getArgs)+import System.Directory+import System.Posix.Files+import System.Time+import System.IO+import System.Terminal.Concurrent++import qualified Data.Map as M+import qualified Data.Set as S+import qualified MultiMap as MM+import MultiMap ((!!!!))+import Data.Char+import Data.List++import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 (ByteString)+import Data.Digest.OpenSSL.MD5 (md5sum)+import Data.Maybe+import System.FilePath++-- Darcs stuff+import Darcs+import Darcs.Watch.Data+import Darcs.Watch.PullRepos+import Darcs.Watch.UpdateRepoData+import Darcs.Watch.GenerateOutput+import LockRestart++main = do+ hSetBuffering stdout NoBuffering+ args <- getArgs+ let confdir = case args of+ [confdir] -> confdir+ _ -> error "Use darcswatch confdir/"+ putStrLn "Reading configuration..."+ config <- read `fmap` readFile (confdir </> "config")++ --lockRestart (cOutput config) patchNew or True (do_work config)+ new <- pullRepos config+ when new $ do+ lockRestart (cData config) False or True $ \new -> do+ updateRepoData config+ generateOutput config new
+ src/SHA1.hs view
@@ -0,0 +1,206 @@+-- Copyright (C) 2001, 2004 Ian Lynagh <igloo@earth.li>+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# OPTIONS_GHC -fno-warn-name-shadowing -cpp #-}+{-# LANGUAGE CPP #-}+++-- {-# OPTIONS_GHC -fglasgow-exts -fno-warn-name-shadowing #-}+-- -fglasgow-exts needed for nasty hack below+-- name shadowing disabled because a,b,c,d,e are shadowed loads in step 4+module SHA1 (sha1PS) where++import ByteStringUtils (unsafeWithInternals)+import qualified Data.ByteString as B (ByteString, pack, length, concat)++import Data.Char (intToDigit)+import Data.Bits (xor, (.&.), (.|.), complement, rotateL, shiftL, shiftR)+import Data.Word (Word8, Word32)+import Foreign.Ptr (Ptr, castPtr)+import Foreign.Marshal.Array (advancePtr)+import Foreign.Storable (peek, poke)+import System.IO.Unsafe (unsafePerformIO)++data ABCDE = ABCDE !Word32 !Word32 !Word32 !Word32 !Word32+data XYZ = XYZ !Word32 !Word32 !Word32++sha1PS :: B.ByteString -> String+sha1PS s = s5+ where s1_2 = sha1_step_1_2_pad_length s+ abcde = sha1_step_3_init+ abcde' = unsafePerformIO+ $ unsafeWithInternals s1_2 (\ptr len ->+ do let ptr' = castPtr ptr+#ifndef BIGENDIAN+ fiddle_endianness ptr' len+#endif+ sha1_step_4_main abcde ptr' len)+ s5 = sha1_step_5_display abcde'++fiddle_endianness :: Ptr Word32 -> Int -> IO ()+fiddle_endianness p 0 = p `seq` return ()+fiddle_endianness p n+ = do x <- peek p+ poke p $ shiftL x 24+ .|. shiftL (x .&. 0xff00) 8+ .|. (shiftR x 8 .&. 0xff00)+ .|. shiftR x 24+ fiddle_endianness (p `advancePtr` 1) (n - 4)++-- sha1_step_1_2_pad_length assumes the length is at most 2^61.+-- This seems reasonable as the Int used to represent it is normally 32bit,+-- but obviously could go wrong with large inputs on 64bit machines.+-- The B.ByteString library should probably move to Word64s if this is an+-- issue, though.++sha1_step_1_2_pad_length :: B.ByteString -> B.ByteString+sha1_step_1_2_pad_length s+ = let len = B.length s+ num_nuls = (55 - len) `mod` 64+ padding = 128:replicate num_nuls 0+ len_w8s = reverse $ size_split 8 (fromIntegral len*8)+ in B.concat [s, B.pack padding, B.pack len_w8s]++size_split :: Int -> Integer -> [Word8]+size_split 0 _ = []+size_split p n = fromIntegral d:size_split (p-1) n'+ where (n', d) = divMod n 256++sha1_step_3_init :: ABCDE+sha1_step_3_init = ABCDE 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0++sha1_step_4_main :: ABCDE -> Ptr Word32 -> Int -> IO ABCDE+sha1_step_4_main abcde _ 0 = return $! abcde+sha1_step_4_main (ABCDE a0@a b0@b c0@c d0@d e0@e) s len+ = do+ (e, b) <- doit f1 0x5a827999 (x 0) a b c d e+ (d, a) <- doit f1 0x5a827999 (x 1) e a b c d+ (c, e) <- doit f1 0x5a827999 (x 2) d e a b c+ (b, d) <- doit f1 0x5a827999 (x 3) c d e a b+ (a, c) <- doit f1 0x5a827999 (x 4) b c d e a+ (e, b) <- doit f1 0x5a827999 (x 5) a b c d e+ (d, a) <- doit f1 0x5a827999 (x 6) e a b c d+ (c, e) <- doit f1 0x5a827999 (x 7) d e a b c+ (b, d) <- doit f1 0x5a827999 (x 8) c d e a b+ (a, c) <- doit f1 0x5a827999 (x 9) b c d e a+ (e, b) <- doit f1 0x5a827999 (x 10) a b c d e+ (d, a) <- doit f1 0x5a827999 (x 11) e a b c d+ (c, e) <- doit f1 0x5a827999 (x 12) d e a b c+ (b, d) <- doit f1 0x5a827999 (x 13) c d e a b+ (a, c) <- doit f1 0x5a827999 (x 14) b c d e a+ (e, b) <- doit f1 0x5a827999 (x 15) a b c d e+ (d, a) <- doit f1 0x5a827999 (m 16) e a b c d+ (c, e) <- doit f1 0x5a827999 (m 17) d e a b c+ (b, d) <- doit f1 0x5a827999 (m 18) c d e a b+ (a, c) <- doit f1 0x5a827999 (m 19) b c d e a+ (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e+ (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d+ (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c+ (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b+ (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a+ (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e+ (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d+ (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c+ (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b+ (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a+ (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e+ (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d+ (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c+ (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b+ (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a+ (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e+ (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d+ (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c+ (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b+ (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a+ (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e+ (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d+ (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c+ (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b+ (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a+ (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e+ (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d+ (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c+ (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b+ (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a+ (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e+ (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d+ (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c+ (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b+ (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a+ (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e+ (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d+ (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c+ (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b+ (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a+ (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e+ (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d+ (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c+ (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b+ (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a+ (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e+ (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d+ (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c+ (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b+ (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a+ (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e+ (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d+ (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c+ (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b+ (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a+ (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e+ (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d+ (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c+ (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b+ (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a+ let abcde' = ABCDE (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e)+ sha1_step_4_main abcde' (s `advancePtr` 16) (len - 64)+ where {-# INLINE f1 #-}+ f1 (XYZ x y z) = (x .&. y) .|. ((complement x) .&. z)+ {-# INLINE f2 #-}+ f2 (XYZ x y z) = x `xor` y `xor` z+ {-# INLINE f3 #-}+ f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z)+ {-# INLINE x #-}+ x n = peek (s `advancePtr` n)+ {-# INLINE m #-}+ m n = do let base = s `advancePtr` (n .&. 15)+ x0 <- peek base+ x1 <- peek (s `advancePtr` ((n - 14) .&. 15))+ x2 <- peek (s `advancePtr` ((n - 8) .&. 15))+ x3 <- peek (s `advancePtr` ((n - 3) .&. 15))+ let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1+ poke base res+ return res+ {-# INLINE doit #-}+ doit f k i a b c d e = a `seq` c `seq`+ do i' <- i+ return (rotateL a 5 + f (XYZ b c d) + e + i' + k,+ rotateL b 30)++sha1_step_5_display :: ABCDE -> String+sha1_step_5_display (ABCDE a b c d e)+ = concatMap showAsHex [a, b, c, d, e]++showAsHex :: Word32 -> String+showAsHex n = showIt 8 n ""+ where+ showIt :: Int -> Word32 -> String -> String+ showIt 0 _ r = r+ showIt i x r = case quotRem x 16 of+ (y, z) -> let c = intToDigit (fromIntegral z)+ in c `seq` showIt (i-1) y (c:r)
+ src/UpdateRepoData-Main.hs view
@@ -0,0 +1,61 @@+{-+Copyright (C) 2008 Joachim Breitner++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}+++import Control.Monad+import Control.Concurrent+import Control.Applicative+import System.Environment (getArgs)+import System.Directory+import System.Posix.Files+import System.Time+import System.IO+import System.Terminal.Concurrent++import qualified Data.Map as M+import qualified Data.Set as S+import qualified MultiMap as MM+import MultiMap ((!!!!))+import Data.Char+import Data.List++import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 (ByteString)+import Data.Digest.OpenSSL.MD5 (md5sum)+import Data.Maybe+import System.FilePath++-- Darcs stuff+import Darcs+import Darcs.Watch.UpdateRepoData+import Darcs.Watch.Data++++main = do+ hSetBuffering stdout NoBuffering+ args <- getArgs+ let confdir = case args of+ [confdir] -> confdir+ _ -> error "Use darcswatch confdir/"+ putStrLn "Reading configuration..."+ config <- read `fmap` readFile (confdir </> "config")++ --lockRestart (cOutput config) patchNew or True (do_work config)+ updateRepoData config
+ src/Zip.hs view
@@ -0,0 +1,15 @@+module Zip (unzipB, maybeUnzipB) where++import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 (ByteString)++import qualified Data.ByteString.Lazy as L++import Codec.Compression.GZip+++unzipB :: ByteString -> ByteString+unzipB = B.concat . L.toChunks . decompress . L.fromChunks . (:[])++maybeUnzipB :: ByteString -> ByteString+maybeUnzipB s = if B.pack "\US\139" `B.isPrefixOf` s then unzipB s else s