feat: rework index's advisory page

code/hsec-tools/src/Security/Advisories/Generate/HTML.hs

@@ -5,6 +5,7 @@
 
 module Security.Advisories.Generate.HTML
   ( renderAdvisoriesIndex,
+    dbg
   )
 where
 
@@ -13,32 +14,42 @@ import qualified Data.ByteString.Char8 as BS8
 import Data.List (sortOn)
 import Data.List.Extra (groupSort)
 import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
 import Data.Ord (Down (..))
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified Data.Text.Lazy as TL
-import Data.Time (UTCTime)
+import Data.Time (UTCTime, formatTime, defaultTimeLocale)
 import Data.Time.Format.ISO8601
 import System.Directory (createDirectoryIfMissing)
 import System.Exit (exitFailure)
 import System.FilePath ((</>), takeDirectory)
 import System.IO (hPrint, hPutStrLn, stderr)
+import System.IO.Unsafe (unsafePerformIO)
 
+import Data.Default (def)
 import Distribution.Pretty (prettyShow)
+import Distribution.Types.VersionRange (earlierVersion, intersectVersionRanges, orLaterVersion)
 import Lucid
 import Safe (maximumMay)
 import qualified Text.Atom.Feed as Feed
 import qualified Text.Atom.Feed.Export as FeedExport
+import Text.Pandoc (runIOorExplode)
+import Text.Pandoc.Writers (writeHtml5String)
 import Validation (Validation (..))
 
 import qualified Security.Advisories as Advisories
 import Security.Advisories.Filesystem (listAdvisories)
 import Security.Advisories.Generate.TH (readDirFilesTH)
 import Security.Advisories.Core.Advisory (ComponentIdentifier (..), ghcComponentToText)
+import qualified Security.OSV as OSV
 
 -- * Actions
 
+dbg :: IO ()
+dbg = renderAdvisoriesIndex "/home/black/ancien/haskell/security-advisories" "/home/black/ancien/haskell/security-advisories/tmp"
+
 renderAdvisoriesIndex :: FilePath -> FilePath -> IO ()
 renderAdvisoriesIndex src dst = do
   advisories <-
@@ -62,10 +73,12 @@ renderAdvisoriesIndex src dst = do
 
   let advisoriesDir = dst </> "advisory"
   createDirectoryIfMissing False advisoriesDir
-  forM_ advisories $ \advisory ->
-    renderHTMLToFile (advisoriesDir </> advisoryHtmlFilename (Advisories.advisoryId advisory)) $
-      inPage PageAdvisory $
-        toHtmlRaw (Advisories.advisoryHtml advisory)
+  forM_ advisories $ \advisory -> do
+    let advisoryPath = advisoriesDir </> advisoryHtmlFilename (Advisories.advisoryId advisory)
+    hPutStrLn stderr $ "Rendering " <> advisoryPath
+    renderHTMLToFile advisoryPath $
+      inPage (T.pack $ Advisories.printHsecId $ Advisories.advisoryId advisory) PageAdvisory $
+        renderAdvisory advisory
 
   hPutStrLn stderr $ "Rendering " <> (dst </> "atom.xml")
   writeFile (dst </> "atom.xml") $ T.unpack $ renderFeed advisories
@@ -98,7 +111,7 @@ data AffectedPackageR = AffectedPackageR
 
 listByDates :: [AdvisoryR] -> Html ()
 listByDates advisories =
-  inPage PageListByDates $ do
+  inPage "Advisories list" PageListByDates $ do
     indexDescription
     div_ [class_ "advisories"] $ do
       table_ [class_ "pure-table pure-table-horizontal"] $ do
@@ -126,7 +139,7 @@ packageName af = case ecosystem af of
 
 listByPackages :: [AdvisoryR] -> Html ()
 listByPackages advisories =
-  inPage PageListByPackages $ do
+  inPage "Advisories list" PageListByPackages $ do
     indexDescription
 
     let byPackage :: Map.Map Text [(AdvisoryR, AffectedPackageR)]
@@ -173,6 +186,84 @@ indexDescription =
       a_ [href_ "https://github.com/haskell/security-advisories/blob/main/PROCESS.md", target_ "_blank", rel_ "noopener noreferrer"] "report new or historic security issues"
       "."
 
