{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Security.Advisories.Parse
  ( parseAdvisory
  , OutOfBandAttributes(..)
  , emptyOutOfBandAttributes
  , AttributeOverridePolicy(..)
  , ParseAdvisoryError(..)
  )
  where

import Data.Bifunctor (first)
import Data.Foldable (toList)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.Monoid (First(..))
import Data.Tuple (swap)
import GHC.Generics (Generic)

import qualified Data.Map as Map
import Data.Sequence (Seq((:<|)))
import qualified Data.Text as T
import qualified Data.Text.Lazy as T (toStrict)
import Data.Time (ZonedTime(..), LocalTime (LocalTime), midnight, utc)
import Distribution.Parsec (eitherParsec)
import Distribution.Types.Version (Version)
import Distribution.Types.VersionRange (VersionRange)

import Commonmark.Html (Html, renderHtml)
import qualified Commonmark.Parser as Commonmark
import Commonmark.Types (HasAttributes(..), IsBlock(..), IsInline(..), Rangeable(..), SourceRange(..))
import Commonmark.Pandoc (Cm(unCm))
import qualified Toml
import qualified Toml.Syntax as Toml (startPos)
import qualified Toml.Schema as Toml
import Text.Pandoc.Builder (Blocks, Many(..))
import Text.Pandoc.Definition (Block(..), Inline(..), Pandoc(..))
import Text.Pandoc.Walk (query)
import Text.Parsec.Pos (sourceLine)

import Security.Advisories.Core.HsecId
import Security.Advisories.Core.Advisory
import Security.OSV (Reference(..), ReferenceType, referenceTypes)
import qualified Security.CVSS as CVSS
-- | A source of attributes supplied out of band from the advisory
-- content.  Values provided out of band are treated according to
-- the 'AttributeOverridePolicy'.
--
-- The convenient way to construct a value of this type is to start
-- with 'emptyOutOfBandAttributes', then use the record accessors to
-- set particular fields.
--
data OutOfBandAttributes = OutOfBandAttributes
  { OutOfBandAttributes -> Maybe ZonedTime
oobModified :: Maybe ZonedTime
  , OutOfBandAttributes -> Maybe ZonedTime
oobPublished :: Maybe ZonedTime
  }
  deriving (Int -> OutOfBandAttributes -> ShowS
[OutOfBandAttributes] -> ShowS
OutOfBandAttributes -> String
(Int -> OutOfBandAttributes -> ShowS)
-> (OutOfBandAttributes -> String)
-> ([OutOfBandAttributes] -> ShowS)
-> Show OutOfBandAttributes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OutOfBandAttributes -> ShowS
showsPrec :: Int -> OutOfBandAttributes -> ShowS
$cshow :: OutOfBandAttributes -> String
show :: OutOfBandAttributes -> String
$cshowList :: [OutOfBandAttributes] -> ShowS
showList :: [OutOfBandAttributes] -> ShowS
Show)

emptyOutOfBandAttributes :: OutOfBandAttributes
emptyOutOfBandAttributes :: OutOfBandAttributes
emptyOutOfBandAttributes = OutOfBandAttributes
  { oobModified :: Maybe ZonedTime
oobModified = Maybe ZonedTime
forall a. Maybe a
Nothing
  , oobPublished :: Maybe ZonedTime
oobPublished = Maybe ZonedTime
forall a. Maybe a
Nothing
  }

data AttributeOverridePolicy
  = PreferInBand
  | PreferOutOfBand
  | NoOverrides -- ^ Parse error if attribute occurs both in-band and out-of-band
  deriving (Int -> AttributeOverridePolicy -> ShowS
[AttributeOverridePolicy] -> ShowS
AttributeOverridePolicy -> String
(Int -> AttributeOverridePolicy -> ShowS)
-> (AttributeOverridePolicy -> String)
-> ([AttributeOverridePolicy] -> ShowS)
-> Show AttributeOverridePolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AttributeOverridePolicy -> ShowS
showsPrec :: Int -> AttributeOverridePolicy -> ShowS
$cshow :: AttributeOverridePolicy -> String
show :: AttributeOverridePolicy -> String
$cshowList :: [AttributeOverridePolicy] -> ShowS
showList :: [AttributeOverridePolicy] -> ShowS
Show, AttributeOverridePolicy -> AttributeOverridePolicy -> Bool
(AttributeOverridePolicy -> AttributeOverridePolicy -> Bool)
-> (AttributeOverridePolicy -> AttributeOverridePolicy -> Bool)
-> Eq AttributeOverridePolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AttributeOverridePolicy -> AttributeOverridePolicy -> Bool
== :: AttributeOverridePolicy -> AttributeOverridePolicy -> Bool
$c/= :: AttributeOverridePolicy -> AttributeOverridePolicy -> Bool
/= :: AttributeOverridePolicy -> AttributeOverridePolicy -> Bool
Eq)

data ParseAdvisoryError
  = MarkdownError Commonmark.ParseError T.Text
  | MarkdownFormatError T.Text
  | TomlError String T.Text
  | AdvisoryError [Toml.MatchMessage Toml.Position] T.Text
  deriving stock (ParseAdvisoryError -> ParseAdvisoryError -> Bool
(ParseAdvisoryError -> ParseAdvisoryError -> Bool)
-> (ParseAdvisoryError -> ParseAdvisoryError -> Bool)
-> Eq ParseAdvisoryError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParseAdvisoryError -> ParseAdvisoryError -> Bool
== :: ParseAdvisoryError -> ParseAdvisoryError -> Bool
$c/= :: ParseAdvisoryError -> ParseAdvisoryError -> Bool
/= :: ParseAdvisoryError -> ParseAdvisoryError -> Bool
Eq, Int -> ParseAdvisoryError -> ShowS
[ParseAdvisoryError] -> ShowS
ParseAdvisoryError -> String
(Int -> ParseAdvisoryError -> ShowS)
-> (ParseAdvisoryError -> String)
-> ([ParseAdvisoryError] -> ShowS)
-> Show ParseAdvisoryError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseAdvisoryError -> ShowS
showsPrec :: Int -> ParseAdvisoryError -> ShowS
$cshow :: ParseAdvisoryError -> String
show :: ParseAdvisoryError -> String
$cshowList :: [ParseAdvisoryError] -> ShowS
showList :: [ParseAdvisoryError] -> ShowS
Show, (forall x. ParseAdvisoryError -> Rep ParseAdvisoryError x)
-> (forall x. Rep ParseAdvisoryError x -> ParseAdvisoryError)
-> Generic ParseAdvisoryError
forall x. Rep ParseAdvisoryError x -> ParseAdvisoryError
forall x. ParseAdvisoryError -> Rep ParseAdvisoryError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ParseAdvisoryError -> Rep ParseAdvisoryError x
from :: forall x. ParseAdvisoryError -> Rep ParseAdvisoryError x
$cto :: forall x. Rep ParseAdvisoryError x -> ParseAdvisoryError
to :: forall x. Rep ParseAdvisoryError x -> ParseAdvisoryError
Generic)

-- | The main parsing function.  'OutOfBandAttributes' are handled
-- according to the 'AttributeOverridePolicy'.
--
parseAdvisory
  :: AttributeOverridePolicy
  -> OutOfBandAttributes
  -> T.Text -- ^ input (CommonMark with TOML header)
  -> Either ParseAdvisoryError Advisory
parseAdvisory :: AttributeOverridePolicy
-> OutOfBandAttributes
-> Text
-> Either ParseAdvisoryError Advisory
parseAdvisory AttributeOverridePolicy
policy OutOfBandAttributes
attrs Text
raw = do
  Blocks
markdown <-
    Cm () Blocks -> Blocks
forall b a. Cm b a -> a
unCm
    (Cm () Blocks -> Blocks)
-> Either ParseAdvisoryError (Cm () Blocks)
-> Either ParseAdvisoryError Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParseError -> Text -> ParseAdvisoryError)
-> (ParseError -> Text)
-> Either ParseError (Cm () Blocks)
-> Either ParseAdvisoryError (Cm () Blocks)
forall e a.
(e -> Text -> ParseAdvisoryError)
-> (e -> Text) -> Either e a -> Either ParseAdvisoryError a
firstPretty ParseError -> Text -> ParseAdvisoryError
MarkdownError (String -> Text
T.pack (String -> Text) -> (ParseError -> String) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show)
          (String -> Text -> Either ParseError (Cm () Blocks)
forall il bl.
IsBlock il bl =>
String -> Text -> Either ParseError bl
Commonmark.commonmark String
"input" Text
raw :: Either Commonmark.ParseError (Cm () Blocks))
  (Text
frontMatter, [Block]
rest) <- (Text -> ParseAdvisoryError)
-> Either Text (Text, [Block])
-> Either ParseAdvisoryError (Text, [Block])
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> ParseAdvisoryError
MarkdownFormatError (Either Text (Text, [Block])
 -> Either ParseAdvisoryError (Text, [Block]))
