Implement config CLI MVP

2021-08-03 09:09:47 +03:00
6 changed files with 102 additions and 30 deletions
--- a/app/ghcup-gen/Validate.hs
+++ b/app/ghcup-gen/Validate.hs
@@ -237,7 +237,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
                  ($(logError) $ T.pack $ prettyShow e)
                liftIO $ exitWith (ExitFailure 2)

-    let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
+    let appstate = AppState (Settings True False Never Curl False GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq

    r <-
      runLogger
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@@ -78,6 +78,8 @@ import qualified Data.Map.Strict               as M
 import qualified Data.Text                     as T
 import qualified Data.Text.IO                  as T
 import qualified Data.Text.Encoding            as E
+import qualified Data.Yaml                     as Y
+import qualified Data.Yaml.Pretty              as YP
 import qualified Text.Megaparsec               as MP
 import qualified Text.Megaparsec.Char          as MPC

@@ -105,6 +107,7 @@ data Command
  | Rm (Either RmCommand RmOptions)
  | DInfo
  | Compile CompileCommand
+  | Config ConfigCommand
  | Whereis WhereisOptions WhereisCommand
  | Upgrade UpgradeOpts Bool
  | ToolRequirements
@@ -173,6 +176,8 @@ data RmOptions = RmOptions

 data CompileCommand = CompileGHC GHCCompileOptions

+data ConfigCommand = ShowConfig | SetConfig String String | InitConfig
+
 data GHCCompileOptions = GHCCompileOptions
  { targetGhc    :: Either Version GitBranch
  , bootstrapGhc :: Either Version FilePath
@@ -408,6 +413,12 @@ com =
                  <> footerDoc (Just $ text changeLogFooter)
                  )
               )
+          <> command
+               "config"
+               (   Config
+               <$> info (configP <**> helper)
+                        (progDesc "Show or set config" <> footerDoc (Just $ text configFooter))
+               )
          <> commandGroup "Other commands:"
          <> hidden
          )
@@ -482,6 +493,17 @@ Examples:
  ghcup prefetch ghc 8.10.5
  ghcup --offline install ghc 8.10.5|]

+configFooter :: String
+configFooter = [s|Examples:
+
+# show current config
+ghcup config
+
+# initialize config
+ghcup config init
+
+# set <key> <value> configuration pair
+ghcup config <key> <value>|]

 installCabalFooter :: String
 installCabalFooter = [s|Discussion:
@@ -786,6 +808,19 @@ Examples:
  # build cross compiler
  ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 -x armv7-unknown-linux-gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|]

+configP :: Parser ConfigCommand
+configP = subparser
+      (  command "init" initP
+      <> command "set"  setP -- [set] KEY VALUE at help lhs
+      <> command "show" showP
+      )
+    <|> argsP -- add show for a single option
+    <|> pure ShowConfig
+ where
+  initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml")
+  showP = info (pure ShowConfig) (progDesc "Show current config (default)")
+  setP  = info argsP (progDesc "Set config KEY to VALUE")
+  argsP = SetConfig <$> argument str (metavar "KEY") <*> argument str (metavar "VALUE")

 whereisP :: Parser WhereisCommand
 whereisP = subparser
@@ -1258,6 +1293,27 @@ toSettings options = do
         , bShowAllTools = fromMaybe bShowAllTools kShowAllTools
         }

+updateSettings :: UTF8.ByteString -> Settings -> IO Settings
+updateSettings config settings = do
+  settings' <- runE @'[JSONError] $ lE' JSONDecodeError . first show . Y.decodeEither' $ config
+
+  case settings' of
+    VRight r -> pure $ mergeConf r settings
+    VLeft (V (JSONDecodeError e)) -> do
+      B.hPut stderr ("Error decoding config: " <> (E.encodeUtf8 . T.pack . show $ e))
+      die ""
+    _ -> die "Unexpected error!"
+  where
+   mergeConf :: UserSettings -> Settings -> Settings
+   mergeConf UserSettings{..} Settings{..} =
+     let cache'      = fromMaybe cache uCache
+         noVerify'   = fromMaybe noVerify uNoVerify
+         keepDirs'   = fromMaybe keepDirs uKeepDirs
+         downloader' = fromMaybe downloader uDownloader
+         verbose'    = fromMaybe verbose uVerbose
+         urlSource'  = fromMaybe urlSource uUrlSource
+         noNetwork'  = fromMaybe noNetwork uNoNetwork
+     in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork'

 upgradeOptsP :: Parser UpgradeOpts
 upgradeOptsP =
@@ -1292,6 +1348,12 @@ describe_result = $( LitE . StringL <$>
                     )
                   )

+formatConfig :: Settings -> KeyBindings -> String
+formatConfig settings keybindings = unlines [formatSettings, formatKeybindings]
+ where
+  formatKeybindings = unlines . ("key-bindings:":) . map ("  "++) . lines . UTF8.toString . YP.encodePretty yamlConfig $ keybindings
+  formatSettings = UTF8.toString . YP.encodePretty yamlConfig $ settings
+  yamlConfig = YP.setConfCompare compare YP.defConfig

 main :: IO ()
 main = do
@@ -1990,6 +2052,28 @@ Make sure to clean up #{tmpdir} afterwards.|])
                        runLogger $ $(logError) $ T.pack $ prettyShow e
                        pure $ ExitFailure 9

