git.iko.soy/rowtype-yoga/purescript-native
on a2f7eb3 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Publish.hs
409 lines 15 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3module Language.PureScript.Publish
4 ( preparePackage
5 , preparePackage'
6 , unsafePreparePackage
7 , PrepareM()
8 , runPrepareM
9 , warn
10 , userError
11 , internalError
12 , otherError
13 , PublishOptions(..)
14 , defaultPublishOptions
15 , getGitWorkingTreeStatus
16 , checkCleanWorkingTree
17 , getVersionFromGitTag
18 , getBowerRepositoryInfo
19 , getModules
20 , getResolvedDependencies
21 ) where
23import Protolude hiding (stdin)
25import Control.Arrow ((***))
26import Control.Category ((>>>))
27import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
28import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell)
30import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asText)
31import Data.Char (isSpace)
32import Data.String (String, lines)
33import Data.List (stripPrefix, (\\), nubBy)
34import Data.List.NonEmpty (NonEmpty(..))
35import Data.List.Split (splitOn)
36import qualified Data.Text as T
37import qualified Data.Text.Lazy as TL
38import qualified Data.Text.Lazy.Encoding as TL
39import Data.Time.Clock (UTCTime)
40import Data.Version
41import qualified Data.SPDX as SPDX
43import System.Directory (doesFileExist, findExecutable)
44import System.FilePath (pathSeparator)
45import System.Process (readProcess)
46import qualified System.FilePath.Glob as Glob
47import qualified System.Info
49import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName, runPackageName, parsePackageName, Repository(..))
50import qualified Web.Bower.PackageMeta as Bower
52import Language.PureScript.Publish.ErrorsWarnings
53import Language.PureScript.Publish.Utils
54import qualified Language.PureScript as P (version, ModuleName)
55import qualified Language.PureScript.Docs as D
57data PublishOptions = PublishOptions
58 { -- | How to obtain the version tag and version that the data being
59 -- generated will refer to.
60 publishGetVersion :: PrepareM (Text, Version)
61 , publishGetTagTime :: Text -> PrepareM UTCTime
62 , -- | What to do when the working tree is dirty
63 publishWorkingTreeDirty :: PrepareM ()
64 }
66defaultPublishOptions :: PublishOptions
67defaultPublishOptions = PublishOptions
68 { publishGetVersion = getVersionFromGitTag
69 , publishGetTagTime = getTagTime
70 , publishWorkingTreeDirty = userError DirtyWorkingTree
71 }
73-- | Attempt to retrieve package metadata from the current directory.
74-- Calls exitFailure if no package metadata could be retrieved.
75unsafePreparePackage :: PublishOptions -> IO D.UploadedPackage
76unsafePreparePackage opts = either (\e -> printError e >> exitFailure) pure =<< preparePackage opts
78-- | Attempt to retrieve package metadata from the current directory.
79-- Returns a PackageError on failure
80preparePackage :: PublishOptions -> IO (Either PackageError D.UploadedPackage)
81preparePackage opts =
82 runPrepareM (preparePackage' opts)
83 >>= either (pure . Left) (fmap Right . handleWarnings)
85 where
86 handleWarnings (result, warns) = do
87 printWarnings warns
88 return result
90newtype PrepareM a =
91 PrepareM { unPrepareM :: WriterT [PackageWarning] (ExceptT PackageError IO) a }
92 deriving (Functor, Applicative, Monad,
93 MonadWriter [PackageWarning],
94 MonadError PackageError)
96-- This MonadIO instance ensures that IO errors don't crash the program.
97instance MonadIO PrepareM where
98 liftIO act =
99 lift' (try act) >>= either (otherError . IOExceptionThrown) return
100 where
101 lift' :: IO a -> PrepareM a
102 lift' = PrepareM . lift . lift
104runPrepareM :: PrepareM a -> IO (Either PackageError (a, [PackageWarning]))
105runPrepareM = runExceptT . runWriterT . unPrepareM
107warn :: PackageWarning -> PrepareM ()
108warn w = tell [w]
110userError :: UserError -> PrepareM a
111userError = throwError . UserError
113internalError :: InternalError -> PrepareM a
114internalError = throwError . InternalError
116otherError :: OtherError -> PrepareM a
117otherError = throwError . OtherError
119catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
120catchLeft a f = either f pure a
122preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage
123preparePackage' opts = do
124 unlessM (liftIO (doesFileExist "bower.json")) (userError BowerJSONNotFound)
125 checkCleanWorkingTree opts
127 pkgMeta <- liftIO (Bower.decodeFile "bower.json")
128 >>= flip catchLeft (userError . CouldntDecodeBowerJSON)
129 checkLicense pkgMeta
131 (pkgVersionTag, pkgVersion) <- publishGetVersion opts
132 pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag
133 pkgGithub <- getBowerRepositoryInfo pkgMeta
134 (pkgModules, pkgModuleMap) <- getModules
136 let declaredDeps = map fst (bowerDependencies pkgMeta ++
137 bowerDevDependencies pkgMeta)
138 pkgResolvedDependencies <- getResolvedDependencies declaredDeps
140 let pkgUploader = D.NotYetKnown
141 let pkgCompilerVersion = P.version
143 return D.Package{..}
145getModules :: PrepareM ([D.Module], Map P.ModuleName PackageName)
146getModules = do
147 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
148 (modules', moduleMap) <- parseFilesInPackages inputFiles depsFiles
150 case runExcept (D.convertModulesInPackage modules' moduleMap) of
151 Right modules -> return (modules, moduleMap)
152 Left err -> userError (CompileError err)
154 where
155 parseFilesInPackages inputFiles depsFiles = do
156 r <- liftIO . runExceptT $ D.parseFilesInPackages inputFiles depsFiles
157 case r of
158 Right r' ->
159 return r'
160 Left err ->
161 userError (CompileError err)
163data TreeStatus = Clean | Dirty deriving (Show, Eq, Ord, Enum)
165getGitWorkingTreeStatus :: PrepareM TreeStatus
166getGitWorkingTreeStatus = do
167 out <- readProcess' "git" ["status", "--porcelain"] ""
168 return $
169 if all null . lines $ out
170 then Clean
171 else Dirty
173checkCleanWorkingTree :: PublishOptions -> PrepareM ()
174checkCleanWorkingTree opts = do
175 status <- getGitWorkingTreeStatus
176 unless (status == Clean) $
177 publishWorkingTreeDirty opts
179getVersionFromGitTag :: PrepareM (Text, Version)
180getVersionFromGitTag = do
181 out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] ""
182 let vs = map trimWhitespace (lines out)
183 case mapMaybe parseMay vs of
184 [] -> userError TagMustBeCheckedOut
185 [x] -> return (first T.pack x)
186 xs -> userError (AmbiguousVersions (map snd xs))
187 where
188 trimWhitespace =
189 dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
190 parseMay str = do
191 digits <- stripPrefix "v" str
192 (str,) <$> D.parseVersion' digits
194-- | Given a git tag, get the time it was created.
195getTagTime :: Text -> PrepareM UTCTime
196getTagTime tag = do
197 out <- readProcess' "git" ["show", T.unpack tag, "--no-patch", "--format=%aI"] ""
198 case mapMaybe D.parseTime (lines out) of
199 [t] -> pure t
200 _ -> internalError (CouldntParseGitTagDate tag)
202getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
203getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract
204 where
205 tryExtract pkgMeta =
206 case bowerRepository pkgMeta of
207 Nothing -> Left RepositoryFieldMissing
208 Just Repository{..} -> do
209 unless (repositoryType == "git")
210 (Left (BadRepositoryType repositoryType))
211 maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
213checkLicense :: PackageMeta -> PrepareM ()
214checkLicense pkgMeta =
215 case bowerLicense pkgMeta of
216 [] ->
217 userError NoLicenseSpecified
218 ls ->
219 unless (any (isValidSPDX . T.unpack) ls)
220 (userError InvalidLicense)
222-- |
223-- Check if a string is a valid SPDX license expression.
224--
225isValidSPDX :: String -> Bool
226isValidSPDX = (== 1) . length . SPDX.parseExpression
228extractGithub :: Text -> Maybe (D.GithubUser, D.GithubRepo)
229extractGithub = stripGitHubPrefixes
230 >>> fmap (T.splitOn "/")
231 >=> takeTwo
232 >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))
234 where
235 takeTwo :: [a] -> Maybe (a, a)
236 takeTwo [x, y] = Just (x, y)
237 takeTwo _ = Nothing
239 stripGitHubPrefixes :: Text -> Maybe Text
240 stripGitHubPrefixes = stripPrefixes [ "git://github.com/"
241 , "https://github.com/"
242 , "git@github.com:"
243 ]
245 stripPrefixes :: [Text] -> Text -> Maybe Text
246 stripPrefixes prefixes str = msum $ (`T.stripPrefix` str) <$> prefixes
248 dropDotGit :: Text -> Text
249 dropDotGit str
250 | ".git" `T.isSuffixOf` str = T.take (T.length str - 4) str
251 | otherwise = str
253readProcess' :: String -> [String] -> String -> PrepareM String
254readProcess' prog args stdin = do
255 out <- liftIO (catch (Right <$> readProcess prog args stdin)
256 (return . Left))
257 either (otherError . ProcessFailed prog args) return out
259data DependencyStatus
260 = Missing
261 -- ^ Listed in bower.json, but not installed.
262 | NoResolution
263 -- ^ In the output of `bower list --json --offline`, there was no
264 -- _resolution key. This can be caused by adding the dependency using
265 -- `bower link`, or simply copying it into bower_components instead of
266 -- installing it normally.
267 | ResolvedOther Text
268 -- ^ Resolved, but to something other than a version. The Text argument
269 -- is the resolution type. The values it can take that I'm aware of are
270 -- "commit" and "branch".
271 | ResolvedVersion Text
272 -- ^ Resolved to a version. The Text argument is the resolution tag (eg,
273 -- "v0.1.0").
274 deriving (Show, Eq)
276-- Go through all bower dependencies which contain purescript code, and
277-- extract their versions.
278--
279-- In the case where a bower dependency is taken from a particular version,
280-- that's easy; take that version. In any other case (eg, a branch, or a commit
281-- sha) we print a warning that documentation links will not work, and avoid
282-- linking to documentation for any types from that package.
283--
284-- The rationale for this is: people will prefer to use a released version
285-- where possible. If they are not using a released version, then this is
286-- probably for a reason. However, docs are only ever available for released
287-- versions. Therefore there will probably be no version of the docs which is
288-- appropriate to link to, and we should omit links.
289getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)]
290getResolvedDependencies declaredDeps = do
291 bower <- findBowerExecutable
292 depsBS <- packUtf8 <$> readProcess' bower ["list", "--json", "--offline"] ""
294 -- Check for undeclared dependencies
295 toplevels <- catchJSON (parse asToplevelDependencies depsBS)
296 warnUndeclared declaredDeps toplevels
298 deps <- catchJSON (parse asResolvedDependencies depsBS)
299 handleDeps deps
301 where
302 packUtf8 = TL.encodeUtf8 . TL.pack
303 catchJSON = flip catchLeft (internalError . JSONError FromBowerList)
305findBowerExecutable :: PrepareM String
306findBowerExecutable = do
307 mname <- liftIO . runMaybeT . msum . map (MaybeT . findExecutable) $ names
308 maybe (userError (BowerExecutableNotFound names)) return mname
309 where
310 names = case System.Info.os of
311 "mingw32" -> ["bower", "bower.cmd"]
312 _ -> ["bower"]
314-- | Extracts all dependencies and their versions from
315-- `bower list --json --offline`
316asResolvedDependencies :: Parse BowerError [(PackageName, DependencyStatus)]
317asResolvedDependencies = nubBy ((==) `on` fst) <$> go
318 where
319 go =
320 fmap (fromMaybe []) $
321 keyMay "dependencies" $
322 (++) <$> eachInObjectWithKey parsePackageName asDependencyStatus
323 <*> (concatMap snd <$> eachInObject asResolvedDependencies)
325-- | Extracts only the top level dependency names from the output of
326-- `bower list --json --offline`
327asToplevelDependencies :: Parse BowerError [PackageName]
328asToplevelDependencies =
329 fmap (map fst) $
330 key "dependencies" $
331 eachInObjectWithKey parsePackageName (return ())
333asDependencyStatus :: Parse e DependencyStatus
334asDependencyStatus = do
335 isMissing <- keyOrDefault "missing" False asBool
336 if isMissing
337 then
338 return Missing
339 else
340 key "pkgMeta" $
341 keyOrDefault "_resolution" NoResolution $ do
342 type_ <- key "type" asText
343 case type_ of
344 "version" -> ResolvedVersion <$> key "tag" asText
345 other -> return (ResolvedOther other)
347warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
348warnUndeclared declared actual =
349 traverse_ (warn . UndeclaredDependency) (actual \\ declared)
351handleDeps ::
352 [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)]
353handleDeps deps = do
354 let (missing, noVersion, installed) = partitionDeps deps
355 case missing of
356 (x:xs) ->
357 userError (MissingDependencies (x :| xs))
358 [] -> do
359 traverse_ (warn . NoResolvedVersion) noVersion
360 withVersions <- catMaybes <$> traverse tryExtractVersion' installed
361 filterM (liftIO . isPureScript . bowerDir . fst) withVersions
363 where
364 partitionDeps = foldr go ([], [], [])
365 go (pkgName, d) (ms, os, is) =
366 case d of
367 Missing -> (pkgName : ms, os, is)
368 NoResolution -> (ms, pkgName : os, is)
369 ResolvedOther _ -> (ms, pkgName : os, is)
370 ResolvedVersion v -> (ms, os, (pkgName, v) : is)
372 bowerDir pkgName = T.unpack $ "bower_components/" <> runPackageName pkgName
374 -- Try to extract a version, and warn if unsuccessful.
375 tryExtractVersion' :: (PackageName, Text) -> PrepareM (Maybe (PackageName, Version))
376 tryExtractVersion' pair =
377 maybe (warn (UnacceptableVersion pair) >> return Nothing)
378 (return . Just)
379 (tryExtractVersion pair)
381tryExtractVersion :: (PackageName, Text) -> Maybe (PackageName, Version)
382tryExtractVersion (pkgName, tag) =
383 let tag' = fromMaybe tag (T.stripPrefix "v" tag)
384 in (pkgName,) <$> D.parseVersion' (T.unpack tag')
386-- | Returns whether it looks like there is a purescript package checked out
387-- in the given directory.
388isPureScript :: FilePath -> IO Bool
389isPureScript dir = do
390 files <- Glob.globDir1 purescriptSourceFiles dir
391 return (not (null files))
393getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])
394getInputAndDepsFiles = do
395 inputFiles <- globRelative purescriptSourceFiles
396 depsFiles' <- globRelative purescriptDepsFiles
397 return (inputFiles, mapMaybe withPackageName depsFiles')
399withPackageName :: FilePath -> Maybe (PackageName, FilePath)
400withPackageName fp = (,fp) <$> getPackageName fp
402getPackageName :: FilePath -> Maybe PackageName
403getPackageName fp = do
404 let xs = splitOn [pathSeparator] fp
405 ys <- stripPrefix ["bower_components"] xs
406 y <- headMay ys
407 case Bower.mkPackageName (T.pack y) of
408 Right name -> Just name
409 Left _ -> Nothing