-- |
-- Module: Staversion.Internal.BuildPlan.V1
-- Description: The legacy "version 1" of build plan YAML files
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- __This is an internal module. End-users should not use it.__
--
-- @since 0.2.4.0
module Staversion.Internal.BuildPlan.V1
  ( fetchBuildPlanYAML,
    parseBuildPlanMapYAML,
    loadBuildPlanMapYAML
  ) where

import Control.Applicative (empty)
import Data.Aeson (FromJSON(..), (.:), Value(..), Object)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.HashMap.Strict as HM
import Data.Monoid ((<>))
import qualified Data.Yaml as Yaml

import Staversion.Internal.HTTP (Manager, fetchURL, OurHttpException)
import Staversion.Internal.Query (PackageName, ErrorMsg)
import Staversion.Internal.BuildPlan.BuildPlanMap (BuildPlanMap)
import qualified Staversion.Internal.BuildPlan.BuildPlanMap as BPMap
import Staversion.Internal.BuildPlan.Stackage (ExactResolver(..), PartialResolver(..), formatResolverString)
import Staversion.Internal.BuildPlan.Version (unVersionJSON)
import Staversion.Internal.Version (Version)


-- | Fetch build plan YAML data from the Internet. This function
-- fetches a build plan YAML file of "version 1" format.
fetchBuildPlanYAML :: Manager -> ExactResolver -> IO BSL.ByteString
fetchBuildPlanYAML :: Manager -> ExactResolver -> IO ByteString
fetchBuildPlanYAML Manager
man ExactResolver
resolver = Manager -> String -> IO ByteString
fetchURL Manager
man String
url where
  resolver_str :: String
resolver_str = PartialResolver -> String
formatResolverString (PartialResolver -> String) -> PartialResolver -> String
forall a b. (a -> b) -> a -> b
$ ExactResolver -> PartialResolver
PartialExact (ExactResolver -> PartialResolver)
-> ExactResolver -> PartialResolver
forall a b. (a -> b) -> a -> b
$ ExactResolver
resolver
  url :: String
url = case ExactResolver
resolver of
    ExactLTS Word
_ Word
_ -> String
"https://raw.githubusercontent.com/fpco/lts-haskell/master/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
resolver_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".yaml"
    ExactNightly Word
_ Word
_ Word
_ -> String
"https://raw.githubusercontent.com/fpco/stackage-nightly/master/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
resolver_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".yaml"

newtype V1BuildPlanMap = V1BuildPlanMap (HM.HashMap PackageName Version) deriving (Int -> V1BuildPlanMap -> String -> String
[V1BuildPlanMap] -> String -> String
V1BuildPlanMap -> String
(Int -> V1BuildPlanMap -> String -> String)
-> (V1BuildPlanMap -> String)
-> ([V1BuildPlanMap] -> String -> String)
-> Show V1BuildPlanMap
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [V1BuildPlanMap] -> String -> String
$cshowList :: [V1BuildPlanMap] -> String -> String
show :: V1BuildPlanMap -> String
$cshow :: V1BuildPlanMap -> String
showsPrec :: Int -> V1BuildPlanMap -> String -> String
$cshowsPrec :: Int -> V1BuildPlanMap -> String -> String
Show,V1BuildPlanMap -> V1BuildPlanMap -> Bool
(V1BuildPlanMap -> V1BuildPlanMap -> Bool)
-> (V1BuildPlanMap -> V1BuildPlanMap -> Bool) -> Eq V1BuildPlanMap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: V1BuildPlanMap -> V1BuildPlanMap -> Bool
$c/= :: V1BuildPlanMap -> V1BuildPlanMap -> Bool
== :: V1BuildPlanMap -> V1BuildPlanMap -> Bool
$c== :: V1BuildPlanMap -> V1BuildPlanMap -> Bool
Eq)

instance FromJSON V1BuildPlanMap where
  parseJSON :: Value -> Parser V1BuildPlanMap
parseJSON (Object Object
object) = (\HashMap PackageName Version
p1 HashMap PackageName Version
p2 -> HashMap PackageName Version -> V1BuildPlanMap
V1BuildPlanMap (HashMap PackageName Version -> V1BuildPlanMap)
-> HashMap PackageName Version -> V1BuildPlanMap
forall a b. (a -> b) -> a -> b
$ HashMap PackageName Version
p1 HashMap PackageName Version
-> HashMap PackageName Version -> HashMap PackageName Version
forall a. Semigroup a => a -> a -> a
<> HashMap PackageName Version
p2) (HashMap PackageName Version
 -> HashMap PackageName Version -> V1BuildPlanMap)
-> Parser (HashMap PackageName Version)
-> Parser (HashMap PackageName Version -> V1BuildPlanMap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (HashMap PackageName Version)
core_packages Parser (HashMap PackageName Version -> V1BuildPlanMap)
-> Parser (HashMap PackageName Version) -> Parser V1BuildPlanMap
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (HashMap PackageName Version)
other_packages where
    core_packages :: Parser (HashMap PackageName Version)
core_packages = Value -> Parser (HashMap PackageName Version)
parseSysInfo (Value -> Parser (HashMap PackageName Version))
-> Parser Value -> Parser (HashMap PackageName Version)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Object
object Object -> PackageName -> Parser Value
forall a. FromJSON a => Object -> PackageName -> Parser a
.: PackageName
"system-info")
    parseSysInfo :: Value -> Parser (HashMap PackageName Version)
