{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}

-- | Functions to calculate nix-style hashes for package ids.
--
-- The basic idea is simple, hash the combination of:
--
--   * the package tarball
--   * the ids of all the direct dependencies
--   * other local configuration (flags, profiling, etc)
--
module Distribution.Client.PackageHash (
    -- * Calculating package hashes
    PackageHashInputs(..),
    PackageHashConfigInputs(..),
    PackageSourceHash,
    hashedInstalledPackageId,
    hashPackageHashInputs,
    renderPackageHashInputs,
    -- ** Platform-specific variations
    hashedInstalledPackageIdLong,
    hashedInstalledPackageIdShort,
  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude

import Distribution.Package
         ( PackageId, PackageIdentifier(..), mkComponentId
         , PkgconfigName )
import Distribution.System
         ( Platform, OS(Windows, OSX), buildOS )
import Distribution.PackageDescription
         ( FlagAssignment, unFlagAssignment, showFlagValue )
import Distribution.Simple.Compiler
         ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)
         , ProfDetailLevel(..), showProfDetailLevel )
import Distribution.Simple.InstallDirs
         ( PathTemplate, fromPathTemplate )
import Distribution.Pretty (prettyShow)
import Distribution.Deprecated.Text
         ( display )
import Distribution.Types.PkgconfigVersion (PkgconfigVersion)
import Distribution.Client.HashValue
import Distribution.Client.Types
         ( InstalledPackageId )
import qualified Distribution.Solver.Types.ComponentDeps as CD

import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Map as Map
import qualified Data.Set as Set

import Data.Function     (on)

-------------------------------
-- Calculating package hashes
--

-- | Calculate a 'InstalledPackageId' for a package using our nix-style
-- inputs hashing method.
--
-- Note that due to path length limitations on Windows, this function uses
-- a different method on Windows that produces shorted package ids.
-- See 'hashedInstalledPackageIdLong' vs 'hashedInstalledPackageIdShort'.
--
hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId
hashedInstalledPackageId
  | buildOS == Windows = hashedInstalledPackageIdShort
  | buildOS == OSX     = hashedInstalledPackageIdVeryShort
  | otherwise          = hashedInstalledPackageIdLong

-- | Calculate a 'InstalledPackageId' for a package using our nix-style
-- inputs hashing method.
--
-- This produces large ids with big hashes. It is only suitable for systems
-- without significant path length limitations (ie not Windows).
--
hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId
hashedInstalledPackageIdLong pkghashinputs@PackageHashInputs{pkgHashPkgId} =
    mkComponentId $
         display pkgHashPkgId   -- to be a bit user friendly
      ++ "-"
      ++ showHashValue (hashPackageHashInputs pkghashinputs)

-- | On Windows we have serious problems with path lengths. Windows imposes a
-- maximum path length of 260 chars, and even if we can use the windows long
-- path APIs ourselves, we cannot guarantee that ghc, gcc, ld, ar, etc etc all
-- do so too.
--
-- So our only choice is to limit the lengths of the paths, and the only real
-- way to do that is to limit the size of the 'InstalledPackageId's that we
-- generate. We do this by truncating the package names and versions and also
-- by truncating the hash sizes.
--
-- Truncating the package names and versions is technically ok because they are
-- just included for human convenience, the full source package id is included
-- in the hash.
--
-- Truncating the hash size is disappointing but also technically ok. We
-- rely on the hash primarily for collision avoidance not for any security
-- properties (at least for now).
--
hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId
hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =
    mkComponentId $
      intercalate "-"
        -- max length now 64
        [ truncateStr 14 (display name)
        , truncateStr  8 (display version)
        , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs))
        ]
  where
    PackageIdentifier name version = pkgHashPkgId

    -- Truncate a string, with a visual indication that it is truncated.
    truncateStr n s | length s <= n = s
                    | otherwise     = take (n-1) s ++ "_"

