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