Skip to content

Commit 3697683

Browse files
david-christiansendavid-christiansen
committed
Example code cleanups
1 parent 32bdef1 commit 3697683

File tree

1 file changed

+155
-60
lines changed

1 file changed

+155
-60
lines changed

‎proposals/advisory-db/app/Main.hs

Lines changed: 155 additions & 60 deletions
Original file line numberDiff line numberDiff line change
@@ -11,10 +11,28 @@
1111
module Main where
1212

1313
import Commonmark.Html (Html, renderHtml)
14-
import Commonmark.Parser
14+
import Commonmark.Parser (commonmark)
1515
import Commonmark.Types
16+
( Attributes,
17+
Format,
18+
HasAttributes (..),
19+
IsBlock (..),
20+
IsInline (..),
21+
ListSpacing,
22+
ListType,
23+
Rangeable (..),
24+
SourceRange,
25+
)
1626
import Control.Monad ((>=>))
17-
import Control.Monad.Except (ExceptT (ExceptT), MonadError, throwError)
27+
import Control.Monad.Except
28+
( ExceptT (ExceptT),
29+
MonadError,
30+
catchError,
31+
runExceptT,
32+
throwError,
33+
)
34+
import Control.Monad.IO.Class (liftIO)
35+
import Data.Bifunctor
1836
import Data.Functor ((<&>))
1937
import Data.Functor.Identity (Identity (Identity))
2038
import qualified Data.HashMap.Lazy as V
@@ -29,60 +47,81 @@ import qualified Data.Text as T
2947
import qualified Data.Text.IO as T
3048
import qualified Data.Text.Lazy as T (toStrict)
3149
import Data.Time.Calendar
32-
import Data.Time.Calendar.OrdinalDate
3350
import Data.Time.Clock (UTCTime (..))
3451
import Distribution.Parsec (eitherParsec)
3552
import Distribution.Types.VersionRange (VersionRange)
3653
import GHC.Exts (IsList (..))
3754
import System.Exit (exitFailure, exitSuccess)
3855
import System.IO (hPrint, hPutStrLn, stderr)
39-
-- import Text.Toml (parseTomlDoc)
40-
-- import qualified Text.Toml.Types as Toml
41-
4256
import qualified TOML
4357

4458
main :: IO ()
4559
main = do
4660
input <- T.getContents
47-
case commonmark "stdin" input of
48-
Left err -> do
49-
hPrint stderr err
50-
exitFailure
51-
Right markdown -> do
52-
case advisoryDoc markdown of
53-
Nothing -> hPrint stderr "Does not have toml code block as first element"
54-
Just (frontMatter, text) -> do
55-
table <- case TOML.decode frontMatter of
56-
Left err -> do
57-
hPutStrLn stderr "Couldn't parse front matter as TOML:"
58-
T.hPutStrLn stderr (TOML.renderTOMLError err)
59-
exitFailure
60-
Right tbl -> do
61-
pure tbl
62-
case parseAdvisory table of
63-
Left err -> do
64-
hPrint stderr (show err)
65-
exitFailure
66-
Right f ->
67-
T.putStrLn $ renderAdvisory $ f $ T.toStrict $ renderHtml (fromBlock text :: Html ())
68-
69-
exitSuccess
70-
71-
newtype CWE = CWE { unCWE :: Integer }
61+
markdown <- runH (T.pack . show) $ commonmark "stdin" input
62+
(frontMatter, text) <- run $ advisoryDoc markdown
63+
table <-
64+
runH (("Couldn't parse front matter as TOML:\n" <>) . TOML.renderTOMLError) $
65+
TOML.decode frontMatter
66+
f <- runH (T.pack . show) $ parseAdvisory table
67+
T.putStrLn $
68+
renderAdvisory $
69+
f $
70+
T.toStrict $
71+
renderHtml (fromBlock text :: Html ())
72+
exitSuccess
73+
where
74+
panic err = T.hPutStrLn stderr err >> exitFailure
75+
run = either panic pure
76+
runH f = run . first f
77+
78+
newtype CWE = CWE {unCWE :: Integer}
7279
deriving (Show)
7380

74-
data Architecture = AArch64 | Alpha | Arm | HPPA | HPPA1_1 | I386 | IA64 | M68K | MIPS | MIPSEB | MIPSEL | NIOS2 | PowerPC | PowerPC64 | PowerPC64LE | RISCV32 | RISCV64 | RS6000 | S390 | S390X | SH4 | SPARC | SPARC64 | VAX | X86_64
81+
data Architecture
82+
= AArch64
83+
| Alpha
84+
| Arm
85+
| HPPA
86+
| HPPA1_1
87+
| I386
88+
| IA64
89+
| M68K
90+
| MIPS
91+
| MIPSEB
92+
| MIPSEL
93+
| NIOS2
94+
| PowerPC
95+
| PowerPC64
96+
| PowerPC64LE
97+
| RISCV32
98+
| RISCV64
99+
| RS6000
100+
| S390
101+
| S390X
102+
| SH4
103+
| SPARC
104+
| SPARC64
105+
| VAX
106+
| X86_64
75107
deriving (Show)
76108

