dfb4bd8e50abc751b4e95ce4d2b57625eb485fc6
[gipeda.git] / src / Shake.hs
1 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, NondecreasingIndentation #-}
2 module Shake where
3
4 import Prelude hiding ((*>))
5
6 import Development.Shake hiding (withTempFile)
7 import Development.Shake.FilePath
8 import Development.Shake.Classes
9 import Control.Monad
10 import qualified Data.Map as M
11 import Data.Functor
12 import Data.List
13 import System.IO.Extra (newTempFile)
14 import qualified Data.ByteString as BS
15 import qualified Data.ByteString.Lazy as LBS
16 import qualified System.Directory
17 import Data.Aeson
18 import qualified Data.Text as T
19
20 import Development.Shake.Gitlib
21
22 import Paths hiding (Hash)
23 import ParentMap
24 import BenchmarksInCSV
25 import qualified BenchmarkSettings as S
26 import JsonUtils
27
28 {- Global settings -}
29 cGRAPH_HISTORY :: Integer
30 cGRAPH_HISTORY = 50
31
32 git :: (CmdResult b) => String -> [String] -> Action b
33 git gitcmd args = do
34     cmd (Traced $ "git " ++ gitcmd) (words "git -C repository" ++ gitcmd : args)
35
36 self :: (CmdResult b) => String -> [String] -> Action b
37 self name args = do
38     -- orderOnly ["gipeda"]
39     cmd (Traced name) "./gipeda" name args
40
41 gitRange :: Action String
42 gitRange = do
43     s <- liftIO $ S.readSettings "settings.yaml"
44     let first = S.start s
45     [head] <- readFileLines "site/out/head.txt"
46     return $ first ++ ".." ++ head
47
48 needIfThere :: [FilePath] -> Action [FilePath]
49 needIfThere files = do
50     existing <- filterM doesFileExist files
51     need existing
52     return existing
53
54 doesLogExist :: LogSource -> Hash -> Action Bool
55 doesLogExist BareGit    hash = doesGitFileExist "logs" (hash <.> "log")
56 doesLogExist FileSystem hash = doesFileExist (logsOf hash)
57 doesLogExist NoLogs     hash = doesFileExist (resultsOf hash)
58
59 findPred, findPredOrSelf :: LogSource -> ParentMap -> Hash -> Action (Maybe Hash)
60 findPredOrSelf logSource m h = do
61     ex <- doesLogExist logSource h
62     if ex then return (Just h)
63           else findPred logSource m h
64 findPred logSource m h = case M.lookup h m of
65     Just h' -> findPredOrSelf logSource m h'
66     Nothing -> return Nothing
67
68 findRecent :: LogSource -> ParentMap -> Integer -> FilePath -> Action [FilePath]
69 findRecent _ _ 0 _ = return []
70 findRecent logSource m n h = do
71     pM <- findPred logSource m h
72     (h:) <$> case pM of
73         Nothing -> return []
74         Just p ->  findRecent logSource m (n-1) p
75
76 newtype LimitRecent = LimitRecent ()
77     deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
78
79 data LogSource = FileSystem | BareGit | NoLogs deriving Show
80
81 determineLogSource :: IO LogSource
82 determineLogSource = do
83     haveLogs <- System.Directory.doesDirectoryExist "logs"
84     if haveLogs
85     then do
86         Stdout s <- cmd "git -C logs rev-parse --is-bare-repository"
87         if s == "true\n"
88         then return BareGit
89         else return FileSystem
90     else return NoLogs
91
92 shakeMain :: IO ()
93 shakeMain = do
94     logSource <- determineLogSource
95     print logSource
96
97     shakeArgs shakeOptions $ do
98     defaultRuleGitLib
99
100 {-
101     "gipeda" *> \out ->  do
102         sources <- getDirectoryFiles "src" ["*.hs"]
103         need (map ("src" </>) sources)
104         cmd "ghc -isrc --make -O src/gipeda.hs -o" out
105     want ["gipeda"]
106 -}
107
108     getLimitRecent <- addOracle $ \(LimitRecent _) -> do
109         need ["settings.yaml"]
110         S.limitRecent <$> liftIO (S.readSettings "settings.yaml")
111
112     "reports" ~> do
113         range <- gitRange
114         Stdout range <- git "log" ["--format=%H",range]
115         let hashes = words range
116         withLogs <- filterM (doesLogExist logSource) hashes
117         need $ map reportOf withLogs
118     want ["reports"]
119
120     "summaries" ~> do
121         range <- gitRange
122         Stdout range <- git "log" ["--format=%H",range]
123         let hashes = words range
124         withLogs <- filterM (doesLogExist logSource) hashes
125         need $ map summaryOf withLogs
126     want ["summaries"]
127
128     "site/out/head.txt" *> \ out -> do
129         alwaysRerun
130         Stdout stdout <- git "rev-parse" ["master"]
131         writeFileChanged out stdout
132
133
134     "site/out/history.csv" *> \out -> do
135         range <- gitRange
136         Stdout stdout <- git "log" ["--format=%H;%P",range]
137         writeFileChanged out stdout
138     want ["site/out/history.csv"]
139
140     history' <- newCache $ \() -> do
141          orderOnly ["site/out/history.csv"]
142          liftIO $ ssvFileToMap "site/out/history.csv"
143     let history = history' ()
144     let pred h = do { hist <- history; findPred logSource hist h }
145     let predOrSelf h = do { hist <- history; findPredOrSelf logSource hist h }
146     let recent n h = do { hist <- history; findRecent logSource hist n h }
147
148     "site/out/latest.txt" *> \ out -> do
149         [head] <- readFileLines "site/out/head.txt"
150         latestM <- predOrSelf head
151         case latestM of
152            Just latest ->
153                 writeFileChanged out latest
154            Nothing ->
155                 fail "Head has no parent with logs?"
156
157     "site/out/tags.txt" *> \ out -> do
158         alwaysRerun
159
160         need ["settings.yaml"]
161         s <- liftIO $ S.readSettings "settings.yaml"
162         case S.interestingTags s of
163             Nothing ->
164                 writeFileChanged out ""
165             Just pattern -> do
166                 Stdout tags <- git "tag" ["-l", pattern]
167                 tags' <- filterM (isGitAncestor "repository" (S.start s)) (lines tags)
168                 writeFileChanged out (unlines tags')
169
170     "site/out/branches.txt" *> \ out -> do
171         alwaysRerun
172
173         need ["settings.yaml"]
174         s <- liftIO $ S.readSettings "settings.yaml"
175         case S.interestingBranches s of
176             Nothing ->
177                 writeFileChanged out ""
178             Just pattern -> do
179                 Stdout branches <- git "branch" ["--list", pattern]
180                 branches <- filterM (isGitAncestor "repository" (S.start s)) (map (drop 2) $ lines branches)
181                 branches <- filterM (\b -> not <$> isGitAncestor "repository" b "master") branches
182                 writeFileChanged out (unlines branches)
183
184     "graphs" ~> do
185         [latest] <- readFileLines "site/out/latest.txt"
186         need [resultsOf latest]
187         b <- liftIO $ benchmarksInCSVFile (resultsOf latest)
188         need (map graphFile b)
189     want ["graphs"]
190
191     case logSource of
192         BareGit ->
193             "site/out/results/*.csv" *> \out -> do
194                 let hash = takeBaseName out
195                 withTempFile $ \fn -> do
196                     log <- readGitFile "logs" (hash <.> "log")
197                     liftIO $ BS.writeFile fn log
198                     Stdout csv <- cmd "./log2csv" fn
199                     writeFile' out csv
200         FileSystem ->
201             "site/out/results/*.csv" *> \out -> do
202                 let hash = takeBaseName out
203                 need [logsOf hash]
204                 Stdout csv <- cmd "./log2csv" (logsOf hash)
205                 writeFile' out csv
206         NoLogs -> return ()
207
208     "site/out/graphs//*.json" *> \out -> do
209         let bench = dropDirectory1 (dropDirectory1 (dropDirectory1 (dropExtension out)))
210
211         [latest] <- readFileLines "site/out/latest.txt"
212         limitRecent <- getLimitRecent (LimitRecent ())
213         r <- recent limitRecent latest
214         need (map reportOf r)
215
216         Stdout json <- self "GraphReport" (bench : r)
217         writeFile' out json
218
219     "site/out/reports/*.json" *> \out -> do
220         let hash = takeBaseName out
221         need [resultsOf hash]
222
223         pred <- pred hash
224         need [resultsOf h | Just h <- return pred]
225
226         Stdout json <- self "RevReport" (hash : [h | Just h <- return pred])
227         writeFile' out json
228
229     "site/out/summaries/*.json" *> \out -> do
230         let hash = takeBaseName out
231         need [reportOf hash]
232
233         Stdout json <- self "Summary" [hash]
234         writeFile' out json
235
236     "site/out/latest-summaries.json" *> \out -> do
237         [latest] <- readFileLines "site/out/latest.txt"
238         recentCommits <- recent cGRAPH_HISTORY latest
239
240         tags <- readFileLines "site/out/tags.txt"
241         tagsAndHashes <- forM tags $ \t -> do
242             h <- getGitReference "repository" ("refs/tags/" ++ t)
243             return $ (t, h)
244
245         branches <- readFileLines "site/out/branches.txt"
246         branchesAndHashes <- forM branches $ \t -> do
247             h <- getGitReference "repository" ("refs/heads/" ++ t)
248             return $ (t, h)
249
250         let o = object
251                 [ T.pack "tags" .= object [ (T.pack t .= h) | (t,h) <- tagsAndHashes ]
252                 , T.pack "branches" .= object [ (T.pack t .= h) | (t,h) <- branchesAndHashes ]
253                 ]
254         liftIO $ LBS.writeFile out (encode o)
255         extraCommits <- filterM (doesLogExist logSource) (map snd tagsAndHashes ++ map snd branchesAndHashes)
256
257         let revs = nub $ recentCommits ++ extraCommits
258
259         need $ map summaryOf revs
260
261         g <- forM revs $ \rev -> do
262             json <- liftIO $ LBS.readFile (summaryOf rev)
263             case eitherDecode json of
264                 Left e -> fail e
265                 Right rep -> return (rep :: Value)
266         liftIO $ LBS.writeFile out (encode (merges (o:g)))
267     want ["site/out/latest-summaries.json"]
268
269     "site/out/graph-summaries.json" *> \out -> do
270         [latest] <- readFileLines "site/out/latest.txt"
271         need [resultsOf latest]
272         b <- liftIO $ benchmarksInCSVFile (resultsOf latest)
273         need (map graphFile b)
274
275         Stdout json <- self "GraphSummaries" b
276         writeFile' out json
277     want ["site/out/graph-summaries.json"]
278
279     "site/out/benchNames.json" *> \out -> do
280         [latest] <- readFileLines "site/out/latest.txt"
281         need [resultsOf latest]
282         b <- liftIO $ benchmarksInCSVFile (resultsOf latest)
283
284         need ["settings.yaml"]
285
286         Stdout json <- self "BenchNames" (nub b)
287         writeFile' out json
288     want ["site/out/benchNames.json"]
289
290
291     "site/out/all-summaries.json" *> \out -> do
292         range <- gitRange
293         Stdout range <- git "log" ["--format=%H",range]
294         let hashes = words range
295         revs <- filterM (doesLogExist logSource) hashes
296         need (map summaryOf revs)
297
298         g <- forM revs $ \rev -> do
299             json <- liftIO $ LBS.readFile (summaryOf rev)
300             case eitherDecode json of
301                 Left e -> fail e
302                 Right rep -> return (rep :: Value)
303         liftIO $ LBS.writeFile out (encode (merges g))
304     want ["site/out/all-summaries.json"]
305
306     "site/out/settings.json" *> \out -> do
307         need ["settings.yaml"]
308
309         Stdout json <- self "JsonSettings" []
310         writeFile' out json
311     want ["site/out/settings.json"]
312
313     phony "clean" $ do
314         removeFilesAfter "site/out" ["//*"]
315
316
317 -- | Create a temporary file in the temporary directory. The file will be deleted
318 --   after the action completes (provided the file is not still open).
319 --   The 'FilePath' will not have any file extension, will exist, and will be zero bytes long.
320 --   If you require a file with a specific name, use 'withTempDir'.
321 withTempFile :: (FilePath -> Action a) -> Action a
322 withTempFile act = do
323     (file, del) <- liftIO newTempFile
324     act file `actionFinally` del