git.iko.soy/rowtype-yoga/purescript-native
on 9170c52 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Publish.hs
349 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 System.FilePath (pathSeparator)
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 depsBS <- fromString <$> readProcess' "bower" ["list", "--json", "--offline"] ""
244 -- Check for undeclared dependencies
245 toplevels <- catchJSON (parse asToplevelDependencies depsBS)
246 warnUndeclared declaredDeps toplevels
248 deps <- catchJSON (parse asResolvedDependencies depsBS)
249 handleDeps deps
251 where
252 catchJSON = flip catchLeft (internalError . JSONError FromBowerList)
254-- | Extracts all dependencies and their versions from
255-- `bower list --json --offline`
256asResolvedDependencies :: Parse BowerError [(PackageName, DependencyStatus)]
257asResolvedDependencies = nubBy ((==) `on` fst) <$> go
258 where
259 go =
260 fmap (fromMaybe []) $
261 keyMay "dependencies" $
262 (++) <$> eachInObjectWithKey (parsePackageName . T.unpack)
263 asDependencyStatus
264 <*> (concatMap snd <$> eachInObject asResolvedDependencies)
266-- | Extracts only the top level dependency names from the output of
267-- `bower list --json --offline`
268asToplevelDependencies :: Parse BowerError [PackageName]
269asToplevelDependencies =
270 fmap (map fst) $
271 key "dependencies" $
272 eachInObjectWithKey (parsePackageName . T.unpack) (return ())
274asDependencyStatus :: Parse e DependencyStatus
275asDependencyStatus = do
276 isMissing <- keyOrDefault "missing" False asBool
277 if isMissing
278 then
279 return Missing
280 else
281 key "pkgMeta" $
282 keyOrDefault "_resolution" NoResolution $ do
283 type_ <- key "type" asString
284 case type_ of
285 "version" -> ResolvedVersion <$> key "tag" asString
286 other -> return (ResolvedOther other)
288warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
289warnUndeclared declared actual =
290 mapM_ (warn . UndeclaredDependency) (actual \\ declared)
292handleDeps ::
293 [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)]
294handleDeps deps = do
295 let (missing, noVersion, installed) = partitionDeps deps
296 case missing of
297 (x:xs) ->
298 userError (MissingDependencies (x :| xs))
299 [] -> do
300 mapM_ (warn . NoResolvedVersion) noVersion
301 withVersions <- catMaybes <$> mapM tryExtractVersion' installed
302 filterM (liftIO . isPureScript . bowerDir . fst) withVersions
304 where
305 partitionDeps = foldr go ([], [], [])
306 go (pkgName, d) (ms, os, is) =
307 case d of
308 Missing -> (pkgName : ms, os, is)
309 NoResolution -> (ms, pkgName : os, is)
310 ResolvedOther _ -> (ms, pkgName : os, is)
311 ResolvedVersion v -> (ms, os, (pkgName, v) : is)
313 bowerDir pkgName = "bower_components/" ++ runPackageName pkgName
315 -- Try to extract a version, and warn if unsuccessful.
316 tryExtractVersion' pair =
317 maybe (warn (UnacceptableVersion pair) >> return Nothing)
318 (return . Just)
319 (tryExtractVersion pair)
321tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version)
322tryExtractVersion (pkgName, tag) =
323 let tag' = fromMaybe tag (stripPrefix "v" tag)
324 in (pkgName,) <$> D.parseVersion' tag'
326-- | Returns whether it looks like there is a purescript package checked out
327-- in the given directory.
328isPureScript :: FilePath -> IO Bool
329isPureScript dir = do
330 files <- Glob.globDir1 purescriptSourceFiles dir
331 return (not (null files))
333getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])
334getInputAndDepsFiles = do
335 inputFiles <- globRelative purescriptSourceFiles
336 depsFiles' <- globRelative purescriptDepsFiles
337 return (inputFiles, mapMaybe withPackageName depsFiles')
339withPackageName :: FilePath -> Maybe (PackageName, FilePath)
340withPackageName fp = (,fp) <$> getPackageName fp
342getPackageName :: FilePath -> Maybe PackageName
343getPackageName fp = do
344 let xs = splitOn [pathSeparator] fp
345 ys <- stripPrefix ["bower_components"] xs
346 y <- headMay ys
347 case Bower.mkPackageName y of
348 Right name -> Just name
349 Left _ -> Nothing