git.iko.soy/rowtype-yoga/purescript-native
on bc257ee help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Publish.hs
314 lines 11 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE TupleSections #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6module Language.PureScript.Publish
7 ( preparePackage
8 , PrepareM()
9 , runPrepareM
10 , getVersionFromGitTag
11 , getBowerInfo
12 , getModulesAndBookmarks
13 , getResolvedDependencies
14 ) where
16import Prelude hiding (userError)
18import Data.Maybe
19import Data.Char (isSpace)
20import Data.String (fromString)
21import Data.List (stripPrefix, isSuffixOf, (\\), nubBy)
22import Data.List.Split (splitOn)
23import Data.List.NonEmpty (NonEmpty(..))
24import Data.Version
25import Data.Function (on)
26import Safe (headMay)
27import Data.Aeson.BetterErrors
28import qualified Data.Text as T
30import Control.Applicative
31import Control.Category ((>>>))
32import Control.Arrow ((***))
33import Control.Exception (catch, try)
34import Control.Monad.Trans.Except
35import Control.Monad.Error.Class (MonadError(..))
36import Control.Monad.Writer
38import System.Directory (doesFileExist)
39import System.Process (readProcess)
40import System.Exit (exitFailure)
41import qualified System.FilePath.Glob as Glob
43import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName,
44 runPackageName, parsePackageName, Repository(..))
45import qualified Web.Bower.PackageMeta as Bower
47import qualified Language.PureScript as P (version)
48import qualified Language.PureScript.Docs as D
49import Language.PureScript.Publish.Utils
50import Language.PureScript.Publish.ErrorsWarnings
52-- | Attempt to retrieve package metadata from the current directory.
53-- Calls exitFailure if no package metadata could be retrieved.
54preparePackage :: IO D.UploadedPackage
55preparePackage =
56 runPrepareM preparePackage'
57 >>= either (\e -> printError e >> exitFailure)
58 handleWarnings
59 where
60 handleWarnings (result, warns) = do
61 printWarnings warns
62 return result
64newtype PrepareM a =
65 PrepareM { unPrepareM :: WriterT [PackageWarning] (ExceptT PackageError IO) a }
66 deriving (Functor, Applicative, Monad,
67 MonadWriter [PackageWarning],
68 MonadError PackageError)
70-- This MonadIO instance ensures that IO errors don't crash the program.
71instance MonadIO PrepareM where
72 liftIO act =
73 lift' (try act) >>= either (otherError . IOExceptionThrown) return
74 where
75 lift' :: IO a -> PrepareM a
76 lift' = PrepareM . lift . lift
78runPrepareM :: PrepareM a -> IO (Either PackageError (a, [PackageWarning]))
79runPrepareM = runExceptT . runWriterT . unPrepareM
81warn :: PackageWarning -> PrepareM ()
82warn w = tell [w]
84userError :: UserError -> PrepareM a
85userError = throwError . UserError
87internalError :: InternalError -> PrepareM a
88internalError = throwError . InternalError
90otherError :: OtherError -> PrepareM a
91otherError = throwError . OtherError
93catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
94catchLeft a f = either f pure a
96preparePackage' :: PrepareM D.UploadedPackage
97preparePackage' = do
98 exists <- liftIO (doesFileExist "bower.json")
99 unless exists (userError BowerJSONNotFound)
101 pkgMeta <- liftIO (Bower.decodeFile "bower.json")
102 >>= flip catchLeft (userError . CouldntParseBowerJSON)
103 (pkgVersionTag, pkgVersion) <- getVersionFromGitTag
104 pkgGithub <- getBowerInfo pkgMeta
105 (pkgBookmarks, pkgModules) <- getModulesAndBookmarks
107 let declaredDeps = map fst (bowerDependencies pkgMeta ++
108 bowerDevDependencies pkgMeta)
109 pkgResolvedDependencies <- getResolvedDependencies declaredDeps
111 let pkgUploader = D.NotYetKnown
112 let pkgCompilerVersion = P.version
114 return D.Package{..}
116getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
117getModulesAndBookmarks = do
118 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
119 liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)
120 >>= either (userError . ParseAndDesugarError) return
121 where
122 renderModules bookmarks modules =
123 return (bookmarks, map D.convertModule modules)
125getVersionFromGitTag :: PrepareM (String, Version)
126getVersionFromGitTag = do
127 out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] ""
128 let vs = map trimWhitespace (lines out)
129 case mapMaybe parseMay vs of
130 [] -> userError TagMustBeCheckedOut
131 [x] -> return x
132 xs -> userError (AmbiguousVersions (map snd xs))
133 where
134 trimWhitespace =
135 dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
136 parseMay str =
137 (str,) <$> D.parseVersion' (dropPrefix "v" str)
138 dropPrefix prefix str =
139 fromMaybe str (stripPrefix prefix str)
141getBowerInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
142getBowerInfo = either (userError . BadRepositoryField) return . tryExtract
143 where
144 tryExtract pkgMeta =
145 case bowerRepository pkgMeta of
146 Nothing -> Left RepositoryFieldMissing
147 Just Repository{..} -> do
148 unless (repositoryType == "git")
149 (Left (BadRepositoryType repositoryType))
150 maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
152extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)
153extractGithub =
154 stripPrefix "git://github.com/"
155 >>> fmap (splitOn "/")
156 >=> takeTwo
157 >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))
159 where
160 takeTwo :: [a] -> Maybe (a, a)
161 takeTwo [x, y] = Just (x, y)
162 takeTwo _ = Nothing
164 dropDotGit :: String -> String
165 dropDotGit str
166 | ".git" `isSuffixOf` str = take (length str - 4) str
167 | otherwise = str
169readProcess' :: String -> [String] -> String -> PrepareM String
170readProcess' prog args stdin = do
171 out <- liftIO (catch (Right <$> readProcess prog args stdin)
172 (return . Left))
173 either (otherError . ProcessFailed prog args) return out
175data DependencyStatus
176 = Missing
177 -- ^ Listed in bower.json, but not installed.
178 | NoResolution
179 -- ^ In the output of `bower list --json --offline`, there was no
180 -- _resolution key. This can be caused by adding the dependency using
181 -- `bower link`, or simply copying it into bower_components instead of
182 -- installing it normally.
183 | ResolvedOther String
184 -- ^ Resolved, but to something other than a version. The String argument
185 -- is the resolution type. The values it can take that I'm aware of are
186 -- "commit" and "branch".
187 | ResolvedVersion String
188 -- ^ Resolved to a version. The String argument is the resolution tag (eg,
189 -- "v0.1.0").
190 deriving (Show, Eq)
192-- Go through all bower dependencies which contain purescript code, and
193-- extract their versions.
194--
195-- In the case where a bower dependency is taken from a particular version,
196-- that's easy; take that version. In any other case (eg, a branch, or a commit
197-- sha) we print a warning that documentation links will not work, and avoid
198-- linking to documentation for any types from that package.
199--
200-- The rationale for this is: people will prefer to use a released version
201-- where possible. If they are not using a released version, then this is
202-- probably for a reason. However, docs are only ever available for released
203-- versions. Therefore there will probably be no version of the docs which is
204-- appropriate to link to, and we should omit links.
205getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)]
206getResolvedDependencies declaredDeps = do
207 depsBS <- fromString <$> readProcess' "bower" ["list", "--json", "--offline"] ""
209 -- Check for undeclared dependencies
210 toplevels <- catchJSON (parse asToplevelDependencies depsBS)
211 warnUndeclared declaredDeps toplevels
213 deps <- catchJSON (parse asResolvedDependencies depsBS)
214 handleDeps deps
216 where
217 catchJSON = flip catchLeft (internalError . JSONError FromBowerList)
219-- | Extracts all dependencies and their versions from
220-- `bower list --json --offline`
221asResolvedDependencies :: Parse BowerError [(PackageName, DependencyStatus)]
222asResolvedDependencies = nubBy ((==) `on` fst) <$> go
223 where
224 go =
225 fmap (fromMaybe []) $
226 keyMay "dependencies" $
227 (++) <$> eachInObjectWithKey (parsePackageName . T.unpack)
228 asDependencyStatus
229 <*> (concatMap snd <$> eachInObject asResolvedDependencies)
231-- | Extracts only the top level dependency names from the output of
232-- `bower list --json --offline`
233asToplevelDependencies :: Parse BowerError [PackageName]
234asToplevelDependencies =
235 fmap (map fst) $
236 key "dependencies" $
237 eachInObjectWithKey (parsePackageName . T.unpack) (return ())
239asDependencyStatus :: Parse e DependencyStatus
240asDependencyStatus = do
241 isMissing <- keyOrDefault "missing" False asBool
242 if isMissing
243 then
244 return Missing
245 else
246 key "pkgMeta" $
247 keyOrDefault "_resolution" NoResolution $ do
248 type_ <- key "type" asString
249 case type_ of
250 "version" -> ResolvedVersion <$> key "tag" asString
251 other -> return (ResolvedOther other)
253warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
254warnUndeclared declared actual =
255 mapM_ (warn . UndeclaredDependency) (actual \\ declared)
257handleDeps ::
258 [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)]
259handleDeps deps = do
260 let (missing, noVersion, installed) = partitionDeps deps
261 case missing of
262 (x:xs) ->
263 userError (MissingDependencies (x :| xs))
264 [] -> do
265 mapM_ (warn . NoResolvedVersion) noVersion
266 withVersions <- catMaybes <$> mapM tryExtractVersion' installed
267 filterM (liftIO . isPureScript . bowerDir . fst) withVersions
269 where
270 partitionDeps = foldr go ([], [], [])
271 go (pkgName, d) (ms, os, is) =
272 case d of
273 Missing -> (pkgName : ms, os, is)
274 NoResolution -> (ms, pkgName : os, is)
275 ResolvedOther _ -> (ms, pkgName : os, is)
276 ResolvedVersion v -> (ms, os, (pkgName, v) : is)
278 bowerDir pkgName = "bower_components/" ++ runPackageName pkgName
280 -- Try to extract a version, and warn if unsuccessful.
281 tryExtractVersion' pair =
282 maybe (warn (UnacceptableVersion pair) >> return Nothing)
283 (return . Just)
284 (tryExtractVersion pair)
286tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version)
287tryExtractVersion (pkgName, tag) =
288 let tag' = fromMaybe tag (stripPrefix "v" tag)
289 in (pkgName,) <$> D.parseVersion' tag'
291-- | Returns whether it looks like there is a purescript package checked out
292-- in the given directory.
293isPureScript :: FilePath -> IO Bool
294isPureScript dir = do
295 files <- Glob.globDir1 purescriptSourceFiles dir
296 return (not (null files))
298getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])
299getInputAndDepsFiles = do
300 inputFiles <- globRelative purescriptSourceFiles
301 depsFiles' <- globRelative purescriptDepsFiles
302 return (inputFiles, mapMaybe withPackageName depsFiles')
304withPackageName :: FilePath -> Maybe (PackageName, FilePath)
305withPackageName fp = (,fp) <$> getPackageName fp
307getPackageName :: FilePath -> Maybe PackageName
308getPackageName fp = do
309 let xs = splitOn "/" fp
310 ys <- stripPrefix ["bower_components"] xs
311 y <- headMay ys
312 case Bower.mkPackageName y of
313 Right name -> Just name
314 Left _ -> Nothing