Freeze.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

module Stack.Freeze
    ( freeze
    , FreezeOpts (..)
    , FreezeMode (..)
    ) where

import           Data.Aeson ((.=), object)
import qualified Data.Yaml as Yaml
import           RIO.Process
import qualified RIO.ByteString as B
import           Stack.Prelude
import           Stack.Types.Config

data FreezeMode = FreezeProject | FreezeSnapshot

newtype FreezeOpts = FreezeOpts
    { freezeMode :: FreezeMode
    }

freeze :: HasEnvConfig env => FreezeOpts -> RIO env ()
freeze (FreezeOpts mode) = do
  mproject <- view $ configL.to configProject
  let warn = logWarn "No project was found: nothing to freeze"
  case mproject of
    PCProject (p, _) -> doFreeze p mode
    PCGlobalProject -> warn
    PCNoProject _ -> warn

doFreeze ::
       (HasProcessContext env, HasLogFunc env, HasPantryConfig env)
    => Project
    -> FreezeMode
    -> RIO env ()
doFreeze p FreezeProject = do
  let deps = projectDependencies p
      resolver = projectResolver p
      completePackageLocation' pl =
        case pl of
          RPLImmutable pli -> PLImmutable <$> completePackageLocation pli
          RPLMutable m -> pure $ PLMutable m
  resolver' <- completeSnapshotLocation resolver
  deps' <- mapM completePackageLocation' deps
  let rawCompleted = map toRawPL deps'
      rawResolver = toRawSL resolver'
  if rawCompleted == deps && rawResolver == resolver
  then
    logInfo "No freezing is required for this project"
  else do
    logInfo "# Fields not mentioned below do not need to be updated"

    if rawResolver == resolver
      then logInfo "# No update to resolver is needed"
      else do
        logInfo "# Frozen version of resolver"
        B.putStr $ Yaml.encode $ object ["resolver" .= rawResolver]

    if rawCompleted == deps
      then logInfo "# No update to extra-deps is needed"
      else do
        logInfo "# Frozen version of extra-deps"
        B.putStr $ Yaml.encode $ object ["extra-deps" .= rawCompleted]

doFreeze p FreezeSnapshot = do
  resolver <- completeSnapshotLocation $ projectResolver p
  result <- loadSnapshotLayer resolver
  case result of
    Left _wc ->
      logInfo "No freezing is required for compiler resolver"
    Right snap -> do
      snap' <- completeSnapshotLayer snap
      let rawCompleted = toRawSnapshotLayer snap'
      if rawCompleted == snap
        then
        logInfo "No freezing is required for the snapshot of this project"
        else
        liftIO $ B.putStr $ Yaml.encode snap'