diff --git a/darcswatch.cabal b/darcswatch.cabal --- a/darcswatch.cabal +++ b/darcswatch.cabal @@ -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 diff --git a/documentation.html b/documentation.html --- a/documentation.html +++ b/documentation.html @@ -21,6 +21,7 @@
  • Link to the submitting mail on gmane.org, if Message-ID is known.
  • Knows about inverse and amend-recorded patches and uses them to consider patches obsolete.
  • Knows about tagged repositories and reads the old patches as well.
    • +
  • Integrates into a roundup bug tracker (at the moment, this feature is hardcoded with the instance on http://bugs.darcs.net/.

    • How can i use DarcsWatch?

    @@ -33,12 +34,15 @@

    To have your patch submissions tracked, you have to send them to darcswatch@nomeata.de. The easiest way to achieve this is by adding the line send cc darcswatch@nomeata.de to ~/.darcs/defaults.

    If the repositories you are submitting to are not yet tracked, you have to drop a note to Joachim Breitner with the repository URL, and it will be added.

    -

    ...as a project maintainer with a mailing list?

    If you receive patches on a mailing list and want to have them tracked by DarcsWatch, just subscribe darcswatch@nomeata.de to the list, and drop Joachim Breitner a note with the darcs repository URL.

    ...as a project maintainer without a mailing list?

    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 darcswatch@nomeata.de. If you can not do that. get in touch with Joachim Breitner, he might be able to set something up for you.

    + +

    ...as developer on the darcs.net codebase?

    +

    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”. +

    Other questions.

    diff --git a/example/config b/example/config --- a/example/config +++ b/example/config @@ -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 } diff --git a/example/keyring b/example/keyring deleted file mode 100644 Binary files a/example/keyring and /dev/null differ diff --git a/example/mails/patchBEbWYh b/example/mails/patchBEbWYh deleted file mode 100644 --- a/example/mails/patchBEbWYh +++ /dev/null @@ -1,156 +0,0 @@ ------BEGIN PGP SIGNED MESSAGE----- -Hash: SHA1 - - -New patches: - -[Fix window order in EWMH -Joachim Breitner **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 **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 **20080409174935] -[Generalize copyWindow, minor style change -Spencer Janssen **20080408210050] -[XMonad.Actions.CopyWindow: added copyToAll and killAllOtherCopies functions -Ivan N. Veselov **20080408195111] -[XMonad.Actions.UpdatePointer: doc fix -Lukas Mai **20080407152741] -[XMonad.Util.Font: minor reformatting -Lukas Mai **20080406020935] -[DynamicLog: resolve merge conflict -Lukas Mai **20080406020527] -[Encode the entire DynamicLog output, instead of just window title. -lithis **20080329031537] -[DynamicLog: add support for UTF-8 locales when compiled with XFT or UFT-8 support -Andrea Rossato **20080313102643] -[XMonad.Util.Font: don't call setlocale; core does it for us -Lukas Mai **20080406013123] -[XMonad.Util.NamedWindows: fix imports -Lukas Mai **20080326172745] -[Changed getName to use locale-aware functions -Mats Jansborg **20070819132104 - Rewrote getName using getTextProperty and wcTextPropertyToTextList. -] -[Added next-window versions of the raise* functions. -Ian Zerny **20080405182900] -[XMonad.Layout.Master: initial import -Lukas Mai **20080404220734] -[update contrib for applySizeHints changes -Lukas Mai **20080404220558] -[XMonad.Hooks.ManageDocks: haddock fix -Lukas Mai **20080404220532] -[MultiToggle/Instances: ghc 6.6 can't parse LANGUAGE pragma -Brent Yorgey **20080404200157] -[onstart=lower, solves floating dzen issue -Don Stewart **20080403203425] -[some bang patterns -Don Stewart **20080403172246] -[have 'dzen' use autoStruts to detect the gaps -Don Stewart **20080403003130] -[Actions/Search.hs: add dictionary.com search -Brent Yorgey **20080402150521] -[HintedGrid: guesstimate window flexibility and layout rigid windows first -Lukas Mai **20080402042846] -[HintedGrid: try both bottom-up/top-down window placement to minimize unused space -Lukas Mai **20080402012538] -[Grid/HintedGrid: use an ncolumns formula inspired by dwm's "optimal" mode -Lukas Mai **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 **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 **20080401231722] -[Documentation improvement. -Roman Cheplyaka **20080401134305] -[Remove broken link to screenshot. -Roman Cheplyaka **20080331210854] -[MultiToggle: add new XMonad.Layout.MultiToggle.Instances module for common instances of Transformer, update MultiToggle docs accordingly -Brent Yorgey **20080331201739] -[XMonad.Actions.CycleRecentWS: initial import -Michal Janeczek **20080331111906] -[XMonad.Hooks.ManageDocks: export checkDoc -Lukas Mai **20080331012911] -[XMonad.Layout.Grid: fix indentation -Lukas Mai **20080330004859] -[move Direction type from WindowNavigation to ManageDocks (ManageDocks will move into the core, taking Direction with it) -Brent Yorgey **20080331010127] -[ManageDocks: clean up + add more documentation -Brent Yorgey **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 **20080328205446] -[ManageDocks: add avoidStrutsOn, for covering some docks and not others by default. -Brent Yorgey **20080327203940] -[ManageDocks: add ability to toggle individual gaps independently -Brent Yorgey **20080327111722] -[PerWorkspace: add modWorkspace(s) combinators, for selectively applying layout modifiers to certain workspaces but not others -Brent Yorgey **20080326214351] -[Haddock fix -Roman Cheplyaka **20080330134435] -[Remove stale status gaps code -Spencer Janssen **20080329230737] -[Document _NET_ACTIVE_WINDOW behaviour more exactly -Joachim Breitner **20080404072944] -[_NET_ACTIVE_WINDOW moves windows if necessary -Joachim Breitner *-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 **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 **20080329202416] -Patch bundle hash: -ab26456486b1f248e095142caf4024e933dc010a ------BEGIN PGP SIGNATURE----- -Version: GnuPG v1.4.6 (GNU/Linux) - -iD8DBQFH/2vF9ijrk0dDIGwRAptwAJ9n0lgCRYVBsC99ADebFthaUf8wXwCgwD/+ -UvLM4JSNTaZgd6MhA+Y7BYk= -=2Nz3 ------END PGP SIGNATURE----- diff --git a/example/mails/patchInvTest b/example/mails/patchInvTest deleted file mode 100644 --- a/example/mails/patchInvTest +++ /dev/null @@ -1,147 +0,0 @@ ------BEGIN PGP SIGNED MESSAGE----- -Hash: SHA1 - - -New patches: - -[Dummy commit -Joachim Breitner **20080416213715] { -hunk ./README 50 -+Dummy commit -+ -} - -[Dummy commit -Joachim Breitner *-20080416213715] { -hunk ./README 50 -- -Dummy commit -- - -} - -Context: - -[MultiMap.fromList -Joachim Breitner **20080416213440] -[Multimap lookup with default -Joachim Breitner **20080416200945] -[TODO: Documentation -mail@joachim-breitner.de**20080416193846] -[unTODO Cabal and Caching -mail@joachim-breitner.de**20080416193826] -[add License-File header -Joachim Breitner **20080416193135] -[basic cabal support - please check that you like the contents -marco-oweber@gmx.de**20080416191953] -[strict reading of tagFile -Joachim Breitner **20080416191500] -[Force an update from the mail script -Joachim Breitner **20080416150644] -[Only regenerate pages if there is something new. -Joachim Breitner **20080416150525] -[pass up-to-dateness to caller in getInventory -Joachim Breitner **20080416144419] -[Add UserAgent Header to requests -Joachim Breitner **20080416143833] -[Pass cache directory to getInventory -Joachim Breitner **20080416143402] -[Use CachedGet in Darcs.hs -Joachim Breitner **20080416142626] -[CachedGet module for Cached HTTP -Joachim Breitner **20080416142301] -[Enable receiving mails from the darcs list -Joachim Breitner **20080416135921] -[Use MultiMap -Joachim Breitner **20080416135024] -[Some helpers for Map k [v] or Map k (Set v) -Joachim Breitner **20080416135006] -[Describe Darcs.hs separation -Joachim Breitner **20080415225608] -[Put the rest under the GPL -Joachim Breitner **20080415225151] -[Put Darcs.hs and StringCrypto.hs under the GPL -Joachim Breitner **20080415225137] -[Add GPL licence -Joachim Breitner **20080415225118] -[unTODO diff view -Joachim Breitner **20080415222355] -[Add toggle button for diffs -Joachim Breitner **20080415222114] -[Liberal inventory parsing, also works with hashed -Joachim Breitner **20080415215043] -[Add darcs.net to example file -Joachim Breitner **20080415213149] -[Use getInventory from Darcs.hs -Joachim Breitner **20080415213128] -[Move getInventory to darcs.hs, stub for hashed -Joachim Breitner **20080415212944] -[Use pure parseInventory -Joachim Breitner **20080415212126] -[Make parseInventory pure -Joachim Breitner **20080415212101] -[Make Darcs.hs accept darcs2.0 submissions without '{' -Joachim Breitner **20080415211235] -[Improve bash code quality slightly -Joachim Breitner **20080415210005] -[Use the md5sum for the patch file to avoid duplicates -Joachim Breitner **20080415202850] -[unTODO download link -Joachim Breitner **20080415201447] -[Document dependencies -Joachim Breitner **20080415201439] -[Factor out common page footer -Joachim Breitner **20080415200819] -[Refactor patchlists, add crosslinks and links to dpatch files -Joachim Breitner **20080415200401] -[Create symlinks to the dpatch files -Joachim Breitner **20080415194550] -[patchBasename function for Darcs.hs -Joachim Breitner **20080415193016] -[HTML.hs uses StringCrypto -Joachim Breitner **20080415192014] -[OldDate module stolen from darcs -Joachim Breitner **20080415191533] -[Use the crypto library, create wrapper module for md5,sha1 -Joachim Breitner **20080415191246] -[typo -Joachim Breitner **20080415100920] -[Add footer with current date -Joachim Breitner **20080415100517] -[Factor out repo/user statistics -Joachim Breitner **20080415095612] -[Add lambdabot to example (large repository) -Joachim Breitner **20080414225332] -[Newest patches first -Joachim Breitner **20080414225311] -[Also work on untagged repositories (lambdabot) -Joachim Breitner **20080414225251] -[List unmatched patches separately -Joachim Breitner **20080414224435] -[Split patches in the per-user view -Joachim Breitner **20080414214504] -[Added README -Joachim Breitner **20080414213958] -[Adding the rest of the files for the very alpha release -Joachim Breitner **20080414213500] -[Actually add Igloos MD5.lhs file -Joachim Breitner **20080414212717] -[Mailfilter helper script -Joachim Breitner **20080414212622] -[More examples -Joachim Breitner **20080414212513] -[Darcs glue code: Parsing mails and inventories -Joachim Breitner **20080414201515] -[Igloos MD5 script, with glue -Joachim Breitner **20080414191343 - Changes made so that it runs without cpp. -] -[Example files -Joachim Breitner **20080414105511] -Patch bundle hash: -36530b7ca0867608c190be96207c3589c20a73c0 ------BEGIN PGP SIGNATURE----- -Version: GnuPG v1.4.6 (GNU/Linux) - -iD8DBQFIBnG59ijrk0dDIGwRAl0mAJ9B71aQ/8YqM1DPiOPgij5y2WZ0ugCdGDsq -Zd1DG512xTXedFmTwKYrQFw= -=VF6v ------END PGP SIGNATURE----- diff --git a/example/mails/patchOKsIKA b/example/mails/patchOKsIKA deleted file mode 100644 --- a/example/mails/patchOKsIKA +++ /dev/null @@ -1,79 +0,0 @@ ------BEGIN PGP SIGNED MESSAGE----- -Hash: SHA1 - - -New patches: - -[Add rqUri field to Record -Joachim Breitner **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 **20080314160613] -[Fix haddock annotation and bump version. -Lemmih **20080229152550] -[Cabal wibble. -Lemmih **20080222232935] -[Cabal wibble. -Lemmih **20080222232730] -[TAG 0.9.2 -Lemmih **20080222225514] -[Bump version to 0.9.2 -Lemmih **20080222225151] -[Update snippet in package-info.xml -Lemmih **20080222223603] -[Don't rely on Xml for serialization. -Lemmih **20080222223302] -[Match changes in HAppS-State. -Lemmih **20080218201437] -[fix conflicts -alex@happs.org**20080216004432] -[Match development in HAppS-State. -Lemmih **20080215010026] -[Match changes in HAppS-State. -Lemmih **20080215004016] -[Comment for AllIn.hs -Lemmih **20080214234424] -[Don't use Xml for serialization. -Lemmih **20080214233742] -[Don't export Cron from SimpleHTTP. -Lemmih **20080212154505] -[Remove ServerPart.hs -Lemmih **20080212154312] -[Update examples to match development in HAppS-State. -Lemmih **20080212142058] -[Show usage of componentInit in AllIn.hs -Lemmih **20080212011338] -[TAG 0.9.1.5 -Lemmih **20080209112439] -Patch bundle hash: -2cfe23050f9e12a183d2bdf2a397e838784bfe47 ------BEGIN PGP SIGNATURE----- -Version: GnuPG v1.4.6 (GNU/Linux) - -iD8DBQFH9Ll99ijrk0dDIGwRAocCAKC+7c5MEvlsUVPGNe5y3S8qitrHcgCcCzZ9 -Fw7xAlKqKaaml0NAiSkTO7E= -=vZHQ ------END PGP SIGNATURE----- diff --git a/example/mails/patch_1f03d40fbe9d0593a9eb7fbefc3bfa85 b/example/mails/patch_1f03d40fbe9d0593a9eb7fbefc3bfa85 deleted file mode 100644 --- a/example/mails/patch_1f03d40fbe9d0593a9eb7fbefc3bfa85 +++ /dev/null @@ -1,332 +0,0 @@ -New patches: - -[Little style change (avoid a bind+return). -Nicolas Pouillard **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 **20080414133342 - Apparently it didn't actually work... - - rolling back: - - Tue Apr 8 07:58:56 PDT 2008 David Roundy - * 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 **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 . -] -[fix typo in show_bug_help -Matyas Janos **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 **20080408151912] -[resolve issue385: don't worry if we can't get local changes. -David Roundy **20080408151823] -[add test for issue385. -David Roundy **20080408151808] -[resolve issue786: implement oops command. -David Roundy **20080408145856] -[fix URL in network test. -David Roundy **20080408145407] -[fix manual bug. -David Roundy **20080407191736] -[add new show bug command (hidden) to see what darcs will report if we encounter a bug. -David Roundy **20080407175410] -[automatically work out the version of the stable release. -David Roundy **20080407171850] -[set prefs again (they got lost on convert). -David Roundy **20080407171559] -[update darcs repository URL. -David Roundy **20080407164601] -[fix up website for new release. -David Roundy **20080407164010] -[simplify determine_release_state.pl. -David Roundy **20080407153000] -[make determine_release_state.pl use changes --count. -David Roundy **20080407152347] -[add --count output option to changes. -David Roundy **20080407151825] -[TAG 2.0.0 -David Roundy **20080407150638] -Patch bundle hash: -45247877729e0cfc5f1be0417f1d8c7deb8e740f - ---=_ diff --git a/example/mails/patch_a963212153b4f5e3f1777daa562dd989 b/example/mails/patch_a963212153b4f5e3f1777daa562dd989 deleted file mode 100644 --- a/example/mails/patch_a963212153b4f5e3f1777daa562dd989 +++ /dev/null @@ -1,35 +0,0 @@ ------BEGIN PGP SIGNED MESSAGE----- -Hash: SHA1 - - -New patches: - -[_NET_ACTIVE_WINDOW moves windows if necessary -Joachim Breitner **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 **20080329202416] -Patch bundle hash: -f36c5831faf5b9da4034c203bd52fd22d1ba67bb ------BEGIN PGP SIGNATURE----- -Version: GnuPG v1.4.6 (GNU/Linux) - -iD8DBQFH85t89ijrk0dDIGwRAvt7AJ0UMm4M/tISQqG6zXn1kLqt28becACggtU6 -fjpKiTWI0EyGvJJYmY1bmZQ= -=Orgm ------END PGP SIGNATURE----- diff --git a/example/mails/patchsmaJcF b/example/mails/patchsmaJcF deleted file mode 100644 --- a/example/mails/patchsmaJcF +++ /dev/null @@ -1,130 +0,0 @@ ------BEGIN PGP SIGNED MESSAGE----- -Hash: SHA1 - - -New patches: - -[instance MonadError e m => MonadError e (WebT m) -Joachim Breitner **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 **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 **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 **20080318144925] -[Add a signature to 'debugFilter'. Haddock doesn't show it otherwise. -lemmih **20080314162252] -[Multimaster example. -lemmih **20080314162014] -[Fix typo in runTests.sh -lemmih **20080314160613] -[Fix haddock annotation and bump version. -Lemmih **20080229152550] -[Cabal wibble. -Lemmih **20080222232935] -[Cabal wibble. -Lemmih **20080222232730] -[TAG 0.9.2 -Lemmih **20080222225514] -[Bump version to 0.9.2 -Lemmih **20080222225151] -[Update snippet in package-info.xml -Lemmih **20080222223603] -[Don't rely on Xml for serialization. -Lemmih **20080222223302] -[Match changes in HAppS-State. -Lemmih **20080218201437] -[fix conflicts -alex@happs.org**20080216004432] -[Match development in HAppS-State. -Lemmih **20080215010026] -[Match changes in HAppS-State. -Lemmih **20080215004016] -[Comment for AllIn.hs -Lemmih **20080214234424] -[Don't use Xml for serialization. -Lemmih **20080214233742] -[Don't export Cron from SimpleHTTP. -Lemmih **20080212154505] -[Remove ServerPart.hs -Lemmih **20080212154312] -[Update examples to match development in HAppS-State. -Lemmih **20080212142058] -[Show usage of componentInit in AllIn.hs -Lemmih **20080212011338] -[TAG 0.9.1.5 -Lemmih **20080209112439] -Patch bundle hash: -6579a6aeca01a58d2845d04ea5fe1c1d4b26f8f2 ------BEGIN PGP SIGNATURE----- -Version: GnuPG v1.4.6 (GNU/Linux) - -iD8DBQFH/+8c9ijrk0dDIGwRAuK7AJ9oCvypMMyHlNmyGq9YKja18EykXQCePZC1 -eg+57CyqIz4VNbwrS3BKx9Q= -=qqvc ------END PGP SIGNATURE----- diff --git a/mailfilter.sh b/mailfilter.sh deleted file mode 100644 --- a/mailfilter.sh +++ /dev/null @@ -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 diff --git a/src/ByteStringUtils.hs b/src/ByteStringUtils.hs new file mode 100644 --- /dev/null +++ b/src/ByteStringUtils.hs @@ -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" -} diff --git a/src/CachedGet.hs b/src/CachedGet.hs --- a/src/CachedGet.hs +++ b/src/CachedGet.hs @@ -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" diff --git a/src/ConvertData-Main.hs b/src/ConvertData-Main.hs new file mode 100644 --- /dev/null +++ b/src/ConvertData-Main.hs @@ -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' + diff --git a/src/Darcs.hs b/src/Darcs.hs --- a/src/Darcs.hs +++ b/src/Darcs.hs @@ -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" diff --git a/src/Darcs/Watch/Data.hs b/src/Darcs/Watch/Data.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Watch/Data.hs @@ -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) + diff --git a/src/Darcs/Watch/GenerateOutput.hs b/src/Darcs/Watch/GenerateOutput.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Watch/GenerateOutput.hs @@ -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 diff --git a/src/Darcs/Watch/ImportMail.hs b/src/Darcs/Watch/ImportMail.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Watch/ImportMail.hs @@ -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 diff --git a/src/Darcs/Watch/PullRepos.hs b/src/Darcs/Watch/PullRepos.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Watch/PullRepos.hs @@ -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 diff --git a/src/Darcs/Watch/Roundup.hs b/src/Darcs/Watch/Roundup.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Watch/Roundup.hs @@ -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 diff --git a/src/Darcs/Watch/Storage.hs b/src/Darcs/Watch/Storage.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Watch/Storage.hs @@ -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` "-_.@:" diff --git a/src/Darcs/Watch/UpdateRepoData.hs b/src/Darcs/Watch/UpdateRepoData.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Watch/UpdateRepoData.hs @@ -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 diff --git a/src/Generate-Main.hs b/src/Generate-Main.hs new file mode 100644 --- /dev/null +++ b/src/Generate-Main.hs @@ -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) diff --git a/src/HTML.hs b/src/HTML.hs --- a/src/HTML.hs +++ b/src/HTML.hs @@ -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" diff --git a/src/ImportBundle-Main.hs b/src/ImportBundle-Main.hs new file mode 100644 --- /dev/null +++ b/src/ImportBundle-Main.hs @@ -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 + diff --git a/src/ImportMail-Main.hs b/src/ImportMail-Main.hs new file mode 100644 --- /dev/null +++ b/src/ImportMail-Main.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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 diff --git a/src/PullRepos-Main.hs b/src/PullRepos-Main.hs new file mode 100644 --- /dev/null +++ b/src/PullRepos-Main.hs @@ -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 diff --git a/src/SHA1.hs b/src/SHA1.hs new file mode 100644 --- /dev/null +++ b/src/SHA1.hs @@ -0,0 +1,206 @@ +-- Copyright (C) 2001, 2004 Ian Lynagh +-- +-- This program is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2, or (at your option) +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; see the file COPYING. If not, write to +-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +-- Boston, MA 02110-1301, USA. + +{-# OPTIONS_GHC -fno-warn-name-shadowing -cpp #-} +{-# LANGUAGE CPP #-} + + +-- {-# OPTIONS_GHC -fglasgow-exts -fno-warn-name-shadowing #-} +-- -fglasgow-exts needed for nasty hack below +-- name shadowing disabled because a,b,c,d,e are shadowed loads in step 4 +module SHA1 (sha1PS) where + +import ByteStringUtils (unsafeWithInternals) +import qualified Data.ByteString as B (ByteString, pack, length, concat) + +import Data.Char (intToDigit) +import Data.Bits (xor, (.&.), (.|.), complement, rotateL, shiftL, shiftR) +import Data.Word (Word8, Word32) +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Marshal.Array (advancePtr) +import Foreign.Storable (peek, poke) +import System.IO.Unsafe (unsafePerformIO) + +data ABCDE = ABCDE !Word32 !Word32 !Word32 !Word32 !Word32 +data XYZ = XYZ !Word32 !Word32 !Word32 + +sha1PS :: B.ByteString -> String +sha1PS s = s5 + where s1_2 = sha1_step_1_2_pad_length s + abcde = sha1_step_3_init + abcde' = unsafePerformIO + $ unsafeWithInternals s1_2 (\ptr len -> + do let ptr' = castPtr ptr +#ifndef BIGENDIAN + fiddle_endianness ptr' len +#endif + sha1_step_4_main abcde ptr' len) + s5 = sha1_step_5_display abcde' + +fiddle_endianness :: Ptr Word32 -> Int -> IO () +fiddle_endianness p 0 = p `seq` return () +fiddle_endianness p n + = do x <- peek p + poke p $ shiftL x 24 + .|. shiftL (x .&. 0xff00) 8 + .|. (shiftR x 8 .&. 0xff00) + .|. shiftR x 24 + fiddle_endianness (p `advancePtr` 1) (n - 4) + +-- sha1_step_1_2_pad_length assumes the length is at most 2^61. +-- This seems reasonable as the Int used to represent it is normally 32bit, +-- but obviously could go wrong with large inputs on 64bit machines. +-- The B.ByteString library should probably move to Word64s if this is an +-- issue, though. + +sha1_step_1_2_pad_length :: B.ByteString -> B.ByteString +sha1_step_1_2_pad_length s + = let len = B.length s + num_nuls = (55 - len) `mod` 64 + padding = 128:replicate num_nuls 0 + len_w8s = reverse $ size_split 8 (fromIntegral len*8) + in B.concat [s, B.pack padding, B.pack len_w8s] + +size_split :: Int -> Integer -> [Word8] +size_split 0 _ = [] +size_split p n = fromIntegral d:size_split (p-1) n' + where (n', d) = divMod n 256 + +sha1_step_3_init :: ABCDE +sha1_step_3_init = ABCDE 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0 + +sha1_step_4_main :: ABCDE -> Ptr Word32 -> Int -> IO ABCDE +sha1_step_4_main abcde _ 0 = return $! abcde +sha1_step_4_main (ABCDE a0@a b0@b c0@c d0@d e0@e) s len + = do + (e, b) <- doit f1 0x5a827999 (x 0) a b c d e + (d, a) <- doit f1 0x5a827999 (x 1) e a b c d + (c, e) <- doit f1 0x5a827999 (x 2) d e a b c + (b, d) <- doit f1 0x5a827999 (x 3) c d e a b + (a, c) <- doit f1 0x5a827999 (x 4) b c d e a + (e, b) <- doit f1 0x5a827999 (x 5) a b c d e + (d, a) <- doit f1 0x5a827999 (x 6) e a b c d + (c, e) <- doit f1 0x5a827999 (x 7) d e a b c + (b, d) <- doit f1 0x5a827999 (x 8) c d e a b + (a, c) <- doit f1 0x5a827999 (x 9) b c d e a + (e, b) <- doit f1 0x5a827999 (x 10) a b c d e + (d, a) <- doit f1 0x5a827999 (x 11) e a b c d + (c, e) <- doit f1 0x5a827999 (x 12) d e a b c + (b, d) <- doit f1 0x5a827999 (x 13) c d e a b + (a, c) <- doit f1 0x5a827999 (x 14) b c d e a + (e, b) <- doit f1 0x5a827999 (x 15) a b c d e + (d, a) <- doit f1 0x5a827999 (m 16) e a b c d + (c, e) <- doit f1 0x5a827999 (m 17) d e a b c + (b, d) <- doit f1 0x5a827999 (m 18) c d e a b + (a, c) <- doit f1 0x5a827999 (m 19) b c d e a + (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e + (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d + (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c + (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b + (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a + (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e + (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d + (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c + (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b + (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a + (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e + (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d + (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c + (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b + (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a + (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e + (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d + (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c + (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b + (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a + (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e + (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d + (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c + (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b + (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a + (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e + (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d + (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c + (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b + (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a + (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e + (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d + (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c + (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b + (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a + (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e + (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d + (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c + (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b + (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a + (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e + (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d + (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c + (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b + (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a + (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e + (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d + (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c + (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b + (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a + (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e + (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d + (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c + (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b + (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a + (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e + (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d + (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c + (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b + (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a + let abcde' = ABCDE (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e) + sha1_step_4_main abcde' (s `advancePtr` 16) (len - 64) + where {-# INLINE f1 #-} + f1 (XYZ x y z) = (x .&. y) .|. ((complement x) .&. z) + {-# INLINE f2 #-} + f2 (XYZ x y z) = x `xor` y `xor` z + {-# INLINE f3 #-} + f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z) + {-# INLINE x #-} + x n = peek (s `advancePtr` n) + {-# INLINE m #-} + m n = do let base = s `advancePtr` (n .&. 15) + x0 <- peek base + x1 <- peek (s `advancePtr` ((n - 14) .&. 15)) + x2 <- peek (s `advancePtr` ((n - 8) .&. 15)) + x3 <- peek (s `advancePtr` ((n - 3) .&. 15)) + let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1 + poke base res + return res + {-# INLINE doit #-} + doit f k i a b c d e = a `seq` c `seq` + do i' <- i + return (rotateL a 5 + f (XYZ b c d) + e + i' + k, + rotateL b 30) + +sha1_step_5_display :: ABCDE -> String +sha1_step_5_display (ABCDE a b c d e) + = concatMap showAsHex [a, b, c, d, e] + +showAsHex :: Word32 -> String +showAsHex n = showIt 8 n "" + where + showIt :: Int -> Word32 -> String -> String + showIt 0 _ r = r + showIt i x r = case quotRem x 16 of + (y, z) -> let c = intToDigit (fromIntegral z) + in c `seq` showIt (i-1) y (c:r) diff --git a/src/UpdateRepoData-Main.hs b/src/UpdateRepoData-Main.hs new file mode 100644 --- /dev/null +++ b/src/UpdateRepoData-Main.hs @@ -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 diff --git a/src/Zip.hs b/src/Zip.hs new file mode 100644 --- /dev/null +++ b/src/Zip.hs @@ -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