-- |
-- Module: Staversion.Internal.BuildPlan
-- Description:  Handle build plan YAML files.
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- __This is an internal module. End-users should not use it.__
{-# LANGUAGE GeneralizedNewtypeDeriving, TupleSections #-}
module Staversion.Internal.BuildPlan
       ( -- * Entry APIs
         HasVersions(..),
         BuildPlan,
         buildPlanSource,
         BuildPlanManager,
         newBuildPlanManager,
         manStackConfig,
         loadBuildPlan,
         -- * Low-level APIs
         BuildPlanMap,
         -- * For tests
         _setLTSDisambiguator
       ) where

import Control.Applicative (empty, (<$>), (<*>))
import Control.Exception (throwIO, catchJust, IOException, catch)
import Control.Monad.IO.Class (liftIO)
import Control.Monad (mapM)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.HashMap.Strict as HM
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Monoid (Monoid, (<>), mconcat)
import Data.Semigroup (Semigroup)
import Data.Text (Text, unpack)
import Data.Traversable (Traversable(traverse))
import Data.Word (Word)
import System.FilePath ((</>), (<.>))
import qualified System.IO.Error as IOE
import Text.Read (readMaybe)

import Staversion.Internal.EIO
  ( EIO, maybeToEIO, runEIO, toEIO, loggedElse, eitherToEIO
  )
import Staversion.Internal.Log
  ( Logger, logDebug, logWarn
  )
import Staversion.Internal.HTTP (niceHTTPManager, Manager, OurHttpException)
import Staversion.Internal.Query
 ( PackageName, PackageSource(..),
   ErrorMsg, Resolver
 )
import Staversion.Internal.BuildPlan.BuildPlanMap
  ( BuildPlanMap, HasVersions(..)
  )
import qualified Staversion.Internal.BuildPlan.BuildPlanMap as BPMap
import Staversion.Internal.BuildPlan.Core (CompilerCores)
import qualified Staversion.Internal.BuildPlan.Core as Core
import Staversion.Internal.BuildPlan.Hackage
  ( RegisteredVersions, latestVersion,
    fetchPreferredVersions
  )
import qualified Staversion.Internal.BuildPlan.Pantry as Pantry
import Staversion.Internal.BuildPlan.Stackage
  ( Disambiguator,
    fetchDisambiguator,
    parseResolverString,
    formatExactResolverString,
    PartialResolver(..), ExactResolver(..)
  )
import Staversion.Internal.BuildPlan.V1 as V1
import Staversion.Internal.StackConfig (StackConfig)
import qualified Staversion.Internal.StackConfig as StackConfig
import Staversion.Internal.Version (Version)


-- | A 'BuildPlanMap' associated with its 'PackageSource'.
data BuildPlan = BuildPlan { BuildPlan -> BuildPlanMap
buildPlanMap :: BuildPlanMap,
                             BuildPlan -> PackageSource
buildPlanSource :: PackageSource
                           }

instance HasVersions BuildPlan where
  packageVersion :: BuildPlan -> PackageName -> Maybe Version
packageVersion BuildPlan
bp = BuildPlanMap -> PackageName -> Maybe Version
forall t. HasVersions t => t -> PackageName -> Maybe Version
packageVersion (BuildPlan -> BuildPlanMap
buildPlanMap BuildPlan
bp)


-- | Stateful manager for 'BuildPlan's.
data BuildPlanManager =
  BuildPlanManager { BuildPlanManager -> FilePath
manBuildPlanDir :: FilePath,
                     -- ^ (accessor function) path to the directory
                     -- where build plans are hold.
                     BuildPlanManager -> Maybe Manager
manHttpManager :: Maybe Manager,
                     -- ^ (accessor function) low-level HTTP
                     -- connection manager. If 'Nothing', it won't
                     -- fetch build plans over the network.
                     BuildPlanManager -> IORef (Maybe Disambiguator)
manDisambiguator :: IORef (Maybe Disambiguator),
                     -- ^ (accessor function) cache of resolver
                     -- disambigutor
                     BuildPlanManager -> IORef (Maybe CompilerCores)
manCores :: IORef (Maybe CompilerCores),
                     -- ^ cache of compiler core packages.
                     BuildPlanManager -> Logger
manLogger :: Logger,
                     BuildPlanManager -> StackConfig
manStackConfig :: StackConfig
                     -- ^ (accessor function)
                   }

newBuildPlanManager :: FilePath -- ^ path to the directory where build plans are hold.
                    -> Logger
                    -> Bool -- ^ If 'True', it queries the Internet for build plans. Otherwise, it won't.
                    -> IO BuildPlanManager
newBuildPlanManager :: FilePath -> Logger -> Bool -> IO BuildPlanManager
newBuildPlanManager FilePath
plan_dir Logger
logger Bool
enable_network = do
  Maybe Manager
mman <- if Bool
enable_network
          then Manager -> Maybe Manager
forall a. a -> Maybe a
Just (Manager -> Maybe Manager) -> IO Manager -> IO (Maybe Manager)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Manager
niceHTTPManager
          else Maybe Manager -> IO (Maybe Manager)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Manager
forall a. Maybe a
Nothing
  IORef (Maybe Disambiguator)
disam <- Maybe Disambiguator -> IO (IORef (Maybe Disambiguator))
forall a. a -> IO (IORef a)
newIORef Maybe Disambiguator
forall a. Maybe a
Nothing
  IORef (Maybe CompilerCores)
cores <- Maybe CompilerCores -> IO (IORef (Maybe CompilerCores))
forall a. a -> IO (IORef a)
newIORef Maybe CompilerCores
forall a. Maybe a
Nothing
  BuildPlanManager -> IO BuildPlanManager
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildPlanManager -> IO BuildPlanManager)
-> BuildPlanManager -> IO BuildPlanManager
forall a b. (a -> b) -> a -> b
$ BuildPlanManager :: FilePath
-> Maybe Manager
-> IORef (Maybe Disambiguator)
-> IORef (Maybe CompilerCores)
-> Logger
-> StackConfig
-> BuildPlanManager
BuildPlanManager { manBuildPlanDir :: FilePath
manBuildPlanDir = FilePath
plan_dir,
                              manHttpManager :: Maybe Manager
manHttpManager = Maybe Manager
mman,
                              manDisambiguator :: IORef (Maybe Disambiguator)
manDisambiguator = IORef (Maybe Disambiguator)
disam,
                              manCores :: IORef (Maybe CompilerCores)
manCores = IORef (Maybe CompilerCores)
cores,
                              manLogger :: Logger
manLogger = Logger
logger,
                              manStackConfig :: StackConfig
manStackConfig = Logger -> StackConfig
StackConfig.newStackConfig Logger
logger
                            }