-> Either Text (Text, [Block])
-> Either ParseAdvisoryError (Text, [Block])
forall a b. (a -> b) -> a -> b
$ Blocks -> Either Text (Text, [Block])
advisoryDoc Blocks
markdown
  let doc :: Pandoc
doc = Meta -> [Block] -> Pandoc
Pandoc Meta
forall a. Monoid a => a
mempty [Block]
rest
  !Text
summary <- (Text -> ParseAdvisoryError)
-> Either Text Text -> Either ParseAdvisoryError Text
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> ParseAdvisoryError
MarkdownFormatError (Either Text Text -> Either ParseAdvisoryError Text)
-> Either Text Text -> Either ParseAdvisoryError Text
forall a b. (a -> b) -> a -> b
$ Pandoc -> Either Text Text
parseAdvisorySummary Pandoc
doc
  Table' Position
table <- case Text -> Either String (Table' Position)
Toml.parse Text
frontMatter of
    Left String
e -> ParseAdvisoryError -> Either ParseAdvisoryError (Table' Position)
forall a b. a -> Either a b
Left (String -> Text -> ParseAdvisoryError
TomlError String
e (String -> Text
T.pack String
e))
    Right Table' Position
t -> Table' Position -> Either ParseAdvisoryError (Table' Position)
forall a b. b -> Either a b
Right Table' Position
t

  -- Re-parse as FirstSourceRange to find the source range of
  -- the TOML header.
  FirstSourceRange (First Maybe SourceRange
mRange) <-
    (ParseError -> Text -> ParseAdvisoryError)
-> (ParseError -> Text)
-> Either ParseError FirstSourceRange
-> Either ParseAdvisoryError FirstSourceRange
forall e a.
(e -> Text -> ParseAdvisoryError)
-> (e -> Text) -> Either e a -> Either ParseAdvisoryError a
firstPretty ParseError -> Text -> ParseAdvisoryError
MarkdownError (String -> Text
T.pack (String -> Text) -> (ParseError -> String) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show) (String -> Text -> Either ParseError FirstSourceRange
forall il bl.
IsBlock il bl =>
String -> Text -> Either ParseError bl
Commonmark.commonmark String
"input" Text
raw)
  let
    details :: Text
details = case Maybe SourceRange
mRange of
      Just (SourceRange ((SourcePos
_,SourcePos
end):[(SourcePos, SourcePos)]
_)) ->
        [Text] -> Text
T.unlines
        ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Text -> Bool
T.null
        ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Text) -> Text) -> [(Int, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Text) -> Text
forall a b. (a, b) -> b
snd
        ([(Int, Text)] -> [Text])
-> ([Text] -> [(Int, Text)]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Text) -> Bool) -> [(Int, Text)] -> [(Int, Text)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< SourcePos -> Int
sourceLine SourcePos
end) (Int -> Bool) -> ((Int, Text) -> Int) -> (Int, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Text) -> Int
forall a b. (a, b) -> a
fst)
        ([(Int, Text)] -> [(Int, Text)])
-> ([Text] -> [(Int, Text)]) -> [Text] -> [(Int, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..]
        ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
raw
      Maybe SourceRange
_ ->
        -- no block elements?  empty range list?
        -- these shouldn't happen, but better be total
        Text
raw

  -- Re-parse input as HTML.  This will probably go away; we now store the
  -- Pandoc doc and can render that instead, where needed.
  Text
html <-
    Text -> Text
T.toStrict (Text -> Text) -> (Html () -> Text) -> Html () -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html () -> Text
forall a. Html a -> Text
renderHtml
    (Html () -> Text)
-> Either ParseAdvisoryError (Html ())
-> Either ParseAdvisoryError Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParseError -> Text -> ParseAdvisoryError)
-> (ParseError -> Text)
-> Either ParseError (Html ())
-> Either ParseAdvisoryError (Html ())
forall e a.
(e -> Text -> ParseAdvisoryError)
-> (e -> Text) -> Either e a -> Either ParseAdvisoryError a
firstPretty ParseError -> Text -> ParseAdvisoryError
MarkdownError (String -> Text
T.pack (String -> Text) -> (ParseError -> String) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show)
          (String -> Text -> Either ParseError (Html ())
forall il bl.
IsBlock il bl =>
String -> Text -> Either ParseError bl
Commonmark.commonmark String
"input" Text
raw :: Either Commonmark.ParseError (Html ()))

  case OutOfBandAttributes
-> AttributeOverridePolicy
-> Pandoc
-> Text
-> Text
-> Text
-> Table' Position
-> Either [MatchMessage Position] Advisory
parseAdvisoryTable OutOfBandAttributes
attrs AttributeOverridePolicy
policy Pandoc
doc Text
summary Text
details Text
html Table' Position
table of
    Left [MatchMessage Position]
es -> ParseAdvisoryError -> Either ParseAdvisoryError Advisory
forall a b. a -> Either a b
Left ([MatchMessage Position] -> Text -> ParseAdvisoryError
AdvisoryError [MatchMessage Position]
es (String -> Text
T.pack ([String] -> String
unlines ((MatchMessage Position -> String)
-> [MatchMessage Position] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map MatchMessage Position -> String
Toml.prettyMatchMessage [MatchMessage Position]
es))))
    Right Advisory
adv -> Advisory -> Either ParseAdvisoryError Advisory
forall a. a -> Either ParseAdvisoryError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Advisory
adv

  where
    firstPretty
      :: (e -> T.Text -> ParseAdvisoryError)
      -> (e -> T.Text)
      -> Either e a
      -> Either ParseAdvisoryError a
    firstPretty :: forall e a.
(e -> Text -> ParseAdvisoryError)
-> (e -> Text) -> Either e a -> Either ParseAdvisoryError a
firstPretty e -> Text -> ParseAdvisoryError
ctr e -> Text
pretty = (e -> ParseAdvisoryError)
-> Either e a -> Either ParseAdvisoryError a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((e -> ParseAdvisoryError)
 -> Either e a -> Either ParseAdvisoryError a)
-> (e -> ParseAdvisoryError)
-> Either e a
-> Either ParseAdvisoryError a
forall a b. (a -> b) -> a -> b
$ (e -> Text -> ParseAdvisoryError)
-> (e -> Text) -> e -> ParseAdvisoryError
forall e.
(e -> Text -> ParseAdvisoryError)
-> (e -> Text) -> e -> ParseAdvisoryError
mkPretty e -> Text -> ParseAdvisoryError
ctr e -> Text
pretty

    mkPretty
      :: (e -> T.Text -> ParseAdvisoryError)
      -> (e -> T.Text)
      -> e
      -> ParseAdvisoryError
    mkPretty :: forall e.
(e -> Text -> ParseAdvisoryError)
-> (e -> Text) -> e -> ParseAdvisoryError
mkPretty e -> Text -> ParseAdvisoryError
ctr e -> Text
pretty e
x = e -> Text -> ParseAdvisoryError
ctr e
x (Text -> ParseAdvisoryError) -> Text -> ParseAdvisoryError
forall a b. (a -> b) -> a -> b
$ e -> Text
pretty e
x

parseAdvisoryTable
  :: OutOfBandAttributes
  -> AttributeOverridePolicy
  -> Pandoc -- ^ parsed document (without frontmatter)
  -> T.Text -- ^ summary
  -> T.Text -- ^ details
  -> T.Text -- ^ rendered HTML
  -> Toml.Table' Toml.Position
  -> Either [Toml.MatchMessage Toml.Position] Advisory
