bootstrap/src/Main.hs

   1 {-# LANGUAGE CPP #-}
   2
   3 module Main (main) where
   4
   5 import Control.Monad      (when)
   6 import Data.Either        (partitionEithers)
   7 import Data.Foldable      (for_, traverse_)
   8 import Data.Maybe         (listToMaybe)
   9 import Data.String        (fromString)
  10 import Data.Traversable   (for)
  11 import System.Environment (getArgs)
  12 import System.Exit        (exitFailure)
  13 import System.IO          (hPutStrLn, stderr)
  14
  15 import qualified Data.Text as T
  16 import qualified Cabal.Index                    as I
  17 import qualified Cabal.Plan                     as P
  18 import qualified Data.Aeson                     as A
  19 import qualified Data.ByteString.Lazy           as LBS
  20 import qualified Data.Map.Strict                as Map
  21 import qualified Data.Set                       as Set
  22 import qualified Distribution.Types.PackageName as C
  23 import qualified Distribution.Types.Version as C
  24 import qualified Topograph                      as TG
  25
  26 -------------------------------------------------------------------------------
  27 -- Main
  28 -------------------------------------------------------------------------------
  29
  30 main :: IO ()
  31 main = do
  32     args <- getArgs
  33     case args of
  34         [fp] -> main1 fp
  35         _    -> die "Usage: cabal-bootstrap-gen plan.json"
  36
  37 main1 :: FilePath -> IO ()
  38 main1 planPath = do
  39     meta <- getMap <$> I.cachedHackageMetadata
  40     plan <- P.decodePlanJson planPath
  41     main2 meta plan
  42   where
  43 #if MIN_VERSION_cabal_install_parsers(0,4,0)
  44     getMap = snd
  45 #else
  46     getMap = id
  47 #endif
  48
  49 main2 :: Map.Map C.PackageName I.PackageInfo -> P.PlanJson -> IO ()
  50 main2 meta plan = do
  51     info $ show $ Map.keys $ P.pjUnits plan
  52
  53     -- find cabal-install:exe:cabal unit
  54     (cabalUid, cabalUnit) <- case findCabalExe plan of
  55         Just x  -> return x
  56         Nothing -> die "Cannot find cabal-install:exe:cabal unit"
  57
  58     info $ "cabal-install:exe:cabal unit " ++ show cabalUid
  59
  60     -- BFS from cabal unit, getting all dependencies
  61     units <- bfs plan cabalUnit
  62
  63     info $ "Unit order:"
  64     for_ units $ \unit -> do
  65         info $ " - " ++ show (P.uId unit)
  66
  67     (builtin, deps) <- fmap partitionEithers $ for units $ \unit -> do
  68         let P.PkgId pkgname@(P.PkgName tpkgname) ver@(P.Ver verdigits) = P.uPId unit
  69
  70         let uid = P.uId unit
  71
  72         let cpkgname :: C.PackageName
  73             cpkgname = C.mkPackageName (T.unpack tpkgname)
  74
  75         let cversion :: C.Version
  76             cversion = C.mkVersion verdigits
  77
  78         case P.uType unit of
  79             P.UnitTypeBuiltin ->
  80                 return $ Left Builtin
  81                   { builtinPackageName = pkgname
  82                   , builtinVersion     = ver
  83                   }
  84
  85             _ -> do
  86                 (src, rev, revhash) <- case P.uSha256 unit of
  87                     Just _  -> do
  88                         pkgInfo <- maybe (die $ "Cannot find " ++ show uid ++ " package metadata") return $
  89                             Map.lookup cpkgname meta
  90                         relInfo <- maybe (die $ "Cannot find " ++ show uid ++ " version metadata") return $
  91                             Map.lookup cversion $ I.piVersions pkgInfo
  92
  93                         return
  94                             ( Hackage
  95                             , Just $ fromIntegral (I.riRevision relInfo)
  96                             , P.sha256FromByteString $ I.getSHA256 $ I.riCabal relInfo
  97                             )
  98
  99                     Nothing -> case P.uType unit of
 100                         P.UnitTypeLocal   -> return (Local, Nothing, Nothing)
 101                         t                 -> die $ "Unit of wrong type " ++ show uid ++ " " ++ show t
 102
 103                 return $ Right Dep
 104                     { depPackageName = pkgname
 105                     , depVersion     = ver
 106                     , depSource      = src
 107                     , depSrcHash     = P.uSha256 unit
 108                     , depRevision    = rev
 109                     , depRevHash     = revhash
 110                     , depFlags       =
 111                         [ (if fval then "+" else "-") ++ T.unpack fname
 112                         | (P.FlagName fname, fval) <- Map.toList (P.uFlags unit)
 113                         ]
 114                     }
 115
 116     LBS.putStr $ A.encode Result
 117         { resBuiltin      = builtin
 118         , resDependencies = deps
 119         }
 120
 121 bfs :: P.PlanJson -> P.Unit -> IO [P.Unit]
 122 bfs plan unit0 = do
 123     uids <- either (\loop -> die $ "Loop in install-plan " ++ show loop) id $ TG.runG am $ \g -> do
 124         v <- maybe (die "Cannot find cabal-install unit in topograph") return $
 125             TG.gToVertex g $ P.uId unit0
 126
 127         let t = TG.dfs g v
 128
 129         return $ map (TG.gFromVertex g) $
 130             -- nub and sort
 131             reverse $ Set.toList $ Set.fromList $ concat t
 132
 133     units <- for uids $ \uid -> do
 134         unit <- lookupUnit (P.pjUnits plan) uid
 135         case Map.toList (P.uComps unit) of
 136             [(_, compinfo)] -> checkExeDeps uid (P.pjUnits plan) (P.ciExeDeps compinfo)
 137             _               -> die $ "Unit with multiple components " ++ show uid
 138         return unit
 139
 140     -- Remove non-exe copies of cabal-install. Otherwise, cabal-install
 141     -- may appear as cabal-install:lib before dependencies of
 142     -- cabal-install:exe:cabal, and the bootstrap build tries to build
 143     -- all of cabal-install before those dependencies.
 144     return $ filter (\u -> P.uId u == P.uId unit0 || P.uPId u /= P.uPId unit0) units
 145   where
 146     am :: Map.Map P.UnitId (Set.Set P.UnitId)
 147     am = fmap (foldMap P.ciLibDeps . P.uComps) (P.pjUnits plan)
 148
 149 checkExeDeps :: P.UnitId -> Map.Map P.UnitId P.Unit -> Set.Set P.UnitId -> IO ()
 150 checkExeDeps pkgUid units = traverse_ check . Set.toList where
 151     check uid = do
 152         unit <- lookupUnit units uid
 153         let P.PkgId pkgname _ = P.uPId unit
 154         when (pkgname /= P.PkgName (fromString "hsc2hs")) $ do
 155             die $ "unit " ++ show pkgUid ++ " depends on executable " ++ show uid
 156
 157 lookupUnit :: Map.Map P.UnitId P.Unit -> P.UnitId -> IO P.Unit
 158 lookupUnit units uid
 159     = maybe (die $ "Cannot find unit " ++ show uid) return
 160     $ Map.lookup uid units
 161
 162 -------------------------------------------------------------------------------
 163 -- Data
 164 -------------------------------------------------------------------------------
 165
 166 data Result = Result
 167     { resBuiltin      :: [Builtin]
 168     , resDependencies :: [Dep]
 169     }
 170   deriving (Show)
 171
 172 data Builtin = Builtin
 173     { builtinPackageName :: P.PkgName
 174     , builtinVersion     :: P.Ver
 175     }
 176   deriving (Show)
 177
 178 data Dep = Dep
 179     { depPackageName :: P.PkgName
 180     , depVersion     :: P.Ver
 181     , depSource      :: SrcType
 182     , depSrcHash     :: Maybe P.Sha256
 183     , depRevision    :: Maybe Int
 184     , depRevHash     :: Maybe P.Sha256
 185     , depFlags       :: [String]
 186     }
 187   deriving (Show)
 188
 189 data SrcType
 190     = Hackage
 191     | Local
 192   deriving (Show)
 193
 194 instance A.ToJSON Result where
 195     toJSON res = A.object
 196         [ fromString "builtin"      A..= resBuiltin res
 197         , fromString "dependencies" A..= resDependencies res
 198         ]
 199
 200 instance A.ToJSON Builtin where
 201     toJSON b = A.object
 202         [ fromString "package"      A..= builtinPackageName b
 203         , fromString "version"      A..= builtinVersion b
 204         ]
 205
 206 instance A.ToJSON Dep where
 207     toJSON dep = A.object
 208         [ fromString "package"      A..= depPackageName dep
 209         , fromString "version"      A..= depVersion dep
 210         , fromString "source"       A..= depSource dep
 211         , fromString "src_sha256"   A..= depSrcHash dep
 212         , fromString "revision"     A..= depRevision dep
 213         , fromString "cabal_sha256" A..= depRevHash dep
 214         , fromString "flags"        A..= depFlags dep
 215         ]
 216
 217 instance A.ToJSON SrcType where
 218     toJSON Hackage     = fromString "hackage"
 219     toJSON Local       = fromString "local"
 220
 221 -------------------------------------------------------------------------------
 222 -- Utilities
 223 -------------------------------------------------------------------------------
 224
 225 -- | Log some debug information to stderr.
 226 --
 227 -- Disabled by default to keep the output tidy, replace by
 228 -- the version with 'hPutStrLn' when debugging.
 229 --
 230 info :: String -> IO ()
 231 info _msg = return ()
 232 -- info msg = hPutStrLn stderr $ "INFO: " ++ msg
 233
 234 die :: String -> IO a
 235 die msg = do
 236     hPutStrLn stderr msg
 237     exitFailure
 238
 239 -------------------------------------------------------------------------------
 240 -- Pure bits
 241 -------------------------------------------------------------------------------
 242
 243 findCabalExe :: P.PlanJson -> Maybe (P.UnitId, P.Unit)
 244 findCabalExe plan = listToMaybe
 245     [ (uid, unit)
 246     | (uid, unit) <- Map.toList (P.pjUnits plan)
 247     , let P.PkgId pkgname _ = P.uPId unit
 248     , pkgname == P.PkgName (fromString "cabal-install")
 249     , Map.keys (P.uComps unit) == [P.CompNameExe (fromString "cabal")]
 250     ]