httpManagerM :: BuildPlanManager -> EIO Manager
httpManagerM :: BuildPlanManager -> EIO Manager
httpManagerM = FilePath -> Maybe Manager -> EIO Manager
forall a. FilePath -> Maybe a -> EIO a
maybeToEIO FilePath
"It is not allowed to access network." (Maybe Manager -> EIO Manager)
-> (BuildPlanManager -> Maybe Manager)
-> BuildPlanManager
-> EIO Manager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildPlanManager -> Maybe Manager
manHttpManager

httpExceptionToEIO :: String -> EIO a -> EIO a
httpExceptionToEIO :: FilePath -> EIO a -> EIO a
httpExceptionToEIO FilePath
context EIO a
action = IO (Either FilePath a) -> EIO a
forall a. IO (Either FilePath a) -> EIO a
toEIO (IO (Either FilePath a) -> EIO a)
-> IO (Either FilePath a) -> EIO a
forall a b. (a -> b) -> a -> b
$ (EIO a -> IO (Either FilePath a)
forall a. EIO a -> IO (Either FilePath a)
runEIO EIO a
action) IO (Either FilePath a)
-> (OurHttpException -> IO (Either FilePath a))
-> IO (Either FilePath a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` OurHttpException -> IO (Either FilePath a)
forall a. OurHttpException -> IO (Either FilePath a)
handler where
  handler :: OurHttpException -> IO (Either ErrorMsg a)
  handler :: OurHttpException -> IO (Either FilePath a)
handler OurHttpException
e = Either FilePath a -> IO (Either FilePath a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath a -> IO (Either FilePath a))
-> Either FilePath a -> IO (Either FilePath a)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath a
forall a b. a -> Either a b
Left (FilePath
context FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ OurHttpException -> FilePath
forall a. Show a => a -> FilePath
show OurHttpException
e)

getCores :: BuildPlanManager -> EIO CompilerCores
getCores :: BuildPlanManager -> EIO CompilerCores
getCores BuildPlanManager
man = do
  Maybe CompilerCores
mcores <- IO (Maybe CompilerCores)
-> ExceptT FilePath IO (Maybe CompilerCores)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CompilerCores)
 -> ExceptT FilePath IO (Maybe CompilerCores))
-> IO (Maybe CompilerCores)
-> ExceptT FilePath IO (Maybe CompilerCores)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe CompilerCores) -> IO (Maybe CompilerCores)
forall a. IORef a -> IO a
readIORef (IORef (Maybe CompilerCores) -> IO (Maybe CompilerCores))
-> IORef (Maybe CompilerCores) -> IO (Maybe CompilerCores)
forall a b. (a -> b) -> a -> b
$ BuildPlanManager -> IORef (Maybe CompilerCores)
manCores BuildPlanManager
man
  case Maybe CompilerCores
mcores of
    Just CompilerCores
c -> CompilerCores -> EIO CompilerCores
forall (m :: * -> *) a. Monad m => a -> m a
return CompilerCores
c
    Maybe CompilerCores
Nothing -> do
      Manager
http <- BuildPlanManager -> EIO Manager
httpManagerM BuildPlanManager
man
      IO () -> ExceptT FilePath IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT FilePath IO ())
-> IO () -> ExceptT FilePath IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> FilePath -> IO ()
logDebug (BuildPlanManager -> Logger
manLogger BuildPlanManager
man) FilePath
"fetching GHC pkg_versions"
      CompilerCores
cores <- FilePath -> EIO CompilerCores -> EIO CompilerCores
forall a. FilePath -> EIO a -> EIO a
httpExceptionToEIO FilePath
"Failed to fetch GHC pkg_versions"
               (EIO CompilerCores -> EIO CompilerCores)
-> EIO CompilerCores -> EIO CompilerCores
forall a b. (a -> b) -> a -> b
$ IO (Either FilePath CompilerCores) -> EIO CompilerCores
forall a. IO (Either FilePath a) -> EIO a
toEIO (IO (Either FilePath CompilerCores) -> EIO CompilerCores)
-> IO (Either FilePath CompilerCores) -> EIO CompilerCores
forall a b. (a -> b) -> a -> b
$ (ByteString -> Either FilePath CompilerCores)
-> IO ByteString -> IO (Either FilePath CompilerCores)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either FilePath CompilerCores
Core.parseGHCPkgVersions (IO ByteString -> IO (Either FilePath CompilerCores))
-> IO ByteString -> IO (Either FilePath CompilerCores)
forall a b. (a -> b) -> a -> b
$ Manager -> IO ByteString
Core.fetchGHCPkgVersions Manager
http
      IO () -> ExceptT FilePath IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT FilePath IO ())
-> IO () -> ExceptT FilePath IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe CompilerCores) -> Maybe CompilerCores -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (BuildPlanManager -> IORef (Maybe CompilerCores)
manCores BuildPlanManager
man) (Maybe CompilerCores -> IO ()) -> Maybe CompilerCores -> IO ()
forall a b. (a -> b) -> a -> b
$ CompilerCores -> Maybe CompilerCores
forall a. a -> Maybe a
Just CompilerCores
cores
      CompilerCores -> EIO CompilerCores
forall (m :: * -> *) a. Monad m => a -> m a
return CompilerCores
cores

loadBuildPlan :: BuildPlanManager
              -> [PackageName]
              -- ^ package names whose versions the user is interested in.
              -> PackageSource
              -> IO (Either ErrorMsg BuildPlan)
              -- ^ the second result is the real (disambiguated) PackageSource.
loadBuildPlan :: BuildPlanManager
-> [PackageName] -> PackageSource -> IO (Either FilePath BuildPlan)
loadBuildPlan BuildPlanManager
man [PackageName]
names PackageSource
s = EIO BuildPlan -> IO (Either FilePath BuildPlan)
forall a. EIO a -> IO (Either FilePath a)
runEIO (EIO BuildPlan -> IO (Either FilePath BuildPlan))
-> EIO BuildPlan -> IO (Either FilePath BuildPlan)
forall a b. (a -> b) -> a -> b
$ BuildPlanManager -> [PackageName] -> PackageSource -> EIO BuildPlan
loadBuildPlanM BuildPlanManager
man [PackageName]
names PackageSource
s

loadBuildPlanM :: BuildPlanManager -> [PackageName] -> PackageSource -> EIO BuildPlan
loadBuildPlanM :: BuildPlanManager -> [PackageName] -> PackageSource -> EIO BuildPlan
loadBuildPlanM BuildPlanManager
man [PackageName]
_ (SourceStackage FilePath
resolver) = EIO BuildPlan
impl where
  impl :: EIO BuildPlan
impl = BuildPlanManager -> FilePath -> EIO BuildPlan
loadBuildPlan_stackageLocalFile BuildPlanManager
man FilePath
resolver EIO BuildPlan -> EIO BuildPlan -> EIO BuildPlan
forall a. EIO a -> EIO a -> EIO a
`loggedElse'` do
    ExactResolver
e_resolver <- BuildPlanManager -> PartialResolver -> EIO ExactResolver
tryDisambiguate BuildPlanManager
man (PartialResolver -> EIO ExactResolver)
-> ExceptT FilePath IO PartialResolver -> EIO ExactResolver
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT FilePath IO PartialResolver
getPresolver
    BuildPlanManager -> FilePath -> EIO BuildPlan
loadBuildPlan_stackageLocalFile BuildPlanManager
man (ExactResolver -> FilePath
formatExactResolverString ExactResolver
e_resolver) EIO BuildPlan -> EIO BuildPlan -> EIO BuildPlan
forall a. EIO a -> EIO a -> EIO a
`loggedElse'` BuildPlanManager -> ExactResolver -> EIO BuildPlan
loadBuildPlan_stackageNetwork BuildPlanManager
man ExactResolver
e_resolver
  getPresolver :: ExceptT FilePath IO PartialResolver
getPresolver = FilePath
-> Maybe PartialResolver -> ExceptT FilePath IO PartialResolver
forall a. FilePath -> Maybe a -> EIO a
maybeToEIO (FilePath
"Invalid resolver format for stackage.org: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
resolver) (Maybe PartialResolver -> ExceptT FilePath IO PartialResolver)
-> Maybe PartialResolver -> ExceptT FilePath IO PartialResolver
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe PartialResolver
parseResolverString FilePath
resolver
  loggedElse' :: EIO a -> EIO a -> EIO a
loggedElse' = Logger -> EIO a -> EIO a -> EIO a
forall a. Logger -> EIO a -> EIO a -> EIO a
loggedElse (Logger -> EIO a -> EIO a -> EIO a)
-> Logger -> EIO a -> EIO a -> EIO a
forall a b. (a -> b) -> a -> b
$ BuildPlanManager -> Logger
manLogger BuildPlanManager
man
loadBuildPlanM BuildPlanManager
man [PackageName]
names PackageSource
SourceHackage = EIO BuildPlan
impl where
  impl :: EIO BuildPlan
impl = do
    Manager
http_man <- BuildPlanManager -> EIO Manager
httpManagerM BuildPlanManager
man
    BuildPlanMap
build_plan_map <- ([BuildPlanMap] -> BuildPlanMap
forall a. Monoid a => [a] -> a
mconcat ([BuildPlanMap] -> BuildPlanMap)
-> ([RegisteredVersions] -> [BuildPlanMap])
-> [RegisteredVersions]
-> BuildPlanMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName -> RegisteredVersions -> BuildPlanMap)
-> [PackageName] -> [RegisteredVersions] -> [BuildPlanMap]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith PackageName -> RegisteredVersions -> BuildPlanMap
registeredVersionToBuildPlanMap [PackageName]
names) ([RegisteredVersions] -> BuildPlanMap)
-> ExceptT FilePath IO [RegisteredVersions]
-> ExceptT FilePath IO BuildPlanMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PackageName -> ExceptT FilePath IO RegisteredVersions)
-> [PackageName] -> ExceptT FilePath IO [RegisteredVersions]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Manager -> PackageName -> ExceptT FilePath IO RegisteredVersions
doFetch Manager
http_man) [PackageName]
names
    BuildPlan -> EIO BuildPlan
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildPlan -> EIO BuildPlan) -> BuildPlan -> EIO BuildPlan
forall a b. (a -> b) -> a -> b
$ BuildPlan :: BuildPlanMap -> PackageSource -> BuildPlan
BuildPlan { buildPlanMap :: BuildPlanMap
buildPlanMap = BuildPlanMap
build_plan_map, buildPlanSource :: PackageSource
buildPlanSource = PackageSource
SourceHackage }
  logDebug' :: FilePath -> m ()
