git.iko.soy/rowtype-yoga/purescript-native
on aec0ece help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Publish.hs
412 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 =
200 (str,) <$> D.parseVersion' (dropPrefix "v" str)
201 dropPrefix prefix str =
202 fromMaybe str (stripPrefix prefix str)
204getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
205getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract
206 where
207 tryExtract pkgMeta =
208 case bowerRepository pkgMeta of
209 Nothing -> Left RepositoryFieldMissing
210 Just Repository{..} -> do
211 unless (repositoryType == "git")
212 (Left (BadRepositoryType repositoryType))
213 maybe (Left NotOnGithub) Right (extractGithub (T.pack repositoryUrl))
215checkLicense :: PackageMeta -> PrepareM ()
216checkLicense pkgMeta =
217 case bowerLicense pkgMeta of
218 [] ->
219 userError NoLicenseSpecified
220 ls ->
221 unless (any isValidSPDX ls)
222 (userError InvalidLicense)
224-- |
225-- Check if a string is a valid SPDX license expression.
226--
227isValidSPDX :: String -> Bool
228isValidSPDX = (== 1) . length . SPDX.parseExpression
230extractGithub :: Text -> Maybe (D.GithubUser, D.GithubRepo)
231extractGithub = stripGitHubPrefixes
232 >>> fmap (T.splitOn "/")
233 >=> takeTwo
234 >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))
236 where
237 takeTwo :: [a] -> Maybe (a, a)
238 takeTwo [x, y] = Just (x, y)
239 takeTwo _ = Nothing
241 stripGitHubPrefixes :: Text -> Maybe Text
242 stripGitHubPrefixes = stripPrefixes [ "git://github.com/"
243 , "https://github.com/"
244 , "git@github.com:"
245 ]
247 stripPrefixes :: [Text] -> Text -> Maybe Text
248 stripPrefixes prefixes str = msum $ (`T.stripPrefix` str) <$> prefixes
250 dropDotGit :: Text -> Text
251 dropDotGit str
252 | ".git" `T.isSuffixOf` str = T.take (T.length str - 4) str
253 | otherwise = str
255readProcess' :: String -> [String] -> String -> PrepareM String
256readProcess' prog args stdin = do
257 out <- liftIO (catch (Right <$> readProcess prog args stdin)
258 (return . Left))
259 either (otherError . ProcessFailed prog args) return out
261data DependencyStatus
262 = Missing
263 -- ^ Listed in bower.json, but not installed.
264 | NoResolution
265 -- ^ In the output of `bower list --json --offline`, there was no
266 -- _resolution key. This can be caused by adding the dependency using
267 -- `bower link`, or simply copying it into bower_components instead of
268 -- installing it normally.
269 | ResolvedOther Text
270 -- ^ Resolved, but to something other than a version. The Text argument
271 -- is the resolution type. The values it can take that I'm aware of are
272 -- "commit" and "branch".
273 | ResolvedVersion Text
274 -- ^ Resolved to a version. The Text argument is the resolution tag (eg,
275 -- "v0.1.0").
276 deriving (Show, Eq)
278-- Go through all bower dependencies which contain purescript code, and
279-- extract their versions.
280--
281-- In the case where a bower dependency is taken from a particular version,
282-- that's easy; take that version. In any other case (eg, a branch, or a commit
283-- sha) we print a warning that documentation links will not work, and avoid
284-- linking to documentation for any types from that package.
285--
286-- The rationale for this is: people will prefer to use a released version
287-- where possible. If they are not using a released version, then this is
288-- probably for a reason. However, docs are only ever available for released
289-- versions. Therefore there will probably be no version of the docs which is
290-- appropriate to link to, and we should omit links.
291getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)]
292getResolvedDependencies declaredDeps = do
293 bower <- findBowerExecutable
294 depsBS <- packUtf8 <$> readProcess' bower ["list", "--json", "--offline"] ""
296 -- Check for undeclared dependencies
297 toplevels <- catchJSON (parse asToplevelDependencies depsBS)
298 warnUndeclared declaredDeps toplevels
300 deps <- catchJSON (parse asResolvedDependencies depsBS)
301 handleDeps deps
303 where
304 packUtf8 = TL.encodeUtf8 . TL.pack
305 catchJSON = flip catchLeft (internalError . JSONError FromBowerList)
307findBowerExecutable :: PrepareM String
308findBowerExecutable = do
309 mname <- liftIO . runMaybeT . msum . map (MaybeT . findExecutable) $ names
310 maybe (userError (BowerExecutableNotFound names)) return mname
311 where
312 names = case System.Info.os of
313 "mingw32" -> ["bower", "bower.cmd"]
314 _ -> ["bower"]
316-- | Extracts all dependencies and their versions from
317-- `bower list --json --offline`
318asResolvedDependencies :: Parse BowerError [(PackageName, DependencyStatus)]
319asResolvedDependencies = nubBy ((==) `on` fst) <$> go
320 where
321 go =
322 fmap (fromMaybe []) $
323 keyMay "dependencies" $
324 (++) <$> eachInObjectWithKey (parsePackageName . T.unpack)
325 asDependencyStatus
326 <*> (concatMap snd <$> eachInObject asResolvedDependencies)
328-- | Extracts only the top level dependency names from the output of
329-- `bower list --json --offline`
330asToplevelDependencies :: Parse BowerError [PackageName]
331asToplevelDependencies =
332 fmap (map fst) $
333 key "dependencies" $
334 eachInObjectWithKey (parsePackageName . T.unpack) (return ())
336asDependencyStatus :: Parse e DependencyStatus
337asDependencyStatus = do
338 isMissing <- keyOrDefault "missing" False asBool
339 if isMissing
340 then
341 return Missing
342 else
343 key "pkgMeta" $
344 keyOrDefault "_resolution" NoResolution $ do
345 type_ <- key "type" asText
346 case type_ of
347 "version" -> ResolvedVersion <$> key "tag" asText
348 other -> return (ResolvedOther other)
350warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
351warnUndeclared declared actual =
352 traverse_ (warn . UndeclaredDependency) (actual \\ declared)
354handleDeps ::
355 [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)]
356handleDeps deps = do
357 let (missing, noVersion, installed) = partitionDeps deps
358 case missing of
359 (x:xs) ->
360 userError (MissingDependencies (x :| xs))
361 [] -> do
362 traverse_ (warn . NoResolvedVersion) noVersion
363 withVersions <- catMaybes <$> traverse tryExtractVersion' installed
364 filterM (liftIO . isPureScript . bowerDir . fst) withVersions
366 where
367 partitionDeps = foldr go ([], [], [])
368 go (pkgName, d) (ms, os, is) =
369 case d of
370 Missing -> (pkgName : ms, os, is)
371 NoResolution -> (ms, pkgName : os, is)
372 ResolvedOther _ -> (ms, pkgName : os, is)
373 ResolvedVersion v -> (ms, os, (pkgName, v) : is)
375 bowerDir pkgName = "bower_components/" ++ runPackageName pkgName
377 -- Try to extract a version, and warn if unsuccessful.
378 tryExtractVersion' :: (PackageName, Text) -> PrepareM (Maybe (PackageName, Version))
379 tryExtractVersion' pair =
380 maybe (warn (UnacceptableVersion pair) >> return Nothing)
381 (return . Just)
382 (tryExtractVersion pair)
384tryExtractVersion :: (PackageName, Text) -> Maybe (PackageName, Version)
385tryExtractVersion (pkgName, tag) =
386 let tag' = fromMaybe tag (T.stripPrefix "v" tag)
387 in (pkgName,) <$> D.parseVersion' (T.unpack tag')
389-- | Returns whether it looks like there is a purescript package checked out
390-- in the given directory.
391isPureScript :: FilePath -> IO Bool
392isPureScript dir = do
393 files <- Glob.globDir1 purescriptSourceFiles dir
394 return (not (null files))
396getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])
397getInputAndDepsFiles = do
398 inputFiles <- globRelative purescriptSourceFiles
399 depsFiles' <- globRelative purescriptDepsFiles
400 return (inputFiles, mapMaybe withPackageName depsFiles')
402withPackageName :: FilePath -> Maybe (PackageName, FilePath)
403withPackageName fp = (,fp) <$> getPackageName fp
405getPackageName :: FilePath -> Maybe PackageName
406getPackageName fp = do
407 let xs = splitOn [pathSeparator] fp
408 ys <- stripPrefix ["bower_components"] xs
409 y <- headMay ys
410 case Bower.mkPackageName y of
411 Right name -> Just name
412 Left _ -> Nothing