hsec-tools-0.3.0.1: 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
import Security.Advisories
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.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 =
  withAdvisory go
    <$> optional (argument str (metavar "FILE"))
  where
    go 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"

commandOsv :: Parser (IO ())
commandOsv =
  withAdvisory . go
    <$> dbLinksParser
    <*> optional (argument str (metavar "FILE"))
  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 links _ adv = do
      L.putStr (Data.Aeson.encode (OSV.convertWithLinks links adv))
      putChar '\n'

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