parseAdvisoryTable :: OutOfBandAttributes
-> AttributeOverridePolicy
-> Pandoc
-> Text
-> Text
-> Text
-> Table' Position
-> Either [MatchMessage Position] Advisory
parseAdvisoryTable OutOfBandAttributes
oob AttributeOverridePolicy
policy Pandoc
doc Text
summary Text
details Text
html Table' Position
tab =
  Matcher Position Advisory
-> Either [MatchMessage Position] Advisory
forall l a. Matcher l a -> Either [MatchMessage l] a
Toml.runMatcherFatalWarn (Matcher Position Advisory
 -> Either [MatchMessage Position] Advisory)
-> Matcher Position Advisory
-> Either [MatchMessage Position] Advisory
forall a b. (a -> b) -> a -> b
$
   do FrontMatter
fm <- Value' Position -> Matcher Position FrontMatter
forall l. Value' l -> Matcher l FrontMatter
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue (Position -> Table' Position -> Value' Position
forall a. a -> Table' a -> Value' a
Toml.Table' Position
Toml.startPos Table' Position
tab)
      ZonedTime
published <-
        AttributeOverridePolicy
-> Maybe ZonedTime
-> String
-> Maybe ZonedTime
-> Matcher Position ZonedTime
forall (m :: * -> *) a.
MonadFail m =>
AttributeOverridePolicy -> Maybe a -> String -> Maybe a -> m a
mergeOobMandatory AttributeOverridePolicy
policy
          (OutOfBandAttributes -> Maybe ZonedTime
oobPublished OutOfBandAttributes
oob)
          String
"advisory.date"
          (AdvisoryMetadata -> Maybe ZonedTime
amdPublished (FrontMatter -> AdvisoryMetadata
frontMatterAdvisory FrontMatter
fm))
      ZonedTime
modified <-
        ZonedTime -> Maybe ZonedTime -> ZonedTime
forall a. a -> Maybe a -> a
fromMaybe ZonedTime
published (Maybe ZonedTime -> ZonedTime)
-> Matcher Position (Maybe ZonedTime) -> Matcher Position ZonedTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          AttributeOverridePolicy
-> Maybe ZonedTime
-> String
-> Maybe ZonedTime
-> Matcher Position (Maybe ZonedTime)
forall (m :: * -> *) a.
MonadFail m =>
AttributeOverridePolicy
-> Maybe a -> String -> Maybe a -> m (Maybe a)
mergeOobOptional AttributeOverridePolicy
policy
            (OutOfBandAttributes -> Maybe ZonedTime
oobPublished OutOfBandAttributes
oob)
            String
"advisory.modified"
            (AdvisoryMetadata -> Maybe ZonedTime
amdModified (FrontMatter -> AdvisoryMetadata
frontMatterAdvisory FrontMatter
fm))
      Advisory -> Matcher Position Advisory
forall a. a -> Matcher Position a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Advisory
        { advisoryId :: HsecId
advisoryId = AdvisoryMetadata -> HsecId
amdId (FrontMatter -> AdvisoryMetadata
frontMatterAdvisory FrontMatter
fm)
        , advisoryPublished :: ZonedTime
advisoryPublished = ZonedTime
published
        , advisoryModified :: ZonedTime
advisoryModified = ZonedTime
modified
        , advisoryCAPECs :: [CAPEC]
advisoryCAPECs = AdvisoryMetadata -> [CAPEC]
amdCAPECs (FrontMatter -> AdvisoryMetadata
frontMatterAdvisory FrontMatter
fm)
        , advisoryCWEs :: [CWE]
advisoryCWEs = AdvisoryMetadata -> [CWE]
amdCWEs (FrontMatter -> AdvisoryMetadata
frontMatterAdvisory FrontMatter
fm)
        , advisoryKeywords :: [Keyword]
advisoryKeywords = AdvisoryMetadata -> [Keyword]
amdKeywords (FrontMatter -> AdvisoryMetadata
frontMatterAdvisory FrontMatter
fm)
        , advisoryAliases :: [Text]
advisoryAliases = AdvisoryMetadata -> [Text]
amdAliases (FrontMatter -> AdvisoryMetadata
frontMatterAdvisory FrontMatter
fm)
        , advisoryRelated :: [Text]
advisoryRelated = AdvisoryMetadata -> [Text]
amdRelated (FrontMatter -> AdvisoryMetadata
frontMatterAdvisory FrontMatter
fm)
        , advisoryAffected :: [Affected]
advisoryAffected = FrontMatter -> [Affected]
frontMatterAffected FrontMatter
fm
        , advisoryReferences :: [Reference]
advisoryReferences = FrontMatter -> [Reference]
frontMatterReferences FrontMatter
fm
        , advisoryPandoc :: Pandoc
advisoryPandoc = Pandoc
doc
        , advisoryHtml :: Text
advisoryHtml = Text
html
        , advisorySummary :: Text
advisorySummary = Text
summary
        , advisoryDetails :: Text
advisoryDetails = Text
details
        }

-- | Internal type corresponding to the complete raw TOML content of an
-- advisory markdown file.
data FrontMatter = FrontMatter {
  FrontMatter -> AdvisoryMetadata
frontMatterAdvisory :: AdvisoryMetadata,
  FrontMatter -> [Reference]
frontMatterReferences :: [Reference],
  FrontMatter -> [Affected]
frontMatterAffected :: [Affected]
} deriving ((forall x. FrontMatter -> Rep FrontMatter x)
-> (forall x. Rep FrontMatter x -> FrontMatter)
-> Generic FrontMatter
forall x. Rep FrontMatter x -> FrontMatter
forall x. FrontMatter -> Rep FrontMatter x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FrontMatter -> Rep FrontMatter x
from :: forall x. FrontMatter -> Rep FrontMatter x
$cto :: forall x. Rep FrontMatter x -> FrontMatter
to :: forall x. Rep FrontMatter x -> FrontMatter
Generic)

instance Toml.FromValue FrontMatter where
  fromValue :: forall l. Value' l -> Matcher l FrontMatter