logDebug' FilePath
msg = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> FilePath -> IO ()
logDebug (BuildPlanManager -> Logger
manLogger BuildPlanManager
man) FilePath
msg
  logWarn' :: FilePath -> m ()
logWarn' FilePath
msg = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> FilePath -> IO ()
logWarn (BuildPlanManager -> Logger
manLogger BuildPlanManager
man) FilePath
msg
  doFetch :: Manager -> PackageName -> ExceptT FilePath IO RegisteredVersions
doFetch Manager
http_man PackageName
name = do
    FilePath -> ExceptT FilePath IO ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
logDebug' (FilePath
"Ask hackage for the latest version of " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageName -> FilePath
unpack PackageName
name)
    RegisteredVersions
reg_ver <- IO (Either FilePath RegisteredVersions)
-> ExceptT FilePath IO RegisteredVersions
forall a. IO (Either FilePath a) -> EIO a
toEIO (IO (Either FilePath RegisteredVersions)
 -> ExceptT FilePath IO RegisteredVersions)
-> IO (Either FilePath RegisteredVersions)
-> ExceptT FilePath IO RegisteredVersions
forall a b. (a -> b) -> a -> b
$ Manager -> PackageName -> IO (Either FilePath RegisteredVersions)
fetchPreferredVersions Manager
http_man PackageName
name
    case RegisteredVersions -> Maybe Version
