Skip to content

Commit e778968

Browse files
csasarakcsasarak
committed
WIP conduits
1 parent b26b15f commit e778968

File tree

2 files changed

+97
-72
lines changed

2 files changed

+97
-72
lines changed

‎src/App/Fossa/Analyze.hs‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -140,6 +140,7 @@ import Prettyprinter.Render.Terminal (
140140
import Srclib.Converter qualified as Srclib
141141
import Srclib.Types (LicenseSourceUnit (..), Locator, SourceUnit, sourceUnitToFullSourceUnit)
142142
import Types (DiscoveredProject (..), FoundTargets)
143+
import Control.Monad.IO.Unlift (MonadUnliftIO)
143144

144145
debugBundlePath :: FilePath
145146
debugBundlePath = "fossa.debug.json.gz"
@@ -154,7 +155,7 @@ dispatch ::
154155
, Has (Lift IO) sig m
155156
, Has Logger sig m
156157
, Has ReadFS sig m
157-
, Has Telemetry sig m
158+
, Has Telemetry sig m, MonadUnliftIO m
158159
) =>
159160
AnalyzeConfig ->
160161
m ()
@@ -170,6 +171,7 @@ analyzeMain ::
170171
, Has Logger sig m
171172
, Has ReadFS sig m
172173
, Has Telemetry sig m
174+
, MonadUnliftIO m
173175
) =>
174176
AnalyzeConfig ->
175177
m Aeson.Value
@@ -275,6 +277,7 @@ analyze ::
275277
, Has Logger sig m
276278
, Has ReadFS sig m
277279
, Has Telemetry sig m
280+
, MonadUnliftIO m
278281
) =>
279282
AnalyzeConfig ->
280283
m Aeson.Value

‎src/App/Fossa/Ficus/Analyze.hs‎

Lines changed: 93 additions & 71 deletions
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,8 @@ module App.Fossa.Ficus.Analyze (
66
analyzeWithFicusMain,
77
-- Exported for testing
88
singletonFicusMessage,
9-
) where
9+
)
10+
where
1011

