hwm 0.1.1 → 0.1.2

raw patch · 5 files changed

+71/−53 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hwm.cabal +1/−1
• src/HWM/Domain/Config.hs +2/−1
• src/HWM/Domain/ConfigT.hs +12/−31
• src/HWM/Domain/Environments.hs +20/−18
• src/HWM/Runtime/Files.hs +36/−2

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           hwm-version:        0.1.1+version:        0.1.2 synopsis:       Haskell Workspace Manager - Orchestrates Stack, Cabal, and HLS description:    HWM (Haskell Workspace Manager) manages multi-package Haskell projects by                 generating and synchronizing configuration files for Stack, Cabal, Hpack, and HLS

@@ -29,7 +29,7 @@ import HWM.Domain.Release (Release) import HWM.Domain.Workspace (PkgRegistry, Workspace) import HWM.Runtime.Cache (Cache)-import HWM.Runtime.Files (aesonYAMLOptionsAdvanced)+import HWM.Runtime.Files (Signature, aesonYAMLOptionsAdvanced) import Relude  data Config = Config@@ -68,6 +68,7 @@     Has env Cache,     Has env Workspace,     Has env Environments,+    Has env Signature,     MonadIO m   ) =>   Check m Config

@@ -27,10 +27,6 @@ where  import Control.Monad.Error.Class-import qualified Crypto.Hash.SHA256 as SHA256-import qualified Data.ByteString.Base16 as Base16-import qualified Data.Text as T-import qualified Data.Text.Encoding as T import HWM.Core.Common (Check (..), Name) import HWM.Core.Formatting (Format (..)) import HWM.Core.Has (Has (..))@@ -38,11 +34,11 @@ import HWM.Core.Result (Issue (..), MonadIssue (..), Result (..), ResultT, runResultT) import HWM.Core.Version (Version, askVersion) import HWM.Domain.Config (Config (..))-import HWM.Domain.Environments (Environments (..))+import HWM.Domain.Environments (Environments (..), environmentHash) import HWM.Domain.Release (ArtifactConfig, Release (..)) import HWM.Domain.Workspace (PkgRegistry, Workspace, pkgRegistry) import HWM.Runtime.Cache (Cache, VersionMap, loadCache, saveCache)-import HWM.Runtime.Files (addHash, readYaml, rewrite_)+import HWM.Runtime.Files (Signature, addHash, getFileSignature, readYaml, rewrite_) import HWM.Runtime.UI (MonadUI (..), UIT, printSummary, runUI) import Relude @@ -50,7 +46,8 @@   { options :: Options,     config :: Config,     cache :: Cache,-    pkgs :: PkgRegistry+    pkgs :: PkgRegistry,+    fileSignature :: Signature   }  type ConfigEnv = Env IO@@ -88,6 +85,9 @@ instance Has (Env m) PkgRegistry where   obtain = pkgs +instance Has (Env m) Signature where+  obtain = fileSignature+ instance MonadUI ConfigT where   uiWrite txt = do     Options {quiet} <- asks options@@ -95,16 +95,6 @@   uiIndentLevel = ConfigT $ lift uiIndentLevel   uiWithIndent f (ConfigT (ReaderT action)) = ConfigT $ ReaderT (uiWithIndent f . action) -getFileHash :: FilePath -> IO (Maybe Text)-getFileHash filePath = do-  content <- T.decodeUtf8 <$> readFileBS filePath-  case T.lines content of-    (firstLine : _) ->-      case T.stripPrefix "# hash: " firstLine of-        Just hash -> pure (Just hash)-        Nothing -> pure Nothing-    [] -> pure Nothing- debug :: Text -> ConfigT () debug _ = pure () @@ -113,16 +103,6 @@   catchIssues (ConfigT action) = ConfigT $ ReaderT (catchIssues . runReaderT action)   mapIssue f (ConfigT action) = ConfigT $ ReaderT $ \env -> mapIssue f (runReaderT action env) -computeHash :: Config -> Text-computeHash cfg =-  let hashInput = T.encodeUtf8 (T.pack (show (envTargets $ cfgEnvironments cfg)))-      hashBytes = SHA256.hash hashInput-   in T.decodeUtf8 (Base16.encode hashBytes)--hasHashChanged :: Config -> Maybe Text -> Bool-hasHashChanged _ Nothing = True-hasHashChanged cfg (Just storedHash) = storedHash /= computeHash cfg- checkConfig :: ConfigT () checkConfig = do   cfg <- asks config@@ -135,7 +115,7 @@ saveConfig config ops = do   let file = hwm ops   rewrite_ file (const $ pure config)-  addHash file (computeHash config)+  addHash file (environmentHash (cfgEnvironments config))  updateConfig :: (Config -> ConfigT Config) -> ConfigT b -> ConfigT b updateConfig f m = do@@ -146,10 +126,11 @@ runConfigT m opts@Options {..} = do   config <- resolveResultTSilent (readYaml hwm)   cache <- loadCache (envDefault (cfgEnvironments config))-  changed <- hasHashChanged config <$> getFileHash hwm+  fileSignature <- getFileSignature hwm+  let currentSignature = environmentHash (cfgEnvironments config)   pkgs <- resolveResultTSilent (pkgRegistry (cfgWorkspace config))-  let env = Env {options = opts, config, cache, pkgs}-      resultT = unpackConfigT (if changed then checkConfig >> m else m) env+  let env = Env {options = opts, config, cache, pkgs, fileSignature}+      resultT = unpackConfigT (if fileSignature /= currentSignature then checkConfig >> m else m) env   resolveResultT resultT cache  resolveResultT :: ResultT (UIT IO) a -> Cache -> IO ()