latestVersion RegisteredVersions
reg_ver of
     Maybe Version
Nothing -> FilePath -> ExceptT FilePath IO ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
logWarn' (FilePath
"Cannot find package version of " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageName -> FilePath
unpack PackageName
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
". Maybe it's not on hackage.")
     Just Version
_ -> () -> ExceptT FilePath IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    RegisteredVersions -> ExceptT FilePath IO RegisteredVersions
forall (m :: * -> *) a. Monad m => a -> m a
return RegisteredVersions
reg_ver
loadBuildPlanM BuildPlanManager
man [PackageName]
names (SourceStackYaml FilePath
file) = BuildPlanManager
-> [PackageName] -> Maybe FilePath -> EIO BuildPlan
loadBuildPlan_sourceStack BuildPlanManager
man [PackageName]
names (Maybe FilePath -> EIO BuildPlan)
-> Maybe FilePath -> EIO BuildPlan
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file
loadBuildPlanM BuildPlanManager
man [PackageName]
names PackageSource
SourceStackDefault = BuildPlanManager
-> [PackageName] -> Maybe FilePath -> EIO BuildPlan
loadBuildPlan_sourceStack BuildPlanManager
man [PackageName]
names (Maybe FilePath -> EIO BuildPlan)
-> Maybe FilePath -> EIO BuildPlan
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
forall a. Maybe a
Nothing