fromValue = ParseTable l FrontMatter -> Value' l -> Matcher l FrontMatter
forall l a. ParseTable l a -> Value' l -> Matcher l a
Toml.parseTableFromValue (ParseTable l FrontMatter -> Value' l -> Matcher l FrontMatter)
-> ParseTable l FrontMatter -> Value' l -> Matcher l FrontMatter
forall a b. (a -> b) -> a -> b
$
   do AdvisoryMetadata
advisory   <- Text -> ParseTable l AdvisoryMetadata
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"advisory"
      [Affected]
affected   <- Text -> ParseTable l [Affected]
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"affected"
      [Reference]
references <- [Reference] -> Maybe [Reference] -> [Reference]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Reference] -> [Reference])
-> ParseTable l (Maybe [Reference]) -> ParseTable l [Reference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ParseTable l (Maybe [Reference])
forall a l. FromValue a => Text -> ParseTable l (Maybe a)
Toml.optKey Text
"references"
      FrontMatter -> ParseTable l FrontMatter
forall a. a -> ParseTable l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FrontMatter {
        frontMatterAdvisory :: AdvisoryMetadata
frontMatterAdvisory = AdvisoryMetadata
advisory,
        frontMatterAffected :: [Affected]
frontMatterAffected = [Affected]
affected,
        frontMatterReferences :: [Reference]
frontMatterReferences = [Reference]
references
        }

instance Toml.ToValue FrontMatter where
  toValue :: FrontMatter -> Value
toValue = FrontMatter -> Value
forall a. ToTable a => a -> Value
Toml.defaultTableToValue

instance Toml.ToTable FrontMatter where
  toTable :: FrontMatter -> Table
toTable FrontMatter
x = [(Text, Value)] -> Table
Toml.table
    [ Text
"advisory" Text -> AdvisoryMetadata -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= FrontMatter -> AdvisoryMetadata
frontMatterAdvisory FrontMatter
x
    , Text
"affected" Text -> [Affected] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= FrontMatter -> [Affected]
frontMatterAffected FrontMatter
x
    , Text
"references" Text -> [Reference] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= FrontMatter -> [Reference]
frontMatterReferences FrontMatter
x
    ]

-- | Internal type corresponding to the @[advisory]@ subsection of the
-- TOML frontmatter in an advisory markdown file.
data AdvisoryMetadata = AdvisoryMetadata
  { AdvisoryMetadata -> HsecId
amdId         :: HsecId
  , AdvisoryMetadata -> Maybe ZonedTime
amdModified   :: Maybe ZonedTime
  , AdvisoryMetadata -> Maybe ZonedTime
amdPublished  :: Maybe ZonedTime
  , AdvisoryMetadata -> [CAPEC]
amdCAPECs     :: [CAPEC]
  , AdvisoryMetadata -> [CWE]
amdCWEs       :: [CWE]
  , AdvisoryMetadata -> [Keyword]
amdKeywords   :: [Keyword]
  , AdvisoryMetadata -> [Text]
amdAliases    :: [T.Text]
  , AdvisoryMetadata -> [Text]
amdRelated    :: [T.Text]
  }

instance Toml.FromValue AdvisoryMetadata where
  fromValue :: forall l. Value' l -> Matcher l AdvisoryMetadata
fromValue = ParseTable l AdvisoryMetadata
-> Value' l -> Matcher l AdvisoryMetadata
forall l a. ParseTable l a -> Value' l -> Matcher l a
Toml.parseTableFromValue (ParseTable l AdvisoryMetadata
 -> Value' l -> Matcher l AdvisoryMetadata)
-> ParseTable l AdvisoryMetadata
-> Value' l
-> Matcher l AdvisoryMetadata
forall a b. (a -> b) -> a -> b
$
   do HsecId
identifier  <- Text -> ParseTable l HsecId
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"id"
      Maybe ZonedTime
published   <- Text
-> (Value' l -> Matcher l ZonedTime)
-> ParseTable l (Maybe ZonedTime)
forall l a.
Text -> (Value' l -> Matcher l a) -> ParseTable l (Maybe a)
Toml.optKeyOf Text
"date" Value' l -> Matcher l ZonedTime
forall l. Value' l -> Matcher l ZonedTime
getDefaultedZonedTime
      Maybe ZonedTime
modified    <- Text
-> (Value' l -> Matcher l ZonedTime)
-> ParseTable l (Maybe ZonedTime)
forall l a.
Text -> (Value' l -> Matcher l a) -> ParseTable l (Maybe a)
Toml.optKeyOf Text
"modified"  Value' l -> Matcher l ZonedTime
forall l. Value' l -> Matcher l ZonedTime
getDefaultedZonedTime
      let optList :: Text -> ParseTable l [a]
optList Text
key = [a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [a] -> [a]) -> ParseTable l (Maybe [a]) -> ParseTable l [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ParseTable l (Maybe [a])
forall a l. FromValue a => Text -> ParseTable l (Maybe a)
Toml.optKey Text
key
      [CAPEC]
capecs      <- Text -> ParseTable l [CAPEC]
forall {a} {l}. FromValue a => Text -> ParseTable l [a]
optList Text
"capec"
      [CWE]
cwes        <- Text -> ParseTable l [CWE]
forall {a} {l}. FromValue a => Text -> ParseTable l [a]
optList Text
"cwe"
      [Keyword]
kwds        <- Text -> ParseTable l [Keyword]
forall {a} {l}. FromValue a => Text -> ParseTable l [a]
optList Text
"keywords"
      [Text]
aliases     <- Text -> ParseTable l [Text]
forall {a} {l}. FromValue a => Text -> ParseTable l [a]
optList Text
"aliases"
      [Text]
related     <- Text -> ParseTable l [Text]
forall {a} {l}. FromValue a => Text -> ParseTable l [a]
optList Text
"related"
      AdvisoryMetadata -> ParseTable l AdvisoryMetadata
forall a. a -> ParseTable l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AdvisoryMetadata
        { amdId :: HsecId
amdId = HsecId
identifier
        , amdModified :: Maybe ZonedTime
amdModified = Maybe ZonedTime
modified
        , amdPublished :: Maybe ZonedTime
amdPublished = Maybe ZonedTime
published
        , amdCAPECs :: [CAPEC]
amdCAPECs = [CAPEC]
capecs
        , amdCWEs :: [CWE]
amdCWEs = [CWE]
cwes
        , amdKeywords :: [Keyword]
amdKeywords = [Keyword]
kwds
        , amdAliases :: [Text]
amdAliases = [Text]
aliases
        , amdRelated :: [Text]
amdRelated = [Text]
related
        }

instance Toml.ToValue AdvisoryMetadata where
  toValue :: AdvisoryMetadata -> Value
toValue = AdvisoryMetadata -> Value
forall a. ToTable a => a -> Value
Toml.defaultTableToValue

instance Toml.ToTable AdvisoryMetadata where
  toTable :: AdvisoryMetadata -> Table
toTable AdvisoryMetadata
x = [(Text, Value)] -> Table
Toml.table ([(Text, Value)] -> Table) -> [(Text, Value)] -> Table
forall a b. (a -> b) -> a -> b
$
    [Text
"id"        Text -> HsecId -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= AdvisoryMetadata -> HsecId
amdId AdvisoryMetadata
x] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++
    [Text
"modified"  Text -> ZonedTime -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= ZonedTime
y | Just ZonedTime
y <- [AdvisoryMetadata -> Maybe ZonedTime
amdModified AdvisoryMetadata
x]] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++
    [Text
"date"      Text -> ZonedTime -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= ZonedTime
y | Just ZonedTime
y <- [AdvisoryMetadata -> Maybe ZonedTime
amdPublished AdvisoryMetadata
x]] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++
    [Text
"capec"     Text -> [CAPEC] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= AdvisoryMetadata -> [CAPEC]
amdCAPECs AdvisoryMetadata
x | Bool -> Bool
not ([CAPEC] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (AdvisoryMetadata -> [CAPEC]
amdCAPECs AdvisoryMetadata
x))] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++
    [Text
"cwe"       Text -> [CWE] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= AdvisoryMetadata -> [CWE]
amdCWEs AdvisoryMetadata
x | Bool -> Bool
not ([CWE] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (AdvisoryMetadata -> [CWE]
amdCWEs AdvisoryMetadata
x))] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++
    [Text
"keywords"  Text -> [Keyword] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= AdvisoryMetadata -> [Keyword]
amdKeywords AdvisoryMetadata
x | Bool -> Bool
not ([Keyword] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (AdvisoryMetadata -> [Keyword]
amdKeywords AdvisoryMetadata
x))] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++
    [Text
"aliases"   Text -> [Text] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= AdvisoryMetadata -> [Text]
amdAliases AdvisoryMetadata
x | Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (AdvisoryMetadata -> [Text]
amdAliases AdvisoryMetadata
x))] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++
    [Text
"Related"   Text -> [Text] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= AdvisoryMetadata -> [Text]
amdRelated AdvisoryMetadata
x | Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (AdvisoryMetadata -> [Text]
amdRelated AdvisoryMetadata
x))]

instance Toml.FromValue Affected where
  fromValue :: forall l. Value' l -> Matcher l Affected
fromValue = ParseTable l Affected -> Value' l -> Matcher l Affected
forall l a. ParseTable l a -> Value' l -> Matcher l a
Toml.parseTableFromValue (ParseTable l Affected -> Value' l -> Matcher l Affected)
-> ParseTable l Affected -> Value' l -> Matcher l Affected
forall a b. (a -> b) -> a -> b
$
   do Text
package   <- Text -> ParseTable l Text
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"package"
      CVSS
cvss      <- Text -> ParseTable l CVSS
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"cvss" -- TODO validate CVSS format
      Maybe [OS]
os        <- Text -> ParseTable l (Maybe [OS])
forall a l. FromValue a => Text -> ParseTable l (Maybe a)
Toml.optKey Text
"os"
      Maybe [Architecture]
arch      <- Text -> ParseTable l (Maybe [Architecture])
forall a l. FromValue a => Text -> ParseTable l (Maybe a)
Toml.optKey Text
"arch"
      [(Text, VersionRange)]
decls     <- [(Text, VersionRange)]
-> (Map Text VersionRange -> [(Text, VersionRange)])
-> Maybe (Map Text VersionRange)
-> [(Text, VersionRange)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Map Text VersionRange -> [(Text, VersionRange)]
forall k a. Map k a -> [(k, a)]
Map.toList (Maybe (Map Text VersionRange) -> [(Text, VersionRange)])
-> ParseTable l (Maybe (Map Text VersionRange))
-> ParseTable l [(Text, VersionRange)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ParseTable l (Maybe (Map Text VersionRange))
forall a l. FromValue a => Text -> ParseTable l (Maybe a)
Toml.optKey Text
"declarations"
      [AffectedVersionRange]
versions  <- Text -> ParseTable l [AffectedVersionRange]
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"versions"
      Affected -> ParseTable l Affected
forall a. a -> ParseTable l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Affected -> ParseTable l Affected)
-> Affected -> ParseTable l Affected
forall a b. (a -> b) -> a -> b
$ Affected
        { affectedPackage :: Text
affectedPackage = Text
package
        , affectedCVSS :: CVSS
affectedCVSS = CVSS
cvss
        , affectedVersions :: [AffectedVersionRange]
affectedVersions = [AffectedVersionRange]
versions
        , affectedArchitectures :: Maybe [Architecture]
affectedArchitectures = Maybe [Architecture]
arch
        , affectedOS :: Maybe [OS]
affectedOS = Maybe [OS]
os
        , affectedDeclarations :: [(Text, VersionRange)]
affectedDeclarations = [(Text, VersionRange)]
decls
        }

instance Toml.ToValue Affected where
  toValue :: Affected -> Value
toValue = Affected -> Value
forall a. ToTable a => a -> Value
Toml.defaultTableToValue

instance Toml.ToTable Affected where
  toTable :: Affected -> Table
toTable Affected
x = [(Text, Value)] -> Table
Toml.table ([(Text, Value)] -> Table) -> [(Text, Value)] -> Table
forall a b. (a -> b) -> a -> b
$
    [ Text
"package" Text -> Text -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= Affected -> Text
affectedPackage Affected
x
    , Text
"cvss"    Text -> CVSS -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= Affected -> CVSS
affectedCVSS Affected
x
    , Text
"versions" Text -> [AffectedVersionRange] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= Affected -> [AffectedVersionRange]
affectedVersions Affected
x
    ] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++
    [ Text
"os"   Text -> [OS] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= [OS]
y | Just [OS]
y <- [Affected -> Maybe [OS]
affectedOS Affected
x]] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++
    [ Text
"arch" Text -> [Architecture] -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= [Architecture]
y | Just [Architecture]
y <- [Affected -> Maybe [Architecture]
affectedArchitectures Affected
x]] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++
    [ Text
"declarations" Text -> Map String VersionRange -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= [(Text, VersionRange)] -> Map String VersionRange
forall {a}. [(Text, a)] -> Map String a
asTable (Affected -> [(Text, VersionRange)]
affectedDeclarations Affected
x) | Bool -> Bool
not ([(Text, VersionRange)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Affected -> [(Text, VersionRange)]
affectedDeclarations Affected
x))]
    where
      asTable :: [(Text, a)] -> Map String a
asTable [(Text, a)]
kvs = [(String, a)] -> Map String a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text -> String
T.unpack Text
k, a
v) | (Text
k,a
v) <- [(Text, a)]
kvs]

instance Toml.FromValue AffectedVersionRange where
  fromValue :: forall l. Value' l -> Matcher l AffectedVersionRange
fromValue = ParseTable l AffectedVersionRange
-> Value' l -> Matcher l AffectedVersionRange
forall l a. ParseTable l a -> Value' l -> Matcher l a
Toml.parseTableFromValue (ParseTable l AffectedVersionRange
 -> Value' l -> Matcher l AffectedVersionRange)
-> ParseTable l AffectedVersionRange
-> Value' l
-> Matcher l AffectedVersionRange
forall a b. (a -> b) -> a -> b
$
   do Version
introduced <- Text -> ParseTable l Version
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"introduced"
      Maybe Version
fixed      <- Text -> ParseTable l (Maybe Version)
forall a l. FromValue a => Text -> ParseTable l (Maybe a)
Toml.optKey Text
"fixed"
      AffectedVersionRange -> ParseTable l AffectedVersionRange
forall a. a -> ParseTable l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AffectedVersionRange {
        affectedVersionRangeIntroduced :: Version
affectedVersionRangeIntroduced = Version
introduced,
        affectedVersionRangeFixed :: Maybe Version
affectedVersionRangeFixed = Maybe Version
fixed
        }

instance Toml.ToValue AffectedVersionRange where
  toValue :: AffectedVersionRange -> Value
toValue = AffectedVersionRange -> Value
forall a. ToTable a => a -> Value
Toml.defaultTableToValue

instance Toml.ToTable AffectedVersionRange where
  toTable :: AffectedVersionRange -> Table
toTable AffectedVersionRange
x = [(Text, Value)] -> Table
Toml.table ([(Text, Value)] -> Table) -> [(Text, Value)] -> Table
forall a b. (a -> b) -> a -> b
$
    (Text
"introduced" Text -> Version -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= AffectedVersionRange -> Version
affectedVersionRangeIntroduced AffectedVersionRange
x) (Text, Value) -> [(Text, Value)] -> [(Text, Value)]
forall a. a -> [a] -> [a]
:
    [Text
"fixed" Text -> Version -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= Version
y | Just Version
y <- [AffectedVersionRange -> Maybe Version
affectedVersionRangeFixed AffectedVersionRange
x]]


instance Toml.FromValue HsecId where
  fromValue :: forall l. Value' l -> Matcher l HsecId
fromValue Value' l
v =
   do String
s <- Value' l -> Matcher l String
forall l. Value' l -> Matcher l String
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue Value' l
v
      case String -> Maybe HsecId
parseHsecId String
s of
        Maybe HsecId
Nothing -> l -> String -> Matcher l HsecId
forall l a. l -> String -> Matcher l a
Toml.failAt (Value' l -> l
forall a. Value' a -> a
Toml.valueAnn Value' l
v) String
"invalid HSEC-ID: expected HSEC-[0-9]{4,}-[0-9]{4,}"
        Just HsecId
x -> HsecId -> Matcher l HsecId
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsecId
x

instance Toml.ToValue HsecId where
  toValue :: HsecId -> Value
toValue = String -> Value
forall a. ToValue a => a -> Value
Toml.toValue (String -> Value) -> (HsecId -> String) -> HsecId -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsecId -> String
printHsecId

instance Toml.FromValue CAPEC where
  fromValue :: forall l. Value' l -> Matcher l CAPEC
fromValue Value' l
v = Integer -> CAPEC
CAPEC (Integer -> CAPEC) -> Matcher l Integer -> Matcher l CAPEC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value' l -> Matcher l Integer
forall l. Value' l -> Matcher l Integer
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue Value' l
v

instance Toml.ToValue CAPEC where
  toValue :: CAPEC -> Value
toValue (CAPEC Integer
x) = Integer -> Value
forall a. ToValue a => a -> Value
Toml.toValue Integer
x

instance Toml.FromValue CWE where
  fromValue :: forall l. Value' l -> Matcher l CWE
fromValue Value' l
v = Integer -> CWE
CWE (Integer -> CWE) -> Matcher l Integer -> Matcher l CWE
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value' l -> Matcher l Integer
forall l. Value' l -> Matcher l Integer
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue Value' l
v

instance Toml.ToValue CWE where
  toValue :: CWE -> Value
toValue (CWE Integer
x) = Integer -> Value
forall a. ToValue a => a -> Value
Toml.toValue Integer
x

instance Toml.FromValue Keyword where
  fromValue :: forall l. Value' l -> Matcher l Keyword
fromValue Value' l
v = Text -> Keyword
Keyword (Text -> Keyword) -> Matcher l Text -> Matcher l Keyword
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value' l -> Matcher l Text
forall l. Value' l -> Matcher l Text
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue Value' l
v

instance Toml.ToValue Keyword where
  toValue :: Keyword -> Value
toValue (Keyword Text
x) = Text -> Value
forall a. ToValue a => a -> Value
Toml.toValue Text
x

-- | Get a datetime with the timezone defaulted to UTC and the time defaulted to midnight
getDefaultedZonedTime :: Toml.Value' l -> Toml.Matcher l ZonedTime
getDefaultedZonedTime :: forall l. Value' l -> Matcher l ZonedTime
getDefaultedZonedTime (Toml.ZonedTime' l
_ ZonedTime
x) = ZonedTime -> Matcher l ZonedTime
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ZonedTime
x
getDefaultedZonedTime (Toml.LocalTime' l
_ LocalTime
x) = ZonedTime -> Matcher l ZonedTime
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTime -> TimeZone -> ZonedTime
ZonedTime LocalTime
x TimeZone
utc)
getDefaultedZonedTime (Toml.Day' l
_       Day
x) = ZonedTime -> Matcher l ZonedTime
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTime -> TimeZone -> ZonedTime
ZonedTime (Day -> TimeOfDay -> LocalTime
LocalTime Day
x TimeOfDay
midnight) TimeZone
utc)
getDefaultedZonedTime Value' l
v                     = l -> String -> Matcher l ZonedTime
forall l a. l -> String -> Matcher l a
Toml.failAt (Value' l -> l
forall a. Value' a -> a
Toml.valueAnn Value' l
v) String
"expected a date with optional time and timezone"

advisoryDoc :: Blocks -> Either T.Text (T.Text, [Block])
advisoryDoc :: Blocks -> Either Text (Text, [Block])
advisoryDoc (Many Seq Block
blocks) = case Seq Block
blocks of
  CodeBlock (Text
_, [Text]
classes, [(Text, Text)]
_) Text
frontMatter :<| Seq Block
t
    | Text
"toml" Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes
    -> (Text, [Block]) -> Either Text (Text, [Block])
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
frontMatter, Seq Block -> [Block]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Block
t)
  Seq Block
_
    -> Text -> Either Text (Text, [Block])
forall a b. a -> Either a b
Left Text
"Does not have toml code block as first element"

parseAdvisorySummary :: Pandoc -> Either T.Text T.Text
parseAdvisorySummary :: Pandoc -> Either Text Text
parseAdvisorySummary = ([Inline] -> Text) -> Either Text [Inline] -> Either Text Text
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Inline] -> Text
inlineText (Either Text [Inline] -> Either Text Text)
-> (Pandoc -> Either Text [Inline]) -> Pandoc -> Either Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pandoc -> Either Text [Inline]
firstHeading

firstHeading :: Pandoc -> Either T.Text [Inline]
firstHeading :: Pandoc -> Either Text [Inline]
firstHeading (Pandoc Meta
_ [Block]
xs) = [Block] -> Either Text [Inline]
forall {a}. IsString a => [Block] -> Either a [Inline]
go [Block]
xs
  where
  go :: [Block] -> Either a [Inline]
go [] = a -> Either a [Inline]
forall a b. a -> Either a b
Left a
"Does not have summary heading"
  go (Header Int
_ (Text, [Text], [(Text, Text)])
_ [Inline]
ys : [Block]
_) = [Inline] -> Either a [Inline]
forall a b. b -> Either a b
Right [Inline]
ys
  go (Block
_ : [Block]
t) = [Block] -> Either a [Inline]
go [Block]
t

-- yield "plain" terminal inline content; discard formatting
inlineText :: [Inline] -> T.Text
inlineText :: [Inline] -> Text
inlineText = (Inline -> Text) -> [Inline] -> Text
forall c. Monoid c => (Inline -> c) -> [Inline] -> c
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
query Inline -> Text
f
  where
  f :: Inline -> Text
f Inline
inl = case Inline
inl of
    Str Text
s -> Text
s
    Code (Text, [Text], [(Text, Text)])
_ Text
s -> Text
s
    Inline
Space -> Text
" "
    Inline
SoftBreak -> Text
" "
    Inline
LineBreak -> Text
"\n"
    Math MathType
_ Text
s -> Text
s
    RawInline Format
_ Text
s -> Text
s
    Inline
_ -> Text
""

instance Toml.FromValue Reference where
  fromValue :: forall l. Value' l -> Matcher l Reference
fromValue = ParseTable l Reference -> Value' l -> Matcher l Reference
forall l a. ParseTable l a -> Value' l -> Matcher l a
Toml.parseTableFromValue (ParseTable l Reference -> Value' l -> Matcher l Reference)
-> ParseTable l Reference -> Value' l -> Matcher l Reference
forall a b. (a -> b) -> a -> b
$
   do ReferenceType
refType <- Text -> ParseTable l ReferenceType
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"type"
      Text
url     <- Text -> ParseTable l Text
forall a l. FromValue a => Text -> ParseTable l a
Toml.reqKey Text
"url"
      Reference -> ParseTable l Reference
forall a. a -> ParseTable l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReferenceType -> Text -> Reference
Reference ReferenceType
refType Text
url)

instance Toml.FromValue ReferenceType where
  fromValue :: forall l. Value' l -> Matcher l ReferenceType
fromValue (Toml.Text' l
_ Text
refTypeStr)
    | Just ReferenceType
a <- Text -> [(Text, ReferenceType)] -> Maybe ReferenceType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
refTypeStr (((ReferenceType, Text) -> (Text, ReferenceType))
-> [(ReferenceType, Text)] -> [(Text, ReferenceType)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReferenceType, Text) -> (Text, ReferenceType)
forall a b. (a, b) -> (b, a)
swap [(ReferenceType, Text)]
referenceTypes) = ReferenceType -> Matcher l ReferenceType
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReferenceType
a
  fromValue Value' l
v =
    l -> String -> Matcher l ReferenceType
forall l a. l -> String -> Matcher l a
Toml.failAt (Value' l -> l
forall a. Value' a -> a
Toml.valueAnn Value' l
v) (String -> Matcher l ReferenceType)
-> String -> Matcher l ReferenceType
forall a b. (a -> b) -> a -> b
$
      String
"reference.type should be one of: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Text -> String
T.unpack (Text -> String)
-> ((ReferenceType, Text) -> Text)
-> (ReferenceType, Text)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReferenceType, Text) -> Text
forall a b. (a, b) -> b
snd ((ReferenceType, Text) -> String)
-> [(ReferenceType, Text)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ReferenceType, Text)]
referenceTypes)

instance Toml.ToValue Reference where
  toValue :: Reference -> Value
toValue = Reference -> Value
forall a. ToTable a => a -> Value
Toml.defaultTableToValue

instance Toml.ToTable Reference where
  toTable :: Reference -> Table
toTable Reference
x = [(Text, Value)] -> Table
Toml.table
    [ Text
"type" Text -> Text -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"UNKNOWN" (ReferenceType -> [(ReferenceType, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Reference -> ReferenceType
referencesType Reference
x) [(ReferenceType, Text)]
referenceTypes)
    , Text
"url" Text -> Text -> (Text, Value)
forall a. ToValue a => Text -> a -> (Text, Value)
Toml..= Reference -> Text
referencesUrl Reference
x
    ]

instance Toml.FromValue OS where
  fromValue :: forall l. Value' l -> Matcher l OS
fromValue Value' l
v =
   do String
s <- Value' l -> Matcher l String
forall l. Value' l -> Matcher l String
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue Value' l
v
      case String
s :: String of
        String
"darwin" -> OS -> Matcher l OS
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OS
MacOS
        String
"freebsd" -> OS -> Matcher l OS
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OS
FreeBSD
        String
"linux" -> OS -> Matcher l OS
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OS
Linux
        String
"linux-android" -> OS -> Matcher l OS
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OS
Android
        String
"mingw32" -> OS -> Matcher l OS
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OS
Windows
        String
"netbsd" -> OS -> Matcher l OS
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OS
NetBSD
        String
"openbsd" -> OS -> Matcher l OS
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OS
OpenBSD
        String
other -> l -> String -> Matcher l OS
forall l a. l -> String -> Matcher l a
Toml.failAt (Value' l -> l
forall a. Value' a -> a
Toml.valueAnn Value' l
v) (String
"Invalid OS: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
other)

instance Toml.ToValue OS where
  toValue :: OS -> Value
toValue OS
x =
    String -> Value
forall a. ToValue a => a -> Value
Toml.toValue (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$
    case OS
x of
      OS
MacOS -> String
"darwin" :: String
      OS
FreeBSD -> String
"freebsd"
      OS
Linux -> String
"linux"
      OS
Android -> String
"linux-android"
      OS
Windows -> String
"mingw32"
      OS
NetBSD -> String
"netbsd"
      OS
OpenBSD -> String
"openbsd"

instance Toml.FromValue Architecture where
  fromValue :: forall l. Value' l -> Matcher l Architecture
fromValue Value' l
v =
   do String
s <- Value' l -> Matcher l String
forall l. Value' l -> Matcher l String
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue Value' l
v
      case String
s :: String of
        String
"aarch64" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
AArch64
        String
"alpha" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
Alpha
        String
"arm" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
Arm
        String
"hppa" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
HPPA
        String
"hppa1_1" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
HPPA1_1
        String
"i386" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
I386
        String
"ia64" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
IA64
        String
"m68k" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
M68K
        String
"mips" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
MIPS
        String
"mipseb" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
MIPSEB
        String
"mipsel" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
MIPSEL
        String
"nios2" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
NIOS2
        String
"powerpc" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
PowerPC
        String
"powerpc64" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
PowerPC64
        String
"powerpc64le" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
PowerPC64LE
        String
"riscv32" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
RISCV32
        String
"riscv64" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
RISCV64
        String
"rs6000" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
RS6000
        String
"s390" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
S390
        String
"s390x" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
S390X
        String
"sh4" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
SH4
        String
"sparc" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
SPARC
        String
"sparc64" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
SPARC64
        String
"vax" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
VAX
        String
"x86_64" -> Architecture -> Matcher l Architecture
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Architecture
X86_64
        String
other -> l -> String -> Matcher l Architecture
forall l a. l -> String -> Matcher l a
Toml.failAt (Value' l -> l
forall a. Value' a -> a
Toml.valueAnn Value' l
v) (String
"Invalid architecture: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
other)

instance Toml.ToValue Architecture where
  toValue :: Architecture -> Value
toValue Architecture
x =
    String -> Value
forall a. ToValue a => a -> Value
Toml.toValue (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$
    case Architecture
x of
        Architecture
AArch64 -> String
"aarch64" :: String
        Architecture
Alpha -> String
"alpha"
        Architecture
Arm -> String
"arm"
        Architecture
HPPA -> String
"hppa"
        Architecture
HPPA1_1 -> String
"hppa1_1"
        Architecture
I386 -> String
"i386"
        Architecture
IA64 -> String
"ia64"
        Architecture
M68K -> String
"m68k"
        Architecture
MIPS -> String
"mips"
        Architecture
MIPSEB -> String
"mipseb"
        Architecture
MIPSEL -> String
"mipsel"
        Architecture
NIOS2 -> String
"nios2"
        Architecture
PowerPC -> String
"powerpc"
        Architecture
PowerPC64 -> String
"powerpc64"
        Architecture
PowerPC64LE -> String
"powerpc64le"
        Architecture
RISCV32 -> String
"riscv32"
        Architecture
RISCV64 -> String
"riscv64"
        Architecture
RS6000 -> String
"rs6000"
        Architecture
S390 -> String
"s390"
        Architecture
S390X -> String
"s390x"
        Architecture
SH4 -> String
"sh4"
        Architecture
SPARC -> String
"sparc"
        Architecture
SPARC64 -> String
"sparc64"
        Architecture
VAX -> String
"vax"
        Architecture
X86_64 -> String
"x86_64"

instance Toml.FromValue Version where
  fromValue :: forall l. Value' l -> Matcher l Version
fromValue Value' l
v =
   do String
s <- Value' l -> Matcher l String
forall l. Value' l -> Matcher l String
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue Value' l
v
      case String -> Either String Version
forall a. Parsec a => String -> Either String a
eitherParsec String
s of
        Left String
err -> l -> String -> Matcher l Version
forall l a. l -> String -> Matcher l a
Toml.failAt (Value' l -> l
forall a. Value' a -> a
Toml.valueAnn Value' l
v) (String
"parse error in version range: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err)
        Right Version
affected -> Version -> Matcher l Version
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
affected

instance Toml.ToValue Version where
  toValue :: Version -> Value
toValue = String -> Value
forall a. ToValue a => a -> Value
Toml.toValue (String -> Value) -> (Version -> String) -> Version -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
forall a. Show a => a -> String
show

instance Toml.FromValue VersionRange where
  fromValue :: forall l. Value' l -> Matcher l VersionRange
fromValue Value' l
v =
   do String
s <- Value' l -> Matcher l String
forall l. Value' l -> Matcher l String
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue Value' l
v
      case String -> Either String VersionRange
forall a. Parsec a => String -> Either String a
eitherParsec String
s of
        Left String
err -> l -> String -> Matcher l VersionRange
forall l a. l -> String -> Matcher l a
Toml.failAt (Value' l -> l
forall a. Value' a -> a
Toml.valueAnn Value' l
v) (String
"parse error in version range: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err)
        Right VersionRange
affected -> VersionRange -> Matcher l VersionRange
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VersionRange
affected

instance Toml.ToValue VersionRange where
  toValue :: VersionRange -> Value
toValue = String -> Value
forall a. ToValue a => a -> Value
Toml.toValue (String -> Value)
-> (VersionRange -> String) -> VersionRange -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRange -> String
forall a. Show a => a -> String
show

instance Toml.FromValue CVSS.CVSS where
  fromValue :: forall l. Value' l -> Matcher l CVSS
fromValue Value' l
v =
    do Text
s <- Value' l -> Matcher l Text
forall l. Value' l -> Matcher l Text
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue Value' l
v
       case Text -> Either CVSSError CVSS
CVSS.parseCVSS Text
s of
         Left CVSSError
err -> l -> String -> Matcher l CVSS
forall l a. l -> String -> Matcher l a
Toml.failAt (Value' l -> l
forall a. Value' a -> a
Toml.valueAnn Value' l
v) (String
"parse error in cvss: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CVSSError -> String
forall a. Show a => a -> String
show CVSSError
err)
         Right CVSS
cvss -> CVSS -> Matcher l CVSS
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CVSS
cvss

instance Toml.ToValue CVSS.CVSS where
  toValue :: CVSS -> Value
toValue = Text -> Value
forall a. ToValue a => a -> Value
Toml.toValue (Text -> Value) -> (CVSS -> Text) -> CVSS -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CVSS -> Text
CVSS.cvssVectorString

mergeOob
  :: MonadFail m
  => AttributeOverridePolicy
  -> Maybe a  -- ^ out-of-band value
  -> String  -- ^ key
  -> Maybe a -- ^ in-band-value
  -> m b  -- ^ when key and out-of-band value absent
  -> (a -> m b) -- ^ when value present
  -> m b
mergeOob :: forall (m :: * -> *) a b.
MonadFail m =>
AttributeOverridePolicy
-> Maybe a -> String -> Maybe a -> m b -> (a -> m b) -> m b
mergeOob AttributeOverridePolicy
policy Maybe a
oob String
k Maybe a
ib m b
absent a -> m b
present = do
  case (Maybe a
oob, Maybe a
ib) of
    (Just a
l, Just a
r) -> case AttributeOverridePolicy
policy of
      AttributeOverridePolicy
NoOverrides -> String -> m b
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"illegal out of band override: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
k)
      AttributeOverridePolicy
PreferOutOfBand -> a -> m b
present a
l
      AttributeOverridePolicy
PreferInBand -> a -> m b
present a
r
    (Just a
a, Maybe a
Nothing) -> a -> m b
present a
a
    (Maybe a
Nothing, Just a
a) -> a -> m b
present a
a
    (Maybe a
Nothing, Maybe a
Nothing) -> m b
absent

mergeOobOptional
  :: MonadFail m
  => AttributeOverridePolicy
  -> Maybe a  -- ^ out-of-band value
  -> String -- ^ key
  -> Maybe a -- ^ in-band-value
  -> m (Maybe a)
mergeOobOptional :: forall (m :: * -> *) a.
MonadFail m =>
AttributeOverridePolicy
-> Maybe a -> String -> Maybe a -> m (Maybe a)
mergeOobOptional AttributeOverridePolicy
policy Maybe a
oob String
k Maybe a
ib =
  AttributeOverridePolicy
-> Maybe a
-> String
-> Maybe a
-> m (Maybe a)
-> (a -> m (Maybe a))
-> m (Maybe a)
forall (m :: * -> *) a b.
MonadFail m =>
AttributeOverridePolicy
-> Maybe a -> String -> Maybe a -> m b -> (a -> m b) -> m b
mergeOob AttributeOverridePolicy
policy Maybe a
oob String
k Maybe a
ib (Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing) (Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)

mergeOobMandatory
  :: MonadFail m
  => AttributeOverridePolicy
  -> Maybe a  -- ^ out-of-band value
  -> String  -- ^ key
  -> Maybe a -- ^ in-band value
  -> m a
mergeOobMandatory :: forall (m :: * -> *) a.
MonadFail m =>
AttributeOverridePolicy -> Maybe a -> String -> Maybe a -> m a
mergeOobMandatory AttributeOverridePolicy
policy Maybe a
oob String
k Maybe a
ib =
  AttributeOverridePolicy
-> Maybe a -> String -> Maybe a -> m a -> (a -> m a) -> m a
forall (m :: * -> *) a b.
MonadFail m =>
AttributeOverridePolicy
-> Maybe a -> String -> Maybe a -> m b -> (a -> m b) -> m b
mergeOob AttributeOverridePolicy
policy Maybe a
oob String
k Maybe a
ib (String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"missing mandatory key: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
k)) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | A solution to an awkward problem: how to delete the TOML
-- block.  We parse into this type to get the source range of
-- the first block element.  We can use it to delete the lines
-- from the input.
--
newtype FirstSourceRange = FirstSourceRange (First SourceRange)
  deriving (Int -> FirstSourceRange -> ShowS
[FirstSourceRange] -> ShowS
FirstSourceRange -> String
(Int -> FirstSourceRange -> ShowS)
-> (FirstSourceRange -> String)
-> ([FirstSourceRange] -> ShowS)
-> Show FirstSourceRange
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FirstSourceRange -> ShowS
showsPrec :: Int -> FirstSourceRange -> ShowS
$cshow :: FirstSourceRange -> String
show :: FirstSourceRange -> String
$cshowList :: [FirstSourceRange] -> ShowS
showList :: [FirstSourceRange] -> ShowS
Show, NonEmpty FirstSourceRange -> FirstSourceRange
FirstSourceRange -> FirstSourceRange -> FirstSourceRange
(FirstSourceRange -> FirstSourceRange -> FirstSourceRange)
-> (NonEmpty FirstSourceRange -> FirstSourceRange)
-> (forall b.
    Integral b =>
    b -> FirstSourceRange -> FirstSourceRange)
-> Semigroup FirstSourceRange
forall b. Integral b => b -> FirstSourceRange -> FirstSourceRange
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: FirstSourceRange -> FirstSourceRange -> FirstSourceRange
<> :: FirstSourceRange -> FirstSourceRange -> FirstSourceRange
$csconcat :: NonEmpty FirstSourceRange -> FirstSourceRange
sconcat :: NonEmpty FirstSourceRange -> FirstSourceRange
$cstimes :: forall b. Integral b => b -> FirstSourceRange -> FirstSourceRange
stimes :: forall b. Integral b => b -> FirstSourceRange -> FirstSourceRange
Semigroup, Semigroup FirstSourceRange
FirstSourceRange
Semigroup FirstSourceRange =>
FirstSourceRange
-> (FirstSourceRange -> FirstSourceRange -> FirstSourceRange)
-> ([FirstSourceRange] -> FirstSourceRange)
-> Monoid FirstSourceRange
[FirstSourceRange] -> FirstSourceRange
FirstSourceRange -> FirstSourceRange -> FirstSourceRange
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: FirstSourceRange
mempty :: FirstSourceRange
$cmappend :: FirstSourceRange -> FirstSourceRange -> FirstSourceRange
mappend :: FirstSourceRange -> FirstSourceRange -> FirstSourceRange
$cmconcat :: [FirstSourceRange] -> FirstSourceRange
mconcat :: [FirstSourceRange] -> FirstSourceRange
Monoid)

instance Rangeable FirstSourceRange where
  ranged :: SourceRange -> FirstSourceRange -> FirstSourceRange
ranged SourceRange
range = (First SourceRange -> FirstSourceRange
FirstSourceRange (Maybe SourceRange -> First SourceRange
forall a. Maybe a -> First a
First (SourceRange -> Maybe SourceRange
forall a. a -> Maybe a
Just SourceRange
range)) FirstSourceRange -> FirstSourceRange -> FirstSourceRange
forall a. Semigroup a => a -> a -> a
<>)

instance HasAttributes FirstSourceRange where
  addAttributes :: [(Text, Text)] -> FirstSourceRange -> FirstSourceRange
addAttributes [(Text, Text)]
_ = FirstSourceRange -> FirstSourceRange
forall a. a -> a
id

instance IsBlock FirstSourceRange FirstSourceRange where
  paragraph :: FirstSourceRange -> FirstSourceRange
paragraph FirstSourceRange
_ = FirstSourceRange
forall a. Monoid a => a
mempty
  plain :: FirstSourceRange -> FirstSourceRange
plain FirstSourceRange
_ = FirstSourceRange
forall a. Monoid a => a
mempty
  thematicBreak :: FirstSourceRange
thematicBreak = FirstSourceRange
forall a. Monoid a => a
mempty
  blockQuote :: FirstSourceRange -> FirstSourceRange
blockQuote FirstSourceRange
_ = FirstSourceRange
forall a. Monoid a => a
mempty
  codeBlock :: Text -> Text -> FirstSourceRange
codeBlock Text
_ = Text -> FirstSourceRange
forall a. Monoid a => a
mempty
  heading :: Int -> FirstSourceRange -> FirstSourceRange
heading Int
_ = FirstSourceRange -> FirstSourceRange
forall a. Monoid a => a
mempty
  rawBlock :: Format -> Text -> FirstSourceRange
rawBlock Format
_ = Text -> FirstSourceRange
forall a. Monoid a => a
mempty
  referenceLinkDefinition :: Text -> (Text, Text) -> FirstSourceRange
referenceLinkDefinition Text
_ = (Text, Text) -> FirstSourceRange
forall a. Monoid a => a
mempty
  list :: ListType -> ListSpacing -> [FirstSourceRange] -> FirstSourceRange
list ListType
_ = ListSpacing -> [FirstSourceRange] -> FirstSourceRange
forall a. Monoid a => a
mempty

instance IsInline FirstSourceRange where
  lineBreak :: FirstSourceRange
lineBreak = FirstSourceRange
forall a. Monoid a => a
mempty
  softBreak :: FirstSourceRange
softBreak = FirstSourceRange
forall a. Monoid a => a
mempty
  str :: Text -> FirstSourceRange
str Text
_ = FirstSourceRange
forall a. Monoid a => a
mempty
  entity :: Text -> FirstSourceRange
entity Text
_ = FirstSourceRange
forall a. Monoid a => a
mempty
  escapedChar :: Char -> FirstSourceRange
escapedChar Char
_ = FirstSourceRange
forall a. Monoid a => a
mempty
  emph :: FirstSourceRange -> FirstSourceRange
emph = FirstSourceRange -> FirstSourceRange
forall a. a -> a
id
  strong :: FirstSourceRange -> FirstSourceRange
strong = FirstSourceRange -> FirstSourceRange
forall a. a -> a
id
  link :: Text -> Text -> FirstSourceRange -> FirstSourceRange
link Text
_ Text
_ FirstSourceRange
_ = FirstSourceRange
forall a. Monoid a => a
mempty
  image :: Text -> Text -> FirstSourceRange -> FirstSourceRange
image Text
_ Text
_ FirstSourceRange
_ = FirstSourceRange
forall a. Monoid a => a
mempty
  code :: Text -> FirstSourceRange
code Text
_ = FirstSourceRange
forall a. Monoid a => a
mempty
  rawInline :: Format -> Text -> FirstSourceRange
rawInline Format
_ Text
_ = FirstSourceRange
forall a. Monoid a => a
mempty