lib/osv: improve types (Range, Event, Severity, Credit)

code/hsec-tools/src/Security/OSV.hs

@@ -5,6 +5,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Security.OSV where
 
+import Control.Applicative ((<|>))
+import Control.Monad (when)
 import Data.Maybe (catMaybes, fromMaybe)
 import Data.Aeson
   ( ToJSON(..), FromJSON(..), Value(..)
@@ -21,11 +23,12 @@ import Data.Time.Format.ISO8601 (iso8601ParseM)
 import Data.Tuple (swap)
 
 data Affected = Affected
-  { affectedRanges :: [Ranges]
+  { affectedRanges :: [Range]
   , affectedPackage :: Package
+  , affectedSeverity :: [Severity]
   , affectedEcosystemSpecific :: EcosystemSpecific
   , affectedDatabaseSpecific :: DatabaseSpecific
-  } deriving (Show, Eq, Ord)
+  } deriving (Show, Eq)
 
 data Affects = Affects
   { affectsOs :: [Value]
@@ -43,9 +46,29 @@ newtype EcosystemSpecific = EcosystemSpecific
   { ecosystemSpecificAffects :: Affects
   } deriving (Show, Eq, Ord)
 
-newtype Events = Events
-  { eventsIntroduced :: Text
-  } deriving (Show, Eq, Ord)
+data Event a
+  = EventIntroduced a
+  | EventFixed a
+  | EventLastAffected a
+  | EventLimit a
+  deriving (Eq, Ord, Show)
+
+instance (FromJSON a) => FromJSON (Event a) where
+  parseJSON = withObject "events[]" $ \o -> do
+    -- there must exactly one key
+    when (length o /= 1) $ typeMismatch "events[]" (Object o)
+    prependFailure "unknown event type" $
+      EventIntroduced <$> o .: "introduced"
+      <|> EventFixed <$> o .: "fixed"
+      <|> EventLastAffected <$> o .: "last_affected"
+      <|> EventLimit <$> o .: "limit"
+
+instance (ToJSON a) => ToJSON (Event a) where
+  toJSON ev = object . pure $ case ev of
+    EventIntroduced a   -> "introduced"    .= a
+    EventFixed a        -> "fixed"         .= a
+    EventLastAffected a -> "last_affected" .= a
+    EventLimit a        -> "limit"         .= a
 
 -- | OSV model parameterised over the @database_specific@ field.
 --
@@ -64,10 +87,10 @@ data Model a = Model
   , modelDetails :: Maybe Text
     -- ^ CommonMark markdown giving additional English textual details about
     -- the vulnerability.
-  , modelSeverity :: [Value]  -- TODO refine type
+  , modelSeverity :: [Severity]
   , modelAffected :: [Affected]
   , modelReferences :: [Reference]
-  , modelCredits :: [Value] -- TODO refine
+  , modelCredits :: [Credit]
   , modelDatabaseSpecific :: Maybe a
   } deriving (Show, Eq)
 
@@ -105,16 +128,62 @@ newModel'
   -> Model a
 newModel' = newModel defaultSchemaVersion
 
+-- | Severity.  There is no 'Ord' instance.  Severity scores should be
+-- calculated and compared in a more nuanced way than 'Ord' can provide
+-- for.
+--
+data Severity
+  = SeverityCvss2 Text {- TODO refine -}
+  | SeverityCvss3 Text {- TODO refine -}
+  deriving (Show, Eq)
+
+instance FromJSON Severity where
+  parseJSON = withObject "severity" $ \o -> do
+    typ <- o .: "type" :: Parser Text
+    case typ of
+      "CVSS_V2" -> SeverityCvss2 <$> o .: "score"
+      "CVSS_V3" -> SeverityCvss3 <$> o .: "score"
+      s ->
+        prependFailure ("unregognised severity type: " <> show s)
+          $ typeMismatch "severity" (Object o)
+
+instance ToJSON Severity where
+  toJSON sev = object $ case sev of
+    SeverityCvss2 score -> [typ "CVSS_V2", "score" .= score]
+    SeverityCvss3 score -> [typ "CVSS_V3", "score" .= score]
+    where
+      typ s = "type" .= (s :: Text)
+
 data Package = Package
   { packageName :: Text
   , packageEcosystem :: Text
   , packagePurl :: Text
   } deriving (Show, Eq, Ord)
 
-data Ranges = Ranges
-  { rangesEvents :: [Events]
-  , rangesType :: Text
-  } deriving (Show, Eq, Ord)
+data Range
+  = RangeSemVer [Event Text {- TODO refine -}]
+  | RangeEcosystem [Event Text]
+  | RangeGit
+      [Event Text {- TODO refine -}]
+      Text -- ^ Git repo URL
+  deriving (Eq, Show)
+
+instance FromJSON Range where
+  parseJSON = withObject "ranges[]" $ \o -> do
+    typ <- o .: "type" :: Parser Text
+    case typ of
+      "SEMVER" -> RangeSemVer <$> o .: "events"
+      "ECOSYSTEM" -> RangeEcosystem <$> o .: "events"
+      "GIT" -> RangeGit <$> o .: "events" <*> o .: "repo"
+      s ->
+        prependFailure ("unregognised range type: " <> show s)
+          $ typeMismatch "ranges[]" (Object o)
+
+instance ToJSON Range where
+  toJSON range = object $ case range of
+    RangeSemVer evs -> ["type" .= ("SEMVER" :: Text), "events" .= evs]
+    RangeEcosystem evs -> ["type" .= ("ECOSYSTEM" :: Text), "events" .= evs]
+    RangeGit evs repo -> ["type" .= ("GIT" :: Text), "events" .= evs, "repo" .= repo]
 
 data ReferenceType
   = ReferenceTypeAdvisory
@@ -134,12 +203,12 @@ data ReferenceType
   -- ^ A source code browser link to the fix (e.g., a GitHub commit) Note that
   -- the @Fix@ type is meant for viewing by people using web browsers. Programs
   -- interested in analyzing the exact commit range would do better to use the
-  -- GIT-typed affected 'Ranges' entries.
+  -- GIT-typed affected 'Range' entries.
   | ReferenceTypeIntroduced
   -- ^ A source code browser link to the introduction of the vulnerability
   -- (e.g., a GitHub commit) Note that the introduced type is meant for viewing
   -- by people using web browsers. Programs interested in analyzing the exact
-  -- commit range would do better to use the GIT-typed affected  'Ranges'
+  -- commit range would do better to use the GIT-typed affected  'Range'
   -- entries.
   | ReferenceTypePackage
   -- ^ A home web page for the package.
@@ -179,13 +248,95 @@ data Reference = Reference
   , referencesUrl :: Text
   } deriving (Show, Eq)
 