loadBuildPlan_sourceStack :: BuildPlanManager -> [PackageName] -> Maybe FilePath -> EIO BuildPlan
loadBuildPlan_sourceStack :: BuildPlanManager
-> [PackageName] -> Maybe FilePath -> EIO BuildPlan
loadBuildPlan_sourceStack BuildPlanManager
man [PackageName]
names Maybe FilePath
mfile = do
  FilePath
resolver <- IO (Either FilePath FilePath) -> EIO FilePath
forall a. IO (Either FilePath a) -> EIO a
toEIO (IO (Either FilePath FilePath) -> EIO FilePath)
-> IO (Either FilePath FilePath) -> EIO FilePath
forall a b. (a -> b) -> a -> b
$ StackConfig -> Maybe FilePath -> IO (Either FilePath FilePath)
StackConfig.readResolver StackConfig
sconf Maybe FilePath
mfile
  BuildPlanManager -> [PackageName] -> PackageSource -> EIO BuildPlan
loadBuildPlanM BuildPlanManager
man [PackageName]
names (PackageSource -> EIO BuildPlan) -> PackageSource -> EIO BuildPlan
forall a b. (a -> b) -> a -> b
$ FilePath -> PackageSource
SourceStackage FilePath
resolver
  where
    sconf :: StackConfig
sconf = BuildPlanManager -> StackConfig
manStackConfig BuildPlanManager
man

loadBuildPlan_stackageLocalFile :: BuildPlanManager -> Resolver -> EIO BuildPlan
loadBuildPlan_stackageLocalFile :: BuildPlanManager -> FilePath -> EIO BuildPlan
loadBuildPlan_stackageLocalFile BuildPlanManager
man FilePath
resolver = IO (Either FilePath BuildPlan) -> EIO BuildPlan
forall a. IO (Either FilePath a) -> EIO a
toEIO (IO (Either FilePath BuildPlan) -> EIO BuildPlan)
-> IO (Either FilePath BuildPlan) -> EIO BuildPlan
forall a b. (a -> b) -> a -> b
$ (IOException -> Maybe FilePath)
-> IO (Either FilePath BuildPlan)
-> (FilePath -> IO (Either FilePath BuildPlan))
-> IO (Either FilePath BuildPlan)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust IOException -> Maybe FilePath
handleIOError IO (Either FilePath BuildPlan)
doLoad (Either FilePath BuildPlan -> IO (Either FilePath BuildPlan)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath BuildPlan -> IO (Either FilePath BuildPlan))
-> (FilePath -> Either FilePath BuildPlan)
-> FilePath
-> IO (Either FilePath BuildPlan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Either FilePath BuildPlan
forall a b. a -> Either a b
Left) where
  yaml_file :: FilePath
