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