+
+-- | Types of individuals or entities to be credited in relation to
+-- an advisory.
+data CreditType
+  = CreditTypeFinder
+  -- ^ Identified the vulnerability
+  | CreditTypeReporter
+  -- ^ Notified the vendor of the vulnerability to a CNA
+  | CreditTypeAnalyst
+  -- ^ Validated the vulnerability to ensure accuracy or severity
+  | CreditTypeCoordinator
+  -- ^ Facilitated the coordinated response process
+  | CreditTypeRemediationDeveloper
+  -- ^ prepared a code change or other remediation plans
+  | CreditTypeRemediationReviewer
+  -- ^ Reviewed vulnerability remediation plans or code changes for effectiveness and completeness
+  | CreditTypeRemediationVerifier
+  -- ^ Tested and verified the vulnerability or its remediation
+  | CreditTypeTool
+  -- ^ Names of tools used in vulnerability discovery or identification
+  | CreditTypeSponsor
+  -- ^ Supported the vulnerability identification or remediation activities
+  | CreditTypeOther
+  -- ^ Any other type or role that does not fall under the categories described above
+  deriving (Show, Eq)
+
+-- | Bijection of credit types and their string representations
+creditTypes :: [(CreditType, Text)]
+creditTypes =
+  [ (CreditTypeFinder               , "FINDER")
+  , (CreditTypeReporter             , "REPORTER")
+  , (CreditTypeAnalyst              , "ANALYST")
+  , (CreditTypeCoordinator          , "COORDINATOR")
+  , (CreditTypeRemediationDeveloper , "REMEDIATION_DEVELOPER")
+  , (CreditTypeRemediationReviewer  , "REMEDIATION_REVIEWER")
+  , (CreditTypeRemediationVerifier  , "REMEDIATION_VERIFIER")
+  , (CreditTypeTool                 , "TOOL")
+  , (CreditTypeSponsor              , "SPONSOR")
+  , (CreditTypeOther                , "OTHER")
+  ]
+
+instance FromJSON CreditType where
+  parseJSON = withText "credits[].type" $ \s ->
+    case lookup s (fmap swap creditTypes) of
+      Just v  -> pure v
+      Nothing -> typeMismatch "credits[].type" (String s)
+
+instance ToJSON CreditType where
+  toJSON v = String $ fromMaybe "OTHER" (lookup v creditTypes)
+
+data Credit = Credit
+  { creditType :: CreditType
+  , creditName :: Text
+    -- ^ The name, label, or other identifier of the individual or entity
+    -- being credited, using whatever notation the creditor prefers.
+  , creditContacts :: [Text] -- TODO refine tpye
+    -- ^ Fully qualified, plain-text URLs at which the credited can be reached.
+  }
+  deriving (Show, Eq)
+
+instance FromJSON Credit where
+  parseJSON = withObject "credits[]" $ \o -> do
+    creditType <- o .: "type"
+    creditName <- o .: "name"
+    creditContacts <- o .::? "contact"
+    pure $ Credit{..}
+
+instance ToJSON Credit where
+  toJSON Credit{..} = object $
+    [ "type" .= creditType
+    , "name" .= creditName
+    ]
+    <> omitEmptyList "contact" creditContacts
+    where
+      omitEmptyList _ [] = []
+      omitEmptyList k xs = [k .= xs]
+
+
 instance ToJSON Affected where
