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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-missing-local-signatures #-}
module Main where
-- base
import Control.Monad
( forM, forM_, unless, when )
import Data.Maybe
( isJust )
import System.Environment
( getArgs )
import System.Exit
( ExitCode(..), exitWith )
-- mtl
import Control.Monad.Writer
( liftIO, execWriter, tell )
-- text
import Data.Text
( Text )
import qualified Data.Text as T
import qualified Data.Text.IO as T
( putStrLn )
-- linters-common
import Linters.Common
( LintMsg(..), LintLvl(..)
, gitCatCommit, gitNormCid, tshow
)
--------------------------------------------------------------------------------
main :: IO ()
main = do
dir:refs <- getArgs >>= \case
[] -> fail "usage: lint-commit-msg <git-repo> [<commit-id>+]"
x -> return x
stats <- forM (map T.pack refs) $ \ref -> do
cid <- gitNormCid dir ref
(_, msg) <- gitCatCommit dir cid
let cmsgs = lintMsg msg
liftIO $ do
-- putStrLn (T.unpack cid)
-- forM_ (zip [1::Int ..] (T.lines msg)) $ \(lno,l) -> do
-- putStrLn (show lno <> "\t" <> show l)
-- putStrLn "--"
let status = maximum (Nothing : [ Just lvl | LintMsg lvl _ _ _ <- cmsgs ])
ok = status < Just LintLvlErr
unless (null cmsgs) $ do
putStrLn "====================================================================================="
putStrLn ("commit " <> T.unpack cid <> " has linter issues:")
putStrLn ""
forM_ cmsgs $ \(LintMsg lvl lno l m) -> do
let lvls = case lvl of
LintLvlErr -> "*ERROR*"
LintLvlWarn -> "Warning"
putStrLn (" " <> lvls <> " on line " <> show lno <> ": " <> T.unpack m)
putStrLn (" > " <> show l)
putStrLn ""
return ()
unless ok $
putStrLn ("Validation FAILED for " <> T.unpack cid)
return status
unless (null $ filter isJust stats) $
T.putStrLn "====================================================================================="
let stats1 = maximum (Nothing : stats)
unless (stats1 == Nothing) $ do
T.putStrLn "There were commit message linter issues! For more information see"
T.putStrLn " http://tbaggery.com/2008/04/19/a-note-about-git-commit-messages.html"
T.putStrLn ""
unless (stats1 < Just LintLvlErr) $ do
T.putStrLn "Validation FAILED because at least one commit had linter errors!"
exitWith (ExitFailure 1)
T.putStrLn "Commit message validation passed!"
-- | Commit message linter
lintMsg :: Text -> [LintMsg]
lintMsg msg0 = execWriter $ do
-- subject-line validations
if | T.null (T.strip subj) -> errSubj "empty subject line"
| otherwise -> do
when (T.stripStart subj /= subj) $
errSubj "subject line with leading whitespace"
when (T.stripEnd subj /= subj) $
warnSubj "subject line with trailing whitespace"
when (T.any (== '\t') subj) $
errSubj "subject line contains TAB"
if | slen > 80 -> errSubj ("subject line longer than 80 characters (was " <> tshow slen <> " characters)"
<> " -- , ideally subject line is at most 50 characters long")
| slen > 50 -> warnSubj ("subject line longer than 50 characters (was " <> tshow slen <> " characters)")
| slen < 8 -> errSubj ("subject line shorter than 8 characters (was " <> tshow slen <> " characters)")
| otherwise -> return ()
-- 2nd-line & body validations
case lns of
[] -> return () -- empty commit msg -- will have caused already an LintLvlErr
[_] -> return () -- single-line commit msg
(_:line2:body) -> do
-- 2nd line validations
if | not (T.null line2)
-> tell [LintMsg LintLvlErr 2 line2 "2nd line must be empty"]
| null body
-> tell [LintMsg LintLvlWarn 2 line2 "2nd line exists, but no commit msg body found"]
| otherwise -> return ()
-- body validations
forM_ (zip [3..] body) $ \(lineno,l) -> do
let llen = T.length l
warnBody m = tell [LintMsg LintLvlWarn lineno l m]
errBody m = tell [LintMsg LintLvlErr lineno l m]
when (T.stripEnd l /= l) $ warnBody "trailing whitespace"
when (T.any (== '\t') l) $ warnBody "contains TAB character"
when (T.isPrefixOf "Summary:" l) $
warnBody "redundant Phabricator 'Summary:' tag detected -- please trim your commit message"
when (T.isPrefixOf "Summary: Signed-off-by:" l) $
errBody "'Signed-Off-by:'-marker not starting on first column"
if | llen > 100 -> errBody ("body line longer than 100 characters (was "
<> tshow llen <> " characters) -- "
<> "ideally body lines are at most 72 characters long")
| llen > 72 -> warnBody ("body line longer than 72 characters (was "
<> tshow llen <> " characters)")
| otherwise -> return ()
return ()
where
warnSubj m = tell [LintMsg LintLvlWarn 1 subj m]
errSubj m = tell [LintMsg LintLvlErr 1 subj m]
lns = T.lines msg0
subj | (l0:_) <- lns = l0
| otherwise = ""
slen = T.length subj
|
