git.iko.soy/rowtype-yoga/purescript-native
on cd4c708 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Publish.hs
410 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.Compat hiding (userError)
26import Control.Arrow ((***))
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, isSuffixOf, (\\), nubBy)
39import Data.List.NonEmpty (NonEmpty(..))
40import Data.List.Split (splitOn)
41import Data.Maybe
42import Data.Version
43import qualified Data.SPDX as SPDX
44import qualified Data.Text as T
45import qualified Data.Text.Lazy as TL
46import qualified Data.Text.Lazy.Encoding as TL
48import Safe (headMay)
50import System.Directory (doesFileExist, findExecutable)
51import System.Exit (exitFailure)
52import System.FilePath (pathSeparator)
53import System.Process (readProcess)
54import qualified System.FilePath.Glob as Glob
55import qualified System.Info
57import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName, runPackageName, parsePackageName, Repository(..))
58import qualified Web.Bower.PackageMeta as Bower
60import Language.PureScript.Publish.ErrorsWarnings
61import Language.PureScript.Publish.Utils
62import qualified Language.PureScript as P (version)
63import qualified Language.PureScript.Docs as D
65data PublishOptions = PublishOptions
66 { -- | How to obtain the version tag and version that the data being
67 -- generated will refer to.
68 publishGetVersion :: PrepareM (String, Version)
69 , -- | What to do when the working tree is dirty
70 publishWorkingTreeDirty :: PrepareM ()
71 }
73defaultPublishOptions :: PublishOptions
74defaultPublishOptions = PublishOptions
75 { publishGetVersion = getVersionFromGitTag
76 , publishWorkingTreeDirty = userError DirtyWorkingTree
77 }
79-- | Attempt to retrieve package metadata from the current directory.
80-- Calls exitFailure if no package metadata could be retrieved.
81unsafePreparePackage :: PublishOptions -> IO D.UploadedPackage
82unsafePreparePackage opts = either (\e -> printError e >> exitFailure) pure =<< preparePackage opts
84-- | Attempt to retrieve package metadata from the current directory.
85-- Returns a PackageError on failure
86preparePackage :: PublishOptions -> IO (Either PackageError D.UploadedPackage)
87preparePackage opts =
88 runPrepareM (preparePackage' opts)
89 >>= either (pure . Left) (fmap Right . handleWarnings)
91 where
92 handleWarnings (result, warns) = do
93 printWarnings warns
94 return result
96newtype PrepareM a =
97 PrepareM { unPrepareM :: WriterT [PackageWarning] (ExceptT PackageError IO) a }
98 deriving (Functor, Applicative, Monad,
99 MonadWriter [PackageWarning],
100 MonadError PackageError)
102-- This MonadIO instance ensures that IO errors don't crash the program.
103instance MonadIO PrepareM where
104 liftIO act =
105 lift' (try act) >>= either (otherError . IOExceptionThrown) return
106 where
107 lift' :: IO a -> PrepareM a
108 lift' = PrepareM . lift . lift
110runPrepareM :: PrepareM a -> IO (Either PackageError (a, [PackageWarning]))
111runPrepareM = runExceptT . runWriterT . unPrepareM
113warn :: PackageWarning -> PrepareM ()
114warn w = tell [w]
116userError :: UserError -> PrepareM a
117userError = throwError . UserError
119internalError :: InternalError -> PrepareM a
120internalError = throwError . InternalError
122otherError :: OtherError -> PrepareM a
123otherError = throwError . OtherError
125catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
126catchLeft a f = either f pure a
128unlessM :: Monad m => m Bool -> m () -> m ()
129unlessM cond act = cond >>= flip unless act
131preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage
132preparePackage' opts = do
133 unlessM (liftIO (doesFileExist "bower.json")) (userError BowerJSONNotFound)
134 checkCleanWorkingTree opts
136 pkgMeta <- liftIO (Bower.decodeFile "bower.json")
137 >>= flip catchLeft (userError . CouldntDecodeBowerJSON)
138 checkLicense pkgMeta
140 (pkgVersionTag, pkgVersion) <- publishGetVersion opts
141 pkgGithub <- getBowerRepositoryInfo pkgMeta
142 (pkgBookmarks, pkgModules) <- getModulesAndBookmarks
144 let declaredDeps = map fst (bowerDependencies pkgMeta ++
145 bowerDevDependencies pkgMeta)
146 pkgResolvedDependencies <- getResolvedDependencies declaredDeps
148 let pkgUploader = D.NotYetKnown
149 let pkgCompilerVersion = P.version
151 return D.Package{..}
153getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
154getModulesAndBookmarks = do
155 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
156 (modules', bookmarks) <- parseAndBookmark inputFiles depsFiles
158 case runExcept (D.convertModulesInPackage modules') of
159 Right modules -> return (bookmarks, modules)
160 Left err -> userError (CompileError err)
162 where
163 parseAndBookmark inputFiles depsFiles = do
164 r <- liftIO . runExceptT $ D.parseAndBookmark inputFiles depsFiles
165 case r of
166 Right r' ->
167 return r'
168 Left err ->
169 userError (CompileError err)
171data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)
173getGitWorkingTreeStatus :: PrepareM TreeStatus
174getGitWorkingTreeStatus = do
175 out <- readProcess' "git" ["status", "--porcelain"] ""
176 return $
177 if all null . lines $ out
178 then Clean
179 else Dirty
181checkCleanWorkingTree :: PublishOptions -> PrepareM ()
182checkCleanWorkingTree opts = do
183 status <- getGitWorkingTreeStatus
184 unless (status == Clean) $
185 publishWorkingTreeDirty opts
187getVersionFromGitTag :: PrepareM (String, Version)
188getVersionFromGitTag = do
189 out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] ""
190 let vs = map trimWhitespace (lines out)
191 case mapMaybe parseMay vs of
192 [] -> userError TagMustBeCheckedOut
193 [x] -> return x
194 xs -> userError (AmbiguousVersions (map snd xs))
195 where
196 trimWhitespace =
197 dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
198 parseMay str =
199 (str,) <$> D.parseVersion' (dropPrefix "v" str)
200 dropPrefix prefix str =
201 fromMaybe str (stripPrefix prefix str)
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 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 :: String -> Maybe (D.GithubUser, D.GithubRepo)
230extractGithub = stripGitHubPrefixes
231 >>> fmap (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 :: String -> Maybe String
241 stripGitHubPrefixes = stripPrefixes [ "git://github.com/"
242 , "https://github.com/"
243 , "git@github.com:"
244 ]
246 stripPrefixes :: [String] -> String -> Maybe String
247 stripPrefixes prefixes str = msum $ (`stripPrefix` str) <$> prefixes
249 dropDotGit :: String -> String
250 dropDotGit str
251 | ".git" `isSuffixOf` str = take (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 String
269 -- ^ Resolved, but to something other than a version. The String argument
270 -- is the resolution type. The values it can take that I'm aware of are
271 -- "commit" and "branch".
272 | ResolvedVersion String
273 -- ^ Resolved to a version. The String argument is the resolution tag (eg,
274 -- "v0.1.0").
275 deriving (Show, Read, 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" asString
345 case type_ of
346 "version" -> ResolvedVersion <$> key "tag" asString
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' pair =
378 maybe (warn (UnacceptableVersion pair) >> return Nothing)
379 (return . Just)
380 (tryExtractVersion pair)
382tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version)
383tryExtractVersion (pkgName, tag) =
384 let tag' = fromMaybe tag (stripPrefix "v" tag)
385 in (pkgName,) <$> D.parseVersion' 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 y of
409 Right name -> Just name
410 Left _ -> Nothing