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