-  toJSON Affected{..} = object
+  toJSON Affected{..} = object $
     [ "ranges" .= affectedRanges
     , "package" .= affectedPackage
     , "ecosystem_specific" .= affectedEcosystemSpecific
     , "database_specific" .= affectedDatabaseSpecific
     ]
+    <> omitEmptyList "severity" affectedSeverity
+    where
+      omitEmptyList _ [] = []
+      omitEmptyList k xs = [k .= xs]
 
 instance ToJSON Affects where
   toJSON Affects{..} = object
@@ -206,11 +357,6 @@ instance ToJSON EcosystemSpecific where
     [ "affects" .= ecosystemSpecificAffects
     ]
 
-instance ToJSON Events where
-  toJSON Events{..} = object
-    [ "introduced" .= eventsIntroduced
-    ]
-
 instance (ToJSON a) => ToJSON (Model a) where
   toJSON Model{..} = object $
     [ "schema_version" .= modelSchemaVersion
@@ -227,7 +373,7 @@ instance (ToJSON a) => ToJSON (Model a) where
       , ("severity" .=) <$> omitEmptyList modelSeverity
       , ("affected" .=) <$> omitEmptyList modelAffected
       , ("references" .=) <$> omitEmptyList modelReferences
-      , ("credits" .=) <$> omitEmptyList modelReferences
+      , ("credits" .=) <$> omitEmptyList modelCredits
       , ("database_specific" .=) <$> modelDatabaseSpecific
     ]
     where
@@ -241,12 +387,6 @@ instance ToJSON Package where
     , "purl" .= packagePurl
     ]
 
-instance ToJSON Ranges where
-  toJSON Ranges{..} = object
-    [ "events" .= rangesEvents
-    , "type" .= rangesType
-    ]
-
 instance ToJSON Reference where
   toJSON Reference{..} = object
     [ "type" .= referencesType
@@ -257,6 +397,7 @@ instance FromJSON Affected where
   parseJSON (Object v) = do
     affectedRanges <- v .: "ranges"
     affectedPackage <- v .: "package"
+    affectedSeverity <- v .::? "severity"
     affectedEcosystemSpecific <- v .: "ecosystem_specific"
     affectedDatabaseSpecific <- v .: "database_specific"
     pure $ Affected{..}
@@ -292,14 +433,6 @@ instance FromJSON EcosystemSpecific where
     prependFailure "parsing EcosystemSpecific failed, "
       (typeMismatch "Object" invalid)
 
-instance FromJSON Events where
-  parseJSON (Object v) = do
-    eventsIntroduced <- v .: "introduced"
-    pure $ Events{..}
-  parseJSON invalid = do
-    prependFailure "parsing Events failed, "
-      (typeMismatch "Object" invalid)
-
 -- | Explicit parser for 'UTCTime', stricter than the @FromJSON@
 -- instance for that type.
 --
@@ -343,15 +476,6 @@ instance FromJSON Package where
     prependFailure "parsing Package failed, "
       (typeMismatch "Object" invalid)
 
-instance FromJSON Ranges where
-  parseJSON (Object v) = do
-    rangesEvents <- v .: "events"
-    rangesType <- v .: "type"
-    pure $ Ranges{..}
-  parseJSON invalid = do
-    prependFailure "parsing Ranges failed, "
-      (typeMismatch "Object" invalid)
-
 instance FromJSON Reference where
   parseJSON (Object v) = do
     referencesType <- v .: "type"