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