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