bootstrap/src/Main.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 {-# LANGUAGE LambdaCase #-}
   4 {-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
   5
   6 module Main (main) where
   7
   8 import Data.Either        (partitionEithers)
   9 import Data.Foldable      (for_)
  10 import Data.String        (fromString)
  11 import Data.Traversable   (for)
  12 import System.Environment (getArgs)
  13 import System.Exit        (exitFailure)
  14 import System.IO          (hPutStrLn, stderr)
  15
  16 import qualified Data.Text as T
  17 import qualified Cabal.Index                    as I
  18 import qualified Cabal.Plan                     as P
  19 import qualified Data.Aeson                     as A
  20 import qualified Data.ByteString.Lazy           as LBS
  21 import qualified Data.Map.Strict                as Map
  22 import qualified Distribution.Types.PackageName as C
  23 import qualified Distribution.Types.Version as C
  24 import qualified Topograph                      as TG
  25 import Control.Exception
  26 import System.IO.Error (isDoesNotExistError)
  27
  28 -------------------------------------------------------------------------------
  29 -- Main
  30 -------------------------------------------------------------------------------
  31
  32 main :: IO ()
  33 main = do
  34     args <- getArgs
  35     case args of
  36         [fp] ->
  37           handleJust
  38             (\e -> if isDoesNotExistError e then Just e else Nothing)
  39               (\e -> die $ unlines ["~~~ ERROR ~~~", "", displayException e, "", cabalDirWarning])
  40               (main1 fp)
  41         _ -> die "Usage: cabal-bootstrap-gen plan.json"
  42
  43 cabalDirWarning :: String
  44 cabalDirWarning =
  45   unlines [
  46     "~~~ NOTE ~~~",
  47     "",
  48     "This script will look for cabal global config file in the following locations",
  49     " - $CABAL_CONFIG",
  50     " - $CABAL_DIR/config",
  51     " - $HOME/.cabal/config (on Unix-like systems)",
  52     " - %APPDATA%/cabal (on Windows)",
  53     "",
  54     "If you are using XDG paths or a entirely different location, you can set either",
  55     "CABAL_CONFIG or CABAL_DIR to guide the script to the correct location.",
  56     "",
  57     "E.g.",
  58     "  $ CABAL_DIR=$HOME/.config/cabal cabal-bootstrap-gen"
  59     ]
  60
  61 main1 :: FilePath -> IO ()
  62 main1 planPath = do
  63     meta <- getMap <$> I.cachedHackageMetadata
  64     plan <- P.decodePlanJson planPath
  65     main2 meta plan
  66   where
  67 #if MIN_VERSION_cabal_install_parsers(0,4,0)
  68     getMap = snd
  69 #else
  70     getMap = id
  71 #endif
  72
  73 main2 :: Map.Map C.PackageName I.PackageInfo -> P.PlanJson -> IO ()
  74 main2 meta plan = do
  75     info $ show $ Map.keys $ P.pjUnits plan
  76
  77     let res = TG.runG (P.planJsonIdGraph plan) $ \g ->
  78           map (TG.gFromVertex g) (reverse $ TG.gVertices g)
  79
  80     units <- case res of
  81               Left loop -> die $ "Loop in install-plan: " ++ show loop
  82               Right uids -> for uids $ lookupUnit (P.pjUnits plan)
  83
  84     info "Unit order:"
  85     for_ units $ \unit -> do
  86         info $ " - " ++ show (P.uId unit)
  87
  88     (builtin, deps) <- fmap partitionEithers $ for units $ \unit -> do
  89         let P.PkgId pkgname@(P.PkgName tpkgname) ver@(P.Ver verdigits) = P.uPId unit
  90
  91         let cpkgname :: C.PackageName
  92             cpkgname = C.mkPackageName (T.unpack tpkgname)
  93
  94         let cversion :: C.Version
  95             cversion = C.mkVersion verdigits
  96
  97         let flags = [ (if fval then "+" else "-") ++ T.unpack fname
  98                         | (P.FlagName fname, fval) <- Map.toList (P.uFlags unit)
  99                         ]
 100         let relInfo = Map.lookup cpkgname meta >>= \pkgInfo -> Map.lookup cversion $ I.piVersions pkgInfo
 101         case P.uType unit of
 102             P.UnitTypeBuiltin ->
 103                 return $ Left Builtin
 104                   { builtinPackageName = pkgname
 105                   , builtinVersion     = ver
 106                   }
 107             _ -> do
 108               let component = case Map.keys (P.uComps unit) of
 109                                 [c] -> Just (P.dispCompNameTarget pkgname c)
 110                                 _ -> Nothing
 111
 112               source <-
 113                 case P.uPkgSrc unit of
 114                       Just (P.RepoTarballPackage (P.RepoSecure _uri)) ->
 115                         return Hackage
 116                       Just (P.LocalUnpackedPackage _path) ->
 117                         return Local
 118                       pkgsrc ->
 119                         die $ "package source not supported: " ++ show pkgsrc
 120
 121               return $ Right Dep
 122                       { depPackageName = pkgname
 123                       , depVersion     = ver
 124                       , depSource      = source
 125                       , depSrcHash     = P.uSha256 unit
 126                       , depRevision    = fromIntegral . I.riRevision <$> relInfo
 127                       , depRevHash     = relInfo >>= P.sha256FromByteString . I.getSHA256 . getHash
 128                       , depFlags       = flags
 129                       , depComponent   = component
 130                       }
 131     LBS.putStr $ A.encode Result
 132         { resBuiltin      = builtin
 133         , resDependencies = deps
 134         }
 135   where
 136 #if MIN_VERSION_cabal_install_parsers(0,6,0)
 137     getHash = I.riCabalHash
 138 #else
 139     getHash = I.riCabal
 140 #endif
 141
 142 lookupUnit :: Map.Map P.UnitId P.Unit -> P.UnitId -> IO P.Unit
 143 lookupUnit units uid
 144     = maybe (die $ "Cannot find unit " ++ show uid) return
 145     $ Map.lookup uid units
 146
 147 -------------------------------------------------------------------------------
 148 -- Data
 149 -------------------------------------------------------------------------------
 150
 151 data Result = Result
 152     { resBuiltin      :: [Builtin]
 153     , resDependencies :: [Dep]
 154     }
 155   deriving (Show)
 156
 157 data Builtin = Builtin
 158     { builtinPackageName :: P.PkgName
 159     , builtinVersion     :: P.Ver
 160     }
 161   deriving (Show)
 162
 163 data Dep = Dep
 164     { depPackageName :: P.PkgName
 165     , depVersion     :: P.Ver
 166     , depSource      :: SrcType
 167     , depSrcHash     :: Maybe P.Sha256
 168     , depRevision    :: Maybe Int
 169     , depRevHash     :: Maybe P.Sha256
 170     , depFlags       :: [String]
 171     , depComponent   :: Maybe T.Text
 172     }
 173   deriving (Show)
 174
 175 data SrcType
 176     = Hackage
 177     | Local
 178   deriving (Show)
 179
 180 instance A.ToJSON Result where
 181     toJSON res = A.object
 182         [ fromString "builtin"      A..= resBuiltin res
 183         , fromString "dependencies" A..= resDependencies res
 184         ]
 185
 186 instance A.ToJSON Builtin where
 187     toJSON b = A.object
 188         [ fromString "package"      A..= builtinPackageName b
 189         , fromString "version"      A..= builtinVersion b
 190         ]
 191
 192 instance A.ToJSON Dep where
 193     toJSON dep = A.object
 194         [ fromString "package"      A..= depPackageName dep
 195         , fromString "version"      A..= depVersion dep
 196         , fromString "source"       A..= depSource dep
 197         , fromString "src_sha256"   A..= depSrcHash dep
 198         , fromString "revision"     A..= depRevision dep
 199         , fromString "cabal_sha256" A..= depRevHash dep
 200         , fromString "flags"        A..= depFlags dep
 201         , fromString "component"    A..= depComponent dep
 202         ]
 203
 204 instance A.ToJSON SrcType where
 205     toJSON Hackage     = fromString "hackage"
 206     toJSON Local       = fromString "local"
 207
 208 -------------------------------------------------------------------------------
 209 -- Utilities
 210 -------------------------------------------------------------------------------
 211
 212 -- | Log some debug information to stderr.
 213 --
 214 -- Disabled by default to keep the output tidy, replace by
 215 -- the version with 'hPutStrLn' when debugging.
 216 --
 217 info :: String -> IO ()
 218 info _msg = return ()
 219 -- info msg = hPutStrLn stderr $ "INFO: " ++ msg
 220
 221 die :: String -> IO a
 222 die msg = do
 223     hPutStrLn stderr msg
 224     exitFailure