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