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