git.iko.soy/rowtype-yoga/purescript-native
on 36aede6 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Publish.hs
394 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 , getBowerInfo
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
130preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage
131preparePackage' opts = do
132 exists <- liftIO (doesFileExist "bower.json")
133 unless exists (userError BowerJSONNotFound)
135 checkCleanWorkingTree opts
137 pkgMeta <- liftIO (Bower.decodeFile "bower.json")
138 >>= flip catchLeft (userError . CouldntDecodeBowerJSON)
139 (pkgVersionTag, pkgVersion) <- publishGetVersion opts
140 pkgGithub <- getBowerInfo pkgMeta
141 (pkgBookmarks, pkgModules) <- getModulesAndBookmarks
143 let declaredDeps = map fst (bowerDependencies pkgMeta ++
144 bowerDevDependencies pkgMeta)
145 pkgResolvedDependencies <- getResolvedDependencies declaredDeps
147 let pkgUploader = D.NotYetKnown
148 let pkgCompilerVersion = P.version
150 return D.Package{..}
152getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
153getModulesAndBookmarks = do
154 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
155 (modules', bookmarks) <- parseAndBookmark inputFiles depsFiles
157 case runExcept (D.convertModulesInPackage modules') of
158 Right modules -> return (bookmarks, modules)
159 Left err -> userError (CompileError err)
161 where
162 parseAndBookmark inputFiles depsFiles = do
163 r <- liftIO . runExceptT $ D.parseAndBookmark inputFiles depsFiles
164 case r of
165 Right r' ->
166 return r'
167 Left err ->
168 userError (CompileError err)
170data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)
172getGitWorkingTreeStatus :: PrepareM TreeStatus
173getGitWorkingTreeStatus = do
174 out <- readProcess' "git" ["status", "--porcelain"] ""
175 return $
176 if all null . lines $ out
177 then Clean
178 else Dirty
180checkCleanWorkingTree :: PublishOptions -> PrepareM ()
181checkCleanWorkingTree opts = do
182 status <- getGitWorkingTreeStatus
183 unless (status == Clean) $
184 publishWorkingTreeDirty opts
186getVersionFromGitTag :: PrepareM (String, Version)
187getVersionFromGitTag = do
188 out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] ""
189 let vs = map trimWhitespace (lines out)
190 case mapMaybe parseMay vs of
191 [] -> userError TagMustBeCheckedOut
192 [x] -> return x
193 xs -> userError (AmbiguousVersions (map snd xs))
194 where
195 trimWhitespace =
196 dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
197 parseMay str =
198 (str,) <$> D.parseVersion' (dropPrefix "v" str)
199 dropPrefix prefix str =
200 fromMaybe str (stripPrefix prefix str)
202getBowerInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
203getBowerInfo = either (userError . BadRepositoryField) return . tryExtract
204 where
205 tryExtract pkgMeta =
206 case bowerRepository pkgMeta of
207 Nothing -> Left RepositoryFieldMissing
208 Just Repository{..} -> do
209 unless (repositoryType == "git")
210 (Left (BadRepositoryType repositoryType))
211 maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
213extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)
214extractGithub = stripGitHubPrefixes
215 >>> fmap (splitOn "/")
216 >=> takeTwo
217 >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))
219 where
220 takeTwo :: [a] -> Maybe (a, a)
221 takeTwo [x, y] = Just (x, y)
222 takeTwo _ = Nothing
224 stripGitHubPrefixes :: String -> Maybe String
225 stripGitHubPrefixes = stripPrefixes [ "git://github.com/"
226 , "https://github.com/"
227 , "git@github.com:"
228 ]
230 stripPrefixes :: [String] -> String -> Maybe String
231 stripPrefixes prefixes str = msum $ (`stripPrefix` str) <$> prefixes
233 dropDotGit :: String -> String
234 dropDotGit str
235 | ".git" `isSuffixOf` str = take (length str - 4) str
236 | otherwise = str
238readProcess' :: String -> [String] -> String -> PrepareM String
239readProcess' prog args stdin = do
240 out <- liftIO (catch (Right <$> readProcess prog args stdin)
241 (return . Left))
242 either (otherError . ProcessFailed prog args) return out
244data DependencyStatus
245 = Missing
246 -- ^ Listed in bower.json, but not installed.
247 | NoResolution
248 -- ^ In the output of `bower list --json --offline`, there was no
249 -- _resolution key. This can be caused by adding the dependency using
250 -- `bower link`, or simply copying it into bower_components instead of
251 -- installing it normally.
252 | ResolvedOther String
253 -- ^ Resolved, but to something other than a version. The String argument
254 -- is the resolution type. The values it can take that I'm aware of are
255 -- "commit" and "branch".
256 | ResolvedVersion String
257 -- ^ Resolved to a version. The String argument is the resolution tag (eg,
258 -- "v0.1.0").
259 deriving (Show, Read, Eq)
261-- Go through all bower dependencies which contain purescript code, and
262-- extract their versions.
263--
264-- In the case where a bower dependency is taken from a particular version,
265-- that's easy; take that version. In any other case (eg, a branch, or a commit
266-- sha) we print a warning that documentation links will not work, and avoid
267-- linking to documentation for any types from that package.
268--
269-- The rationale for this is: people will prefer to use a released version
270-- where possible. If they are not using a released version, then this is
271-- probably for a reason. However, docs are only ever available for released
272-- versions. Therefore there will probably be no version of the docs which is
273-- appropriate to link to, and we should omit links.
274getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)]
275getResolvedDependencies declaredDeps = do
276 bower <- findBowerExecutable
277 depsBS <- packUtf8 <$> readProcess' bower ["list", "--json", "--offline"] ""
279 -- Check for undeclared dependencies
280 toplevels <- catchJSON (parse asToplevelDependencies depsBS)
281 warnUndeclared declaredDeps toplevels
283 deps <- catchJSON (parse asResolvedDependencies depsBS)
284 handleDeps deps
286 where
287 packUtf8 = TL.encodeUtf8 . TL.pack
288 catchJSON = flip catchLeft (internalError . JSONError FromBowerList)
290findBowerExecutable :: PrepareM String
291findBowerExecutable = do
292 mname <- liftIO . runMaybeT . msum . map (MaybeT . findExecutable) $ names
293 maybe (userError (BowerExecutableNotFound names)) return mname
294 where
295 names = case System.Info.os of
296 "mingw32" -> ["bower", "bower.cmd"]
297 _ -> ["bower"]
299-- | Extracts all dependencies and their versions from
300-- `bower list --json --offline`
301asResolvedDependencies :: Parse BowerError [(PackageName, DependencyStatus)]
302asResolvedDependencies = nubBy ((==) `on` fst) <$> go
303 where
304 go =
305 fmap (fromMaybe []) $
306 keyMay "dependencies" $
307 (++) <$> eachInObjectWithKey (parsePackageName . T.unpack)
308 asDependencyStatus
309 <*> (concatMap snd <$> eachInObject asResolvedDependencies)
311-- | Extracts only the top level dependency names from the output of
312-- `bower list --json --offline`
313asToplevelDependencies :: Parse BowerError [PackageName]
314asToplevelDependencies =
315 fmap (map fst) $
316 key "dependencies" $
317 eachInObjectWithKey (parsePackageName . T.unpack) (return ())
319asDependencyStatus :: Parse e DependencyStatus
320asDependencyStatus = do
321 isMissing <- keyOrDefault "missing" False asBool
322 if isMissing
323 then
324 return Missing
325 else
326 key "pkgMeta" $
327 keyOrDefault "_resolution" NoResolution $ do
328 type_ <- key "type" asString
329 case type_ of
330 "version" -> ResolvedVersion <$> key "tag" asString
331 other -> return (ResolvedOther other)
333warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
334warnUndeclared declared actual =
335 traverse_ (warn . UndeclaredDependency) (actual \\ declared)
337handleDeps ::
338 [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)]
339handleDeps deps = do
340 let (missing, noVersion, installed) = partitionDeps deps
341 case missing of
342 (x:xs) ->
343 userError (MissingDependencies (x :| xs))
344 [] -> do
345 traverse_ (warn . NoResolvedVersion) noVersion
346 withVersions <- catMaybes <$> traverse tryExtractVersion' installed
347 filterM (liftIO . isPureScript . bowerDir . fst) withVersions
349 where
350 partitionDeps = foldr go ([], [], [])
351 go (pkgName, d) (ms, os, is) =
352 case d of
353 Missing -> (pkgName : ms, os, is)
354 NoResolution -> (ms, pkgName : os, is)
355 ResolvedOther _ -> (ms, pkgName : os, is)
356 ResolvedVersion v -> (ms, os, (pkgName, v) : is)
358 bowerDir pkgName = "bower_components/" ++ runPackageName pkgName
360 -- Try to extract a version, and warn if unsuccessful.
361 tryExtractVersion' pair =
362 maybe (warn (UnacceptableVersion pair) >> return Nothing)
363 (return . Just)
364 (tryExtractVersion pair)
366tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version)
367tryExtractVersion (pkgName, tag) =
368 let tag' = fromMaybe tag (stripPrefix "v" tag)
369 in (pkgName,) <$> D.parseVersion' tag'
371-- | Returns whether it looks like there is a purescript package checked out
372-- in the given directory.
373isPureScript :: FilePath -> IO Bool
374isPureScript dir = do
375 files <- Glob.globDir1 purescriptSourceFiles dir
376 return (not (null files))
378getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])
379getInputAndDepsFiles = do
380 inputFiles <- globRelative purescriptSourceFiles
381 depsFiles' <- globRelative purescriptDepsFiles
382 return (inputFiles, mapMaybe withPackageName depsFiles')
384withPackageName :: FilePath -> Maybe (PackageName, FilePath)
385withPackageName fp = (,fp) <$> getPackageName fp
387getPackageName :: FilePath -> Maybe PackageName
388getPackageName fp = do
389 let xs = splitOn [pathSeparator] fp
390 ys <- stripPrefix ["bower_components"] xs
391 y <- headMay ys
392 case Bower.mkPackageName y of
393 Right name -> Just name
394 Left _ -> Nothing