1{-# LANGUAGE ViewPatterns #-} 2{-# LANGUAGE OverloadedLists #-} 3module Spago.Config 4 ( defaultPath 5 , makeConfig 6 , makeTempConfig 7 , ensureConfig 8 , addDependencies 9 , parsePackage 10 , parsePackageSet 11 , Config(..) 12 , PublishConfig(..) 13 ) where 14 15import Spago.Prelude 16import Spago.Env 17 18import qualified Data.List as List 19import qualified Data.List.NonEmpty as NonEmpty 20import qualified Data.Map as Map 21import qualified Data.SemVer as SemVer 22import qualified Data.Sequence as Seq 23import qualified Data.Set as Set 24import qualified Data.Text as Text 25import qualified Data.Text.Encoding as Text 26import qualified Data.Versions as Version 27import qualified Dhall.Core 28import qualified Dhall.Map 29import qualified Dhall.TypeCheck 30import qualified Web.Bower.PackageMeta as Bower 31 32import qualified Spago.Dhall as Dhall 33import qualified Spago.Messages as Messages 34import qualified Spago.PackageSet as PackageSet 35import qualified Spago.PscPackage as PscPackage 36import qualified Spago.Templates as Templates 37 38 39type Expr = Dhall.DhallExpr Dhall.Import 40type ResolvedExpr = Dhall.DhallExpr Void 41 42 43-- | Default path for the Spago Config 44defaultPath :: IsString t => t 45defaultPath = "spago.dhall" 46 47 48isLocationType :: (Eq s, Eq a) => Dhall.Expr s a -> Bool 49isLocationType (Dhall.Union kvs) | locationUnionMap == Dhall.Map.toMap kvs = True 50 where 51 locationUnionMap = Map.fromList 52 [ ("Environment", Just Dhall.Text) 53 , ("Remote", Just Dhall.Text) 54 , ("Local", Just Dhall.Text) 55 , ("Missing", Nothing) 56 ] 57isLocationType _ = False 58 59 60dependenciesType :: Dhall.Decoder [PackageName] 61dependenciesType = Dhall.list (Dhall.auto :: Dhall.Decoder PackageName) 62 63 64parsePackage :: (MonadIO m, MonadThrow m, MonadReader env m, HasLogFunc env) => ResolvedExpr -> m Package 65parsePackage (Dhall.RecordLit ks') = do 66 let ks = Dhall.extractRecordValues ks' 67 repo <- Dhall.requireTypedKey ks "repo" (Dhall.auto :: Dhall.Decoder Repo) 68 version <- Dhall.requireTypedKey ks "version" Dhall.strictText 69 dependencies <- Dhall.requireTypedKey ks "dependencies" dependenciesType 70 let location = Remote{..} 71 pure Package{..} 72parsePackage (Dhall.App 73 (Dhall.Field union (Dhall.FieldSelection { fieldSelectionLabel = "Local" })) 74 (Dhall.TextLit (Dhall.Chunks [] spagoConfigPath))) 75 | isLocationType union = do 76 localPath <- case Text.isSuffixOf "/spago.dhall" spagoConfigPath of 77 True -> pure $ Text.dropEnd 12 spagoConfigPath 78 False -> die [ display $ Messages.failedToParseLocalRepo spagoConfigPath ] 79 rawConfig <- liftIO $ Dhall.readRawExpr spagoConfigPath 80 dependencies <- case rawConfig of 81 Nothing -> die [ display $ Messages.cannotFindConfigLocalPackage spagoConfigPath ] 82 Just (_header, expr) -> do 83 newExpr <- transformMExpr (pure . filterDependencies . addSourcePaths) expr 84 -- Note: we have to use inputWithSettings here because we're about to resolve 85 -- the raw config from the local project. So if that has any imports they 86 -- should be relative to the directory of that package 87 liftIO $ 88 Dhall.inputWithSettings 89 (set Dhall.rootDirectory (Text.unpack localPath) Dhall.defaultInputSettings) 90 dependenciesType 91 (pretty newExpr) 92 let location = Local{..} 93 pure Package{..} 94parsePackage expr = die [ display $ Messages.failedToParsePackage $ pretty expr ] 95 96 97-- | Parse the contents of a "packages.dhall" file (or the "packages" key of an 98-- evaluated "spago.dhall") 99parsePackageSet 100 :: HasLogFunc env 101 => Dhall.Map.Map Text (Dhall.DhallExpr Void) 102 -> RIO env PackageSet 103parsePackageSet pkgs = do 104 packagesDB <- fmap (Map.mapKeys PackageName . Dhall.Map.toMap) $ traverse parsePackage pkgs 105 106 let metadataPackageName = PackageName "metadata" 107 let packagesMinPursVersion = join 108 $ fmap (hush . Version.semver . Text.replace "v" "" . version . location) 109 $ Map.lookup metadataPackageName packagesDB 110 pure PackageSet{..} 111 112 113-- | Tries to read in a Spago Config 114parseConfig 115 :: (HasLogFunc env, HasConfigPath env) 116 => RIO env Config 117parseConfig = do 118 -- Here we try to migrate any config that is not in the latest format 119 void $ withConfigAST $ pure . addSourcePaths 120 121 ConfigPath path <- view (the @ConfigPath) 122 expr <- liftIO $ Dhall.inputExpr $ "./" <> path 123 case expr of 124 Dhall.RecordLit ks' -> do 125 let ks = Dhall.extractRecordValues ks' 126 let sourcesType = Dhall.list (Dhall.auto :: Dhall.Decoder SourcePath) 127 name <- Dhall.requireTypedKey ks "name" Dhall.strictText 128 dependencies <- Dhall.requireTypedKey ks "dependencies" dependenciesType 129 configSourcePaths <- Dhall.requireTypedKey ks "sources" sourcesType 130 alternateBackend <- Dhall.maybeTypedKey ks "backend" Dhall.strictText 131 132 let ensurePublishConfig = do 133 publishLicense <- Dhall.requireTypedKey ks "license" Dhall.strictText 134 publishRepository <- Dhall.requireTypedKey ks "repository" Dhall.strictText 135 pure PublishConfig{..} 136 publishConfig <- try ensurePublishConfig 137 138 packageSet <- Dhall.requireKey ks "packages" (\case 139 Dhall.RecordLit pkgs -> parsePackageSet (Dhall.extractRecordValues pkgs) 140 something -> throwM $ Dhall.PackagesIsNotRecord something) 141 142 pure Config{..} 143 _ -> case Dhall.TypeCheck.typeOf expr of 144 Right e -> throwM $ Dhall.ConfigIsNotRecord e 145 Left err -> throwM err 146 147 148-- | Checks that the Spago config is there and readable 149ensureConfig 150 :: (HasLogFunc env, HasConfigPath env) 151 => RIO env (Either Utf8Builder Config) 152ensureConfig = do 153 ConfigPath path <- view (the @ConfigPath) 154 exists <- testfile path 155 if not exists 156 then pure $ Left $ display $ Messages.cannotFindConfig path 157 else try parseConfig >>= \case 158 Right config -> do 159 PackageSet.ensureFrozen $ Text.unpack path 160 pure $ Right config 161 Left (err :: Dhall.ReadError Void) -> pure $ Left $ displayShow err 162 163-- | Create a Config in memory 164-- | For use by `spago script` and `spago repl` 165makeTempConfig 166 :: (HasLogFunc env, HasPurs env) 167 => [PackageName] 168 -> Maybe Text 169 -> [SourcePath] 170 -> Maybe Text 171 -> RIO env Config 172makeTempConfig dependencies alternateBackend configSourcePaths maybeTag = do 173 PursCmd { compilerVersion } <- view (the @PursCmd) 174 tag <- case maybeTag of 175 Nothing -> 176 PackageSet.getLatestSetForCompilerVersion compilerVersion "purescript" "package-sets" >>= \case 177 Left _ -> die [ "spago script: failed to fetch latest package set tag" ] 178 Right tag -> pure tag 179 Just tag -> pure tag 180 181 expr <- liftIO $ Dhall.inputExpr $ "https://github.com/purescript/package-sets/releases/download/" <> tag <> "/packages.dhall" 182 183 case expr of 184 Dhall.RecordLit ks' -> do 185 let ks = Dhall.extractRecordValues ks' 186 packageSet <- parsePackageSet ks 187 let publishConfig = Left $ Dhall.RequiredKeyMissing "license" ks 188 pure $ Config { name = "", ..} 189 _ -> die [ "Failed to parse package set" ] 190 191-- | Copies over `spago.dhall` to set up a Spago project. 192-- Eventually ports an existing `psc-package.json` to the new config. 193makeConfig 194 :: (HasConfigPath env, HasLogFunc env) 195 => Force -> Dhall.TemplateComments 196 -> RIO env Config 197makeConfig force comments = do 198 ConfigPath path <- view (the @ConfigPath) 199 when (force == NoForce) $ do 200 hasSpagoDhall <- testfile path 201 when hasSpagoDhall $ die [ display $ Messages.foundExistingProject path ] 202 writeTextFile path $ Dhall.processComments comments Templates.spagoDhall 203 Dhall.format path 204 205 -- We try to find an existing psc-package or Bower config, and if 206 -- we find any we migrate the existing content 207 -- Otherwise we just keep the default template 208 bowerFileExists <- testfile "bower.json" 209 pscfileExists <- testfile PscPackage.configPath 210 eitherConfig <- ensureConfig 211 212 case (pscfileExists, bowerFileExists) of 213 (True, _) -> do 214 -- first, read the psc-package file content 215 content <- readTextFile PscPackage.configPath 216 case (eitherDecodeStrict $ Text.encodeUtf8 content, eitherConfig) of 217 (Left err, _) -> logWarn $ display $ Messages.failedToReadPscFile err 218 (_, Left err) -> die [err] 219 (Right pscConfig, Right config) -> do 220 logInfo "Found a \"psc-package.json\" file, migrating to a new Spago config.." 221 -- try to update the dependencies (will fail if not found in package set) 222 let pscPackages = map PackageName $ PscPackage.depends pscConfig 223 void $ withConfigAST ( addRawDeps config pscPackages 224 . updateName (PscPackage.name pscConfig)) 225 (_, True) -> do 226 -- read the bowerfile 227 content <- readTextFile "bower.json" 228 case (eitherDecodeStrict $ Text.encodeUtf8 content, eitherConfig) of 229 (Left err, _) -> logWarn $ display $ Messages.failedToParseFile path err 230 (_, Left err) -> die [err] 231 (Right packageMeta, Right config@Config{..}) -> do 232 logInfo "Found a \"bower.json\" file, migrating to a new Spago config.." 233 -- then try to update the dependencies. We'll migrates the ones that we can, 234 -- and print a message to the user to fix the missing ones 235 let (bowerName, packageResults) = migrateBower packageMeta packageSet 236 (bowerErrors, bowerPackages) = partitionEithers packageResults 237 238 if null bowerErrors 239 then do 240 logInfo "All Bower dependencies are in the set! " 241 logInfo $ "You can now safely delete your " <> surroundQuote "bower.json" 242 else do 243 logWarn $ display $ showBowerErrors bowerErrors 244 245 void $ withConfigAST ( addRawDeps config bowerPackages 246 . updateName bowerName) 247 248 _ -> pure () 249 -- at last we return the new config 250 case eitherConfig of 251 Right c -> pure c 252 Left err -> die [err] 253 254 255migrateBower :: Bower.PackageMeta -> PackageSet -> (Text, [Either BowerDependencyError PackageName]) 256migrateBower Bower.PackageMeta{..} PackageSet{..} = (packageName, dependencies) 257 where 258 dependencies = map migratePackage (bowerDependencies <> bowerDevDependencies) 259 260 -- | For each Bower dependency, we: 261 -- * try to parse the range into a SemVer.Range 262 -- * then check if it's a purescript package 263 -- * then try to search in the Package Set for that package 264 -- * then try to match the version there into the Bower range 265 migratePackage :: (Bower.PackageName, Bower.VersionRange) -> Either BowerDependencyError PackageName 266 migratePackage (Bower.runPackageName -> name, Bower.VersionRange unparsedRange) = 267 case SemVer.parseSemVerRange unparsedRange of 268 Left _err -> Left $ UnparsableRange (PackageName name) unparsedRange 269 Right range -> case Text.stripPrefix "purescript-" name of 270 Nothing -> Left $ NonPureScript name 271 Just packageSetName | package <- PackageName packageSetName -> case Map.lookup package packagesDB of 272 Nothing -> Left $ MissingFromTheSet package 273 Just Package{ location = Local _ } -> Right package 274 Just Package{ location = Remote {..} } -> case SemVer.parseSemVer version of 275 Right v | SemVer.matches range v -> Right package 276 _ -> Left $ WrongVersion package range version 277 278 packageName = 279 let name = Bower.runPackageName bowerName 280 in case Text.isPrefixOf "purescript-" name of 281 True -> Text.drop 11 name 282 False -> name 283 284data BowerDependencyError 285 = UnparsableRange PackageName Text 286 | NonPureScript Text 287 | MissingFromTheSet PackageName 288 | WrongVersion PackageName SemVer.SemVerRange Text 289 deriving (Eq, Ord) 290 291 292showBowerErrors :: [BowerDependencyError] -> Text 293showBowerErrors (List.sort -> errors) 294 = "\n\nSpago encountered some errors while trying to migrate your Bower config.\n" 295 <> "A Spago config has been generated but it's recommended that you apply the suggestions here\n\n" 296 <> (Text.unlines $ map (\errorGroup -> 297 (case List.head errorGroup of 298 UnparsableRange _ _ -> "It was not possible to parse the version range for these packages:" 299 NonPureScript _ -> "These packages are not PureScript packages, so you should install them with `npm` instead:" 300 MissingFromTheSet _ -> "These packages are missing from the package set. You should add them in your local package set:\n(See here for how: https://github.com/purescript/spago#add-a-package-to-the-package-set)" 301 WrongVersion _ _ _ -> "These packages are in the set, but did not match the Bower range. You can try to install them with `spago install some-package-name`") 302 <> "\n" 303 <> Text.unlines (map (("* " <>) . showE) errorGroup)) (List.groupBy groupFn errors)) 304 where 305 groupFn (UnparsableRange _ _) (UnparsableRange _ _) = True 306 groupFn (NonPureScript _) (NonPureScript _) = True 307 groupFn (MissingFromTheSet _) (MissingFromTheSet _) = True 308 groupFn (WrongVersion _ _ _) (WrongVersion _ _ _) = True 309 groupFn _ _ = False 310 311 showE (UnparsableRange (PackageName name) range) = surroundQuote name <> " had range " <> surroundQuote range 312 showE (NonPureScript name) = surroundQuote name 313 showE (MissingFromTheSet (PackageName name)) = surroundQuote name 314 showE (WrongVersion (PackageName name) range version) = surroundQuote name <> " has version " <> version <> ", but range is " <> tshow range 315 316 317updateName :: Text -> Expr -> Expr 318updateName newName (Dhall.RecordLit kvs) 319 | Just _name <- Dhall.Map.lookup "name" kvs = Dhall.RecordLit 320 $ Dhall.Map.insert "name" (Dhall.makeRecordField $ Dhall.toTextLit newName) kvs 321updateName _ other = other 322 323addRawDeps :: HasLogFunc env => Config -> [PackageName] -> Expr -> RIO env Expr 324addRawDeps config newPackages r@(Dhall.RecordLit kvs) = case Dhall.Map.lookup "dependencies" kvs of 325 Just (Dhall.RecordField { recordFieldValue = Dhall.ListLit _ dependencies }) -> do 326 case NonEmpty.nonEmpty notInPackageSet of 327 -- If none of the newPackages are outside of the set, add them to existing dependencies 328 Nothing -> do 329 oldPackages <- traverse (throws . Dhall.fromTextLit) dependencies 330 let newDepsExpr 331 = Dhall.makeRecordField 332 $ Dhall.ListLit Nothing $ fmap (Dhall.toTextLit . packageName) 333 $ Seq.sort $ nubSeq (Seq.fromList newPackages <> fmap PackageName oldPackages) 334 pure $ Dhall.RecordLit $ Dhall.Map.insert "dependencies" newDepsExpr kvs 335 Just pkgs -> do 336 logWarn $ display $ Messages.failedToAddDeps $ NonEmpty.map packageName pkgs 337 pure r 338 where 339 Config { packageSet = PackageSet{..} } = config 340 notInPackageSet = filter (\p -> Map.notMember p packagesDB) newPackages 341 342 -- | Code from https://stackoverflow.com/questions/45757839 343 nubSeq :: Ord a => Seq a -> Seq a 344 nubSeq xs = (fmap fst . Seq.filter (uncurry notElem)) (Seq.zip xs seens) 345 where 346 seens = Seq.scanl (flip Set.insert) Set.empty xs 347 Just _ -> do 348 logWarn "Failed to add dependencies. The `dependencies` field wasn't a List of Strings." 349 pure r 350 Nothing -> do 351 logWarn "Failed to add dependencies. You should have a record with the `dependencies` key for this to work." 352 pure r 353addRawDeps _ _ other = pure other 354 355addSourcePaths :: Expr -> Expr 356addSourcePaths (Dhall.RecordLit kvs) 357 | isConfigV1 kvs = 358 let sources = Dhall.ListLit Nothing $ fmap Dhall.toTextLit $ Seq.fromList ["src/**/*.purs", "test/**/*.purs"] 359 in Dhall.RecordLit (Dhall.Map.insert "sources" (Dhall.makeRecordField sources) kvs) 360addSourcePaths expr = expr 361 362isConfigV1, isConfigV2 :: Dhall.Map.Map Text v -> Bool 363isConfigV1 (Set.fromList . Dhall.Map.keys -> configKeySet) = 364 let configV1Keys = ["name", "dependencies", "packages"] 365 in configKeySet == configV1Keys 366 367 368isConfigV2 (Set.fromList . Dhall.Map.keys -> configKeySet) = 369 let configV2Keys = ["name", "dependencies", "packages", "sources"] 370 optionalKeys = ["backend", "license", "repository"] 371 in Set.difference configKeySet optionalKeys == configV2Keys 372 373 374filterDependencies :: Expr -> Expr 375filterDependencies (Dhall.RecordLit kvs) 376 | isConfigV2 kvs, Just deps <- Dhall.Map.lookup "dependencies" (Dhall.extractRecordValues kvs) = deps 377filterDependencies expr = expr 378 379 380-- | Takes a function that manipulates the Dhall AST of the Config, and tries to run it 381-- on the current config. If it succeeds, it writes back to file the result returned. 382-- Note: it will pass in the parsed AST, not the resolved one (so e.g. imports will 383-- still be in the tree). If you need the resolved one, use `ensureConfig`. 384withConfigAST 385 :: (HasLogFunc env, HasConfigPath env) 386 => (Expr -> RIO env Expr) -> RIO env Bool 387withConfigAST transform = do 388 ConfigPath path <- view (the @ConfigPath) 389 rawConfig <- liftIO $ Dhall.readRawExpr path 390 case rawConfig of 391 Nothing -> die [ display $ Messages.cannotFindConfig path ] 392 Just (header, expr) -> do 393 newExpr <- transformMExpr transform expr 394 -- Write the new expression only if it has actually changed 395 let exprHasChanged = Dhall.Core.denote expr /= newExpr 396 if exprHasChanged 397 then liftIO $ Dhall.writeRawExpr path (header, newExpr) 398 else logDebug "Transformed config is the same as the read one, not overwriting it" 399 pure exprHasChanged 400 401 402transformMExpr 403 :: MonadIO m 404 => (Dhall.Expr s Dhall.Import -> m (Dhall.Expr s Dhall.Import)) 405 -> Dhall.Expr s Dhall.Import 406 -> m (Dhall.Expr s Dhall.Import) 407transformMExpr rules = 408 transformMOf 409 Dhall.subExpressions 410 rules 411 . Dhall.Core.denote 412 413 414-- | Try to add the `newPackages` to the "dependencies" list in the Config. 415-- It will not add any dependency if any of them is not in the package set. 416-- If everything is fine instead, it will add the new deps, sort all the 417-- dependencies, and write the Config back to file. 418addDependencies 419 :: (HasLogFunc env, HasConfigPath env) 420 => Config -> [PackageName] 421 -> RIO env () 422addDependencies config newPackages = do 423 configHasChanged <- withConfigAST $ addRawDeps config newPackages 424 unless configHasChanged $ 425 logWarn "Configuration file was not updated." 426