-- | On macOS we shorten the name very aggressively.  The mach-o linker on
-- macOS has a limited load command size, to which the name of the library
-- as well as its relative path (\@rpath) entry count.  To circumvent this,
-- on macOS the libraries are not stored as
--  @store/<libraryname>/libHS<libraryname>.dylib@
-- where libraryname contains the libraries name, version and abi hash, but in
--  @store/lib/libHS<very short libraryname>.dylib@
-- where the very short library name drops all vowels from the package name,
-- and truncates the hash to 4 bytes.
--
-- We therefore we only need one \@rpath entry to @store/lib@ instead of one
-- \@rpath entry for each library. And the reduced library name saves some
-- additional space.
--
-- This however has two major drawbacks:
-- 1) Packages can collide more easily due to the shortened hash.
-- 2) The libraries are *not* prefix relocatable anymore as they all end up
--    in the same @store/lib@ folder.
--
-- The ultimate solution would have to include generating proxy dynamic
-- libraries on macOS, such that the proxy libraries and the linked libraries
-- stay under the load command limit, and the recursive linker is still able
-- to link all of them.
hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId
hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =
  mkComponentId $
    intercalate "-"
      [ filter (not . flip elem "aeiou") (display name)
      , display version
      , showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs))
      ]
  where
    PackageIdentifier name version = pkgHashPkgId

-- | All the information that contribues to a package's hash, and thus its
-- 'InstalledPackageId'.
--
data PackageHashInputs = PackageHashInputs {
       pkgHashPkgId         :: PackageId,
       pkgHashComponent     :: Maybe CD.Component,
       pkgHashSourceHash    :: PackageSourceHash,
       pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion),
       pkgHashDirectDeps    :: Set InstalledPackageId,
       pkgHashOtherConfig   :: PackageHashConfigInputs
     }

type PackageSourceHash = HashValue

-- | Those parts of the package configuration that contribute to the
-- package hash.
--
data PackageHashConfigInputs = PackageHashConfigInputs {
       pkgHashCompilerId          :: CompilerId,
       pkgHashPlatform            :: Platform,
       pkgHashFlagAssignment      :: FlagAssignment, -- complete not partial
       pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure
       pkgHashVanillaLib          :: Bool,
       pkgHashSharedLib           :: Bool,
       pkgHashDynExe              :: Bool,
       pkgHashFullyStaticExe      :: Bool,
       pkgHashGHCiLib             :: Bool,
       pkgHashProfLib             :: Bool,
       pkgHashProfExe             :: Bool,
       pkgHashProfLibDetail       :: ProfDetailLevel,
       pkgHashProfExeDetail       :: ProfDetailLevel,
       pkgHashCoverage            :: Bool,
       pkgHashOptimization        :: OptimisationLevel,
       pkgHashSplitObjs           :: Bool,
       pkgHashSplitSections       :: Bool,
       pkgHashStripLibs           :: Bool,
       pkgHashStripExes           :: Bool,
       pkgHashDebugInfo           :: DebugInfoLevel,
       pkgHashProgramArgs         :: Map String [String],
       pkgHashExtraLibDirs        :: [FilePath],
       pkgHashExtraFrameworkDirs  :: [FilePath],
       pkgHashExtraIncludeDirs    :: [FilePath],
       pkgHashProgPrefix          :: Maybe PathTemplate,
       pkgHashProgSuffix          :: Maybe PathTemplate,

       -- Haddock options
       pkgHashDocumentation       :: Bool,
       pkgHashHaddockHoogle       :: Bool,
       pkgHashHaddockHtml         :: Bool,
       pkgHashHaddockHtmlLocation :: Maybe String,
       pkgHashHaddockForeignLibs  :: Bool,
       pkgHashHaddockExecutables  :: Bool,
       pkgHashHaddockTestSuites   :: Bool,
       pkgHashHaddockBenchmarks   :: Bool,
       pkgHashHaddockInternal     :: Bool,
       pkgHashHaddockCss          :: Maybe FilePath,
       pkgHashHaddockLinkedSource :: Bool,
       pkgHashHaddockQuickJump    :: Bool,
       pkgHashHaddockContents     :: Maybe PathTemplate

--     TODO: [required eventually] pkgHashToolsVersions     ?
--     TODO: [required eventually] pkgHashToolsExtraOptions ?
     }
  deriving Show


-- | Calculate the overall hash to be used for an 'InstalledPackageId'.
--
hashPackageHashInputs :: PackageHashInputs -> HashValue
hashPackageHashInputs = hashValue . renderPackageHashInputs

