hsec-tools-0.3.0.2: app/Main.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Monad (forM_, join, void, when)
import Control.Monad.Trans.Except (runExceptT, ExceptT (ExceptT), withExceptT, throwE)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson
import qualified Data.ByteString.Lazy as L
import Data.Foldable (for_)
import Data.List (intercalate, isPrefixOf)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Control.Exception (Exception(displayException))
import Distribution.Parsec (eitherParsec)
import Distribution.Types.VersionRange (VersionRange, anyVersion)
import Network.URI (nullURI)
import Options.Applicative hiding (Failure, Success)
import Security.Advisories
import Security.Advisories.Filesystem (forAdvisory, advisoryFromFile)
import qualified Security.Advisories.Convert.OSV as OSV
import Security.Advisories.Generate.HTML
import Security.Advisories.Generate.Snapshot
import Security.Advisories.Git
import Security.Advisories.Queries (listVersionRangeAffectedBy)
import System.Exit (die, exitFailure, exitSuccess)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>), takeBaseName, (<.>))
import System.IO (hPrint, hPutStrLn, stderr)
import Validation (Validation (..))

import qualified Command.Reserve
import qualified Command.NextID

main :: IO ()
main =
  join $
    customExecParser
      (prefs showHelpOnEmpty)
      cliOpts

cliOpts :: ParserInfo (IO ())
cliOpts = info (commandsParser <**> helper) (fullDesc <> header "Haskell Advisories tools")
  where
    commandsParser :: Parser (IO ())
    commandsParser =
      hsubparser
        ( command "check" (info commandCheck (progDesc "Syntax check a single advisory"))
            <> command "next-id" (info commandNextID (progDesc "Print the next available HSEC ID"))
            <> command "reserve" (info commandReserve (progDesc "Reserve an HSEC ID"))
            <> command "osv" (info commandOsv (progDesc "Convert a single advisory to OSV"))
            <> command "render" (info commandRender (progDesc "Render a single advisory as HTML"))
            <> command "generate-index" (info commandGenerateIndex (progDesc "Generate an HTML index"))
            <> command "generate-snapshot" (info commandGenerateSnapshot (progDesc "Generate a snapshot from a Git repository"))
            <> command "query" (info commandQuery (progDesc "Run various queries against the database"))
            <> command "help" (info commandHelp (progDesc "Show command help"))
        )

-- | Create an option with a fixed set of values
multiOption :: [(String, a)] -> Mod OptionFields a -> Parser a
multiOption kvs m = option rdr (m <> metavar choices)
  where
    choices = "{" <> intercalate "|" (fmap fst kvs) <> "}"
    errMsg = "must be one of " <> choices
    rdr = eitherReader (maybe (Left errMsg) Right . flip lookup kvs)

commandReserve :: Parser (IO ())
commandReserve =
  Command.Reserve.runReserveCommand
    <$> optional (argument str (metavar "REPO"))
    <*> multiOption
      [ ("placeholder", Command.Reserve.IdModePlaceholder),
        ("auto", Command.Reserve.IdModeAuto)
      ]
      (long "id-mode" <> help "How to assign IDs")
    <*> flag
      Command.Reserve.DoNotCommit -- default value
      Command.Reserve.Commit -- active value
      ( long "commit"
          <> help "Commit the reservation file"
      )

commandNextID :: Parser (IO ())
commandNextID =
  Command.NextID.runNextIDCommand
    <$> optional (argument str (metavar "REPO"))

commandCheck :: Parser (IO ())
commandCheck = go
    <$> switch (long "all" <> help "Check all published advisories")
    <*> optional (argument str (metavar "PATH"))
  where
    go True mPath = checkAll (fromMaybe "." mPath)
    go False mPath = withAdvisory checkSingle mPath

checkSingle :: Maybe FilePath -> Advisory -> IO ()
checkSingle mPath advisory = do
  for_ mPath $ \path -> do
    let base = takeBaseName path
    when ("HSEC-" `isPrefixOf` base && base /= printHsecId (advisoryId advisory)) $
      die $
        "Filename does not match advisory ID: " <> path
  T.putStrLn "no error"

checkAll :: FilePath -> IO ()
checkAll root = do
  errors <- forAdvisory root $ \path hsidFromFile -> do
    parsed <- advisoryFromFile path
    case parsed of
      Failure err -> pure [(path, displayException err)]
      Success advisory ->
        if printHsecId hsidFromFile /= printHsecId (advisoryId advisory)
          then pure [(path, "Filename does not match advisory ID")]
          else pure []
  case errors of
    [] -> T.putStrLn "no error"
    _ -> do
      forM_ errors $ \(path, err) ->
        hPutStrLn stderr $ path <> ": " <> err
      exitFailure

commandOsv :: Parser (IO ())
commandOsv = go
    <$> switch (long "all" <> help "Convert all published advisories to OSV")
    <*> dbLinksParser
    <*> optional (argument str (metavar "PATH"))
    <*> optional (argument str (metavar "OUTPUT-DIR"))
  where
    dbLinksParser :: Parser OSV.DbLinks
    dbLinksParser =
      OSV.DbLinks
        <$> url "repository" (OSV.dbLinksRepository OSV.haskellLinks) "Repository URL"
        <*> url "osvs" (OSV.dbLinksOSVs OSV.haskellLinks) "OSVs link"
        <*> url "home" (OSV.dbLinksHome OSV.haskellLinks) "Home page URL"
      where
        url :: String -> T.Text -> String -> Parser T.Text
        url name def desc =
          T.pack <$> strOption
            ( long name <> metavar "URL"
           <> help desc
           <> value (T.unpack def)
           <> showDefault
             )
    go False links (Just file) _ = osvSingle links file
    go False _ Nothing _ = die "File required without --all"
    go True links mPath mOutDir = osvAll links (fromMaybe "." mPath) (fromMaybe "osv" mOutDir)