yaml_file = BuildPlanManager -> FilePath
manBuildPlanDir BuildPlanManager
man FilePath -> FilePath -> FilePath
</> FilePath
resolver FilePath -> FilePath -> FilePath
<.> FilePath
"yaml"
  doLoad :: IO (Either FilePath BuildPlan)
doLoad = do
    Logger -> FilePath -> IO ()
logDebug (BuildPlanManager -> Logger
manLogger BuildPlanManager
man) (FilePath
"Read " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
yaml_file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" for build plan.")
    Either FilePath BuildPlanMap
e_build_plan_map <- FilePath -> IO (Either FilePath BuildPlanMap)
V1.loadBuildPlanMapYAML FilePath
yaml_file
    Either FilePath BuildPlan -> IO (Either FilePath BuildPlan)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath BuildPlan -> IO (Either FilePath BuildPlan))
-> Either FilePath BuildPlan -> IO (Either FilePath BuildPlan)
forall a b. (a -> b) -> a -> b
$ BuildPlanMap -> BuildPlan
makeBuildPlan (BuildPlanMap -> BuildPlan)
-> Either FilePath BuildPlanMap -> Either FilePath BuildPlan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either FilePath BuildPlanMap
e_build_plan_map
  makeBuildPlan :: BuildPlanMap -> BuildPlan
makeBuildPlan BuildPlanMap
bp_map = BuildPlan :: BuildPlanMap -> PackageSource -> BuildPlan
BuildPlan { buildPlanMap :: BuildPlanMap
buildPlanMap = BuildPlanMap
bp_map, buildPlanSource :: PackageSource
buildPlanSource = FilePath -> PackageSource
SourceStackage FilePath
resolver }
  handleIOError :: IOException -> Maybe ErrorMsg
  handleIOError :: IOException -> Maybe FilePath
handleIOError IOException
e | IOException -> Bool
IOE.isDoesNotExistError IOException
e = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ IOException -> FilePath -> FilePath
forall a. Show a => a -> FilePath -> FilePath
makeErrorMsg IOException
e (FilePath
yaml_file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not found.")
                  | IOException -> Bool
IOE.isPermissionError IOException
e = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ IOException -> FilePath -> FilePath
forall a. Show a => a -> FilePath -> FilePath
makeErrorMsg IOException
e (FilePath
"you cannot open " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
yaml_file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".")
                  | Bool
otherwise = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ IOException -> FilePath -> FilePath
forall a. Show a => a -> FilePath -> FilePath
makeErrorMsg IOException
e (FilePath
"some error.")
  makeErrorMsg :: a -> FilePath -> FilePath
makeErrorMsg a
exception FilePath
body = FilePath
"Loading build plan for package resolver '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
resolver FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' failed: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
body FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
exception

tryDisambiguate :: BuildPlanManager -> PartialResolver -> EIO ExactResolver
tryDisambiguate :: BuildPlanManager -> PartialResolver -> EIO ExactResolver
tryDisambiguate BuildPlanManager
_ (PartialExact ExactResolver
e) = ExactResolver -> EIO ExactResolver
forall (m :: * -> *) a. Monad m => a -> m a
return ExactResolver
e
tryDisambiguate BuildPlanManager
bp_man PartialResolver
presolver = EIO ExactResolver
impl where
  impl :: EIO ExactResolver
impl = do
    Disambiguator
disam <- FilePath -> EIO Disambiguator -> EIO Disambiguator
forall a. FilePath -> EIO a -> EIO a
httpExceptionToEIO FilePath
"Failed to download disambiguator" (EIO Disambiguator -> EIO Disambiguator)
-> EIO Disambiguator -> EIO Disambiguator
forall a b. (a -> b) -> a -> b
$ EIO Disambiguator
getDisambiguator
    FilePath -> Maybe ExactResolver -> EIO ExactResolver
forall a. FilePath -> Maybe a -> EIO a
maybeToEIO (FilePath
"Cannot disambiguate the resolver: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PartialResolver -> FilePath
forall a. Show a => a -> FilePath
show PartialResolver
presolver) (Maybe ExactResolver -> EIO ExactResolver)
-> Maybe ExactResolver -> EIO ExactResolver
forall a b. (a -> b) -> a -> b
$ Disambiguator
disam PartialResolver
presolver
  getDisambiguator :: EIO Disambiguator
getDisambiguator = do
    Maybe Disambiguator
m_disam <- IO (Maybe Disambiguator)
-> ExceptT FilePath IO (Maybe Disambiguator)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Disambiguator)
 -> ExceptT FilePath IO (Maybe Disambiguator))
