git.iko.soy/rowtype-yoga/purescript-native
on ffd3594 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Publish.hs
371 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 . ParseAndDesugarError) 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 =
200 stripPrefix "git://github.com/"
201 >>> fmap (splitOn "/")
202 >=> takeTwo
203 >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))
205 where
206 takeTwo :: [a] -> Maybe (a, a)
207 takeTwo [x, y] = Just (x, y)
208 takeTwo _ = Nothing
210 dropDotGit :: String -> String
211 dropDotGit str
212 | ".git" `isSuffixOf` str = take (length str - 4) str
213 | otherwise = str
215readProcess' :: String -> [String] -> String -> PrepareM String
216readProcess' prog args stdin = do
217 out <- liftIO (catch (Right <$> readProcess prog args stdin)
218 (return . Left))
219 either (otherError . ProcessFailed prog args) return out
221data DependencyStatus
222 = Missing
223 -- ^ Listed in bower.json, but not installed.
224 | NoResolution
225 -- ^ In the output of `bower list --json --offline`, there was no
226 -- _resolution key. This can be caused by adding the dependency using
227 -- `bower link`, or simply copying it into bower_components instead of
228 -- installing it normally.
229 | ResolvedOther String
230 -- ^ Resolved, but to something other than a version. The String argument
231 -- is the resolution type. The values it can take that I'm aware of are
232 -- "commit" and "branch".
233 | ResolvedVersion String
234 -- ^ Resolved to a version. The String argument is the resolution tag (eg,
235 -- "v0.1.0").
236 deriving (Show, Read, Eq)
238-- Go through all bower dependencies which contain purescript code, and
239-- extract their versions.
240--
241-- In the case where a bower dependency is taken from a particular version,
242-- that's easy; take that version. In any other case (eg, a branch, or a commit
243-- sha) we print a warning that documentation links will not work, and avoid
244-- linking to documentation for any types from that package.
245--
246-- The rationale for this is: people will prefer to use a released version
247-- where possible. If they are not using a released version, then this is
248-- probably for a reason. However, docs are only ever available for released
249-- versions. Therefore there will probably be no version of the docs which is
250-- appropriate to link to, and we should omit links.
251getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)]
252getResolvedDependencies declaredDeps = do
253 bower <- findBowerExecutable
254 depsBS <- packUtf8 <$> readProcess' bower ["list", "--json", "--offline"] ""
256 -- Check for undeclared dependencies
257 toplevels <- catchJSON (parse asToplevelDependencies depsBS)
258 warnUndeclared declaredDeps toplevels
260 deps <- catchJSON (parse asResolvedDependencies depsBS)
261 handleDeps deps
263 where
264 packUtf8 = TL.encodeUtf8 . TL.pack
265 catchJSON = flip catchLeft (internalError . JSONError FromBowerList)
267findBowerExecutable :: PrepareM String
268findBowerExecutable = do
269 mname <- liftIO . runMaybeT . msum . map (MaybeT . findExecutable) $ names
270 maybe (userError (BowerExecutableNotFound names)) return mname
271 where
272 names = case System.Info.os of
273 "mingw32" -> ["bower", "bower.cmd"]
274 _ -> ["bower"]
276-- | Extracts all dependencies and their versions from
277-- `bower list --json --offline`
278asResolvedDependencies :: Parse BowerError [(PackageName, DependencyStatus)]
279asResolvedDependencies = nubBy ((==) `on` fst) <$> go
280 where
281 go =
282 fmap (fromMaybe []) $
283 keyMay "dependencies" $
284 (++) <$> eachInObjectWithKey (parsePackageName . T.unpack)
285 asDependencyStatus
286 <*> (concatMap snd <$> eachInObject asResolvedDependencies)
288-- | Extracts only the top level dependency names from the output of
289-- `bower list --json --offline`
290asToplevelDependencies :: Parse BowerError [PackageName]
291asToplevelDependencies =
292 fmap (map fst) $
293 key "dependencies" $
294 eachInObjectWithKey (parsePackageName . T.unpack) (return ())
296asDependencyStatus :: Parse e DependencyStatus
297asDependencyStatus = do
298 isMissing <- keyOrDefault "missing" False asBool
299 if isMissing
300 then
301 return Missing
302 else
303 key "pkgMeta" $
304 keyOrDefault "_resolution" NoResolution $ do
305 type_ <- key "type" asString
306 case type_ of
307 "version" -> ResolvedVersion <$> key "tag" asString
308 other -> return (ResolvedOther other)
310warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
311warnUndeclared declared actual =
312 traverse_ (warn . UndeclaredDependency) (actual \\ declared)
314handleDeps ::
315 [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)]
316handleDeps deps = do
317 let (missing, noVersion, installed) = partitionDeps deps
318 case missing of
319 (x:xs) ->
320 userError (MissingDependencies (x :| xs))
321 [] -> do
322 traverse_ (warn . NoResolvedVersion) noVersion
323 withVersions <- catMaybes <$> traverse tryExtractVersion' installed
324 filterM (liftIO . isPureScript . bowerDir . fst) withVersions
326 where
327 partitionDeps = foldr go ([], [], [])
328 go (pkgName, d) (ms, os, is) =
329 case d of
330 Missing -> (pkgName : ms, os, is)
331 NoResolution -> (ms, pkgName : os, is)
332 ResolvedOther _ -> (ms, pkgName : os, is)
333 ResolvedVersion v -> (ms, os, (pkgName, v) : is)
335 bowerDir pkgName = "bower_components/" ++ runPackageName pkgName
337 -- Try to extract a version, and warn if unsuccessful.
338 tryExtractVersion' pair =
339 maybe (warn (UnacceptableVersion pair) >> return Nothing)
340 (return . Just)
341 (tryExtractVersion pair)
343tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version)
344tryExtractVersion (pkgName, tag) =
345 let tag' = fromMaybe tag (stripPrefix "v" tag)
346 in (pkgName,) <$> D.parseVersion' tag'
348-- | Returns whether it looks like there is a purescript package checked out
349-- in the given directory.
350isPureScript :: FilePath -> IO Bool
351isPureScript dir = do
352 files <- Glob.globDir1 purescriptSourceFiles dir
353 return (not (null files))
355getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])
356getInputAndDepsFiles = do
357 inputFiles <- globRelative purescriptSourceFiles
358 depsFiles' <- globRelative purescriptDepsFiles
359 return (inputFiles, mapMaybe withPackageName depsFiles')
361withPackageName :: FilePath -> Maybe (PackageName, FilePath)
362withPackageName fp = (,fp) <$> getPackageName fp
364getPackageName :: FilePath -> Maybe PackageName
365getPackageName fp = do
366 let xs = splitOn [pathSeparator] fp
367 ys <- stripPrefix ["bower_components"] xs
368 y <- headMay ys
369 case Bower.mkPackageName y of
370 Right name -> Just name
371 Left _ -> Nothing