77-
data OS = Windows | MacOS | Linux | FreeBSD | Android | NetBSD | OpenBSD
109+
data OS
110+
= Windows
111+
| MacOS
112+
| Linux
113+
| FreeBSD
114+
| Android
115+
| NetBSD
116+
| OpenBSD
78117
deriving (Show)
79118

80119
data Date = Date {dateYear :: Integer, dateMonth :: Int, dateDay :: Int}
81120
deriving (Show)
82121

83122
newtype Keyword = Keyword Text
84123
deriving (Eq, Ord)
85-
deriving Show via Text
124+
deriving (Show) via Text
86125

87126
data Advisory = Advisory
88127
{ advisoryId :: Text,
@@ -117,9 +156,22 @@ renderAdvisory adv =
117156
row "Aliases" (T.intercalate ", " . advisoryAliases),
118157
row "CVSS" (fromMaybe "" . advisoryCVSS),
119158
row "Versions" (T.pack . show . advisoryVersions),
120-
row "Architectures" (maybe "All" ( T.intercalate ", " . map (T.pack . show)) . advisoryArchitectures),
121-
row "OS" (maybe "All" ( T.intercalate ", " . map (T.pack . show)) . advisoryOS),
122-
row "Affected exports" (T.intercalate ", " . map (\(name, version) -> name <> " in " <> T.pack (show version)) . advisoryNames)
159+
row
160+
"Architectures"
161+
( maybe
162+
"All"
163+
( T.intercalate ", "
164+
. map (T.pack . show)
165+
)
166+
. advisoryArchitectures
167+
),
168+
row "OS" (maybe "All" (T.intercalate ", " . map (T.pack . show)) . advisoryOS),
169+
row
170+
"Affected exports"
171+
( T.intercalate ", "
172+
. map (\(name, version) -> name <> " in " <> T.pack (show version))
173+
. advisoryNames
174+
)
123175
],
124176
"</table>",
125177
advisoryHtml adv
@@ -139,18 +191,30 @@ parseAdvisory table = runTableParser $ do
139191
package <- mandatory advisory "package" isString
140192
date <- mandatory advisory "date" isDate <&> uncurry3 Date . toGregorian
141193
url <- mandatory advisory "url" isString
142-
cats <- fromMaybe [] <$> optional advisory "cwe" (isArrayOf (fmap CWE . isInt))
143-
kwds <- fromMaybe [] <$> optional advisory "keywords" (isArrayOf (fmap Keyword . isString))
144-
aliases <- fromMaybe [] <$> optional advisory "aliases" (isArrayOf isString)
194+
cats <-
195+
fromMaybe []
196+
<$> optional advisory "cwe" (isArrayOf (fmap CWE . isInt))
197+
kwds <-
198+
fromMaybe []
199+
<$> optional advisory "keywords" (isArrayOf (fmap Keyword . isString))
200+
aliases <-
201+
fromMaybe []
202+
<$> optional advisory "aliases" (isArrayOf isString)
145203
cvss <- optional advisory "cvss" isString
146204

147205
(os, arch, decls) <-
148206
optional table "affected" isTable >>= \case
149207
Nothing -> pure (Nothing, Nothing, [])
150208
Just tbl -> do
151-
os <- optional tbl "os" $ isArrayOf (isString >=> operatingSystem)
152-
arch <- optional tbl "os" $ isArrayOf (isString >=> architecture)
153-
decls <- maybe [] Map.toList <$> optional tbl "declarations" (isTableOf versionRange)
209+
os <-
210+
optional tbl "os" $
211+
isArrayOf (isString >=> operatingSystem)
212+
arch <-
213+
optional tbl "os" $
214+
isArrayOf (isString >=> architecture)
215+
decls <-
216+
maybe [] Map.toList
217+
<$> optional tbl "declarations" (isTableOf versionRange)
154218
pure (os, arch, decls)
155219

156220
versions <- mandatory table "versions" isTable
@@ -231,7 +295,13 @@ data TableParseErr
231295
deriving (Show)
232296

233297
newtype TableParser a = TableParser {runTableParser :: Either TableParseErr a}
234-
deriving (Functor, Applicative, Monad, MonadError TableParseErr) via ExceptT TableParseErr Identity
298+
deriving
299+
( Functor,
300+
Applicative,
301+
Monad,
302+
MonadError TableParseErr
303+
)
304+
via ExceptT TableParseErr Identity
235305

