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