osvSingle :: OSV.DbLinks -> FilePath -> IO ()
osvSingle links file = withAdvisory (\_ adv -> L.putStr (Data.Aeson.encode (OSV.convertWithLinks links adv)) >> putChar '\n') (Just file)

osvAll :: OSV.DbLinks -> FilePath -> FilePath -> IO ()
osvAll links root outputDir = do
  errors <- forAdvisory root $ \path hsid -> do
    parsed <- advisoryFromFile path
    case parsed of
      Failure err -> pure [(path, displayException err)]
      Success advisory -> do
        let year = show $ hsecIdYear hsid
            idStr = printHsecId hsid
            outPath = outputDir </> year </> idStr <.> "json"
        createDirectoryIfMissing True (outputDir </> year)
        L.writeFile outPath (Data.Aeson.encode (OSV.convertWithLinks links advisory))
        pure []
  case errors of
    [] -> pure ()
    _ -> do
      forM_ errors $ \(path, err) ->
        hPutStrLn stderr $ path <> ": " <> err
      exitFailure

commandRender :: Parser (IO ())
commandRender =
  withAdvisory (\_ -> T.putStrLn . advisoryHtml)
    <$> optional (argument str (metavar "FILE"))

commandQuery :: Parser (IO ())
commandQuery =
  hsubparser
    ( command "is-affected" (info isAffected (progDesc "Check if a package/version range is marked vulnerable"))
    )
  where
    isAffected :: Parser (IO ())
    isAffected =
      go
        <$> argument (parseComponent <$> str) (metavar "PACKAGE|REPO:PACKAGE|GHC:COMPONENT")
        <*> optional (option versionRangeReader (metavar "VERSION-RANGE" <> short 'v' <> long "version-range"))
        <*> optional (option str (metavar "ADVISORIES-PATH" <> short 'p' <> long "advisories-path"))
      where
        parseComponent raw =
          case T.breakOn ":" raw of
            (pkg, "") -> hackage $ mkPackageName $ T.unpack pkg
            (p, pkg) ->
              let pkgName = mkPackageName $ T.unpack pkg
              in if T.toCaseFold p == T.toCaseFold "ghc"
                  then fromMaybe (hackage pkgName) $ GHC <$> ghcComponentFromText p
                  else Repository (RepositoryURL nullURI) (RepositoryName p) pkgName
        go :: ComponentIdentifier -> Maybe VersionRange -> Maybe FilePath -> IO ()
        go component versionRange advisoriesPath = do
          let versionRange' = fromMaybe anyVersion versionRange
          maybeAffectedAdvisories <- listVersionRangeAffectedBy (fromMaybe "." advisoriesPath) component versionRange'
          case maybeAffectedAdvisories of
            Validation.Failure errors -> do
              T.hPutStrLn stderr "Cannot parse some advisories"
              forM_ errors $
                hPrint stderr
              exitFailure
            Validation.Success [] -> putStrLn "Not affected"
            Validation.Success affectedAdvisories -> do
              hPutStrLn stderr "Affected by:"
              forM_ affectedAdvisories $ \advisory ->
                T.hPutStrLn stderr $ "* [" <> T.pack (printHsecId $ advisoryId advisory) <> "] " <> advisorySummary advisory
              exitFailure

commandGenerateIndex :: Parser (IO ())
commandGenerateIndex =
  ( \src dst -> do
      renderAdvisoriesIndex src dst
      T.putStrLn "Index generated"
  )
    <$> argument str (metavar "SOURCE-DIR")
    <*> argument str (metavar "DESTINATION-DIR")

commandGenerateSnapshot :: Parser (IO ())
commandGenerateSnapshot =
  ( \src dst -> do
      createSnapshot src dst
      T.putStrLn "Snapshot generated"
  )
    <$> argument str (metavar "SOURCE-DIR")
    <*> argument str (metavar "DESTINATION-DIR")

commandHelp :: Parser (IO ())
commandHelp =
  ( \mCmd ->
      let args = maybe id (:) mCmd ["-h"]
       in void $ handleParseResult $ execParserPure defaultPrefs cliOpts args
  )
    <$> optional (argument str (metavar "COMMAND"))

versionRangeReader :: ReadM VersionRange
versionRangeReader = eitherReader eitherParsec

withAdvisory :: (Maybe FilePath -> Advisory -> IO ()) -> Maybe FilePath -> IO ()
withAdvisory go file = do
  input <- maybe T.getContents T.readFile file

  oob <- runExceptT $ case file of
    Nothing -> throwE StdInHasNoOOB
    Just path -> do
     withExceptT GitHasNoOOB $ do
      gitInfo <- ExceptT $ liftIO $ getAdvisoryGitInfo path
      pure OutOfBandAttributes
        { oobPublished = firstAppearanceCommitDate gitInfo
        , oobModified = lastModificationCommitDate gitInfo
        }

  case parseAdvisory NoOverrides oob input of
    Left e -> do
      hPutStrLn stderr (displayException e)
      exitFailure
    Right advisory -> do
      go file advisory
      exitSuccess