Fix #6121 Make use of Casa optional, and more configurable

Author: mpilgrem

ChangeLog.md

@@ -28,6 +28,11 @@ Other enhancements:
 * `stack --verbose` excludes lengthy information about build plan construction
   in the debug output by default. The new `stack --[no-]plan-in-log` flag
   enables or disables the inclusion of the information in the debug output.
+* In YAML configuration files, the `casa` key is introduced, which takes
+  precedence over the existing `casa-repo-prefix` key. The latter is deprecated.
+  The new key also allows Stack's use of a Casa (content-addressable storage
+  archive) server to be disabled and the maximum number of keys per request to
+  be configured. The defaults are unchanged.
 
 Bug fixes:
 

doc/yaml_configuration.md

@@ -474,17 +474,39 @@ of the same name. For further information, see the
 [`stack build` command](build_command.md) documentation and the
 [users guide](GUIDE.md#the-build-command).
 
+### casa
+
+:octicons-tag-24: UNRELEASED
+
+Default:
+
+~~~yaml
+casa:
+  enable: true # Use a Casa server?
+  repo-prefix: https://casa.fpcomplete.com # Unless casa-repo-prefix is set.
+  max-keys-per-request: 1280 # Maximum number of keys per request.
+~~~
+
+This option specifies whether or not Stack should use a Casa
+(content-addressable storage archive) server to cache Cabal files and all other
+files in packages; and, if so, the prefix for the URL used to pull information
+from the server and the maximum number of keys per request. For further
+information, see this blog post about
+[Casa and Stack](https://www.fpcomplete.com/blog/casa-and-stack/).
+
+`repo-prefix` replaces [`casa-repo-prefix`](#casa-repo-prefix) (which is
+deprecated) and has precedence if both keys are set.
+
 ### casa-repo-prefix
 
 [:octicons-tag-24: 2.3.1](https://github.com/commercialhaskell/stack/releases/tag/v2.3.1)
 
+Deprecated in favour of [`casa`](#casa), which takes precedence if present.
+
 Default: `https://casa.fpcomplete.com`
 
 This option specifies the prefix for the URL used to pull information from the
-Casa (content-addressable storage archive) server that is used by Stack to cache
-Cabal files and all other files in packages. For further information, see this
-blog post about
-[Casa and Stack](https://www.fpcomplete.com/blog/casa-and-stack/).
+Casa server.
 
 ### color
 

package.yaml

@@ -95,7 +95,7 @@ dependencies:
 - neat-interpolation
 - open-browser
 - optparse-applicative >= 0.18.1.0
-- pantry >= 0.8.2.2
+- pantry >= 0.8.3
 - path
 - path-io
 # In order for Cabal (the tool) to build Stack, it needs to be told of the

src/Stack/Config.hs

@@ -114,6 +114,7 @@ import           Stack.Types.Config.Exception
                    , ParseAbsolutePathException (..), packageIndicesWarning )
 import           Stack.Types.ConfigMonoid
                    ( ConfigMonoid (..), parseConfigMonoid )
+import           Stack.Types.Casa ( CasaOptsMonoid (..) )
 import           Stack.Types.Docker ( DockerOptsMonoid (..), dockerEnable )
 import           Stack.Types.DumpLogs ( DumpLogs (..) )
 import           Stack.Types.GlobalOpts (  GlobalOpts (..) )
@@ -482,16 +483,33 @@ configFromConfigMonoid
                 addr' = display $ T.dropWhileEnd (=='/') addr
     let configStackDeveloperMode =
           fromFirst stackDeveloperModeDefault configMonoidStackDeveloperMode
+        configCasa = if fromFirstTrue $ casaMonoidEnable configMonoidCasaOpts
+          then
+            let casaRepoPrefix = fromFirst
+                  (fromFirst defaultCasaRepoPrefix configMonoidCasaRepoPrefix)
+                  (casaMonoidRepoPrefix configMonoidCasaOpts)
+                casaMaxKeysPerRequest = fromFirst
+                  defaultCasaMaxPerRequest
+                  (casaMonoidMaxKeysPerRequest configMonoidCasaOpts)
+            in  Just (casaRepoPrefix, casaMaxKeysPerRequest)
+          else Nothing
     withNewLogFunc go useColor'' stylesUpdate' $ \logFunc -> do
       let configRunner = configRunner'' & logFuncL .~ logFunc
-      withLocalLogFunc logFunc $ handleMigrationException $
-        withPantryConfig
+      withLocalLogFunc logFunc $ handleMigrationException $ do
+        logDebug $ case configCasa of
+          Nothing -> "Use of Casa server disabled."
+          Just (repoPrefix, maxKeys) ->
+               "Use of Casa server enabled: ("
+            <> fromString (show repoPrefix)
+            <> ", "
+            <> fromString (show maxKeys)
+            <> ")."
+        withPantryConfig'
           pantryRoot
           pic
           (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack)
           clConnectionCount
-          (fromFirst defaultCasaRepoPrefix configMonoidCasaRepoPrefix)
-          defaultCasaMaxPerRequest
+          configCasa
           snapLoc
           (\configPantryConfig -> initUserStorage
             (configStackRoot </> relFileStorage)

src/Stack/Types/Casa.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE NoImplicitPrelude  #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RecordWildCards    #-}
+
+-- | Casa configuration types.
+
+module Stack.Types.Casa
+  ( CasaOptsMonoid (..)
+  ) where
+
+import           Casa.Client ( CasaRepoPrefix )
+import           Generics.Deriving.Monoid ( mappenddefault, memptydefault )
+import           Pantry.Internal.AesonExtended
+                   ( FromJSON (..), WithJSONWarnings, (..:?), withObjectWarnings
+                   )
+import           Stack.Prelude
+
+-- | An uninterpreted representation of Casa configuration options.
+-- Configurations may be "cascaded" using mappend (left-biased).
+data CasaOptsMonoid = CasaOptsMonoid
+  { casaMonoidEnable :: !FirstTrue
+  , casaMonoidRepoPrefix :: !(First CasaRepoPrefix)
+  , casaMonoidMaxKeysPerRequest :: !(First Int)
+  }
+  deriving (Generic, Show)
+
+-- | Decode uninterpreted Casa configuration options from JSON/YAML.
+instance FromJSON (WithJSONWarnings CasaOptsMonoid) where
+  parseJSON = withObjectWarnings "CasaOptsMonoid"
+    ( \o -> do
+        casaMonoidEnable <- FirstTrue <$> o ..:? casaEnableName
+        casaMonoidRepoPrefix <- First <$> o ..:? casaRepoPrefixName
+        casaMonoidMaxKeysPerRequest <-
+          First <$> o ..:? casaMaxKeysPerRequestName
+        pure CasaOptsMonoid {..}
+    )
+
+-- | Left-biased combine Casa configuration options
+instance Semigroup CasaOptsMonoid where
+  (<>) = mappenddefault
+
+-- | Left-biased combine Casa configurations options
+instance Monoid CasaOptsMonoid where
+  mempty = memptydefault
+  mappend = (<>)
+
+-- | Casa configuration enable setting name.
+casaEnableName :: Text
+casaEnableName = "enable"
+
+-- | Casa configuration repository prefix setting name.
+casaRepoPrefixName :: Text
+casaRepoPrefixName = "repo-prefix"
+
+-- | Casa configuration maximum keys per request setting name.
+casaMaxKeysPerRequestName :: Text
+casaMaxKeysPerRequestName = "max-keys-per-request"

src/Stack/Types/Config.hs

@@ -27,6 +27,7 @@ module Stack.Types.Config
   , prettyStackDevL
   ) where
 
+import           Casa.Client ( CasaRepoPrefix )
 import           Distribution.System ( Platform )
 import           Path ( (</>), parent, reldir, relfile )
 import           RIO.Process ( HasProcessContext (..), ProcessContext )
@@ -182,6 +183,8 @@ data Config = Config
     -- ^ Use --no-run and --compile options when using `stack script`
   , configStackDeveloperMode  :: !Bool
     -- ^ Turn on Stack developer mode for additional messages?
+  , configCasa                :: !(Maybe (CasaRepoPrefix, Int))
+    -- ^ Optional Casa configuration
   }
 
 -- | The project root directory, if in a project.

src/Stack/Types/ConfigMonoid.hs

@@ -32,6 +32,7 @@ import           Stack.Types.AllowNewerDeps ( AllowNewerDeps )
 import           Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) )
 import           Stack.Types.ApplyProgOptions ( ApplyProgOptions (..) )
 import           Stack.Types.BuildOpts ( BuildOptsMonoid )
+import           Stack.Types.Casa ( CasaOptsMonoid )
 import           Stack.Types.CabalConfigKey ( CabalConfigKey )
 import           Stack.Types.ColorWhen ( ColorWhen )
 import           Stack.Types.Compiler ( CompilerRepository )
@@ -166,7 +167,10 @@ data ConfigMonoid = ConfigMonoid
     -- ^ See 'configHideSourcePaths'
   , configMonoidRecommendUpgrade   :: !FirstTrue
     -- ^ See 'configRecommendUpgrade'
+  , configMonoidCasaOpts :: !CasaOptsMonoid
+    -- ^ Casa configuration options.
   , configMonoidCasaRepoPrefix     :: !(First CasaRepoPrefix)
+    -- ^ Casa repository prefix (deprecated).
   , configMonoidSnapshotLocation :: !(First Text)
     -- ^ Custom location of LTS/Nightly snapshots
   , configMonoidNoRunCompile  :: !FirstFalse
@@ -333,7 +337,8 @@ parseConfigMonoidObject rootDir obj = do
     FirstTrue <$> obj ..:? configMonoidHideSourcePathsName
   configMonoidRecommendUpgrade <-
     FirstTrue <$> obj ..:? configMonoidRecommendUpgradeName
-
+  configMonoidCasaOpts <-
+    jsonSubWarnings (obj ..:? configMonoidCasaOptsName ..!= mempty)
   configMonoidCasaRepoPrefix <-
     First <$> obj ..:? configMonoidCasaRepoPrefixName
   configMonoidSnapshotLocation <-
@@ -509,6 +514,9 @@ configMonoidHideSourcePathsName = "hide-source-paths"
 configMonoidRecommendUpgradeName :: Text
 configMonoidRecommendUpgradeName = "recommend-stack-upgrade"
 
+configMonoidCasaOptsName :: Text
+configMonoidCasaOptsName = "casa"
+
 configMonoidCasaRepoPrefixName :: Text
 configMonoidCasaRepoPrefixName = "casa-repo-prefix"
 

stack.cabal

@@ -314,6 +314,7 @@ library
       Stack.Internal.BuildInfo
       Stack.PackageFile
       Stack.Types.Cache
+      Stack.Types.Casa
       Stack.Types.Dependency
       Stack.Types.PackageFile
       Stack.Types.Storage
@@ -361,7 +362,7 @@ library
     , neat-interpolation
     , open-browser
     , optparse-applicative >=0.18.1.0
-    , pantry >=0.8.2.2
+    , pantry >=0.8.3
     , path
     , path-io
     , persistent >=2.14.0.0 && <2.15
@@ -471,7 +472,7 @@ executable stack
     , neat-interpolation
     , open-browser
     , optparse-applicative >=0.18.1.0
-    , pantry >=0.8.2.2
+    , pantry >=0.8.3
     , path
     , path-io
     , persistent >=2.14.0.0 && <2.15
@@ -576,7 +577,7 @@ executable stack-integration-test
     , open-browser
     , optparse-applicative >=0.18.1.0
     , optparse-generic
-    , pantry >=0.8.2.2
+    , pantry >=0.8.3
     , path
     , path-io
     , persistent >=2.14.0.0 && <2.15
@@ -685,7 +686,7 @@ test-suite stack-test
     , neat-interpolation
     , open-browser
     , optparse-applicative >=0.18.1.0
-    , pantry >=0.8.2.2
+    , pantry >=0.8.3
     , path
     , path-io
     , persistent >=2.14.0.0 && <2.15

stack.yaml

@@ -9,7 +9,7 @@ extra-deps:
 - ansi-terminal-types-0.11.5@sha256:f78440dfd95c4509e88855ac7cc2d9566ddf956a92c1290404cac93ad1a1b00a,1482
 - fsnotify-0.4.1.0@sha256:44540beabea36aeeef930aa4d5f28091d431904bc9923b6ac4d358831c651235,2854
 - optparse-applicative-0.18.1.0@sha256:b4cf8d9018e5e67cb1f14edb5130b6d05ad8bc1b5f6bd4efaa6ec0b7f28f559d,5132
-- pantry-0.8.2.2@sha256:579aa8538c0fde65f9c08fb97d1d5aee8f59e5cc44e5f8feb350ec54bd2b14a6,6026
+- pantry-0.8.3@sha256:3717b64fa283624832cf2ed5042c5f4ec549276633d1e1c6845c6c0d462a17dc,5750
 - persistent-2.14.5.0@sha256:c3c7a6a200930f956b2a6bb15b9d2cd512980692f6a2d95368a6db335c34c916,7199
 - rio-prettyprint-0.1.4.0@sha256:1f8eb3ead0ef33d3736d53e1de5e9b2c91a0c207cdca23321bd74c401e85f23a,1301
 # lts-20.23 specifies Cabal-3.6.3.0

stack.yaml.lock

@@ -33,12 +33,12 @@ packages:
   original:
     hackage: optparse-applicative-0.18.1.0@sha256:b4cf8d9018e5e67cb1f14edb5130b6d05ad8bc1b5f6bd4efaa6ec0b7f28f559d,5132
 - completed:
-    hackage: pantry-0.8.2.2@sha256:579aa8538c0fde65f9c08fb97d1d5aee8f59e5cc44e5f8feb350ec54bd2b14a6,6026
+    hackage: pantry-0.8.3@sha256:3717b64fa283624832cf2ed5042c5f4ec549276633d1e1c6845c6c0d462a17dc,5750
     pantry-tree:
-      sha256: f979dadd233a05272bfee435de5d66532692532453d199adb902079a75cb878d
+      sha256: 1b991741e05313c0029adb8c014a1205068cebdd9d63a70e041ad79e1cd48c15
       size: 2970
   original:
-    hackage: pantry-0.8.2.2@sha256:579aa8538c0fde65f9c08fb97d1d5aee8f59e5cc44e5f8feb350ec54bd2b14a6,6026
+    hackage: pantry-0.8.3@sha256:3717b64fa283624832cf2ed5042c5f4ec549276633d1e1c6845c6c0d462a17dc,5750
 - completed:
     hackage: persistent-2.14.5.0@sha256:c3c7a6a200930f956b2a6bb15b9d2cd512980692f6a2d95368a6db335c34c916,7199
     pantry-tree: