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