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