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
|
module Output (
Output,
OutputType(..),
OutputEvent(..),
OutputFootnote(..),
withOutput,
outputTerminal,
outputMessage,
outputEvent,
outputFootnote,
) where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.Text (Text)
import Data.Text.IO qualified as T
import System.IO
import Job.Types
import Terminal
data Output = Output
{ outLock :: MVar ()
, outTerminal :: Maybe TerminalOutput
, outLogs :: [ Handle ]
, outTest :: [ Handle ]
}
data OutputType
= TerminalOutput
| LogOutput FilePath
| TestOutput FilePath
deriving (Eq, Ord)
data OutputEvent
= OutputMessage Text
| TestMessage Text
| LogMessage Text
| JobStarted JobId
| JobFinished JobId Text
| JobIsDuplicate JobId Text
| JobPreviouslyFinished JobId Text
| JobWasSkipped JobId
data OutputFootnote = OutputFootnote
{ footnoteText :: Text
, footnoteTerminal :: Maybe TerminalFootnote
}
deriving (Eq)
withOutput :: [ OutputType ] -> (Output -> IO a) -> IO a
withOutput types inner = do
lock <- newMVar ()
go types (Output lock Nothing [] [])
where
go (TerminalOutput : ts) out = do
term <- initTerminalOutput
go ts out { outTerminal = Just term }
go (LogOutput path : ts) out = withOutputFile path $ \h -> do
go ts out { outLogs = h : outLogs out }
go (TestOutput path : ts) out = withOutputFile path $ \h -> do
go ts out { outTest = h : outTest out }
go [] out = inner out
withOutputFile "-" f = hSetBuffering stdout LineBuffering >> f stdout
withOutputFile path f = bracket (openFile' path) hClose f
openFile' path = do
h <- openFile path WriteMode
hSetBuffering h LineBuffering
return h
outputTerminal :: Output -> Maybe TerminalOutput
outputTerminal = outTerminal
outStrLn :: Output -> Handle -> Text -> IO ()
outStrLn Output {..} h text
| Just tout <- outTerminal, terminalHandle tout == h = do
void $ newLine tout text
| otherwise = do
withMVar outLock $ \_ -> do
T.hPutStrLn h text
outputMessage :: MonadIO m => Output -> Text -> m ()
outputMessage out msg = outputEvent out (OutputMessage msg)
outputEvent :: MonadIO m => Output -> OutputEvent -> m ()
outputEvent out@Output {..} = liftIO . \case
OutputMessage msg -> do
forM_ outTerminal $ \term -> void $ newLine term msg
forM_ outLogs $ \h -> outStrLn out h msg
forM_ outTest $ \h -> outStrLn out h ("msg " <> msg)
TestMessage msg -> do
forM_ outTest $ \h -> outStrLn out h msg
LogMessage msg -> do
forM_ outLogs $ \h -> outStrLn out h msg
JobStarted jid -> do
forM_ outLogs $ \h -> outStrLn out h ("Started " <> textJobId jid)
forM_ outTest $ \h -> outStrLn out h ("job-start " <> textJobId jid)
JobFinished jid status -> do
forM_ outLogs $ \h -> outStrLn out h ("Finished " <> textJobId jid <> " (" <> status <> ")")
forM_ outTest $ \h -> outStrLn out h ("job-finish " <> textJobId jid <> " " <> status)
JobIsDuplicate jid status -> do
forM_ outLogs $ \h -> outStrLn out h ("Duplicate " <> textJobId jid <> " (" <> status <> ")")
forM_ outTest $ \h -> outStrLn out h ("job-duplicate " <> textJobId jid <> " " <> status)
JobPreviouslyFinished jid status -> do
forM_ outLogs $ \h -> outStrLn out h ("Previously finished " <> textJobId jid <> " (" <> status <> ")")
forM_ outTest $ \h -> outStrLn out h ("job-previous " <> textJobId jid <> " " <> status)
JobWasSkipped jid -> do
forM_ outLogs $ \h -> outStrLn out h ("Skipped " <> textJobId jid)
forM_ outTest $ \h -> outStrLn out h ("job-skip " <> textJobId jid)
outputFootnote :: Output -> Text -> IO OutputFootnote
outputFootnote out@Output {..} footnoteText = do
footnoteTerminal <- forM outTerminal $ \term -> newFootnote term footnoteText
forM_ outLogs $ \h -> outStrLn out h footnoteText
forM_ outTest $ \h -> outStrLn out h ("note " <> footnoteText)
return OutputFootnote {..}
|