-> IO (Maybe Disambiguator)
-> ExceptT FilePath IO (Maybe Disambiguator)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Disambiguator) -> IO (Maybe Disambiguator)
forall a. IORef a -> IO a
readIORef (IORef (Maybe Disambiguator) -> IO (Maybe Disambiguator))
-> IORef (Maybe Disambiguator) -> IO (Maybe Disambiguator)
forall a b. (a -> b) -> a -> b
$ BuildPlanManager -> IORef (Maybe Disambiguator)
manDisambiguator BuildPlanManager
bp_man
    case Maybe Disambiguator
m_disam of
     Just Disambiguator
d -> Disambiguator -> EIO Disambiguator
forall (m :: * -> *) a. Monad m => a -> m a
return Disambiguator
d
     Maybe Disambiguator
Nothing -> do
       Manager
http_man <- BuildPlanManager -> EIO Manager
httpManagerM BuildPlanManager
bp_man
       FilePath -> ExceptT FilePath IO ()
logDebug' FilePath
"Fetch resolver disambiguator from network..."
       Disambiguator
got_d <- IO (Either FilePath Disambiguator) -> EIO Disambiguator
forall a. IO (Either FilePath a) -> EIO a
toEIO (IO (Either FilePath Disambiguator) -> EIO Disambiguator)
-> IO (Either FilePath Disambiguator) -> EIO Disambiguator
forall a b. (a -> b) -> a -> b
$ Manager -> IO (Either FilePath Disambiguator)
fetchDisambiguator Manager
http_man
       FilePath -> ExceptT FilePath IO ()
logDebug' FilePath
"Successfully fetched resolver disambiguator."
       IO () -> ExceptT FilePath IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT FilePath IO ())
-> IO () -> ExceptT FilePath IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Disambiguator) -> Maybe Disambiguator -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (BuildPlanManager -> IORef (Maybe Disambiguator)
manDisambiguator BuildPlanManager
bp_man) (Maybe Disambiguator -> IO ()) -> Maybe Disambiguator -> IO ()
forall a b. (a -> b) -> a -> b
$ Disambiguator -> Maybe Disambiguator
forall a. a -> Maybe a
Just Disambiguator
got_d
       Disambiguator -> EIO Disambiguator
forall (m :: * -> *) a. Monad m => a -> m a
return Disambiguator
got_d
  logDebug' :: FilePath -> ExceptT FilePath IO ()
logDebug' = IO () -> ExceptT FilePath IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT FilePath IO ())
-> (FilePath -> IO ()) -> FilePath -> ExceptT FilePath IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> FilePath -> IO ()
logDebug (BuildPlanManager -> Logger
manLogger BuildPlanManager
bp_man)
  
loadBuildPlan_stackageNetwork :: BuildPlanManager -> ExactResolver -> EIO BuildPlan
loadBuildPlan_stackageNetwork :: BuildPlanManager -> ExactResolver -> EIO BuildPlan
loadBuildPlan_stackageNetwork BuildPlanManager
man ExactResolver
e_resolver = do
  CompilerCores
cores <- BuildPlanManager -> EIO CompilerCores
getCores BuildPlanManager
man
  Manager
http_man <- BuildPlanManager -> EIO Manager
httpManagerM BuildPlanManager
man
  IO () -> ExceptT FilePath IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT FilePath IO ())
-> IO () -> ExceptT FilePath IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> FilePath -> IO ()
logDebug (BuildPlanManager -> Logger
manLogger BuildPlanManager
man) (FilePath
"Fetch build plan from network: resolver = " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExactResolver -> FilePath
forall a. Show a => a -> FilePath
show ExactResolver
e_resolver)
  ByteString
yaml_data <- FilePath -> EIO ByteString -> EIO ByteString
forall a. FilePath -> EIO a -> EIO a
httpExceptionToEIO (FilePath
"Downloading build plan failed: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExactResolver -> FilePath
forall a. Show a => a -> FilePath
show ExactResolver
e_resolver)
               (EIO ByteString -> EIO ByteString)
