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