parseSysInfo (Object Object
o) = Value -> Parser (HashMap PackageName Version)
parseCorePackages (Value -> Parser (HashMap PackageName Version))
-> Parser Value -> Parser (HashMap PackageName Version)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Object
o Object -> PackageName -> Parser Value
forall a. FromJSON a => Object -> PackageName -> Parser a
.: PackageName
"core-packages")
    parseSysInfo Value
_ = Parser (HashMap PackageName Version)
forall (f :: * -> *) a. Alternative f => f a
empty
    parseCorePackages :: Value -> Parser (HashMap PackageName Version)
parseCorePackages (Object Object
o) = (Value -> Parser Version)
-> Object -> Parser (HashMap PackageName Version)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Value
v -> VersionJSON -> Version
unVersionJSON (VersionJSON -> Version) -> Parser VersionJSON -> Parser Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser VersionJSON
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v) Object
o
    parseCorePackages Value
_ = Parser (HashMap PackageName Version)
forall (f :: * -> *) a. Alternative f => f a
empty

    other_packages :: Parser (HashMap PackageName Version)
other_packages = Value -> Parser (HashMap PackageName Version)
parsePackages (Value -> Parser (HashMap PackageName Version))
-> Parser Value -> Parser (HashMap PackageName Version)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Object
object Object -> PackageName -> Parser Value
forall a. FromJSON a => Object -> PackageName -> Parser a
.: PackageName
"packages")
    parsePackages :: Value -> Parser (HashMap PackageName Version)
parsePackages (Object Object
o) = (Value -> Parser Version)
-> Object -> Parser (HashMap PackageName Version)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Parser Version
parsePackageObject Object
o
    parsePackages Value
_ = Parser (HashMap PackageName Version)
forall (f :: * -> *) a. Alternative f => f a
empty
    parsePackageObject :: Value -> Parser Version
parsePackageObject (Object Object
o) = VersionJSON -> Version
unVersionJSON (VersionJSON -> Version) -> Parser VersionJSON -> Parser Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> PackageName -> Parser VersionJSON
forall a. FromJSON a => Object -> PackageName -> Parser a
.: PackageName
"version")
    parsePackageObject Value
_ = Parser Version
forall (f :: * -> *) a. Alternative f => f a
empty
  parseJSON Value
_ = Parser V1BuildPlanMap
forall (f :: * -> *) a. Alternative f => f a
empty

toBuildPlanMap :: V1BuildPlanMap -> BuildPlanMap
toBuildPlanMap :: V1BuildPlanMap -> BuildPlanMap
toBuildPlanMap (V1BuildPlanMap HashMap PackageName Version
m) = HashMap PackageName Version -> BuildPlanMap
BPMap.fromMap HashMap PackageName Version
m

-- | Parse "version 1" format of build plan YAML file.
parseBuildPlanMapYAML :: BS.ByteString -> Either ErrorMsg BuildPlanMap
parseBuildPlanMapYAML :: ByteString -> Either String BuildPlanMap
parseBuildPlanMapYAML = (ParseException -> Either String BuildPlanMap)
-> (V1BuildPlanMap -> Either String BuildPlanMap)
-> Either ParseException V1BuildPlanMap
-> Either String BuildPlanMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String BuildPlanMap
forall a b. a -> Either a b
Left (String -> Either String BuildPlanMap)
-> (ParseException -> String)
-> ParseException
-> Either String BuildPlanMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseException -> String
forall a. Show a => a -> String
toErrorMsg) (BuildPlanMap -> Either String BuildPlanMap
forall a b. b -> Either a b
Right (BuildPlanMap -> Either String BuildPlanMap)
-> (V1BuildPlanMap -> BuildPlanMap)
-> V1BuildPlanMap
-> Either String BuildPlanMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V1BuildPlanMap -> BuildPlanMap
toBuildPlanMap)  (Either ParseException V1BuildPlanMap
 -> Either String BuildPlanMap)
-> (ByteString -> Either ParseException V1BuildPlanMap)
-> ByteString
-> Either String BuildPlanMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ParseException V1BuildPlanMap
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' where
  toErrorMsg :: a -> String
toErrorMsg a
parse_exception = String
"Error while parsing BuildPlanMap YAML: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
parse_exception

-- | Load a 'BuildPlanMap' from a file.
loadBuildPlanMapYAML :: FilePath -> IO (Either ErrorMsg BuildPlanMap)
loadBuildPlanMapYAML :: String -> IO (Either String BuildPlanMap)
loadBuildPlanMapYAML String
yaml_file = ByteString -> Either String BuildPlanMap
parseBuildPlanMapYAML (ByteString -> Either String BuildPlanMap)
-> IO ByteString -> IO (Either String BuildPlanMap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
yaml_file where -- TODO: make it memory-efficient!