1112
import App.Fossa.EmbeddedBinary (BinaryPaths, toPath, withFicusBinary)
1213
import App.Fossa.Ficus.Types (
@@ -23,26 +24,30 @@ import App.Fossa.Ficus.Types (
2324
FicusSnippetScanResults (..),
2425
)
2526
import App.Types (ProjectRevision (..))
27+
import Conduit ((.|))
28+
import Conduit qualified
2629
import Control.Carrier.Diagnostics (Diagnostics)
27-
import Control.Effect.Lift (Has, Lift, sendIO)
28-
import Effect.Logger (Logger, logDebug, logInfo)
29-
import Prettyprinter (pretty)
30-
31-
import Data.Time (getCurrentTime)
32-
import Data.Time.Format (defaultTimeLocale, formatTime)
33-
34-
import Control.Concurrent.Async (async, wait)
35-
import Data.Aeson (Object, decode, (.:))
30+
import Control.Concurrent.Async (async, wait, Async)
31+
import Control.Effect.Lift (Has, Lift, liftWith, sendIO)
32+
import Data.Aeson (Object, decode, decodeStrict, (.:))
3633
import Data.Aeson.Types (parseMaybe)
34+
import Data.ByteString qualified as BS
3735
import Data.ByteString.Lazy qualified as BL
36+
import Data.Conduit.Combinators qualified as CC
3837
import Data.Hashable (Hashable)
3938
import Data.Maybe (mapMaybe)
4039
import Data.String.Conversion (ToText (toText), toString)
4140
import Data.Text (Text)
4241
import Data.Text qualified as Text
4342
import Data.Text.Encoding qualified as Text.Encoding
43+
import Data.Time (getCurrentTime)
44+
import Data.Time.Format (defaultTimeLocale, formatTime)
4445
import Effect.Exec (AllowErr (Never), Command (..), ExitCode (ExitSuccess), renderCommand)
46+
import Effect.Logger (Logger, LoggerF, logDebug, logInfo, logStdout)
4547
import Fossa.API.Types (ApiKey (..), ApiOpts (..))
48+
import Path (Abs, Dir, Path, toFilePath)
49+
import Prettyprinter (pretty)
50+
import Srclib.Types (Locator (..), renderLocator)
4651
import System.IO (Handle, hGetLine, hIsEOF)
4752
import System.Process.Typed (
4853
createPipe,
@@ -55,16 +60,18 @@ import System.Process.Typed (
5560
waitExitCode,
5661
withProcessWait,
5762
)
58-
59-
import Path (Abs, Dir, Path, toFilePath)
60-
import Srclib.Types (Locator (..), renderLocator)
6163
import Text.URI (render)
6264
import Text.URI.Builder (PathComponent (PathComponent), TrailingSlash (TrailingSlash), setPath)
6365
import Types (GlobFilter (..), LicenseScanPathFilters (..))
64-
import Prelude
66+
import Control.Monad.IO.Class
67+
import Control.Monad.Trans (lift)
68+
import Control.Monad.IO.Unlift (withRunInIO, MonadUnliftIO)
69+
import Data.Sequence (Seq)
70+
import qualified Data.Aeson as Aeson
6571

6672
newtype CustomLicensePath = CustomLicensePath {unCustomLicensePath :: Text}
6773
deriving (Eq, Ord, Show, Hashable)
74+
6875
newtype CustomLicenseTitle = CustomLicenseTitle {unCustomLicenseTitle :: Text}
6976
deriving (Eq, Ord, Show, Hashable)
7077

@@ -79,7 +86,7 @@ logDebugWithTime msg = do
7986
analyzeWithFicus ::
8087
( Has Diagnostics sig m
8188
, Has (Lift IO) sig m
82-
, Has Logger sig m
89+
, Has Logger sig m, MonadUnliftIO m
8390
) =>
8491
Path Abs Dir ->
8592
Maybe ApiOpts ->
@@ -93,6 +100,7 @@ analyzeWithFicusMain ::
93100
( Has Diagnostics sig m
94101
, Has (Lift IO) sig m
95102
, Has Logger sig m
103+
, MonadIO m
96104
) =>
97105
Path Abs Dir ->
98106
Maybe ApiOpts ->
@@ -163,18 +171,20 @@ runFicus ficusConfig = do
163171

164172
logInfo $ "Running Ficus analysis on " <> pretty (toFilePath $ ficusConfigRootDir ficusConfig)
165173
logDebugWithTime "Starting Ficus process..."
166-
(messages, exitCode, stdErrLines) <- sendIO $ withProcessWait processConfig $ \p -> do
167-
getCurrentTime >>= \now -> putStrLn $ "[TIMING " ++ formatTime defaultTimeLocale "%H:%M:%S.%3q" now ++ "] Ficus process started, beginning stream processing..."
174+
(messages, exitCode, stdErrLines) <- withProcessWait processConfig $ \p -> do
175+
currentTimeStamp >>= \now -> logStdout $ "[TIMING " <> now <> "] Ficus process started, beginning stream processing..."
168176
let stdoutHandle = getStdout p
169177
let stderrHandle = getStderr p
178+
179+
170180
-- Start async reading of stderr to prevent blocking
171-
stderrAsync <- async $ consumeStderr stderrHandle
181+
stderrAsync <- withRunInIO $ \runIO -> async $ runIO (consumeStderr stderrHandle)
172182
-- Read stdout in the main thread
173183
result <- streamFicusOutput stdoutHandle
174184
-- Wait for stderr to finish
175-
stdErrLines <- wait stderrAsync
185+
stdErrLines <- sendIO $ wait stderrAsync
176186
exitCode <- waitExitCode p
177-
putStrLn $ "[Ficus] Ficus process returned exit code: " <> show exitCode
187+
logStdout $ "[Ficus] Ficus process returned exit code: " <> (toText . show $ exitCode)
178188
pure (result, exitCode, stdErrLines)
179189

180190
if exitCode /= ExitSuccess
@@ -196,58 +206,70 @@ runFicus ficusConfig = do
196206

197207
pure messages
198208
where
199-
streamFicusOutput :: Handle -> IO FicusMessages
200-
streamFicusOutput handle = do
201-
let loop acc = do
202-
eof <- hIsEOF handle
203-
if eof
204-
then do
205-
putStrLn "[DEBUG] Reached end of Ficus output stream"
206-
pure acc
207-
else do
208-
line <- hGetLine handle
209-
let lineBS = BL.fromStrict $ Text.Encoding.encodeUtf8 $ toText line
210-
case decode lineBS of
211-
Just message -> do
212-
-- Log messages as they come, with timestamps
213-
now <- getCurrentTime
214-
let timestamp = formatTime defaultTimeLocale "%H:%M:%S.%3q" now
215-
case message of
216-
FicusMessageError err ->
217-
putStrLn $ "[" ++ timestamp ++ "] ERROR " <> toString (displayFicusError err)
218-
FicusMessageDebug dbg ->
219-
putStrLn $ "[" ++ timestamp ++ "] DEBUG " <> toString (displayFicusDebug dbg)
220-
FicusMessageFinding finding ->
221-
putStrLn $ "[" ++ timestamp ++ "] FINDING " <> toString (displayFicusFinding finding)
222-
let newMessage = singletonFicusMessage message
223-
loop (acc <> newMessage)
224-
Nothing -> do
225-
loop acc
226-
loop mempty
209+
decodeFicusLine ::
210+
(Has Logger sig m,
211+
Has (Lift IO) sig m
212+
) =>
213+
Text -> m FicusMessages
214+
decodeFicusLine line = case Aeson.decodeStrictText line of
215+
Just message -> do
216+
-- Log messages as they come, with timestamps
217+
timestamp <- currentTimeStamp
218+
case message of
219+
FicusMessageError err ->
220+
logStdout $ "[" <> timestamp <> "] ERROR " <> displayFicusError err
221+
FicusMessageDebug dbg ->
222+
logStdout $ "[" <> timestamp <> "] DEBUG " <> displayFicusDebug dbg
223+
FicusMessageFinding finding ->
224+
logStdout $ "[" <> timestamp <> "] FINDING " <> displayFicusFinding finding
225+
pure $ singletonFicusMessage message
226+
Nothing -> pure mempty
227+
228+
-- TODO: decodeUtf8Lenient replaces bad codepoints with its own thing.
229+
lineStream :: (MonadIO m) => Handle -> Conduit.ConduitT a Text m ()
230+
lineStream handle = CC.sourceHandle handle .| CC.decodeUtf8Lenient .| CC.linesUnbounded
231+
232+
streamFicusOutput :: (Has Logger sig m, MonadIO m, Has (Lift IO) sig m) => Handle -> m FicusMessages
233+
streamFicusOutput handle =
234+
Conduit.runConduit $
235+
lineStream handle
236+
.| CC.foldMapM decodeFicusLine
237+
238+
currentTimeStamp :: (Has (Lift IO) sig m) => m Text
239+
currentTimeStamp = do
240+
now <- sendIO getCurrentTime
241+
pure . toText . formatTime defaultTimeLocale "%H:%M:%S.%3q" $ now
242+
243+
consumeStderr :: (MonadIO m, Has (Lift IO) sig m) => Handle -> m [Text]
244+
consumeStderr handle =
245+
Conduit.runConduit $
246+
lineStream handle
247+
.| CC.mapM (\line -> do timestamp <- currentTimeStamp
248+
pure $ "[" <> timestamp <> "] STDERR " <> line)
249+
-- Keep at most the last 50 lines of stderr
250+
-- I came up with 50 lines by looking at a few different error traces and making
251+
-- sure that we captured all of the relevant error output, and then going a bit higher
252+
-- to make sure that we didn't miss anything. I'd rather capture a bit too much than not enough.
253+
-- Use cons (:) for O(1) prepending, track count explicitly for O(1) truncation
254+
.| CC.slidingWindow 50
255+
.| CC.lastDef mempty
227256

228-
consumeStderr :: Handle -> IO [Text]
229-
consumeStderr handle = do
230-
let loop acc (count :: Int) = do
231-
eof <- hIsEOF handle
232-
if eof
233-
then pure (reverse acc) -- Reverse at the end to get correct order
234-
else do
235-
line <- hGetLine handle -- output stderr
236-
now <- getCurrentTime
237-
let timestamp = formatTime defaultTimeLocale "%H:%M:%S.%3q" now
238-
let msg = "[" ++ timestamp ++ "] STDERR " <> line
239-
-- Keep at most the last 50 lines of stderr
240-
-- I came up with 50 lines by looking at a few different error traces and making
241-
-- sure that we captured all of the relevant error output, and then going a bit higher
242-
-- to make sure that we didn't miss anything. I'd rather capture a bit too much than not enough.
243-
-- Use cons (:) for O(1) prepending, track count explicitly for O(1) truncation
244-
let newAcc =
245-
if count >= 50
246-
then take 50 (toText msg : acc)
247-
else toText msg : acc
248-
let newCount = min (count + 1) 50
249-
loop newAcc newCount
250-
loop [] 0
257+
-- let loop acc (count :: Int) = do
258+
-- eof <- hIsEOF handle
259+
-- if eof
260+
-- then pure (reverse acc) -- Reverse at the end to get correct order
261+
-- else do
262+
-- line <- hGetLine handle -- output stderr
263+
-- now <- getCurrentTime
264+
-- let timestamp = formatTime defaultTimeLocale "%H:%M:%S.%3q" now
265+
-- let msg = "[" ++ timestamp ++ "] STDERR " <> line
266+
-- let newAcc =
267+
-- if count >= 50
268+
-- then take 50 (toText msg : acc)
269+
-- else toText msg : acc
270+
-- let newCount = min (count + 1) 50
271+
-- loop newAcc newCount
272+
-- loop [] 0
251273

252274
displayFicusDebug :: FicusDebug -> Text
253275
displayFicusDebug (FicusDebug FicusMessageData{..}) = ficusMessageDataStrategy <> ": " <> ficusMessageDataPayload

0 commit comments

Comments
 (0)