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
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
|
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Linters.Common where
-- base
import Control.Monad
( liftM, unless )
import Data.Function
( on )
import Data.List
( groupBy )
import Data.Maybe
( fromMaybe )
import GHC.IO.Encoding
( utf8, setLocaleEncoding, getLocaleEncoding, textEncodingName )
-- deepseq
import Control.DeepSeq
( NFData(rnf), force, ($!!) )
-- process
import System.Process
( readProcess )
-- text
import Data.Text
( Text )
import qualified Data.Text as T
--------------------------------------------------------------------------------
data LintMsg = LintMsg !LintLvl !Int !Text !Text
deriving stock Show
data LintLvl = LintLvlWarn | LintLvlErr
deriving stock ( Show, Eq, Ord )
type GitRef = Text
type Sh = IO
silently :: a -> a
silently = id
runGit :: FilePath -> Text -> [Text] -> Sh Text
runGit fp t ts = runGitStdin fp t ts ""
-- | Run @git@ operation
runGitStdin :: FilePath -> Text -> [Text] -> Text -> Sh Text
runGitStdin d op args std_in = do
d' <- return $ T.pack d
out <- withUtf8 $ silently $ readProcess "git" (map T.unpack ("-C" : d' : op : args)) (T.unpack std_in)
return (T.pack out)
-- | WARNING: non-reentrant Hack!
withUtf8 :: Sh a -> Sh a
withUtf8 act = do
oldloc <- getLocaleEncoding
if (textEncodingName oldloc == textEncodingName utf8)
then act
else do
setLocaleEncoding utf8
r <- act
setLocaleEncoding oldloc
return r
-- | wrapper around @git cat-file commit@
--
-- Returns (commit-header, commit-body)
gitCatCommit :: FilePath -> GitRef -> Sh (Text,Text)
gitCatCommit d ref = do
tmp <- runGit d "cat-file" ["commit", ref ]
return (fmap (T.drop 2) $ T.breakOn "\n\n" tmp)
-- | wrapper around @git cat-file commit@
gitCatBlob :: FilePath -> GitRef -> Sh Text
gitCatBlob d ref = do
tmpl <- liftM tread $ runGit d "cat-file" ["-s", ref] -- workaround shelly adding EOLs
tmp <- runGit d "cat-file" ["blob", ref]
return (T.take tmpl tmp)
where
tread = read . T.unpack
-- | Wrapper around @git rev-parse --verify@
--
-- Normalise git ref to commit sha1
gitNormCid :: FilePath -> GitRef -> Sh GitRef
gitNormCid d ref = do
tmp <- runGit d "rev-parse" ["-q", "--verify", ref <> "^{commit}" ]
return (T.strip tmp)
-- | wrapper around @git branch --contains@
gitBranchesContain :: FilePath -> GitRef -> Sh [Text]
gitBranchesContain d ref = do
tmp <- liftM T.lines $
--errExit False $ print_stderr False $
runGit d "branch" ["--contains", ref, "-r"]
unless (all (\s -> T.take 2 s `elem` [" ","* "]) tmp) $
fail "gitBranchesContain: internal error"
return $!! map (T.drop 2) tmp
-- | returns @[(path, (url, key))]@
--
-- may throw exception
getModules :: FilePath -> GitRef -> Sh [(Text, (Text, Text))]
getModules d ref = do
tmp <- runGit d "show" [ref <> ":.gitmodules"]
res <- liftM T.lines $ runGitStdin d "config" [ "--file", "/dev/stdin", "-l" ] tmp
let ms = [ (T.tail key1,(key2, T.tail val))
| r <- res, "submodule." `T.isPrefixOf` r
, let (key,val) = T.break (=='=') r
, let (key',key2) = T.breakOnEnd "." key
, let (_,key1) = T.break (=='.') (T.init key')
]
ms' = [ (path', (url, k))
| es@((k,_):_) <- groupBy ((==) `on` fst) ms
, let props = map snd es
, let url = fromMaybe (error "getModules1") (lookup "url" props)
, let path' = fromMaybe (error "getModules2") (lookup "path" props)
]
return $!! ms'
{- |
Possible meanings of the 'Char' value:
* Added (A),
* Copied (C),
* Deleted (D),
* Modified (M),
* Renamed (R),
* have their type (i.e. regular file, symlink, submodule, ...) changed (T),
* are Unmerged (U),
* are Unknown (X),
* or have had their pairing Broken (B).
-}
gitDiffTree :: FilePath -> GitRef -> Sh (Text, [([(GitType, Text, Char)], (GitType, Text), Text)])
gitDiffTree d ref = do
tmp <- liftM T.lines $ runGit d "diff-tree" ["--root","-c", "-r", ref]
case tmp of
cid:deltas -> return $!! (cid, map parseDtLine deltas)
[] -> return ("", [])
where
parseDtLine :: Text -> ([(GitType, Text, Char)], (GitType, Text), Text)
parseDtLine l
| sanityCheck = force (zip3 (map cvtMode mode') oid' (T.unpack k),(cvtMode mode,oid),fp)
| otherwise = error "in parseDtLine"
where
sanityCheck = n > 0 && T.length k == n
n = T.length cols
(mode',mode:tmp') = splitAt n $ T.split (==' ') l''
(oid',[oid,k]) = splitAt n tmp'
[l'',fp] = T.split (=='\t') l'
(cols,l') = T.span (==':') l
gitDiffTreePatch :: FilePath -> GitRef -> Text -> Sh Text
gitDiffTreePatch d ref fname = runGit d "diff-tree" ["--root", "--cc", "-r", ref, "--", fname]
z40 :: GitRef
z40 = T.pack (replicate 40 '0')
data GitType
= GitTypeVoid
| GitTypeRegFile
| GitTypeExeFile
| GitTypeTree
| GitTypeSymLink
| GitTypeGitLink
deriving stock (Show,Eq,Ord,Enum)
instance NFData GitType where rnf !_ = ()
cvtMode :: Text -> GitType
cvtMode "000000" = GitTypeVoid
cvtMode "040000" = GitTypeSymLink
cvtMode "100644" = GitTypeRegFile
cvtMode "100755" = GitTypeExeFile
cvtMode "120000" = GitTypeSymLink
cvtMode "160000" = GitTypeGitLink
cvtMode x = error ("cvtMode: " ++ show x)
tshow :: Show a => a -> Text
tshow = T.pack . show
|
