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