-- |
-- 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 -> [Char]
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 :: [Char] -> Logger -> Bool -> IO BuildPlanManager
newBuildPlanManager [Char]
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildPlanManager -> IO BuildPlanManager)
-> BuildPlanManager -> IO BuildPlanManager
forall a b. (a -> b) -> a -> b
$ BuildPlanManager { manBuildPlanDir :: [Char]
manBuildPlanDir = [Char]
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 = [Char] -> Maybe Manager -> EIO Manager
forall a. [Char] -> Maybe a -> EIO a
maybeToEIO [Char]
"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 :: forall a. [Char] -> EIO a -> EIO a
httpExceptionToEIO [Char]
context EIO a
action = IO (Either [Char] a) -> EIO a
forall a. IO (Either [Char] a) -> EIO a
toEIO (IO (Either [Char] a) -> EIO a) -> IO (Either [Char] a) -> EIO a
forall a b. (a -> b) -> a -> b
$ (EIO a -> IO (Either [Char] a)
forall a. EIO a -> IO (Either [Char] a)
runEIO EIO a
action) IO (Either [Char] a)
-> (OurHttpException -> IO (Either [Char] a))
-> IO (Either [Char] a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` OurHttpException -> IO (Either [Char] a)
forall a. OurHttpException -> IO (Either [Char] a)
handler where
  handler :: OurHttpException -> IO (Either ErrorMsg a)
  handler :: forall a. OurHttpException -> IO (Either [Char] a)
handler OurHttpException
e = Either [Char] a -> IO (Either [Char] a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] a -> IO (Either [Char] a))
-> Either [Char] a -> IO (Either [Char] a)
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] a
forall a b. a -> Either a b
Left ([Char]
context [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ OurHttpException -> [Char]
forall a. Show a => a -> [Char]
show OurHttpException
e)

getCores :: BuildPlanManager -> EIO CompilerCores
getCores :: BuildPlanManager -> EIO CompilerCores
getCores BuildPlanManager
man = do
  Maybe CompilerCores
mcores <- IO (Maybe CompilerCores) -> ExceptT [Char] IO (Maybe CompilerCores)
forall a. IO a -> ExceptT [Char] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CompilerCores)
 -> ExceptT [Char] IO (Maybe CompilerCores))
-> IO (Maybe CompilerCores)
-> ExceptT [Char] 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 a. a -> ExceptT [Char] IO a
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 [Char] IO ()
forall a. IO a -> ExceptT [Char] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT [Char] IO ()) -> IO () -> ExceptT [Char] IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> [Char] -> IO ()
logDebug (BuildPlanManager -> Logger
manLogger BuildPlanManager
man) [Char]
"fetching GHC pkg_versions"
      CompilerCores
cores <- [Char] -> EIO CompilerCores -> EIO CompilerCores
forall a. [Char] -> EIO a -> EIO a
httpExceptionToEIO [Char]
"Failed to fetch GHC pkg_versions"
               (EIO CompilerCores -> EIO CompilerCores)
-> EIO CompilerCores -> EIO CompilerCores
forall a b. (a -> b) -> a -> b
$ IO (Either [Char] CompilerCores) -> EIO CompilerCores
forall a. IO (Either [Char] a) -> EIO a
toEIO (IO (Either [Char] CompilerCores) -> EIO CompilerCores)
-> IO (Either [Char] CompilerCores) -> EIO CompilerCores
forall a b. (a -> b) -> a -> b
$ (ByteString -> Either [Char] CompilerCores)
-> IO ByteString -> IO (Either [Char] CompilerCores)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either [Char] CompilerCores
Core.parseGHCPkgVersions (IO ByteString -> IO (Either [Char] CompilerCores))
-> IO ByteString -> IO (Either [Char] CompilerCores)
forall a b. (a -> b) -> a -> b
$ Manager -> IO ByteString
Core.fetchGHCPkgVersions Manager
http
      IO () -> ExceptT [Char] IO ()
forall a. IO a -> ExceptT [Char] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT [Char] IO ()) -> IO () -> ExceptT [Char] 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 a. a -> ExceptT [Char] IO a
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 [Char] BuildPlan)
loadBuildPlan BuildPlanManager
man [PackageName]
names PackageSource
s = EIO BuildPlan -> IO (Either [Char] BuildPlan)
forall a. EIO a -> IO (Either [Char] a)
runEIO (EIO BuildPlan -> IO (Either [Char] BuildPlan))
-> EIO BuildPlan -> IO (Either [Char] 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 [Char]
resolver) = EIO BuildPlan
impl where
  impl :: EIO BuildPlan
impl = BuildPlanManager -> [Char] -> EIO BuildPlan
loadBuildPlan_stackageLocalFile BuildPlanManager
man [Char]
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 [Char] IO PartialResolver -> EIO ExactResolver
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT [Char] IO PartialResolver
getPresolver
    BuildPlanManager -> [Char] -> EIO BuildPlan
loadBuildPlan_stackageLocalFile BuildPlanManager
man (ExactResolver -> [Char]
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 [Char] IO PartialResolver
getPresolver = [Char]
-> Maybe PartialResolver -> ExceptT [Char] IO PartialResolver
forall a. [Char] -> Maybe a -> EIO a
maybeToEIO ([Char]
"Invalid resolver format for stackage.org: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
resolver) (Maybe PartialResolver -> ExceptT [Char] IO PartialResolver)
-> Maybe PartialResolver -> ExceptT [Char] IO PartialResolver
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe PartialResolver
parseResolverString [Char]
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 [Char] IO [RegisteredVersions]
-> ExceptT [Char] IO BuildPlanMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PackageName -> ExceptT [Char] IO RegisteredVersions)
-> [PackageName] -> ExceptT [Char] IO [RegisteredVersions]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Manager -> PackageName -> ExceptT [Char] IO RegisteredVersions
doFetch Manager
http_man) [PackageName]
names
    BuildPlan -> EIO BuildPlan
forall a. a -> ExceptT [Char] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildPlan -> EIO BuildPlan) -> BuildPlan -> EIO BuildPlan
forall a b. (a -> b) -> a -> b
$ BuildPlan { buildPlanMap :: BuildPlanMap
buildPlanMap = BuildPlanMap
build_plan_map, buildPlanSource :: PackageSource
buildPlanSource = PackageSource
SourceHackage }
  logDebug' :: [Char] -> m ()
logDebug' [Char]
msg = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> [Char] -> IO ()
logDebug (BuildPlanManager -> Logger
manLogger BuildPlanManager
man) [Char]
msg
  logWarn' :: [Char] -> m ()
logWarn' [Char]
msg = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> [Char] -> IO ()
logWarn (BuildPlanManager -> Logger
manLogger BuildPlanManager
man) [Char]
msg
  doFetch :: Manager -> PackageName -> ExceptT [Char] IO RegisteredVersions
doFetch Manager
http_man PackageName
name = do
    [Char] -> ExceptT [Char] IO ()
forall {m :: * -> *}. MonadIO m => [Char] -> m ()
logDebug' ([Char]
"Ask hackage for the latest version of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PackageName -> [Char]
unpack PackageName
name)
    RegisteredVersions
reg_ver <- IO (Either [Char] RegisteredVersions)
-> ExceptT [Char] IO RegisteredVersions
forall a. IO (Either [Char] a) -> EIO a
toEIO (IO (Either [Char] RegisteredVersions)
 -> ExceptT [Char] IO RegisteredVersions)
-> IO (Either [Char] RegisteredVersions)
-> ExceptT [Char] IO RegisteredVersions
forall a b. (a -> b) -> a -> b
$ Manager -> PackageName -> IO (Either [Char] RegisteredVersions)
fetchPreferredVersions Manager
http_man PackageName
name
    case RegisteredVersions -> Maybe Version
latestVersion RegisteredVersions
reg_ver of
     Maybe Version
Nothing -> [Char] -> ExceptT [Char] IO ()
forall {m :: * -> *}. MonadIO m => [Char] -> m ()
logWarn' ([Char]
"Cannot find package version of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PackageName -> [Char]
unpack PackageName
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
". Maybe it's not on hackage.")
     Just Version
_ -> () -> ExceptT [Char] IO ()
forall a. a -> ExceptT [Char] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    RegisteredVersions -> ExceptT [Char] IO RegisteredVersions
forall a. a -> ExceptT [Char] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RegisteredVersions
reg_ver
loadBuildPlanM BuildPlanManager
man [PackageName]
names (SourceStackYaml [Char]
file) = BuildPlanManager -> [PackageName] -> Maybe [Char] -> EIO BuildPlan
loadBuildPlan_sourceStack BuildPlanManager
man [PackageName]
names (Maybe [Char] -> EIO BuildPlan) -> Maybe [Char] -> EIO BuildPlan
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
file
loadBuildPlanM BuildPlanManager
man [PackageName]
names PackageSource
SourceStackDefault = BuildPlanManager -> [PackageName] -> Maybe [Char] -> EIO BuildPlan
loadBuildPlan_sourceStack BuildPlanManager
man [PackageName]
names (Maybe [Char] -> EIO BuildPlan) -> Maybe [Char] -> EIO BuildPlan
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
forall a. Maybe a
Nothing

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

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

tryDisambiguate :: BuildPlanManager -> PartialResolver -> EIO ExactResolver
tryDisambiguate :: BuildPlanManager -> PartialResolver -> EIO ExactResolver
tryDisambiguate BuildPlanManager
_ (PartialExact ExactResolver
e) = ExactResolver -> EIO ExactResolver
forall a. a -> ExceptT [Char] IO a
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 <- [Char] -> EIO Disambiguator -> EIO Disambiguator
forall a. [Char] -> EIO a -> EIO a
httpExceptionToEIO [Char]
"Failed to download disambiguator" (EIO Disambiguator -> EIO Disambiguator)
-> EIO Disambiguator -> EIO Disambiguator
forall a b. (a -> b) -> a -> b
$ EIO Disambiguator
getDisambiguator
    [Char] -> Maybe ExactResolver -> EIO ExactResolver
forall a. [Char] -> Maybe a -> EIO a
maybeToEIO ([Char]
"Cannot disambiguate the resolver: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PartialResolver -> [Char]
forall a. Show a => a -> [Char]
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 [Char] IO (Maybe Disambiguator)
forall a. IO a -> ExceptT [Char] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Disambiguator)
 -> ExceptT [Char] IO (Maybe Disambiguator))
-> IO (Maybe Disambiguator)
-> ExceptT [Char] 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 a. a -> ExceptT [Char] IO a
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
       [Char] -> ExceptT [Char] IO ()
logDebug' [Char]
"Fetch resolver disambiguator from network..."
       Disambiguator
got_d <- IO (Either [Char] Disambiguator) -> EIO Disambiguator
forall a. IO (Either [Char] a) -> EIO a
toEIO (IO (Either [Char] Disambiguator) -> EIO Disambiguator)
-> IO (Either [Char] Disambiguator) -> EIO Disambiguator
forall a b. (a -> b) -> a -> b
$ Manager -> IO (Either [Char] Disambiguator)
fetchDisambiguator Manager
http_man
       [Char] -> ExceptT [Char] IO ()
logDebug' [Char]
"Successfully fetched resolver disambiguator."
       IO () -> ExceptT [Char] IO ()
forall a. IO a -> ExceptT [Char] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT [Char] IO ()) -> IO () -> ExceptT [Char] 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 a. a -> ExceptT [Char] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Disambiguator
got_d
  logDebug' :: [Char] -> ExceptT [Char] IO ()
logDebug' = IO () -> ExceptT [Char] IO ()
forall a. IO a -> ExceptT [Char] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT [Char] IO ())
-> ([Char] -> IO ()) -> [Char] -> ExceptT [Char] IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> [Char] -> 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 [Char] IO ()
forall a. IO a -> ExceptT [Char] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT [Char] IO ()) -> IO () -> ExceptT [Char] IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> [Char] -> IO ()
logDebug (BuildPlanManager -> Logger
manLogger BuildPlanManager
man) ([Char]
"Fetch build plan from network: resolver = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ExactResolver -> [Char]
forall a. Show a => a -> [Char]
show ExactResolver
e_resolver)
  ByteString
yaml_data <- [Char] -> EIO ByteString -> EIO ByteString
forall a. [Char] -> EIO a -> EIO a
httpExceptionToEIO ([Char]
"Downloading build plan failed: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ExactResolver -> [Char]
forall a. Show a => a -> [Char]
show ExactResolver
e_resolver)
               (EIO ByteString -> EIO ByteString)
-> EIO ByteString -> EIO ByteString
forall a b. (a -> b) -> a -> b
$ IO ByteString -> EIO ByteString
forall a. IO a -> ExceptT [Char] IO a
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 [Char] BuildPlanMap -> ExceptT [Char] IO BuildPlanMap
forall a. Either [Char] a -> EIO a
eitherToEIO (Either [Char] BuildPlanMap -> ExceptT [Char] IO BuildPlanMap)
-> Either [Char] BuildPlanMap -> ExceptT [Char] IO BuildPlanMap
forall a b. (a -> b) -> a -> b
$ (CompilerCores -> PantryBuildPlanMap -> Either [Char] BuildPlanMap
Pantry.coresToBuildPlanMap CompilerCores
cores) (PantryBuildPlanMap -> Either [Char] BuildPlanMap)
-> Either [Char] PantryBuildPlanMap -> Either [Char] BuildPlanMap
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ByteString -> Either [Char] PantryBuildPlanMap
Pantry.parseBuildPlanMapYAML (ByteString -> Either [Char] PantryBuildPlanMap)
-> ByteString -> Either [Char] PantryBuildPlanMap
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
yaml_data)
  BuildPlan -> EIO BuildPlan
forall a. a -> ExceptT [Char] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildPlan -> EIO BuildPlan) -> BuildPlan -> EIO BuildPlan
forall a b. (a -> b) -> a -> b
$ BuildPlan { buildPlanMap :: BuildPlanMap
buildPlanMap = BuildPlanMap
bp_map,
                       buildPlanSource :: PackageSource
buildPlanSource = [Char] -> PackageSource
SourceStackage ([Char] -> PackageSource) -> [Char] -> PackageSource
forall a b. (a -> b) -> a -> b
$ ExactResolver -> [Char]
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