+renderAdvisory :: Advisories.Advisory -> Html ()
+renderAdvisory advisory = do
+  let renderedDescription = unsafePerformIO $ runIOorExplode $ writeHtml5String def $ Advisories.advisoryPandoc advisory
+  toHtmlRaw renderedDescription
+
+  let placeholderWhenEmptyOr :: [a] -> ([a] -> Html ()) -> Html ()
+      placeholderWhenEmptyOr xs f = if null xs then i_ "< none >" else f xs
+
+  h3_ [] "Info"
+  dl_ [] $ do
+    dt_ "Published"
+    dd_ [] $ toHtml $ formatTime defaultTimeLocale "%B %d, %Y" $ Advisories.advisoryPublished advisory
+    dt_ "Modified"
+    dd_ [] $ toHtml $ formatTime defaultTimeLocale "%B %d, %Y" $ Advisories.advisoryModified advisory
+    dt_ "CAPECs"
+    dd_ [] $
+      placeholderWhenEmptyOr (Advisories.advisoryCAPECs advisory) $ \capecs ->
+        ul_ [] $
+          forM_ capecs $ \(Advisories.CAPEC capec) ->
+            a_ [href_ $ "https://capec.mitre.org/data/definitions/" <> T.pack (show capec) <> ".html"] $ toHtml $ show capec
+    dt_ "CWEs"
+    dd_ [] $
+      placeholderWhenEmptyOr (Advisories.advisoryCWEs advisory) $ \cwes ->
+        ul_ [] $
+          forM_ cwes $ \(Advisories.CWE cwe) ->
+            li_ [] $ a_ [href_ $ "https://cwe.mitre.org/data/definitions/" <> T.pack (show cwe) <> ".html"] $ toHtml $ show cwe
+    dt_ "Keywords"
+    dd_ [] $ placeholderWhenEmptyOr (Advisories.advisoryKeywords advisory) $ toHtml . T.intercalate ", " . map Advisories.unKeyword
+    dt_ "Aliases"
+    dd_ [] $ placeholderWhenEmptyOr (Advisories.advisoryAliases advisory) $ toHtml . T.intercalate ", "
+    dt_ "Related"
+    dd_ [] $ placeholderWhenEmptyOr (Advisories.advisoryRelated advisory) $ toHtml . T.intercalate ", "
+    dt_ "References"
+    dd_ [] $
+      placeholderWhenEmptyOr (Advisories.advisoryReferences advisory) $ \references ->
+        ul_ [] $
+          forM_ references $ \reference ->
+            li_ [] $ a_ [href_ $ OSV.referencesUrl reference] $ toHtml $ "[" <> fromMaybe "WEB" (lookup (OSV.referencesType reference) OSV.referenceTypes) <> "] " <> OSV.referencesUrl reference
+
+  h4_ [] "Affected"
+  forM_ (Advisories.advisoryAffected advisory) $ \affected -> do
+    h5_ [] $
+      case Advisories.affectedComponentIdentifier affected of
+        Hackage package -> a_ [href_ $ "https://hackage.haskell.org/package/" <> package] $ code_ [] $ toHtml package
+        GHC component -> code_ [] $ toHtml $ Advisories.ghcComponentToText component
+
+    dl_ [] $ do
+      dt_ "CVSS"
+      dd_ [] $ toHtml $ T.pack $ show $ Advisories.affectedCVSS affected
+      dt_ "Versions"
+      dd_ [] $
+        ul_ [] $
+          forM_ (Advisories.affectedVersions affected) $ \affectedVersionRange ->
+            li_ [] $
+              code_ [] $
+                toHtml $
+                  T.pack $
+                    prettyShow $
+                      let introducedVersionRange = orLaterVersion $ Advisories.affectedVersionRangeIntroduced affectedVersionRange
+                      in case Advisories.affectedVersionRangeFixed affectedVersionRange of
+                        Nothing -> introducedVersionRange
+                        Just fixedVersion -> introducedVersionRange `intersectVersionRanges` earlierVersion fixedVersion
+      forM_ (Advisories.affectedArchitectures affected) $ \architectures -> do
+        dt_ "Architectures"
+        dd_ [] $ toHtml $ T.intercalate ", " $ T.toLower . T.pack . show <$> architectures
+      forM_ (Advisories.affectedOS affected) $ \oses -> do
+        dt_ "OSes"
+        dd_ [] $ toHtml $ T.intercalate ", " $ T.toLower . T.pack . show <$> oses
+      dt_ "Declarations"
+      dd_ [] $
+        placeholderWhenEmptyOr (Advisories.affectedDeclarations affected) $ \declarations ->
+          ul_ [] $
+            forM_ declarations $ \(declaration, versionRange) ->
+              li_ [] $ do
+                code_ [] $ toHtml declaration
+                ": "
+                code_ [] $ toHtml $ T.pack $ prettyShow versionRange
+
 -- * Utils
 
 data NavigationPage
@@ -187,8 +278,8 @@ baseUrlForPage = \case
   PageListByPackages -> "."
   PageAdvisory -> ".."
 
-inPage :: NavigationPage -> Html () -> Html ()
-inPage page content =
+inPage :: Text -> NavigationPage -> Html () -> Html ()
+inPage title page content =
   doctypehtml_ $
     html_ [lang_ "en"] $ do
       head_ $ do
@@ -210,7 +301,7 @@ inPage page content =
               a_ [href_ "by-dates.html"] "by date"
             li_ [class_ $ selectedOn PageListByPackages] $
               a_ [href_ "by-packages.html"] "by package"
-        h1_ [] "Advisories list"
+        h1_ [] $ toHtml title
         div_ [class_ "content"] content
         footer_ [] $ do
           div_ [class_ "HF"] $ do