Initial commit

app/ghcup-gen/Main.hs

@@ -0,0 +1,164 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+
+module Main where
+
+import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Logger
+import           GHCupDownloads
+
+import           Data.Aeson                     ( eitherDecode )
+import           Data.Aeson.Encode.Pretty
+import           Data.Semigroup                 ( (<>) )
+import           Options.Applicative     hiding ( style )
+import           System.Console.Pretty
+import           System.Exit
+import           System.IO                      ( stdout )
+import           Validate
+
+import qualified Data.ByteString               as B
+import qualified Data.ByteString.Lazy          as L
+
+
+data Options = Options
+  { optCommand :: Command
+  }
+
+data Command = GenJSON GenJSONOpts
+             | ValidateJSON ValidateJSONOpts
+             | ValidateTarballs ValidateJSONOpts
+
+data Output
+  = FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
+  | StdOutput
+
+fileOutput :: Parser Output
+fileOutput =
+  FileOutput
+    <$> (strOption
+          (long "file" <> short 'f' <> metavar "FILENAME" <> help
+            "Output to a file"
+          )
+        )
+
+stdOutput :: Parser Output
+stdOutput = flag'
+  StdOutput
+  (short 'o' <> long "stdout" <> help "Print to stdout (default)")
+
+outputP :: Parser Output
+outputP = fileOutput <|> stdOutput
+
+
+data GenJSONOpts = GenJSONOpts
+  { output :: Maybe Output
+  }
+
+genJSONOpts :: Parser GenJSONOpts
+genJSONOpts = GenJSONOpts <$> optional outputP
+
+
+data Input
+  = FileInput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
+  | StdInput
+
+fileInput :: Parser Input
+fileInput =
+  FileInput
+    <$> (strOption
+          (long "file" <> short 'f' <> metavar "FILENAME" <> help
+            "Input file to validate"
+          )
+        )
+
+stdInput :: Parser Input
+stdInput = flag'
+  StdInput
+  (short 'i' <> long "stdin" <> help "Validate from stdin (default)")
+
+inputP :: Parser Input
+inputP = fileInput <|> stdInput
+
+data ValidateJSONOpts = ValidateJSONOpts
+  { input :: Maybe Input
+  }
+
+validateJSONOpts :: Parser ValidateJSONOpts
+validateJSONOpts = ValidateJSONOpts <$> optional inputP
+
+opts :: Parser Options
+opts = Options <$> com
+
+com :: Parser Command
+com = subparser
+  (  (command
+       "gen"
+       (   GenJSON
+       <$> (info (genJSONOpts <**> helper)
+                 (progDesc "Generate the json downloads file")
+           )
+       )
+     )
+  <> (command
+       "check"
+       (   ValidateJSON
+       <$> (info (validateJSONOpts <**> helper)
+                 (progDesc "Validate the JSON")
+           )
+       )
+     )
+  <> (command
+       "check-tarballs"
+       (   ValidateTarballs
+       <$> (info
+             (validateJSONOpts <**> helper)
+             (progDesc "Validate all tarballs (download and checksum)")
+           )
+       )
+     )
+  )
+
+
+
+main :: IO ()
+main = do
+  customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
+    >>= \Options {..} -> case optCommand of
+          GenJSON gopts -> do
+            let
+              bs = encodePretty' (defConfig { confIndent = Spaces 2 })
+                                 ghcupDownloads
+            case gopts of
+              GenJSONOpts { output = Nothing }        -> L.hPutStr stdout bs
+              GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs
+              GenJSONOpts { output = Just (FileOutput file) } ->
+                L.writeFile file bs
+          ValidateJSON vopts -> case vopts of
+            ValidateJSONOpts { input = Nothing } ->
+              L.getContents >>= valAndExit validate
+            ValidateJSONOpts { input = Just StdInput } ->
+              L.getContents >>= valAndExit validate
+            ValidateJSONOpts { input = Just (FileInput file) } ->
+              L.readFile file >>= valAndExit validate
+          ValidateTarballs vopts -> case vopts of
+            ValidateJSONOpts { input = Nothing } ->
+              L.getContents >>= valAndExit validateTarballs
+            ValidateJSONOpts { input = Just StdInput } ->
+              L.getContents >>= valAndExit validateTarballs
+            ValidateJSONOpts { input = Just (FileInput file) } ->
+              L.readFile file >>= valAndExit validateTarballs
+  pure ()
+
+ where
+  valAndExit f contents = do
+    av <- case eitherDecode contents of
+      Right r -> pure r
+      Left  e -> die (color Red $ show e)
+    myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
+      >>= exitWith
+