git.iko.soy/rowtype-yoga/purescript-native
on 072cadd help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Publish.hs
411 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 (T.pack repositoryUrl))
214checkLicense :: PackageMeta -> PrepareM ()
215checkLicense pkgMeta =
216 case bowerLicense pkgMeta of
217 [] ->
218 userError NoLicenseSpecified
219 ls ->
220 unless (any isValidSPDX 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 . T.unpack)
324 asDependencyStatus
325 <*> (concatMap snd <$> eachInObject asResolvedDependencies)
327-- | Extracts only the top level dependency names from the output of
328-- `bower list --json --offline`
329asToplevelDependencies :: Parse BowerError [PackageName]
330asToplevelDependencies =
331 fmap (map fst) $
332 key "dependencies" $
333 eachInObjectWithKey (parsePackageName . T.unpack) (return ())
335asDependencyStatus :: Parse e DependencyStatus
336asDependencyStatus = do
337 isMissing <- keyOrDefault "missing" False asBool
338 if isMissing
339 then
340 return Missing
341 else
342 key "pkgMeta" $
343 keyOrDefault "_resolution" NoResolution $ do
344 type_ <- key "type" asText
345 case type_ of
346 "version" -> ResolvedVersion <$> key "tag" asText
347 other -> return (ResolvedOther other)
349warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
350warnUndeclared declared actual =
351 traverse_ (warn . UndeclaredDependency) (actual \\ declared)
353handleDeps ::
354 [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)]
355handleDeps deps = do
356 let (missing, noVersion, installed) = partitionDeps deps
357 case missing of
358 (x:xs) ->
359 userError (MissingDependencies (x :| xs))
360 [] -> do
361 traverse_ (warn . NoResolvedVersion) noVersion
362 withVersions <- catMaybes <$> traverse tryExtractVersion' installed
363 filterM (liftIO . isPureScript . bowerDir . fst) withVersions
365 where
366 partitionDeps = foldr go ([], [], [])
367 go (pkgName, d) (ms, os, is) =
368 case d of
369 Missing -> (pkgName : ms, os, is)
370 NoResolution -> (ms, pkgName : os, is)
371 ResolvedOther _ -> (ms, pkgName : os, is)
372 ResolvedVersion v -> (ms, os, (pkgName, v) : is)
374 bowerDir pkgName = "bower_components/" ++ runPackageName pkgName
376 -- Try to extract a version, and warn if unsuccessful.
377 tryExtractVersion' :: (PackageName, Text) -> PrepareM (Maybe (PackageName, Version))
378 tryExtractVersion' pair =
379 maybe (warn (UnacceptableVersion pair) >> return Nothing)
380 (return . Just)
381 (tryExtractVersion pair)
383tryExtractVersion :: (PackageName, Text) -> Maybe (PackageName, Version)
384tryExtractVersion (pkgName, tag) =
385 let tag' = fromMaybe tag (T.stripPrefix "v" tag)
386 in (pkgName,) <$> D.parseVersion' (T.unpack tag')
388-- | Returns whether it looks like there is a purescript package checked out
389-- in the given directory.
390isPureScript :: FilePath -> IO Bool
391isPureScript dir = do
392 files <- Glob.globDir1 purescriptSourceFiles dir
393 return (not (null files))
395getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])
396getInputAndDepsFiles = do
397 inputFiles <- globRelative purescriptSourceFiles
398 depsFiles' <- globRelative purescriptDepsFiles
399 return (inputFiles, mapMaybe withPackageName depsFiles')
401withPackageName :: FilePath -> Maybe (PackageName, FilePath)
402withPackageName fp = (,fp) <$> getPackageName fp
404getPackageName :: FilePath -> Maybe PackageName
405getPackageName fp = do
406 let xs = splitOn [pathSeparator] fp
407 ys <- stripPrefix ["bower_components"] xs
408 y <- headMay ys
409 case Bower.mkPackageName y of
410 Right name -> Just name
411 Left _ -> Nothing