darcs repository web UI and hosting app. This is the main darcsden trunk, which also runs hub.darcs.net. (http://hub.darcs.net)

root / post-hook / darcsden-post-hook.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
{-# LANGUAGE OverloadedStrings, ImplicitParams #-}
module Main where

import Control.Lens (view, set)
import Control.Monad (forM_)
import Data.Maybe (catMaybes)
import Data.Time (getCurrentTime)
import System.Directory
import System.Environment
import System.FilePath
import Text.XML.Light
import Text.Regex.PCRE.Light.Char8

import DarcsDen.Backend.Permanent ( withBP )
import DarcsDen.Settings (Settings, withSettings)
import DarcsDen.Settings.Production ( getSettings, backendPermanent )
import DarcsDen.State.Comment
import DarcsDen.State.Issue
import DarcsDen.State.Repo
import DarcsDen.State.User
import DarcsDen.Util


maybeEnv :: String -> IO (Maybe String)
maybeEnv n = fmap (lookup n) getEnvironment

-- |Preparse the arguments to look for the '--config' argument.
readCfgArg :: [String] -> IO (Settings, [String])
readCfgArg as = case as of
  ("--config":cfgfile:as') -> do
    settings <- getSettings cfgfile
    return (settings, as')
  as' -> do
    cwd <- getCurrentDirectory
    settings <- getSettings $ cwd ++ [pathSeparator] ++ "darcsden.conf"
    return (settings, as')

main :: IO ()
main = do
    as <- getArgs
    (settings, _) <- readCfgArg as
    withSettings settings $ do
      mps <- maybeEnv "DARCS_PATCHES_XML"
      case mps of
        Nothing -> putStrLn "no darcs patch info available"
        Just ps -> go ps

go :: (?settings :: Settings) => String -> IO ()
go ps = withBP backendPermanent $ do
    here <- getCurrentDirectory

    let [owner, repo]
            = reverse
            . take 2
            . reverse
            $ splitDirectories here

        xml = parseXML ps

        names
            = catMaybes
            . map nameAndAuthor
            . elChildren
            . head
            $ onlyElems xml

        closing :: [(String, String, Int)]
        closing = catMaybes (map closeMatch names)

    mr <- getOwnerRepository (owner, repo)
    case mr of
        Just (repoRef -> rid) ->
            forM_ closing $ \(e, name, num) -> do
                ma <- getUserByEmail (emailFrom e)
                mi <- getIssue rid num
                case mi of
                    Just (i@(view iIsClosed -> False)) -> do
                        now <- getCurrentTime
                        updateIssue (set iIsClosed True . set iUpdated now $ i)
                        case ma of
                            Just (view uName -> author) -> do
                                addComment $
                                    freshCommentData name [Closed True] author
                                                 now now (issueRef i)

                                return ()

                            _ -> return ()

                        putStrLn ("issue #" ++ show num ++ " closed")
                    Just _ ->
                        putStrLn $ "issue #" ++ show num ++ " already closed, ignoring"
                    Nothing ->
                        putStrLn $ "issue #" ++ show num ++ " not found, ignoring"
        _ -> error ("unknown repository: " ++ owner ++ "/" ++ repo)
  where
    closeMatch (a, s) =
        case match (compile regex [caseless]) s [] of
            Just [_, _, n] -> Just (a, s, read n)
            Just [_, _, "", n] -> Just (a, s, read n)
            Just [_, _, "", "", n] -> Just (a, s, read n)
            _ -> Nothing

    regex = "(closes #([0-9]+)|resolves #([0-9]+)|fixes #([0-9]+))"

    nameAndAuthor e =
        case (ma, mn) of
            (Just a, Just n) -> Just (a, strContent n)
            _ -> Nothing
      where
        ma = findAttr (QName "author" Nothing Nothing) e
        mn = findChild (QName "name" Nothing Nothing) e