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