module Staversion.Internal.BuildPlan.Pantry
( PantryBuildPlanMap,
PantryName,
pantryCompiler,
pantryName,
toBuildPlanMap,
coresToBuildPlanMap,
parseBuildPlanMapYAML,
fetchBuildPlanMapYAML
) where
import Control.Applicative ((<$>), (<*>), empty, (<|>))
import Control.Monad (void)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Aeson (FromJSON(..), Value(..), (.:), (.:!))
import qualified Data.Aeson.Types as Aeson
import qualified Data.HashMap.Strict as HM
import Data.Monoid ((<>))
import Data.Text (pack, Text)
import qualified Data.Yaml as Yaml
import Staversion.Internal.BuildPlan.BuildPlanMap
( BuildPlanMap,
HasVersions(..),
)
import qualified Staversion.Internal.BuildPlan.BuildPlanMap as BuildPlanMap
import Staversion.Internal.BuildPlan.Core
( Compiler(..),
CoreBuildPlanMap(..),
CompilerVersion(..),
CompilerCores
)
import Staversion.Internal.BuildPlan.Parser (parserVersion, manyTillWithEnd)
import Staversion.Internal.BuildPlan.Stackage (ExactResolver(..))
import qualified Staversion.Internal.Megaparsec as P
import Staversion.Internal.HTTP (Manager, fetchURL)
import Staversion.Internal.Query (ErrorMsg, PackageName)
import Staversion.Internal.Version (Version)
type PantryName = Text
data PantryBuildPlanMap =
PantryBuildPlanMap
{ pantryName :: Maybe PantryName,
pantryCompiler :: Compiler,
pantryMap :: BuildPlanMap
}
instance HasVersions PantryBuildPlanMap where
packageVersion pbp = packageVersion (pantryMap pbp)
instance FromJSON PantryBuildPlanMap where
parseJSON (Object o) =
PantryBuildPlanMap
<$> (o .:! "name")
<*> fmap unPantryCompiler parserCompiler
<*> fmap fromPantryPackageList (o .: "packages")
where
parserCompiler = (o .: "compiler") <|> parserResolverCompiler
parserResolverCompiler = do
res <- o .: "resolver"
res .: "compiler"
parseJSON _ = empty
newtype PantryPackage = PantryPackage { unPantryPackage :: (PackageName, Version) }
deriving (Show,Eq,Ord)
fromPantryPackageList :: [PantryPackage] -> BuildPlanMap
fromPantryPackageList = BuildPlanMap.fromList . map unPantryPackage
instance FromJSON PantryPackage where
parseJSON (Object o) = fmap PantryPackage $ parsePText =<< (o .: "hackage")
where
parsePText :: Text -> Aeson.Parser (PackageName, Version)
parsePText t = either (fail . show) return $ P.runParser the_parser "" t
the_parser = parserPackage (void $ P.char '@')
parseJSON _ = empty
newtype PantryCompiler = PantryCompiler { unPantryCompiler :: Compiler }
deriving (Show,Eq,Ord)
instance FromJSON PantryCompiler where
parseJSON (String s) = fmap toCompiler $ either (fail . show) return $ P.runParser the_parser "" s
where
the_parser = parserPackage (P.eof)
toCompiler (name, ver) = PantryCompiler $ Compiler name $ CVNumbered ver
parseJSON _ = empty
toBuildPlanMap :: CoreBuildPlanMap -> PantryBuildPlanMap -> Either String BuildPlanMap
toBuildPlanMap cbp pbp =
if ccv == pcv
then Right $ pantryMap pbp <> coreMap cbp
else Left ("Unmatched compiler versions: Core: " <> show ccv <> ", Pantry: " <> show pcv)
where
ccv = coreCompiler cbp
pcv = pantryCompiler pbp
coresToBuildPlanMap :: CompilerCores -> PantryBuildPlanMap -> Either String BuildPlanMap
coresToBuildPlanMap cmap pbp = do
cbp <- maybe (Left ("No CoreBuildPlanMap for compiler " ++ show compiler)) Right $ HM.lookup compiler cmap
toBuildPlanMap cbp pbp
where
compiler = pantryCompiler pbp
parseBuildPlanMapYAML :: BS.ByteString -> Either ErrorMsg PantryBuildPlanMap
parseBuildPlanMapYAML = either (Left . toErrorMsg) Right . Yaml.decodeEither'
where
toErrorMsg e = "Error while parsing PantryBuildPlanMap: " ++ show e
fetchBuildPlanMapYAML :: Manager -> ExactResolver -> IO BSL.ByteString
fetchBuildPlanMapYAML man er = fetchURL man url
where
url = "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/" <> resolver_part
resolver_part =
case er of
ExactLTS major minor -> "lts/" ++ show major ++ "/" ++ show minor ++ ".yaml"
ExactNightly year month day -> "nightly/" ++ show year ++ "/" ++ show month ++ "/" ++ show day ++ ".yaml"
parserPackage :: P.Parser ()
-> P.Parser (PackageName, Version)
parserPackage end = do
(pstr, ver) <- manyTillWithEnd P.anyChar versionAndEnd
return (pack pstr, ver)
where
versionAndEnd = do
void $ P.char '-'
v <- parserVersion
end
return v