Implement config CLI MVP

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

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

lib/GHCup/Download.hs

@@ -172,31 +172,21 @@ getBase :: ( MonadReader env m
         -> Excepts '[JSONError] m GHCupInfo
 getBase uri = do
   Settings { noNetwork } <- lift getSettings
-
-  -- try to download yaml... usually this writes it into cache dir,
-  -- but in some cases not (e.g. when using file://), so we honour
-  -- the return filepath, if any
-  mYaml <- if noNetwork && view (uriSchemeL' % schemeBSL') uri /= "file" -- for file://, let it fall through
-           then pure Nothing
-           else handleIO (\e -> warnCache (displayException e) >> pure Nothing)
-               . catchE @_ @_ @'[] (\e@(DownloadFailed _) -> warnCache (prettyShow e) >> pure Nothing)
-               . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed
-               . fmap Just
-               . smartDl
-               $ uri
-
-  -- if we didn't get a filepath from the download, use the cached yaml
-  actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
-  lift $ $(logDebug) [i|Decoding yaml at: #{actualYaml}|]
-
+  yaml <- lift $ yamlFromCache uri
+  unless noNetwork $
+    handleIO (\e -> warnCache (displayException e))
+      . catchE @_ @_ @'[] (\e@(DownloadFailed _) -> warnCache (prettyShow e))
+      . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed
+      . smartDl
+      $ uri
   liftE
-    . onE_ (onError actualYaml)
+    . onE_ (onError yaml)
     . lEM' @_ @_ @'[JSONError] JSONDecodeError
     . fmap (first (\e -> [i|#{displayException e}
-Consider removing "#{actualYaml}" manually.|]))
+Consider removing "#{yaml}" manually.|]))
     . liftIO
     . Y.decodeFileEither
-    $ actualYaml
+    $ yaml
  where
   -- On error, remove the etags file and set access time to 0. This should ensure the next invocation
   -- may re-download and succeed.
@@ -231,32 +221,28 @@ Consider removing "#{actualYaml}" manually.|]))
                 , DigestError
                 ]
                m1
-               FilePath
+               ()
   smartDl uri' = do
     json_file <- lift $ yamlFromCache uri'
-    let scheme = view (uriSchemeL' % schemeBSL') uri'
     e <- liftIO $ doesFileExist json_file
     currentTime <- liftIO getCurrentTime
-    Dirs { cacheDir } <- lift getDirs
+    if e
+      then do
+        accessTime <- liftIO $ getAccessTime json_file
 
-       -- for local files, let's short-circuit and ignore access time
-    if | scheme == "file" -> liftE $ download uri' Nothing cacheDir Nothing True
-       | e -> do
-          accessTime <- liftIO $ getAccessTime json_file
-
-          -- access time won't work on most linuxes, but we can try regardless
-          if | ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) ->
-                -- no access in last 5 minutes, re-check upstream mod time
-                dlWithMod currentTime json_file
-             | otherwise -> pure json_file
-       | otherwise -> dlWithMod currentTime json_file
+        -- access time won't work on most linuxes, but we can try regardless
+        when ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) $
+          -- no access in last 5 minutes, re-check upstream mod time
+          dlWithMod currentTime json_file
+      else
+        dlWithMod currentTime json_file
    where
     dlWithMod modTime json_file = do
       let (dir, fn) = splitFileName json_file
       f <- liftE $ download uri' Nothing dir (Just fn) True
       liftIO $ setModificationTime f modTime
       liftIO $ setAccessTime f modTime
-      pure f
+ 
 
 
 getDownloadInfo :: ( MonadReader env m
@@ -318,22 +304,24 @@ download :: ( MonadReader env m
             )
          => URI
          -> Maybe T.Text      -- ^ expected hash
-         -> FilePath          -- ^ destination dir (ignored for file:// scheme)
+         -> FilePath          -- ^ destination dir
          -> Maybe FilePath    -- ^ optional filename
          -> Bool              -- ^ whether to read an write etags
          -> Excepts '[DigestError , DownloadFailed] m FilePath
 download uri eDigest dest mfn etags
   | scheme == "https" = dl
   | scheme == "http"  = dl
-  | scheme == "file"  = do
-      let destFile' = T.unpack . decUTF8Safe $ path
-      lift $ $(logDebug) [i|using local file: #{destFile'}|]
-      forM_ eDigest (liftE . flip checkDigest destFile')
-      pure destFile'
+  | scheme == "file"  = cp
   | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
 
  where
   scheme = view (uriSchemeL' % schemeBSL') uri
+  cp     = do
+    -- destination dir must exist
+    liftIO $ createDirRecursive' dest
+    let fromFile = T.unpack . decUTF8Safe $ path
+    liftIO $ copyFile fromFile destFile
+    pure destFile
   dl = do
     let uri' = decUTF8Safe (serializeURIRef' uri)
     lift $ $(logInfo) [i|downloading: #{uri'}|]

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