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