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