@@ -21,6 +21,7 @@     removeEnvironmentByName,     newEnv,     existsEnviroment,+    environmentHash,   ) where @@ -35,20 +36,21 @@ import Data.List ((\\)) import qualified Data.Map as M import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Traversable (for) import HWM.Core.Common   ( Check (..),     Name,   ) import HWM.Core.Formatting (Color (..), Format (..), availableOptions, chalk)-import HWM.Core.Has (Has, HasAll, askEnv)+import HWM.Core.Has (Has (..), HasAll, askEnv) import HWM.Core.Pkg (Pkg (..), PkgName, pkgId) import HWM.Core.Result (Issue) import HWM.Core.Version (Version) import HWM.Domain.Bounds (TestedRange (..)) import HWM.Domain.Workspace (Workspace, allPackages) import HWM.Runtime.Cache (Cache, Registry (currentEnv), VersionMap, getLatestNightlySnapshot, getRegistry, getSnapshot, getVersions)-import HWM.Runtime.Files (aesonYAMLOptions, aesonYAMLOptionsAdvanced)+import HWM.Runtime.Files (Signature, aesonYAMLOptions, aesonYAMLOptionsAdvanced, genSignature) import HWM.Runtime.UI (MonadUI, forTable_, sectionEnvironments) import Relude @@ -73,6 +75,12 @@       allowNewer = Nothing     } +environmentHash :: Environments -> Signature+environmentHash Environments {..} =+  genSignature $ Set.toList $ Set.fromList $ map toSig $ concatMap Map.toList $ mapMaybe extraDeps (toList envTargets)+  where+    toSig (pkg, v) = format pkg <> "-" <> format v+ prefix :: String prefix = "env" @@ -88,11 +96,20 @@     Has env Environments,     Has env Workspace,     Has env Cache,+    Has env Signature,     MonadIO m   ) =>   Check m Environments   where-  check Environments {..} = traverse_ check envTargets+  check Environments {..} = do+    fileSig <- askEnv+    traverse_ (checkTarget fileSig) envTargets+    where+      signature = environmentHash Environments {..}+      checkTarget fileSig EnviromentTarget {..}+        | fileSig == signature = checkPkgNames exclude+        -- checking all hkgRefs is expensive, so we skip it if the signature matches+        | otherwise = sequence_ [traverse_ check (maybe [] hkgRefs extraDeps), checkPkgNames exclude]  data EnviromentTarget = EnviromentTarget   { ghc :: Version,@@ -113,21 +130,6 @@  instance ToJSON EnviromentTarget where   toJSON = genericToJSON aesonYAMLOptions--instance-  ( MonadError Issue m,-    MonadReader env m,-    Has env Workspace,-    Has env Cache,-    MonadIO m-  ) =>-  Check m EnviromentTarget-  where-  check EnviromentTarget {..} =-    sequence_-      [ traverse_ check (maybe [] hkgRefs extraDeps),-        checkPkgNames exclude-      ]  checkPkgNames ::   ( MonadError Issue m,

@@ -15,11 +15,15 @@     forbidOverride,     cleanRelativePath,     aesonYAMLOptionsAdvanced,+    genSignature,+    Signature,+    getFileSignature,   ) where  import Control.Exception (catch, throwIO, tryJust) import Control.Monad.Error.Class (MonadError (..))+import qualified Crypto.Hash.SHA256 as SHA256 import Data.Aeson   ( FromJSON (..),     Object,@@ -29,10 +33,12 @@     defaultOptions,   ) import Data.ByteString (readFile, writeFile)+import qualified Data.ByteString.Base16 as Base16 import Data.Char (isUpper, toLower) import Data.List (elemIndex, stripPrefix) import Data.Map (lookup) import Data.Text (toTitle)+import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Yaml (decodeThrow) import Data.Yaml.Pretty (defConfig, encodePretty, setConfCompare, setConfDropNull)@@ -43,6 +49,23 @@ import System.FilePath (joinPath, splitDirectories) import System.IO.Error (isDoesNotExistError) +data Signature = Signed Text | Unsigned+  deriving (Ord, Show)++instance Eq Signature where+  (Signed hash1) == (Signed hash2) = hash1 == hash2+  _ == _ = False++genSignature :: [Text] -> Signature+genSignature txt =+  let hashInput = T.encodeUtf8 (T.intercalate ":" txt)+      hashBytes = SHA256.hash hashInput+   in Signed (T.decodeUtf8 (Base16.encode hashBytes))++instance Format Signature where+  format (Signed hash) = "# hash: " <> hash <> "\n"+  format Unsigned = ""+ printException :: SomeException -> String printException = show @@ -181,11 +204,22 @@ select :: (MonadError Issue m, Format t, Ord t) => Text -> t -> Map t a -> m a select e k = maybe (throwError $ fromString $ "Unknown " <> toString e <> ": " <> toString (format k) <> "!") pure . lookup k -addHash :: (MonadIO m) => FilePath -> Text -> m ()-addHash filePath hash = do+addHash :: (MonadIO m) => FilePath -> Signature -> m ()+addHash filePath (Signed hash) = do   content <- liftIO $ T.decodeUtf8 <$> readFileBS filePath   let contentWithHash = "# hash: " <> hash <> "\n" <> content   liftIO $ writeFileBS filePath (T.encodeUtf8 contentWithHash)+addHash _ Unsigned = pure ()++getFileSignature :: (MonadIO m) => FilePath -> m Signature+getFileSignature filePath = do+  content <- liftIO $ T.decodeUtf8 <$> readFileBS filePath+  case T.lines content of+    (firstLine : _) ->+      case T.stripPrefix "# hash: " firstLine of+        Just hash -> pure (Signed hash)+        Nothing -> pure Unsigned+    [] -> pure Unsigned  forbidOverride :: (MonadIO m, MonadError e m, IsString e) => FilePath -> m () forbidOverride path = do