236306
hasNoKeysBut :: [Text] -> TOML.Table -> TableParser ()
237307
hasNoKeysBut keys tbl =
@@ -242,14 +312,30 @@ hasNoKeysBut keys tbl =
242312
[] -> pure ()
243313
k : ks -> throwError (UnexpectedKeys $ k :| ks)
244314

245-
optional :: TOML.Table -> Text -> (TOML.Value -> TableParser a) -> TableParser (Maybe a)
246-
optional tbl k act = onKey tbl k (pure Nothing) (fmap Just . act)
247-
248-
mandatory :: TOML.Table -> Text -> (TOML.Value -> TableParser a) -> TableParser a
249-
mandatory tbl k act = onKey tbl k (throwError $ MissingKey k) act
250-
251-
onKey :: TOML.Table -> Text -> TableParser a -> (TOML.Value -> TableParser a) -> TableParser a
252-
onKey tbl k absent present = maybe absent present $ Map.lookup k tbl
315+
optional ::
316+
TOML.Table ->
317+
Text ->
318+
(TOML.Value -> TableParser a) ->
319+
TableParser (Maybe a)
320+
optional tbl k act =
321+
onKey tbl k (pure Nothing) (fmap Just . act)
322+
323+
mandatory ::
324+
TOML.Table ->
325+
Text ->
326+
(TOML.Value -> TableParser a) ->
327+
TableParser a
328+
mandatory tbl k act =
329+
onKey tbl k (throwError $ MissingKey k) act
330+
331+
onKey ::
332+
TOML.Table ->
333+
Text ->
334+
TableParser a ->
335+
(TOML.Value -> TableParser a) ->
336+
TableParser a
337+
onKey tbl k absent present =
338+
maybe absent present $ Map.lookup k tbl
253339

254340
isInt :: TOML.Value -> TableParser Integer
255341
isInt (TOML.Integer i) = pure i
@@ -263,9 +349,14 @@ isTable :: TOML.Value -> TableParser TOML.Table
263349
isTable (TOML.Table table) = pure table
264350
isTable other = throwError $ InvalidFormat "Table" (describeValue other)
265351

266-
isTableOf :: (TOML.Value -> TableParser a) -> TOML.Value -> TableParser (Map Text a)
267-
isTableOf elt (TOML.Table table) = traverse elt table
268-
isTableOf _ other = throwError $ InvalidFormat "Table" (describeValue other)
352+
isTableOf ::
353+
(TOML.Value -> TableParser a) ->
354+
TOML.Value ->
355+
TableParser (Map Text a)
356+
isTableOf elt (TOML.Table table) =
357+
traverse elt table
358+
isTableOf _ other =
359+
throwError $ InvalidFormat "Table" (describeValue other)
269360

270361
isDate :: TOML.Value -> TableParser Day
271362
isDate (TOML.LocalDate time) = pure time
@@ -275,8 +366,12 @@ isArray :: TOML.Value -> TableParser [TOML.Value]
275366
isArray (TOML.Array arr) = pure arr
276367
isArray other = throwError $ InvalidFormat "Array" (describeValue other)
277368

278-
isArrayOf :: (TOML.Value -> TableParser a) -> TOML.Value -> TableParser [a]
279-
isArrayOf elt v = isArray v >>= traverse elt . toList
369+
isArrayOf ::
370+
(TOML.Value -> TableParser a) ->
371+
TOML.Value ->
372+
TableParser [a]
373+
isArrayOf elt v =
374+
isArray v >>= traverse elt . toList
280375

281376
describeValue :: TOML.Value -> Text
282377
describeValue TOML.String {} = "string"
@@ -290,14 +385,14 @@ describeValue TOML.LocalDateTime {} = "local date/time"
290385
describeValue TOML.LocalDate {} = "local date"
291386
describeValue TOML.LocalTime {} = "local time"
292387

293-
advisoryDoc :: Block -> Maybe (Text, Block)
388+
advisoryDoc :: Block -> Either Text (Text, Block)
294389
advisoryDoc (BSeq bs) =
295390
case bs of
296-
[] -> Nothing
391+
[] -> Left "Does not have toml code block as first element"
297392
b : bs -> advisoryDoc b >>= \(toml, code) -> pure (toml, BSeq (code : bs))
298393
advisoryDoc (BRanged _ b) = advisoryDoc b
299394
advisoryDoc (CodeBlock (T.unpack -> "toml") frontMatter) = pure (frontMatter, mempty)
300-
advisoryDoc _ = Nothing
395+
advisoryDoc _ = Left "Does not have toml code block as first element"
301396

302397
data Block
303398
= Para Inline

0 commit comments

Comments
 (0)