{-# LANGUAGE GeneralizedNewtypeDeriving, TupleSections #-}
module Staversion.Internal.BuildPlan
(
HasVersions(..),
BuildPlan,
buildPlanSource,
BuildPlanManager,
newBuildPlanManager,
manStackConfig,
loadBuildPlan,
BuildPlanMap,
loadBuildPlanMapYAML,
_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.Aeson (FromJSON(..), (.:), Value(..), Object)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
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 qualified Data.Yaml as Yaml
import System.FilePath ((</>), (<.>))
import qualified System.IO.Error as IOE
import Text.Read (readMaybe)
import Staversion.Internal.EIO
( EIO, maybeToEIO, runEIO, toEIO, loggedElse
)
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.Hackage
( RegisteredVersions, latestVersion,
fetchPreferredVersions
)
import Staversion.Internal.BuildPlan.Stackage
( Disambiguator,
fetchDisambiguator,
parseResolverString,
formatExactResolverString,
PartialResolver(..), ExactResolver(..),
fetchBuildPlanYAML
)
import Staversion.Internal.StackConfig (StackConfig)
import qualified Staversion.Internal.StackConfig as StackConfig
import Staversion.Internal.BuildPlan.Version (unVersionJSON)
import Staversion.Internal.Version (Version)
newtype BuildPlanMap = BuildPlanMap (HM.HashMap PackageName Version) deriving (Semigroup,Monoid)
instance FromJSON BuildPlanMap where
parseJSON (Object object) = (\p1 p2 -> BuildPlanMap $ p1 <> p2) <$> core_packages <*> other_packages where
core_packages = parseSysInfo =<< (object .: "system-info")
parseSysInfo (Object o) = parseCorePackages =<< (o .: "core-packages")
parseSysInfo _ = empty
parseCorePackages (Object o) = traverse (\v -> unVersionJSON <$> parseJSON v) o
parseCorePackages _ = empty
other_packages = parsePackages =<< (object .: "packages")
parsePackages (Object o) = traverse parsePackageObject o
parsePackages _ = empty
parsePackageObject (Object o) = unVersionJSON <$> (o .: "version")
parsePackageObject _ = empty
parseJSON _ = empty
data BuildPlan = BuildPlan { buildPlanMap :: BuildPlanMap,
buildPlanSource :: PackageSource
}
class HasVersions t where
packageVersion :: t -> PackageName -> Maybe Version
instance HasVersions BuildPlanMap where
packageVersion (BuildPlanMap bp_map) name = HM.lookup name bp_map
instance HasVersions BuildPlan where
packageVersion bp = packageVersion (buildPlanMap bp)
data BuildPlanManager =
BuildPlanManager { manBuildPlanDir :: FilePath,
manHttpManager :: Maybe Manager,
manDisambiguator :: IORef (Maybe Disambiguator),
manLogger :: Logger,
manStackConfig :: StackConfig
}
newBuildPlanManager :: FilePath
-> Logger
-> Bool
-> IO BuildPlanManager
newBuildPlanManager plan_dir logger enable_network = do
mman <- if enable_network
then Just <$> niceHTTPManager
else return Nothing
disam <- newIORef Nothing
return $ BuildPlanManager { manBuildPlanDir = plan_dir,
manHttpManager = mman,
manDisambiguator = disam,
manLogger = logger,
manStackConfig = StackConfig.newStackConfig logger
}
httpManagerM :: BuildPlanManager -> EIO Manager
httpManagerM = maybeToEIO "It is not allowed to access network." . manHttpManager
httpExceptionToEIO :: String -> EIO a -> EIO a
httpExceptionToEIO context action = toEIO $ (runEIO action) `catch` handler where
handler :: OurHttpException -> IO (Either ErrorMsg a)
handler e = return $ Left (context ++ ": " ++ show e)
loadBuildPlan :: BuildPlanManager
-> [PackageName]
-> PackageSource
-> IO (Either ErrorMsg BuildPlan)
loadBuildPlan man names s = runEIO $ loadBuildPlanM man names s
loadBuildPlanM :: BuildPlanManager -> [PackageName] -> PackageSource -> EIO BuildPlan
loadBuildPlanM man _ (SourceStackage resolver) = impl where
impl = loadBuildPlan_stackageLocalFile man resolver `loggedElse'` do
e_resolver <- tryDisambiguate man =<< getPresolver
loadBuildPlan_stackageLocalFile man (formatExactResolverString e_resolver) `loggedElse'` loadBuildPlan_stackageNetwork man e_resolver
getPresolver = maybeToEIO ("Invalid resolver format for stackage.org: " ++ resolver) $ parseResolverString resolver
loggedElse' = loggedElse $ manLogger man
loadBuildPlanM man names SourceHackage = impl where
impl = do
http_man <- httpManagerM man
build_plan_map <- (mconcat . zipWith registeredVersionToBuildPlanMap names) <$> mapM (doFetch http_man) names
return $ BuildPlan { buildPlanMap = build_plan_map, buildPlanSource = SourceHackage }
logDebug' msg = liftIO $ logDebug (manLogger man) msg
logWarn' msg = liftIO $ logWarn (manLogger man) msg
doFetch http_man name = do
logDebug' ("Ask hackage for the latest version of " ++ unpack name)
reg_ver <- toEIO $ fetchPreferredVersions http_man name
case latestVersion reg_ver of
Nothing -> logWarn' ("Cannot find package version of " ++ unpack name ++ ". Maybe it's not on hackage.")
Just _ -> return ()
return reg_ver
loadBuildPlanM man names (SourceStackYaml file) = loadBuildPlan_sourceStack man names $ Just file
loadBuildPlanM man names SourceStackDefault = loadBuildPlan_sourceStack man names $ Nothing
loadBuildPlan_sourceStack :: BuildPlanManager -> [PackageName] -> Maybe FilePath -> EIO BuildPlan
loadBuildPlan_sourceStack man names mfile = do
resolver <- toEIO $ StackConfig.readResolver sconf mfile
loadBuildPlanM man names $ SourceStackage resolver
where
sconf = manStackConfig man
loadBuildPlan_stackageLocalFile :: BuildPlanManager -> Resolver -> EIO BuildPlan
loadBuildPlan_stackageLocalFile man resolver = toEIO $ catchJust handleIOError doLoad (return . Left) where
yaml_file = manBuildPlanDir man </> resolver <.> "yaml"
doLoad = do
logDebug (manLogger man) ("Read " ++ yaml_file ++ " for build plan.")
e_build_plan_map <- loadBuildPlanMapYAML yaml_file
return $ makeBuildPlan <$> e_build_plan_map
makeBuildPlan bp_map = BuildPlan { buildPlanMap = bp_map, buildPlanSource = SourceStackage resolver }
handleIOError :: IOException -> Maybe ErrorMsg
handleIOError e | IOE.isDoesNotExistError e = Just $ makeErrorMsg e (yaml_file ++ " not found.")
| IOE.isPermissionError e = Just $ makeErrorMsg e ("you cannot open " ++ yaml_file ++ ".")
| otherwise = Just $ makeErrorMsg e ("some error.")
makeErrorMsg exception body = "Loading build plan for package resolver '" ++ resolver ++ "' failed: " ++ body ++ "\n" ++ show exception
tryDisambiguate :: BuildPlanManager -> PartialResolver -> EIO ExactResolver
tryDisambiguate _ (PartialExact e) = return e
tryDisambiguate bp_man presolver = impl where
impl = do
disam <- httpExceptionToEIO "Failed to download disambiguator" $ getDisambiguator
maybeToEIO ("Cannot disambiguate the resolver: " ++ show presolver) $ disam presolver
getDisambiguator = do
m_disam <- liftIO $ readIORef $ manDisambiguator bp_man
case m_disam of
Just d -> return d
Nothing -> do
http_man <- httpManagerM bp_man
logDebug' "Fetch resolver disambiguator from network..."
got_d <- toEIO $ fetchDisambiguator http_man
logDebug' "Successfully fetched resolver disambiguator."
liftIO $ writeIORef (manDisambiguator bp_man) $ Just got_d
return got_d
logDebug' = liftIO . logDebug (manLogger bp_man)
loadBuildPlan_stackageNetwork :: BuildPlanManager -> ExactResolver -> EIO BuildPlan
loadBuildPlan_stackageNetwork man e_resolver = do
http_man <- httpManagerM man
liftIO $ logDebug (manLogger man) ("Fetch build plan from network: resolver = " ++ show e_resolver)
yaml_data <- httpExceptionToEIO ("Downloading build plan failed: " ++ show e_resolver) $ liftIO $ fetchBuildPlanYAML http_man e_resolver
makeBuildPlan <$> (toEIO $ return $ parseBuildPlanMapYAML $ BSL.toStrict yaml_data)
where
makeBuildPlan bp_map = BuildPlan { buildPlanMap = bp_map,
buildPlanSource = SourceStackage $ formatExactResolverString e_resolver
}
parseBuildPlanMapYAML :: BS.ByteString -> Either ErrorMsg BuildPlanMap
parseBuildPlanMapYAML = either (Left . toErrorMsg) Right . Yaml.decodeEither' where
toErrorMsg parse_exception = "Error while parsing BuildPlanMap YAML: " ++ show parse_exception
loadBuildPlanMapYAML :: FilePath -> IO (Either ErrorMsg BuildPlanMap)
loadBuildPlanMapYAML yaml_file = parseBuildPlanMapYAML <$> BS.readFile yaml_file where
registeredVersionToBuildPlanMap :: PackageName -> RegisteredVersions -> BuildPlanMap
registeredVersionToBuildPlanMap name rvers = BuildPlanMap $ HM.fromList $ pairs where
pairs = case latestVersion rvers of
Nothing -> []
Just v -> [(name, v)]
_setDisambiguator :: BuildPlanManager -> Maybe Disambiguator -> IO ()
_setDisambiguator bp_man = writeIORef (manDisambiguator bp_man)
_setLTSDisambiguator :: BuildPlanManager
-> Word
-> Word
-> IO ()
_setLTSDisambiguator bp_man lts_major lts_minor = _setDisambiguator bp_man $ Just disam where
disam PartialLTSLatest = Just $ ExactLTS lts_major lts_minor
disam _ = Nothing