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