-> EIO ByteString -> EIO ByteString
forall a b. (a -> b) -> a -> b
$ IO ByteString -> EIO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> EIO ByteString)
-> IO ByteString -> EIO ByteString
forall a b. (a -> b) -> a -> b
$ Manager -> ExactResolver -> IO ByteString
Pantry.fetchBuildPlanMapYAML Manager
http_man ExactResolver
e_resolver
  BuildPlanMap
bp_map <- Either FilePath BuildPlanMap -> ExceptT FilePath IO BuildPlanMap
forall a. Either FilePath a -> EIO a
eitherToEIO (Either FilePath BuildPlanMap -> ExceptT FilePath IO BuildPlanMap)
-> Either FilePath BuildPlanMap -> ExceptT FilePath IO BuildPlanMap
forall a b. (a -> b) -> a -> b
$ (CompilerCores -> PantryBuildPlanMap -> Either FilePath BuildPlanMap
Pantry.coresToBuildPlanMap CompilerCores
cores) (PantryBuildPlanMap -> Either FilePath BuildPlanMap)
-> Either FilePath PantryBuildPlanMap
-> Either FilePath BuildPlanMap
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ByteString -> Either FilePath PantryBuildPlanMap
Pantry.parseBuildPlanMapYAML (ByteString -> Either FilePath PantryBuildPlanMap)
-> ByteString -> Either FilePath PantryBuildPlanMap
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
yaml_data)
  BuildPlan -> EIO BuildPlan
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildPlan -> EIO BuildPlan) -> BuildPlan -> EIO BuildPlan
forall a b. (a -> b) -> a -> b
$ BuildPlan :: BuildPlanMap -> PackageSource -> BuildPlan
BuildPlan { buildPlanMap :: BuildPlanMap
buildPlanMap = BuildPlanMap
bp_map,
                       buildPlanSource :: PackageSource
buildPlanSource = FilePath -> PackageSource
SourceStackage (FilePath -> PackageSource) -> FilePath -> PackageSource
forall a b. (a -> b) -> a -> b
$ ExactResolver -> FilePath
formatExactResolverString ExactResolver
e_resolver
                     }
registeredVersionToBuildPlanMap :: PackageName -> RegisteredVersions -> BuildPlanMap
registeredVersionToBuildPlanMap :: PackageName -> RegisteredVersions -> BuildPlanMap
registeredVersionToBuildPlanMap PackageName
name RegisteredVersions
rvers = [(PackageName, Version)] -> BuildPlanMap
BPMap.fromList ([(PackageName, Version)] -> BuildPlanMap)
-> [(PackageName, Version)] -> BuildPlanMap
forall a b. (a -> b) -> a -> b
$ [(PackageName, Version)]
pairs where
  pairs :: [(PackageName, Version)]
pairs = case RegisteredVersions -> Maybe Version
latestVersion RegisteredVersions
rvers of
    Maybe Version
Nothing -> []
    Just Version
v -> [(PackageName
name, Version
v)]

_setDisambiguator :: BuildPlanManager -> Maybe Disambiguator -> IO ()
_setDisambiguator :: BuildPlanManager -> Maybe Disambiguator -> IO ()
_setDisambiguator BuildPlanManager
bp_man = IORef (Maybe Disambiguator) -> Maybe Disambiguator -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (BuildPlanManager -> IORef (Maybe Disambiguator)
manDisambiguator BuildPlanManager
bp_man)

_setLTSDisambiguator :: BuildPlanManager
                     -> Word -- ^ disambiguated LTS major version
                     -> Word -- ^ disambiguated LTS minor version
                     -> IO ()
_setLTSDisambiguator :: BuildPlanManager -> Word -> Word -> IO ()
_setLTSDisambiguator BuildPlanManager
bp_man Word
lts_major Word
lts_minor = BuildPlanManager -> Maybe Disambiguator -> IO ()
_setDisambiguator BuildPlanManager
bp_man (Maybe Disambiguator -> IO ()) -> Maybe Disambiguator -> IO ()
forall a b. (a -> b) -> a -> b
$ Disambiguator -> Maybe Disambiguator
forall a. a -> Maybe a
Just Disambiguator
disam where
  disam :: Disambiguator
disam PartialResolver
PartialLTSLatest = ExactResolver -> Maybe ExactResolver
forall a. a -> Maybe a
Just (ExactResolver -> Maybe ExactResolver)
-> ExactResolver -> Maybe ExactResolver
forall a b. (a -> b) -> a -> b
$ Word -> Word -> ExactResolver
ExactLTS Word
lts_major Word
lts_minor
  disam PartialResolver
_ = Maybe ExactResolver
forall a. Maybe a
Nothing