Code cleanup and documentation. (#23)

Author: chungyc

src/AutomationDetails.hs

@@ -21,27 +21,22 @@ import Data.Aeson.KeyMap hiding (lookup, map)
 import Data.Maybe (fromMaybe)
 import Data.Text hiding (singleton)
 
--- See https://github.com/github/codeql-action/blob/v2/lib/upload-lib.js
 -- See https://docs.github.com/en/code-security/code-scanning/integrating-with-code-scanning/sarif-support-for-code-scanning#runautomationdetails-object
 
 add :: [(String, String)] -> Maybe String -> Value -> Value
-add env category (Object v) = Object $ mapWithKey (addToRuns details) v
+add env category (Object v) = Object $ mapWithKey addToRuns v
   where
     details = fromMaybe "" category <> "/" <> runId
     runId = fromMaybe "" (lookup "GITHUB_RUN_ID" env)
-add _ _ v = v
 
-addToRuns :: String -> Key -> Value -> Value
-addToRuns details "runs" (Array v) =
-  Array $ fmap (addToRun details) v
-addToRuns _ _ v = v
+    addToRuns "runs" (Array u) = Array $ fmap addToRun u
+    addToRuns _ u = u
 
-addToRun :: String -> Value -> Value
-addToRun details (Object v) = Object $ addDetails details v
-addToRun _ v = v
+    addToRun (Object u) = Object $ addDetails u
+    addToRun u = u
 
-addDetails :: String -> Object -> Object
-addDetails details =
-  insert
-    "automationDetails"
-    (Object $ singleton "id" (String $ pack details))
+    addDetails =
+      insert
+        "automationDetails"
+        (Object $ singleton "id" (String $ pack details))
+add _ _ v = v

src/Fingerprint.hs

@@ -22,7 +22,7 @@ limitations under the License.
 --
 -- SARIF uses partial fingerprints in results to aid in an attempt
 -- to track the "same" issues despite changes.  This fills partial
--- fingerprints in results which do not already have them,
+-- fingerprints in result objects which do not already have them,
 -- while keeping everything else the same in SARIF output.
 module Fingerprint (fill) where
 
@@ -53,10 +53,9 @@ fillResults _ v = v
 fillResult :: Value -> Value
 fillResult o@(Object v)
   | member "partialFingerprint" v = o
-  | otherwise = Object $ insert "partialFingerprints" fpValue v
+  | otherwise = Object $ insert "partialFingerprints" fp v
   where
-    fp = toPartialFingerprint $ toCodeIssue v
-    fpValue = Object $ singleton "LogicalCodeIssue/v1" $ String fp
+    fp = toPartialFingerprint v
 fillResult v = v
 
 data CodeIssue = CodeIssue
@@ -96,9 +95,14 @@ qualifiedName (Object v)
   | otherwise = Nothing
 qualifiedName _ = Nothing
 
-toPartialFingerprint :: CodeIssue -> Text
-toPartialFingerprint CodeIssue {ruleId, level, locations} =
-  encodeTextList [ruleId, level, encodeTextList . map Just <$> locations]
+toPartialFingerprint :: Object -> Value
+toPartialFingerprint v =
+  Object $ singleton propertyName $ String encodedResult
+  where
+    CodeIssue {ruleId, level, locations} = toCodeIssue v
+    encodedLocations = encodeTextList . map Just <$> locations
+    encodedResult = encodeTextList [ruleId, level, encodedLocations]
+    propertyName = "LogicalCodeIssue/v1"
 
 encodeTextList :: [Maybe Text] -> Text
 encodeTextList = encodeBase64 . Text.concat . map encodeItem

src/Scan.hs

@@ -48,7 +48,10 @@ import Prelude hiding (lookup, putStr)
 -- In particular, this is used to pass on the category and access token
 -- which would have been passed in as arguments to the program
 -- from the argument parsing stage to the API call to GitHub.
-data Context = Context {category :: Maybe String, gitHubToken :: Maybe String}
+data Context = Context
+  { category :: Maybe String,
+    gitHubToken :: Maybe String
+  }
 
 main :: [String] -> IO ()
 main args = case Arguments.validate args of
@@ -57,10 +60,12 @@ main args = case Arguments.validate args of
 
 invoke :: [String] -> IO ()
 invoke args = do
-  let (executable, flags, cat, tok) = Arguments.translate args
-  (exitCode, out, err) <- readCreateProcessWithExitCode (proc executable flags) ""
+  let (executable, flags, category, token) = Arguments.translate args
+  (exitCode, out, err) <-
+    readCreateProcessWithExitCode (proc executable flags) ""
+  let context = Context {category = category, gitHubToken = token}
   case exitCode of
-    ExitSuccess -> annotate Context {category = cat, gitHubToken = tok} (fromString out)
+    ExitSuccess -> annotate context $ fromString out
     _ -> putStrLn err >> exitWith exitCode
 
 annotate :: Context -> ByteString -> IO ()
@@ -70,7 +75,7 @@ annotate context output = do
   let annotated' = Fingerprint.fill <$> annotated
   case annotated' of
     Nothing -> die $ "invalid encoding\n" <> show output <> "\n"
-    Just output' -> send context (encode output')
+    Just output' -> send context $ encode output'
   where
     value = decode output :: Maybe Value
 
@@ -81,8 +86,9 @@ send context output = do
   let endpoint' = toCall env output
   case endpoint' of
     Just endpoint -> call settings endpoint
-    _ -> die ("missing environment variables\n" <> show env)
+    _ -> die "not all necessary environment variables available"
 
 call :: GitHubSettings -> GHEndpoint -> IO ()
-call settings endpoint = do
-  putStrLn . unlines . toOutputs =<< runGitHubT settings (queryGitHub endpoint)
+call settings endpoint =
+  putStrLn . unlines . toOutputs
+    =<< runGitHubT settings (queryGitHub endpoint)

src/Upload.hs

@@ -29,7 +29,8 @@ toCall :: [(String, String)] -> ByteString -> Maybe GHEndpoint
 toCall env sarifLog
   | Just repo <- repo',
     Just commitSha <- commitSha',
-    Just ref <- ref' =
+    Just ref <- ref',
+    Just workspace <- workspace' =
       Just
         GHEndpoint
           { method = POST,
@@ -39,6 +40,7 @@ toCall env sarifLog
               [ "commit_sha" := commitSha,
                 "ref" := ref,
                 "sarif" := encodedSarif,
+                "checkout_uri" := "file://" <> workspace,
                 "tool_name" := ("HLint" :: Text),
                 "validate" := True
               ]
@@ -50,6 +52,7 @@ toCall env sarifLog
     repo' = lookup "GITHUB_REPOSITORY" env
     commitSha' = lookup "GITHUB_SHA" env
     ref' = lookup "GITHUB_REF" env
+    workspace' = lookup "GITHUB_WORKSPACE" env
     encodedSarif = encodeBase64 $ compress sarifLog
 
 toSettings :: Maybe String -> GitHubSettings