+            Config InitConfig -> do
+              path <- getConfigFilePath
+              writeFile path $ formatConfig settings keybindings
+              runLogger $ $(logDebug) [i|"config.yaml initialized at #{path}|]
+              pure ExitSuccess
+
+            Config ShowConfig -> do
+              putStrLn $ formatConfig settings keybindings
+              pure ExitSuccess
+
+            Config (SetConfig k v) -> do
+              case v of
+                "" -> die "Empty values are not allowed."
+                _  -> do
+                  settings' <- updateSettings [i|#{k}: #{v}\n|] settings
+                  runLogger $ $(logDebug) $ T.pack $ show settings'
+
+                  path <- getConfigFilePath
+                  writeFile path $ formatConfig settings' keybindings
+
+                  pure ExitSuccess
+
            Whereis WhereisOptions{..} (WhereisTool tool (Just (ToolVersion v))) ->
              runLeanWhereIs (do
                loc <- liftE $ whereIsTool tool v
--- a/ghcup.cabal
+++ b/ghcup.cabal
@@ -226,6 +226,7 @@ executable ghcup
    , uri-bytestring        ^>=0.3.2.2
    , utf8-string           ^>=1.0
    , versions              >=4.0.1    && <5.1
+    , yaml                  ^>=0.11.4.0

  if flag(internal-downloader)
    cpp-options: -DINTERNAL_DOWNLOADER
--- a/lib/GHCup/Download.hs
+++ b/lib/GHCup/Download.hs
@@ -320,12 +320,11 @@ download uri eDigest dest mfn etags
    -- destination dir must exist
    liftIO $ createDirRecursive' dest
    let fromFile = T.unpack . decUTF8Safe $ path
-    destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
    liftIO $ copyFile fromFile destFile
    pure destFile
  dl = do
-    destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
-    lift $ $(logInfo) [i|downloading: #{uri'} as file #{destFile}|]
+    let uri' = decUTF8Safe (serializeURIRef' uri)
+    lift $ $(logInfo) [i|downloading: #{uri'}|]

    -- destination dir must exist
    liftIO $ createDirRecursive' dest
@@ -367,7 +366,7 @@ download uri eDigest dest mfn etags
                            _ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
                              :: V '[MalformedHeaders]))

-                          writeEtags destFile (parseEtags headers)
+                          writeEtags (parseEtags headers)
                    else
                      liftE $ lEM @_ @'[ProcessError] $ exec "curl" 
                        (o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
@@ -384,13 +383,13 @@ download uri eDigest dest mfn etags
                        case _exitCode of
                          ExitSuccess -> do
                            liftIO $ copyFile destFileTemp destFile
-                            writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
+                            writeEtags (parseEtags (decUTF8Safe' _stdErr))
                          ExitFailure i'
                            | i' == 8
                            , Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
                                     -> do
                                          $logDebug "Not modified, skipping download"
-                                          writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
+                                          writeEtags (parseEtags (decUTF8Safe' _stdErr))
                            | otherwise -> throwE (NonZeroExit i' "wget" opts)
                      else do
                        let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
@@ -405,10 +404,10 @@ download uri eDigest dest mfn etags
                      let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
                                                                         , E.encodeUtf8 etag)]) metag
                      liftE
-                        $ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
+                        $ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags (pure $ Just etag))
                        $ do
                          r <- downloadToFile https host fullPath port destFile addHeaders
-                          writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
+                          writeEtags (pure $ decUTF8Safe <$> getHeader r "etag")
                    else void $ liftE $ catchE @HTTPNotModified
                                        @'[DownloadFailed]
                                   (\e@(HTTPNotModified _) ->
@@ -421,18 +420,12 @@ download uri eDigest dest mfn etags


  -- Manage to find a file we can write the body into.
-  getDestFile :: Monad m => Excepts '[NoUrlBase] m FilePath
-  getDestFile = 
-    case mfn of
-        Just fn -> pure (dest </> fn)
-        Nothing
-          | let urlBase = T.unpack (decUTF8Safe (urlBaseName path))
-          , not (null urlBase) -> pure (dest </> urlBase)
-          -- TODO: remove this once we use hpath again
-          | otherwise -> throwE $ NoUrlBase uri'
+  destFile :: FilePath
+  destFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path)))
+                  (dest </>)
+                  mfn

  path = view pathL' uri
-  uri' = decUTF8Safe (serializeURIRef' uri)

  parseEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
  parseEtags stderr = do
@@ -451,8 +444,8 @@ download uri eDigest dest mfn etags
        $logDebug "No etags header found"
        pure Nothing

-  writeEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
-  writeEtags destFile getTags = do
+  writeEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => m (Maybe T.Text) -> m ()
+  writeEtags getTags = do
    getTags >>= \case
      Just t -> do
        $logDebug [i|Writing etagsFile #{(etagsFile destFile)}|]
--- a/lib/GHCup/Errors.hs
+++ b/lib/GHCup/Errors.hs
@@ -327,15 +327,6 @@ instance Pretty UnexpectedListLength where

 instance Exception UnexpectedListLength

-data NoUrlBase = NoUrlBase Text
-  deriving Show
-
-instance Pretty NoUrlBase where
-  pPrint (NoUrlBase url) =
-    text [i|Couldn't get a base filename from url #{url}|]
-
-instance Exception NoUrlBase
-


    ------------------------
--- a/lib/GHCup/Types/JSON.hs
+++ b/lib/GHCup/Types/JSON.hs
@@ -316,3 +316,6 @@ deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
 deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
+
+deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
+deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key