git.iko.soy/rowtype-yoga/purescript-native
on 03260df help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Publish.hs
411 lines 14 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE OverloadedStrings #-}
4module Language.PureScript.Publish
5 ( preparePackage
6 , preparePackage'
7 , unsafePreparePackage
8 , PrepareM()
9 , runPrepareM
10 , warn
11 , userError
12 , internalError
13 , otherError
14 , PublishOptions(..)
15 , defaultPublishOptions
16 , getGitWorkingTreeStatus
17 , checkCleanWorkingTree
18 , getVersionFromGitTag
19 , getBowerRepositoryInfo
20 , getModulesAndBookmarks
21 , getResolvedDependencies
22 ) where
24import Prelude ()
25import Prelude.Compat hiding (userError)
27import Control.Arrow ((***))
28import Control.Category ((>>>))
29import Control.Exception (catch, try)
30import Control.Monad.Error.Class (MonadError(..))
31import Control.Monad.Trans.Except
32import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
33import Control.Monad.Writer.Strict
35import Data.Aeson.BetterErrors
36import Data.Char (isSpace)
37import Data.Foldable (traverse_)
38import Data.Function (on)
39import Data.List (stripPrefix, isSuffixOf, (\\), nubBy)
40import Data.List.NonEmpty (NonEmpty(..))
41import Data.List.Split (splitOn)
42import Data.Maybe
43import Data.Version
44import qualified Data.SPDX as SPDX
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 (String, 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 (String, 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 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 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 :: String -> Maybe (D.GithubUser, D.GithubRepo)
231extractGithub = stripGitHubPrefixes
232 >>> fmap (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 :: String -> Maybe String
242 stripGitHubPrefixes = stripPrefixes [ "git://github.com/"
243 , "https://github.com/"
244 , "git@github.com:"
245 ]
247 stripPrefixes :: [String] -> String -> Maybe String
248 stripPrefixes prefixes str = msum $ (`stripPrefix` str) <$> prefixes
250 dropDotGit :: String -> String
251 dropDotGit str
252 | ".git" `isSuffixOf` str = take (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 String
270 -- ^ Resolved, but to something other than a version. The String argument
271 -- is the resolution type. The values it can take that I'm aware of are
272 -- "commit" and "branch".
273 | ResolvedVersion String
274 -- ^ Resolved to a version. The String 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" asString
346 case type_ of
347 "version" -> ResolvedVersion <$> key "tag" asString
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' pair =
379 maybe (warn (UnacceptableVersion pair) >> return Nothing)
380 (return . Just)
381 (tryExtractVersion pair)
383tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version)
384tryExtractVersion (pkgName, tag) =
385 let tag' = fromMaybe tag (stripPrefix "v" tag)
386 in (pkgName,) <$> D.parseVersion' 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