-- | Render a textual representation of the 'PackageHashInputs'.
--
-- The 'hashValue' of this text is the overall package hash.
--
renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString
renderPackageHashInputs PackageHashInputs{
                          pkgHashPkgId,
                          pkgHashComponent,
                          pkgHashSourceHash,
                          pkgHashDirectDeps,
                          pkgHashPkgConfigDeps,
                          pkgHashOtherConfig =
                            PackageHashConfigInputs{..}
                        } =
    -- The purpose of this somewhat laboured rendering (e.g. why not just
    -- use show?) is so that existing package hashes do not change
    -- unnecessarily when new configuration inputs are added into the hash.

    -- In particular, the assumption is that when a new configuration input
    -- is included into the hash, that existing packages will typically get
    -- the default value for that feature. So if we avoid adding entries with
    -- the default value then most of the time adding new features will not
    -- change the hashes of existing packages and so fewer packages will need
    -- to be rebuilt.

    --TODO: [nice to have] ultimately we probably want to put this config info
    -- into the ghc-pkg db. At that point this should probably be changed to
    -- use the config file infrastructure so it can be read back in again.
    LBS.pack $ unlines $ catMaybes $
      [ entry "pkgid"       display pkgHashPkgId
      , mentry "component"  show pkgHashComponent
      , entry "src"         showHashValue pkgHashSourceHash
      , entry "pkg-config-deps"
                            (intercalate ", " . map (\(pn, mb_v) -> display pn ++
                                                    case mb_v of
                                                        Nothing -> ""
                                                        Just v -> " " ++ prettyShow v)
                                              . Set.toList) pkgHashPkgConfigDeps
      , entry "deps"        (intercalate ", " . map display
                                              . Set.toList) pkgHashDirectDeps
        -- and then all the config
      , entry "compilerid"  display pkgHashCompilerId
      , entry "platform"    display pkgHashPlatform
      , opt   "flags" mempty showFlagAssignment pkgHashFlagAssignment
      , opt   "configure-script" [] unwords pkgHashConfigureScriptArgs
      , opt   "vanilla-lib" True  display pkgHashVanillaLib
      , opt   "shared-lib"  False display pkgHashSharedLib
      , opt   "dynamic-exe" False display pkgHashDynExe
      , opt   "fully-static-exe" False display pkgHashFullyStaticExe
      , opt   "ghci-lib"    False display pkgHashGHCiLib
      , opt   "prof-lib"    False display pkgHashProfLib
      , opt   "prof-exe"    False display pkgHashProfExe
      , opt   "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail
      , opt   "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail
      , opt   "hpc"          False display pkgHashCoverage
      , opt   "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization
      , opt   "split-objs"   False display pkgHashSplitObjs
      , opt   "split-sections" False display pkgHashSplitSections
      , opt   "stripped-lib" False display pkgHashStripLibs
      , opt   "stripped-exe" True  display pkgHashStripExes
      , opt   "debug-info"   NormalDebugInfo (show . fromEnum) pkgHashDebugInfo
      , opt   "extra-lib-dirs"     [] unwords pkgHashExtraLibDirs
      , opt   "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs
      , opt   "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs
      , opt   "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix
      , opt   "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix

      , opt   "documentation"  False display pkgHashDocumentation
      , opt   "haddock-hoogle" False display pkgHashHaddockHoogle
      , opt   "haddock-html"   False display pkgHashHaddockHtml
      , opt   "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation
      , opt   "haddock-foreign-libraries" False display pkgHashHaddockForeignLibs
      , opt   "haddock-executables" False display pkgHashHaddockExecutables
      , opt   "haddock-tests" False display pkgHashHaddockTestSuites
      , opt   "haddock-benchmarks" False display pkgHashHaddockBenchmarks
      , opt   "haddock-internal" False display pkgHashHaddockInternal
      , opt   "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss
      , opt   "haddock-hyperlink-source" False display pkgHashHaddockLinkedSource
      , opt   "haddock-quickjump" False display pkgHashHaddockQuickJump
      , opt   "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents

      ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs
  where
    entry key     format value = Just (key ++ ": " ++ format value)
    mentry key    format value = fmap (\v -> key ++ ": " ++ format v) value
    opt   key def format value
         | value == def = Nothing
         | otherwise    = entry key format value

    showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) . unFlagAssignment
