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