content: {-# LANGUAGE DeriveAnyClass #-}
  {-# LANGUAGE OverloadedStrings #-}
  module Pier.Build.Stackage
      ( buildPlanRules
      , askBuildPlan
      , askInstalledGhc
      , installGhcRules
      , InstalledGhc(..)
      , GhcDistro(..)
      , ghcProg
      , ghcPkgProg
      , hsc2hsProg
      , parseGlobalPackagePath
      , PlanName(..)
      , BuildPlan(..)
      , PlanPackage(..)
      , Flags
      ) where
  
  import Control.Exception (throw)
  import Data.Binary.Orphans ()
  import Data.Monoid ((<>))
  import Data.Text (Text)
  import Data.Yaml
  import Development.Shake
  import Development.Shake.Classes
  import Development.Shake.FilePath
  import Distribution.Package
  import Distribution.PackageDescription (FlagName)
  import Distribution.System (buildPlatform, Platform(..), Arch(..), OS(..))
  import Distribution.Version
  import GHC.Generics
  
  import qualified Data.HashMap.Strict as HM
  import qualified Data.List as List
  import qualified Data.Set as Set
  import qualified Data.Text as T
  import qualified Distribution.Text as Cabal
  
  import Pier.Core.Artifact
  import Pier.Core.Download
  import Pier.Core.Persistent
  import Pier.Orphans ()
  
  newtype PlanName = PlanName { renderPlanName :: String }
      deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic)
  
  instance FromJSON PlanName where
      parseJSON = fmap PlanName . parseJSON
  
  data BuildPlan = BuildPlan
      { corePackageVersions :: HM.HashMap PackageName Version
      , planPackages :: HM.HashMap PackageName PlanPackage
      , ghcVersion :: Version
      } deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic)
  
  data PlanPackage = PlanPackage
      { planPackageVersion :: Version
      , planPackageFlags :: Flags
      } deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic)
  
  type Flags = HM.HashMap FlagName Bool
  
  instance FromJSON BuildPlan where
      parseJSON = withObject "Plan" $ \o -> do
          sys <- o .: "system-info"
          coreVersions <- sys .: "core-packages"
          ghcVers <- sys .: "ghc-version"
          pkgs <- o .: "packages"
          return BuildPlan { corePackageVersions = coreVersions
                           , planPackages = pkgs
                           , ghcVersion = ghcVers
          }
  
  instance FromJSON PlanPackage where
      parseJSON = withObject "PlanPackage" $ \o ->
          PlanPackage <$> (o .: "version") <*> ((o .: "constraints") >>= (.: "flags"))
  
  buildPlanRules :: Rules ()
  buildPlanRules = addPersistent $ \(ReadPlan planName) -> do
          f <- askDownload Download
                  { downloadName = renderPlanName planName <.> "yaml"
                  , downloadUrlPrefix = planUrlPrefix planName
                  }
          cs <- readArtifactB f
          case decodeEither' cs of
              Left err -> throw err
              Right x -> return x
  
  planUrlPrefix :: PlanName -> String
  planUrlPrefix (PlanName name)
      | "lts-" `List.isPrefixOf` name = ltsBuildPlansUrl
      | "nightly-" `List.isPrefixOf` name = nightlyBuildPlansUrl
      | otherwise = error $ "Unrecognized plan name " ++ show name
    where
      ltsBuildPlansUrl = "https://raw.githubusercontent.com/fpco/lts-haskell/master/"
      nightlyBuildPlansUrl = "https://raw.githubusercontent.com/fpco/stackage-nightly/master/"
  
  newtype ReadPlan = ReadPlan PlanName
      deriving (Typeable,Eq,Hashable,Binary,NFData,Generic)
  type instance RuleResult ReadPlan = BuildPlan
  
  instance Show ReadPlan where
      show (ReadPlan p) = "Read build plan: " ++ renderPlanName p
  
  askBuildPlan :: PlanName -> Action BuildPlan
  askBuildPlan = askPersistent . ReadPlan
  
  
  data InstalledGhcQ = InstalledGhcQ GhcDistro Version [PackageName]
      deriving (Typeable, Eq, Hashable, Binary, NFData, Generic)
  
  data GhcDistro
      = SystemGhc
      | StackageGhc
      deriving (Show, Typeable, Eq, Hashable, Binary, NFData, Generic)
  
  instance Show InstalledGhcQ where
      show (InstalledGhcQ d v pn) = "GHC"
                              ++ " " ++ show d
                              ++ ", version " ++ Cabal.display v
                              ++ ", built-in packages "
                              ++ List.intercalate ", " (map Cabal.display pn)
  
  -- | TODO: make the below functions that use Version take InstalledGhc directly instead
  data InstalledGhc = InstalledGhc
      { ghcLibRoot :: Artifact
      , ghcInstalledVersion :: Version
      } deriving (Show, Typeable, Eq, Generic)
  instance Hashable InstalledGhc
  instance Binary InstalledGhc
  instance NFData InstalledGhc
  
  type instance RuleResult InstalledGhcQ = InstalledGhc
  
  globalPackageDb :: InstalledGhc -> Artifact
  globalPackageDb ghc = ghcLibRoot ghc /> packageConfD
  
  packageConfD :: String
  packageConfD = "package.conf.d"
  
  askInstalledGhc :: BuildPlan -> GhcDistro -> Action InstalledGhc
  askInstalledGhc plan distro
      = askPersistent $ InstalledGhcQ distro (ghcVersion plan)
                      $ HM.keys $ corePackageVersions plan
  
  -- | Convert @${pkgroot}@ prefixes, for utilities like hsc2hs that don't
  -- see packages directly
  --
  parseGlobalPackagePath :: InstalledGhc -> FilePath -> Artifact
  parseGlobalPackagePath ghc f
      | Just f' <- List.stripPrefix "${pkgroot}/" f
          = ghcLibRoot ghc /> f'
      | otherwise = external f
  
  ghcBinDir :: InstalledGhc -> Artifact
  ghcBinDir ghc = ghcLibRoot ghc /> "bin"
  
  ghcProg :: InstalledGhc -> [String] -> Command
  ghcProg ghc args =
      progA (ghcBinDir ghc /> "ghc")
          (["-B" ++ pathIn (ghcLibRoot ghc)
           , "-clear-package-db"
           , "-hide-all-packages"
           , "-package-db=" ++ pathIn (globalPackageDb ghc)
           ] ++ args)
          <> input (ghcLibRoot ghc)
          <> input (globalPackageDb ghc)
  
  ghcPkgProg :: InstalledGhc -> [String] -> Command
  ghcPkgProg ghc args =
      progA (ghcBinDir ghc /> "ghc-pkg")
          ([ "--global-package-db=" ++ pathIn (globalPackageDb ghc)
           , "--no-user-package-db"
           , "--no-user-package-conf"
           ] ++ args)
          <> input (ghcLibRoot ghc)
          <> input (globalPackageDb ghc)
  
  hsc2hsProg :: InstalledGhc -> [String] -> Command
  hsc2hsProg ghc args =
      progA (ghcBinDir ghc /> "hsc2hs")
          (("--template=${TMPDIR}/" ++ pathIn template) : args)
      <> input template
    where
      template = ghcLibRoot ghc /> "template-hsc.h"
  
  installGhcRules :: Rules ()
  installGhcRules = addPersistent installGhc
  
  installGhc :: InstalledGhcQ -> Action InstalledGhc
  installGhc (InstalledGhcQ distro version corePkgs) = do
      installed <- case distro of
                      StackageGhc -> downloadAndInstallGHC version
                      SystemGhc -> getSystemGhc version
      fixed <- makeRelativeGlobalDb corePkgs installed
      runCommand_ $ ghcPkgProg fixed ["check"]
      return fixed
  
  getSystemGhc :: Version -> Action InstalledGhc
  getSystemGhc version = do
      path <- fmap (head . words) . runCommandStdout
                  $ prog (versionedGhc version) ["--print-libdir"]
      return $ InstalledGhc (external path) version
  
  data DownloadInfo = DownloadInfo
      { downloadUrl :: String
      -- TODO: use these
      , _contentLength :: Int
      , _sha1 :: String
      }
  
  instance FromJSON DownloadInfo where
      parseJSON = withObject "DownloadInfo" $ \o ->
          DownloadInfo <$> o .: "url"
                       <*> o .: "content-length"
                       <*> o .: "sha1"
  
  -- TODO: multiple OSes, configure-env
  
  newtype StackSetup = StackSetup { ghcVersions :: HM.HashMap Version DownloadInfo }
  
  instance FromJSON StackSetup where
      parseJSON = withObject "StackSetup" $ \o -> do
          ghc <- o .: "ghc"
          StackSetup <$> (ghc .: platformKey)
  
  -- TODO: make this more configurable (eventually, using
  -- `LocalBuildInfo.hostPlatform` to help support cross-compilation)
  platformKey :: Text
  platformKey = case buildPlatform of
      Platform I386   Linux   -> "linux32"
      Platform X86_64 Linux   -> "linux64"
      Platform I386   OSX     -> "macosx"
      Platform X86_64 OSX     -> "macosx"
      Platform I386   FreeBSD -> "freebsd32"
      Platform X86_64 FreeBSD -> "freebsd64"
      Platform I386   OpenBSD -> "openbsd32"
      Platform X86_64 OpenBSD -> "openbsd64"
      Platform I386   Windows -> "windows32"
      Platform X86_64 Windows -> "windows64"
      Platform Arm    Linux   -> "linux-armv7"
      _ -> error $ "Unrecognized platform: " ++ Cabal.display buildPlatform
  
  setupUrl :: String
  setupUrl = "https://raw.githubusercontent.com/fpco/stackage-content/master/stack"
  
  downloadAndInstallGHC
      :: Version -> Action InstalledGhc
  downloadAndInstallGHC version = do
      setupYaml <- askDownload Download
                      { downloadName = "stack-setup-2.yaml"
                      , downloadUrlPrefix = setupUrl
                      }
      -- TODO: don't re-parse the yaml for every GHC version
      cs <- readArtifactB setupYaml
      download <- case decodeEither' cs of
          Left err -> throw err
          Right x
              | Just download <- HM.lookup version (ghcVersions x)
                  -> pure download
              | otherwise -> fail $ "Couldn't find GHC version" ++ Cabal.display version
      -- TODO: reenable this once we've fixed the issue with nondetermistic
      -- temp file locations.
      -- rerunIfCleaned
      let (url, f) = splitFileName $ downloadUrl download
      tar <- askDownload Download
              { downloadName = f
              , downloadUrlPrefix = url
              }
      -- TODO: check file size and sha1
      -- GHC's configure step requires an absolute prefix.
      -- We'll install it explicitly in ${TMPDIR}, but that puts explicit references
      -- to those paths in the package DB.  So we'll then generate a new DB with
      -- relative paths.
      let installDir = "ghc-install"
      let unpackedDir = versionedGhc version
      installed <- runCommand
         (output installDir)
         $ message "Unpacking GHC"
            <> input tar
            <> prog "tar" ["-xJf", pathIn tar]
            <> withCwd unpackedDir
                  (message "Installing GHC locally"
                  <> progTemp (unpackedDir </> "configure")
                          ["--prefix=${TMPDIR}/" ++ installDir]
                  <> prog "make" ["install"])
      return InstalledGhc { ghcLibRoot = installed /> "lib" </> versionedGhc version
                          , ghcInstalledVersion = version
                          }
  
  versionedGhc :: Version -> String
  versionedGhc version = "ghc-" ++ Cabal.display version
  
  makeRelativeGlobalDb :: [PackageName] -> InstalledGhc -> Action InstalledGhc
  makeRelativeGlobalDb corePkgs ghc = do
      let corePkgsSet = Set.fromList corePkgs
      -- List all packages, excluding Cabal which stack doesn't consider a "core"
      -- package.
      -- TODO: if our package ids included a hash, this wouldn't be as big a problem
      -- because two versions of the same package could exist simultaneously.
      builtinPackages <- fmap (filter ((`Set.member` corePkgsSet) . mkPackageName)
                                  . words)
                          . runCommandStdout
                          $ ghcPkgProg ghc
                              ["list", "--global", "--names-only",
                               "--simple-output" ]
      let makePkgConf pkg = do
              desc <- runCommandStdout
                          $ ghcPkgProg ghc ["describe", pkg]
              let tempRoot = parsePkgRoot desc
              let desc' =
                      T.unpack
                      . T.replace (T.pack tempRoot)
                          (T.pack "${pkgroot}")
                      . T.pack
                      $ desc
              writeArtifact (pkg ++ ".conf") desc'
      confs <- mapM makePkgConf builtinPackages
      -- let globalRelativePackageDb = "global-packages/package-fixed.conf.d"
      let ghcFixed = "ghc-fixed"
      let db = ghcFixed </> packageConfD
      let ghcPkg = progTemp (ghcFixed </> "bin/ghc-pkg")
      ghcDir <- runCommandOutput ghcFixed
                  $ shadow (ghcLibRoot ghc) ghcFixed
                  <> inputList confs
                  <> message "Building core package database"
                  <> prog "rm" ["-rf", db]
                  <> ghcPkg ["init", db]
                  <> foldMap
                          (\conf -> ghcPkg
                              [ "register", pathIn conf
                              , "--global-package-db=" ++ db
                              , "--no-user-package-db"
                              , "--no-user-package-conf"
                              , "--no-expand-pkgroot"
                              , "--force"
                              ])
                          confs
      return ghc { ghcLibRoot = ghcDir }
  
  -- TODO: this gets the TMPDIR that was used when installing; consider allowing
  -- that to be captured explicitly.
  parsePkgRoot :: String -> String
  parsePkgRoot desc = loop $ lines desc
    where
      loop [] = error "Couldn't parse pkgRoot: " ++ show desc
      loop (l:ls)
          | take (length prefix) l == prefix = takeDirectory
                                              $ drop (length prefix) l
          | otherwise = loop ls
      prefix = "library-dirs: "
  