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