1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE PatternGuards #-}
4-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
5module Distribution.Backpack.Id(
6    computeComponentId,
7    computeCompatPackageKey,
8) where
9
10import Prelude ()
11import Distribution.Compat.Prelude
12
13import Distribution.Types.UnqualComponentName
14import Distribution.Simple.Compiler
15import Distribution.PackageDescription
16import Distribution.Simple.Setup as Setup
17import qualified Distribution.Simple.InstallDirs as InstallDirs
18import Distribution.Simple.LocalBuildInfo
19import Distribution.Types.ComponentId
20import Distribution.Types.UnitId
21import Distribution.Types.MungedPackageName
22import Distribution.Utils.Base62
23import Distribution.Version
24
25import Distribution.Pretty
26    ( prettyShow )
27import Distribution.Parsec ( simpleParsec )
28
29-- | This method computes a default, "good enough" 'ComponentId'
30-- for a package.  The intent is that cabal-install (or the user) will
31-- specify a more detailed IPID via the @--ipid@ flag if necessary.
32computeComponentId
33    :: Bool -- deterministic mode
34    -> Flag String
35    -> Flag ComponentId
36    -> PackageIdentifier
37    -> ComponentName
38    -- This is used by cabal-install's legacy codepath
39    -> Maybe ([ComponentId], FlagAssignment)
40    -> ComponentId
41computeComponentId deterministic mb_ipid mb_cid pid cname mb_details =
42    -- show is found to be faster than intercalate and then replacement of
43    -- special character used in intercalating. We cannot simply hash by
44    -- doubly concating list, as it just flatten out the nested list, so
45    -- different sources can produce same hash
46    let hash_suffix
47            | Just (dep_ipids, flags) <- mb_details
48            = "-" ++ hashToBase62
49                -- For safety, include the package + version here
50                -- for GHC 7.10, where just the hash is used as
51                -- the package key
52                    (    prettyShow pid
53                      ++ show dep_ipids
54                      ++ show flags     )
55            | otherwise = ""
56        generated_base = prettyShow pid ++ hash_suffix
57        explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env
58                                                    (toPathTemplate cid0))
59            -- Hack to reuse install dirs machinery
60            -- NB: no real IPID available at this point
61          where env = packageTemplateEnv pid (mkUnitId "")
62        actual_base = case mb_ipid of
63                        Flag ipid0 -> explicit_base ipid0
64                        NoFlag | deterministic -> prettyShow pid
65                               | otherwise     -> generated_base
66    in case mb_cid of
67          Flag cid -> cid
68          NoFlag -> mkComponentId $ actual_base
69                        ++ (case componentNameString cname of
70                                Nothing -> ""
71                                Just s -> "-" ++ unUnqualComponentName s)
72
73-- | In GHC 8.0, the string we pass to GHC to use for symbol
74-- names for a package can be an arbitrary, IPID-compatible string.
75-- However, prior to GHC 8.0 there are some restrictions on what
76-- format this string can be (due to how ghc-pkg parsed the key):
77--
78--      1. In GHC 7.10, the string had either be of the form
79--      foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated
80--      prefix and ABCD is two base-64 encoded 64-bit integers,
81--      or a GHC 7.8 style identifier.
82--
83--      2. In GHC 7.8, the string had to be a valid package identifier
84--      like foo-0.1.
85--
86-- So, the problem is that Cabal, in general, has a general IPID,
87-- but needs to figure out a package key / package ID that the
88-- old ghc-pkg will actually accept.  But there's an EVERY WORSE
89-- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx
90-- as if it were a package identifier, which means it will SILENTLY
91-- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.)
92-- So we must CONNIVE to ensure that we don't pick something that
93-- looks like this.
94--
95-- So this function attempts to define a mapping into the old formats.
96--
97-- The mapping for GHC 7.8 and before:
98--
99--      * We use the *compatibility* package name and version.  For
100--        public libraries this is just the package identifier; for
101--        internal libraries, it's something like "z-pkgname-z-libname-0.1".
102--        See 'computeCompatPackageName' for more details.
103--
104-- The mapping for GHC 7.10:
105--
106--      * For CLibName:
107--          If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would
108--          validly parse as a package key, we pass "ABCDEF".  (NB: not
109--          all hashes parse this way, because GHC 7.10 mandated that
110--          these hashes be two base-62 encoded 64 bit integers),
111--          but hashes that Cabal generated using 'computeComponentId'
112--          are guaranteed to have this form.
113--
114--          If it is not of this form, we rehash the IPID into the
115--          correct form and pass that.
116--
117--      * For sub-components, we rehash the IPID into the correct format
118--        and pass that.
119--
120computeCompatPackageKey
121    :: Compiler
122    -> MungedPackageName
123    -> Version
124    -> UnitId
125    -> String
126computeCompatPackageKey comp pkg_name pkg_version uid
127    | not (packageKeySupported comp || unitIdSupported comp)
128    = prettyShow pkg_name ++ "-" ++ prettyShow pkg_version
129    | not (unifiedIPIDRequired comp) =
130        let str = unUnitId uid -- assume no Backpack support
131            mb_verbatim_key
132                = case simpleParsec str :: Maybe PackageId of
133                    -- Something like 'foo-0.1', use it verbatim.
134                    -- (NB: hash tags look like tags, so they are parsed,
135                    -- so the extra equality check tests if a tag was dropped.)
136                    Just pid0 | prettyShow pid0 == str -> Just str
137                    _ -> Nothing
138            mb_truncated_key
139                = let cand = reverse (takeWhile isAlphaNum (reverse str))
140                  in if length cand == 22 && all isAlphaNum cand
141                        then Just cand
142                        else Nothing
143            rehashed_key = hashToBase62 str
144        in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key)
145    | otherwise = prettyShow uid
146