git.iko.soy/rowtype-yoga/purescript-native
on e4dca75 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 #-}
5{-# LANGUAGE CPP #-}
7module Language.PureScript.Publish
8 ( preparePackage
9 , preparePackage'
10 , PrepareM()
11 , runPrepareM
12 , PublishOptions(..)
13 , defaultPublishOptions
14 , getGitWorkingTreeStatus
15 , requireCleanWorkingTree
16 , getVersionFromGitTag
17 , getBowerInfo
18 , getModulesAndBookmarks
19 , getResolvedDependencies
20 ) where
22import Prelude hiding (userError)
24import Data.Maybe
25import Data.Char (isSpace)
26import Data.String (fromString)
27import Data.List (stripPrefix, isSuffixOf, (\\), nubBy)
28import Data.List.Split (splitOn)
29import Data.List.NonEmpty (NonEmpty(..))
30import Data.Version
31import Data.Function (on)
32import Safe (headMay)
33import Data.Aeson.BetterErrors
34import qualified Data.Text as T
36#if __GLASGOW_HASKELL__ < 710
37import Control.Applicative
38#endif
39import Control.Category ((>>>))
40import Control.Arrow ((***))
41import Control.Exception (catch, try)
42import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
43import Control.Monad.Trans.Except
44import Control.Monad.Error.Class (MonadError(..))
45import Control.Monad.Writer.Strict
47import System.Directory (doesFileExist, findExecutable)
48import System.Process (readProcess)
49import System.Exit (exitFailure)
50import System.FilePath (pathSeparator)
51import qualified System.FilePath.Glob as Glob
52import qualified System.Info
54import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName,
55 runPackageName, parsePackageName, Repository(..))
56import qualified Web.Bower.PackageMeta as Bower
58import qualified Language.PureScript as P (version)
59import qualified Language.PureScript.Docs as D
60import Language.PureScript.Publish.Utils
61import Language.PureScript.Publish.ErrorsWarnings
63data PublishOptions = PublishOptions
64 { -- | How to obtain the version tag and version that the data being
65 -- generated will refer to.
66 publishGetVersion :: PrepareM (String, Version)
67 }
69defaultPublishOptions :: PublishOptions
70defaultPublishOptions = PublishOptions
71 { publishGetVersion = getVersionFromGitTag
72 }
74-- | Attempt to retrieve package metadata from the current directory.
75-- Calls exitFailure if no package metadata could be retrieved.
76preparePackage :: PublishOptions -> IO D.UploadedPackage
77preparePackage opts =
78 runPrepareM (preparePackage' opts)
79 >>= either (\e -> printError e >> exitFailure)
80 handleWarnings
81 where
82 handleWarnings (result, warns) = do
83 printWarnings warns
84 return result
86newtype PrepareM a =
87 PrepareM { unPrepareM :: WriterT [PackageWarning] (ExceptT PackageError IO) a }
88 deriving (Functor, Applicative, Monad,
89 MonadWriter [PackageWarning],
90 MonadError PackageError)
92-- This MonadIO instance ensures that IO errors don't crash the program.
93instance MonadIO PrepareM where
94 liftIO act =
95 lift' (try act) >>= either (otherError . IOExceptionThrown) return
96 where
97 lift' :: IO a -> PrepareM a
98 lift' = PrepareM . lift . lift
100runPrepareM :: PrepareM a -> IO (Either PackageError (a, [PackageWarning]))
101runPrepareM = runExceptT . runWriterT . unPrepareM
103warn :: PackageWarning -> PrepareM ()
104warn w = tell [w]
106userError :: UserError -> PrepareM a
107userError = throwError . UserError
109internalError :: InternalError -> PrepareM a
110internalError = throwError . InternalError
112otherError :: OtherError -> PrepareM a
113otherError = throwError . OtherError
115catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
116catchLeft a f = either f pure a
118preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage
119preparePackage' opts = do
120 exists <- liftIO (doesFileExist "bower.json")
121 unless exists (userError BowerJSONNotFound)
123 requireCleanWorkingTree
125 pkgMeta <- liftIO (Bower.decodeFile "bower.json")
126 >>= flip catchLeft (userError . CouldntParseBowerJSON)
127 (pkgVersionTag, pkgVersion) <- publishGetVersion opts
128 pkgGithub <- getBowerInfo pkgMeta
129 (pkgBookmarks, pkgModules) <- getModulesAndBookmarks
131 let declaredDeps = map fst (bowerDependencies pkgMeta ++
132 bowerDevDependencies pkgMeta)
133 pkgResolvedDependencies <- getResolvedDependencies declaredDeps
135 let pkgUploader = D.NotYetKnown
136 let pkgCompilerVersion = P.version
138 return D.Package{..}
140getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
141getModulesAndBookmarks = do
142 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
143 liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)
144 >>= either (userError . ParseAndDesugarError) return
145 where
146 renderModules bookmarks modules =
147 return (bookmarks, map D.convertModule modules)
149data TreeStatus = Clean | Dirty deriving (Show, Eq, Ord, Enum)
151getGitWorkingTreeStatus :: PrepareM TreeStatus
152getGitWorkingTreeStatus = do
153 out <- readProcess' "git" ["status", "--porcelain"] ""
154 return $
155 if null . filter (not . null) . lines $ out
156 then Clean
157 else Dirty
159requireCleanWorkingTree :: PrepareM ()
160requireCleanWorkingTree = do
161 status <- getGitWorkingTreeStatus
162 unless (status == Clean) $
163 userError DirtyWorkingTree
165getVersionFromGitTag :: PrepareM (String, Version)
166getVersionFromGitTag = do
167 out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] ""
168 let vs = map trimWhitespace (lines out)
169 case mapMaybe parseMay vs of
170 [] -> userError TagMustBeCheckedOut
171 [x] -> return x
172 xs -> userError (AmbiguousVersions (map snd xs))
173 where
174 trimWhitespace =
175 dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
176 parseMay str =
177 (str,) <$> D.parseVersion' (dropPrefix "v" str)
178 dropPrefix prefix str =
179 fromMaybe str (stripPrefix prefix str)
181getBowerInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
182getBowerInfo = either (userError . BadRepositoryField) return . tryExtract
183 where
184 tryExtract pkgMeta =
185 case bowerRepository pkgMeta of
186 Nothing -> Left RepositoryFieldMissing
187 Just Repository{..} -> do
188 unless (repositoryType == "git")
189 (Left (BadRepositoryType repositoryType))
190 maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
192extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)
193extractGithub =
194 stripPrefix "git://github.com/"
195 >>> fmap (splitOn "/")
196 >=> takeTwo
197 >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))
199 where
200 takeTwo :: [a] -> Maybe (a, a)
201 takeTwo [x, y] = Just (x, y)
202 takeTwo _ = Nothing
204 dropDotGit :: String -> String
205 dropDotGit str
206 | ".git" `isSuffixOf` str = take (length str - 4) str
207 | otherwise = str
209readProcess' :: String -> [String] -> String -> PrepareM String
210readProcess' prog args stdin = do
211 out <- liftIO (catch (Right <$> readProcess prog args stdin)
212 (return . Left))
213 either (otherError . ProcessFailed prog args) return out
215data DependencyStatus
216 = Missing
217 -- ^ Listed in bower.json, but not installed.
218 | NoResolution
219 -- ^ In the output of `bower list --json --offline`, there was no
220 -- _resolution key. This can be caused by adding the dependency using
221 -- `bower link`, or simply copying it into bower_components instead of
222 -- installing it normally.
223 | ResolvedOther String
224 -- ^ Resolved, but to something other than a version. The String argument
225 -- is the resolution type. The values it can take that I'm aware of are
226 -- "commit" and "branch".
227 | ResolvedVersion String
228 -- ^ Resolved to a version. The String argument is the resolution tag (eg,
229 -- "v0.1.0").
230 deriving (Show, Eq)
232-- Go through all bower dependencies which contain purescript code, and
233-- extract their versions.
234--
235-- In the case where a bower dependency is taken from a particular version,
236-- that's easy; take that version. In any other case (eg, a branch, or a commit
237-- sha) we print a warning that documentation links will not work, and avoid
238-- linking to documentation for any types from that package.
239--
240-- The rationale for this is: people will prefer to use a released version
241-- where possible. If they are not using a released version, then this is
242-- probably for a reason. However, docs are only ever available for released
243-- versions. Therefore there will probably be no version of the docs which is
244-- appropriate to link to, and we should omit links.
245getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)]
246getResolvedDependencies declaredDeps = do
247 bower <- findBowerExecutable
248 depsBS <- fromString <$> readProcess' bower ["list", "--json", "--offline"] ""
250 -- Check for undeclared dependencies
251 toplevels <- catchJSON (parse asToplevelDependencies depsBS)
252 warnUndeclared declaredDeps toplevels
254 deps <- catchJSON (parse asResolvedDependencies depsBS)
255 handleDeps deps
257 where
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 mapM_ (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 mapM_ (warn . NoResolvedVersion) noVersion
316 withVersions <- catMaybes <$> mapM 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