module Language.PureScript.Publish
( preparePackage
, preparePackage'
, unsafePreparePackage
, PrepareM()
, runPrepareM
, warn
, userError
, internalError
, otherError
, PublishOptions(..)
, defaultPublishOptions
, getGitWorkingTreeStatus
, checkCleanWorkingTree
, getVersionFromGitTag
, getManifestRepositoryInfo
, getModules
) where
import Protolude hiding (stdin, lines)
import Control.Arrow ((***))
import Control.Category ((>>>))
import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell)
import qualified Data.ByteString.Lazy as BL
import Data.String (String, lines)
import Data.List (stripPrefix, (\\))
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Version
import qualified Distribution.SPDX as SPDX
import qualified Distribution.Parsec as CabalParsec
import System.Directory (doesFileExist)
import System.FilePath.Glob (globDir1)
import System.Process (readProcess)
import Web.Bower.PackageMeta (PackageMeta(..), PackageName, Repository(..))
import qualified Web.Bower.PackageMeta as Bower
import Language.PureScript.Publish.ErrorsWarnings
import Language.PureScript.Publish.Registry.Compat
import Language.PureScript.Publish.Utils
import qualified Language.PureScript as P (version, ModuleName)
import qualified Language.PureScript.CoreFn.FromJSON as P
import qualified Language.PureScript.Docs as D
import Data.Aeson.BetterErrors (Parse, withString, eachInObjectWithKey, asString, key, keyMay, parse, mapError)
import Language.PureScript.Docs.Types (ManifestError(BowerManifest, PursManifest))
data PublishOptions = PublishOptions
{
PublishOptions -> PrepareM (Text, Version)
publishGetVersion :: PrepareM (Text, Version)
, PublishOptions -> Text -> PrepareM UTCTime
publishGetTagTime :: Text -> PrepareM UTCTime
,
PublishOptions -> PrepareM ()
publishWorkingTreeDirty :: PrepareM ()
,
PublishOptions -> FilePath
publishCompileOutputDir :: FilePath
,
PublishOptions -> FilePath
publishManifestFile :: FilePath
,
PublishOptions -> FilePath
publishResolutionsFile :: FilePath
}
defaultPublishOptions :: PublishOptions
defaultPublishOptions :: PublishOptions
defaultPublishOptions = PublishOptions
{ publishGetVersion :: PrepareM (Text, Version)
publishGetVersion = PrepareM (Text, Version)
getVersionFromGitTag
, publishGetTagTime :: Text -> PrepareM UTCTime
publishGetTagTime = Text -> PrepareM UTCTime
getTagTime
, publishWorkingTreeDirty :: PrepareM ()
publishWorkingTreeDirty = forall a. UserError -> PrepareM a
userError UserError
DirtyWorkingTree
, publishCompileOutputDir :: FilePath
publishCompileOutputDir = FilePath
"output"
, publishManifestFile :: FilePath
publishManifestFile = FilePath
"bower.json"
, publishResolutionsFile :: FilePath
publishResolutionsFile = FilePath
"resolutions.json"
}
unsafePreparePackage :: PublishOptions -> IO D.UploadedPackage
unsafePreparePackage :: PublishOptions -> IO UploadedPackage
unsafePreparePackage PublishOptions
opts =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\PackageError
e -> PackageError -> IO ()
printError PackageError
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. IO a
exitFailure) forall (f :: * -> *) a. Applicative f => a -> f a
pure
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PublishOptions -> IO (Either PackageError UploadedPackage)
preparePackage PublishOptions
opts
preparePackage :: PublishOptions -> IO (Either PackageError D.UploadedPackage)
preparePackage :: PublishOptions -> IO (Either PackageError UploadedPackage)
preparePackage PublishOptions
opts =
forall a.
PrepareM a -> IO (Either PackageError (a, [PackageWarning]))
runPrepareM (PublishOptions -> PrepareM UploadedPackage
preparePackage' PublishOptions
opts)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. (b, [PackageWarning]) -> IO b
handleWarnings)
where
handleWarnings :: (b, [PackageWarning]) -> IO b
handleWarnings (b
result, [PackageWarning]
warns) = do
[PackageWarning] -> IO ()
printWarnings [PackageWarning]
warns
forall (m :: * -> *) a. Monad m => a -> m a
return b
result
newtype PrepareM a =
PrepareM { forall a.
PrepareM a -> WriterT [PackageWarning] (ExceptT PackageError IO) a
unPrepareM :: WriterT [PackageWarning] (ExceptT PackageError IO) a }
deriving (forall a b. a -> PrepareM b -> PrepareM a
forall a b. (a -> b) -> PrepareM a -> PrepareM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> PrepareM b -> PrepareM a
$c<$ :: forall a b. a -> PrepareM b -> PrepareM a
fmap :: forall a b. (a -> b) -> PrepareM a -> PrepareM b
$cfmap :: forall a b. (a -> b) -> PrepareM a -> PrepareM b
Functor, Functor PrepareM
forall a. a -> PrepareM a
forall a b. PrepareM a -> PrepareM b -> PrepareM a
forall a b. PrepareM a -> PrepareM b -> PrepareM b
forall a b. PrepareM (a -> b) -> PrepareM a -> PrepareM b
forall a b c.
(a -> b -> c) -> PrepareM a -> PrepareM b -> PrepareM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. PrepareM a -> PrepareM b -> PrepareM a
$c<* :: forall a b. PrepareM a -> PrepareM b -> PrepareM a
*> :: forall a b. PrepareM a -> PrepareM b -> PrepareM b
$c*> :: forall a b. PrepareM a -> PrepareM b -> PrepareM b
liftA2 :: forall a b c.
(a -> b -> c) -> PrepareM a -> PrepareM b -> PrepareM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> PrepareM a -> PrepareM b -> PrepareM c
<*> :: forall a b. PrepareM (a -> b) -> PrepareM a -> PrepareM b
$c<*> :: forall a b. PrepareM (a -> b) -> PrepareM a -> PrepareM b
pure :: forall a. a -> PrepareM a
$cpure :: forall a. a -> PrepareM a
Applicative, Applicative PrepareM
forall a. a -> PrepareM a
forall a b. PrepareM a -> PrepareM b -> PrepareM b
forall a b. PrepareM a -> (a -> PrepareM b) -> PrepareM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> PrepareM a
$creturn :: forall a. a -> PrepareM a
>> :: forall a b. PrepareM a -> PrepareM b -> PrepareM b
$c>> :: forall a b. PrepareM a -> PrepareM b -> PrepareM b
>>= :: forall a b. PrepareM a -> (a -> PrepareM b) -> PrepareM b
$c>>= :: forall a b. PrepareM a -> (a -> PrepareM b) -> PrepareM b
Monad,
MonadWriter [PackageWarning],
MonadError PackageError)
instance MonadIO PrepareM where
liftIO :: forall a. IO a -> PrepareM a
liftIO IO a
act =
forall a. IO a -> PrepareM a
lift' (forall e a. Exception e => IO a -> IO (Either e a)
try IO a
act) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. OtherError -> PrepareM a
otherError forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> OtherError
IOExceptionThrown) forall (m :: * -> *) a. Monad m => a -> m a
return
where
lift' :: IO a -> PrepareM a
lift' :: forall a. IO a -> PrepareM a
lift' = forall a.
WriterT [PackageWarning] (ExceptT PackageError IO) a -> PrepareM a
PrepareM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
runPrepareM :: PrepareM a -> IO (Either PackageError (a, [PackageWarning]))
runPrepareM :: forall a.
PrepareM a -> IO (Either PackageError (a, [PackageWarning]))
runPrepareM = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
PrepareM a -> WriterT [PackageWarning] (ExceptT PackageError IO) a
unPrepareM
warn :: PackageWarning -> PrepareM ()
warn :: PackageWarning -> PrepareM ()
warn PackageWarning
w = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [PackageWarning
w]
userError :: UserError -> PrepareM a
userError :: forall a. UserError -> PrepareM a
userError = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserError -> PackageError
UserError
internalError :: InternalError -> PrepareM a
internalError :: forall a. InternalError -> PrepareM a
internalError = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalError -> PackageError
InternalError
otherError :: OtherError -> PrepareM a
otherError :: forall a. OtherError -> PrepareM a
otherError = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. OtherError -> PackageError
OtherError
catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
catchLeft :: forall (f :: * -> *) a b.
Applicative f =>
Either a b -> (a -> f b) -> f b
catchLeft Either a b
a a -> f b
f = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> f b
f forall (f :: * -> *) a. Applicative f => a -> f a
pure Either a b
a
preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage
preparePackage' :: PublishOptions -> PrepareM UploadedPackage
preparePackage' PublishOptions
opts = do
PublishOptions -> PrepareM ()
checkCleanWorkingTree PublishOptions
opts
let manifestPath :: FilePath
manifestPath = PublishOptions -> FilePath
publishManifestFile PublishOptions
opts
PackageMeta
pkgMeta <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e a. Exception e => IO a -> IO (Either e a)
try (FilePath -> IO ByteString
BL.readFile FilePath
manifestPath)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (IOException
_ :: IOException) ->
forall a. UserError -> PrepareM a
userError forall a b. (a -> b) -> a -> b
$ FilePath -> UserError
PackageManifestNotFound FilePath
manifestPath
Right ByteString
found -> do
let isPursJson :: Bool
isPursJson = Text
"purs.json" Text -> Text -> Bool
`T.isInfixOf` FilePath -> Text
T.pack FilePath
manifestPath
if Bool
isPursJson then do
PursJson
pursJson <- forall (f :: * -> *) a b.
Applicative f =>
Either a b -> (a -> f b) -> f b
catchLeft (forall err a.
Parse err a -> ByteString -> Either (ParseError err) a
parse (forall (m :: * -> *) err err' a.
Functor m =>
(err -> err') -> ParseT err m a -> ParseT err' m a
mapError PursJsonError -> ManifestError
PursManifest Parse PursJsonError PursJson
asPursJson) ByteString
found) (forall a. UserError -> PrepareM a
userError forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError ManifestError -> UserError
CouldntDecodePackageManifest)
forall (f :: * -> *) a b.
Applicative f =>
Either a b -> (a -> f b) -> f b
catchLeft (PursJson -> Either BowerError PackageMeta
toBowerPackage PursJson
pursJson) (forall a. UserError -> PrepareM a
userError forall b c a. (b -> c) -> (a -> b) -> a -> c
. BowerError -> UserError
CouldntConvertPackageManifest)
else
forall (f :: * -> *) a b.
Applicative f =>
Either a b -> (a -> f b) -> f b
catchLeft (forall err a.
Parse err a -> ByteString -> Either (ParseError err) a
parse (forall (m :: * -> *) err err' a.
Functor m =>
(err -> err') -> ParseT err m a -> ParseT err' m a
mapError BowerError -> ManifestError
BowerManifest Parse BowerError PackageMeta
Bower.asPackageMeta) ByteString
found) (forall a. UserError -> PrepareM a
userError forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError ManifestError -> UserError
CouldntDecodePackageManifest)
PackageMeta -> PrepareM ()
checkLicense PackageMeta
pkgMeta
(Text
pkgVersionTag, Version
pkgVersion) <- PublishOptions -> PrepareM (Text, Version)
publishGetVersion PublishOptions
opts
Maybe UTCTime
pkgTagTime <- forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PublishOptions -> Text -> PrepareM UTCTime
publishGetTagTime PublishOptions
opts Text
pkgVersionTag
(GithubUser, GithubRepo)
pkgGithub <- PackageMeta -> PrepareM (GithubUser, GithubRepo)
getManifestRepositoryInfo PackageMeta
pkgMeta
[(PackageName, (FilePath, DependencyStatus))]
resolvedDeps <- FilePath -> PrepareM [(PackageName, (FilePath, DependencyStatus))]
parseResolutionsFile (PublishOptions -> FilePath
publishResolutionsFile PublishOptions
opts)
([Module]
pkgModules, Map ModuleName PackageName
pkgModuleMap) <- PublishOptions
-> [(PackageName, FilePath)]
-> PrepareM ([Module], Map ModuleName PackageName)
getModules PublishOptions
opts (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a, b) -> a
fst) [(PackageName, (FilePath, DependencyStatus))]
resolvedDeps)
let declaredDeps :: [PackageName]
declaredDeps = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ PackageMeta -> [(PackageName, VersionRange)]
Bower.bowerDependencies PackageMeta
pkgMeta
[(PackageName, Version)]
pkgResolvedDependencies <- [PackageName]
-> [(PackageName, DependencyStatus)]
-> PrepareM [(PackageName, Version)]
handleDeps [PackageName]
declaredDeps (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a, b) -> b
snd) [(PackageName, (FilePath, DependencyStatus))]
resolvedDeps)
let pkgUploader :: NotYetKnown
pkgUploader = NotYetKnown
D.NotYetKnown
let pkgCompilerVersion :: Version
pkgCompilerVersion = Version
P.version
forall (m :: * -> *) a. Monad m => a -> m a
return D.Package{[(PackageName, Version)]
[Module]
Maybe UTCTime
(GithubUser, GithubRepo)
Version
Map ModuleName PackageName
Text
PackageMeta
NotYetKnown
pkgCompilerVersion :: Version
pkgUploader :: NotYetKnown
pkgGithub :: (GithubUser, GithubRepo)
pkgResolvedDependencies :: [(PackageName, Version)]
pkgModuleMap :: Map ModuleName PackageName
pkgModules :: [Module]
pkgTagTime :: Maybe UTCTime
pkgVersionTag :: Text
pkgVersion :: Version
pkgMeta :: PackageMeta
pkgCompilerVersion :: Version
pkgUploader :: NotYetKnown
pkgResolvedDependencies :: [(PackageName, Version)]
pkgModuleMap :: Map ModuleName PackageName
pkgModules :: [Module]
pkgGithub :: (GithubUser, GithubRepo)
pkgTagTime :: Maybe UTCTime
pkgVersion :: Version
pkgVersionTag :: Text
pkgMeta :: PackageMeta
..}
getModules
:: PublishOptions
-> [(PackageName, FilePath)]
-> PrepareM ([D.Module], Map P.ModuleName PackageName)
getModules :: PublishOptions
-> [(PackageName, FilePath)]
-> PrepareM ([Module], Map ModuleName PackageName)
getModules PublishOptions
opts [(PackageName, FilePath)]
paths = do
([FilePath]
inputFiles, [(PackageName, FilePath)]
depsFiles) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([(PackageName, FilePath)]
-> IO ([FilePath], [(PackageName, FilePath)])
getInputAndDepsFiles [(PackageName, FilePath)]
paths)
([(FilePath, Module)]
modules, Map ModuleName PackageName
moduleMap) <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall (m :: * -> *).
(MonadError MultipleErrors m, MonadIO m) =>
FilePath
-> [FilePath]
-> [(PackageName, FilePath)]
-> m ([(FilePath, Module)], Map ModuleName PackageName)
D.collectDocs (PublishOptions -> FilePath
publishCompileOutputDir PublishOptions
opts) [FilePath]
inputFiles [(PackageName, FilePath)]
depsFiles))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. UserError -> PrepareM a
userError forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultipleErrors -> UserError
CompileError) forall (m :: * -> *) a. Monad m => a -> m a
return
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> b
snd [(FilePath, Module)]
modules, Map ModuleName PackageName
moduleMap)
data TreeStatus = Clean | Dirty deriving (Int -> TreeStatus -> ShowS
[TreeStatus] -> ShowS
TreeStatus -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TreeStatus] -> ShowS
$cshowList :: [TreeStatus] -> ShowS
show :: TreeStatus -> FilePath
$cshow :: TreeStatus -> FilePath
showsPrec :: Int -> TreeStatus -> ShowS
$cshowsPrec :: Int -> TreeStatus -> ShowS
Show, TreeStatus -> TreeStatus -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TreeStatus -> TreeStatus -> Bool
$c/= :: TreeStatus -> TreeStatus -> Bool
== :: TreeStatus -> TreeStatus -> Bool
$c== :: TreeStatus -> TreeStatus -> Bool
Eq, Eq TreeStatus
TreeStatus -> TreeStatus -> Bool
TreeStatus -> TreeStatus -> Ordering
TreeStatus -> TreeStatus -> TreeStatus
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TreeStatus -> TreeStatus -> TreeStatus
$cmin :: TreeStatus -> TreeStatus -> TreeStatus
max :: TreeStatus -> TreeStatus -> TreeStatus
$cmax :: TreeStatus -> TreeStatus -> TreeStatus
>= :: TreeStatus -> TreeStatus -> Bool
$c>= :: TreeStatus -> TreeStatus -> Bool
> :: TreeStatus -> TreeStatus -> Bool
$c> :: TreeStatus -> TreeStatus -> Bool
<= :: TreeStatus -> TreeStatus -> Bool
$c<= :: TreeStatus -> TreeStatus -> Bool
< :: TreeStatus -> TreeStatus -> Bool
$c< :: TreeStatus -> TreeStatus -> Bool
compare :: TreeStatus -> TreeStatus -> Ordering
$ccompare :: TreeStatus -> TreeStatus -> Ordering
Ord, Int -> TreeStatus
TreeStatus -> Int
TreeStatus -> [TreeStatus]
TreeStatus -> TreeStatus
TreeStatus -> TreeStatus -> [TreeStatus]
TreeStatus -> TreeStatus -> TreeStatus -> [TreeStatus]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TreeStatus -> TreeStatus -> TreeStatus -> [TreeStatus]
$cenumFromThenTo :: TreeStatus -> TreeStatus -> TreeStatus -> [TreeStatus]
enumFromTo :: TreeStatus -> TreeStatus -> [TreeStatus]
$cenumFromTo :: TreeStatus -> TreeStatus -> [TreeStatus]
enumFromThen :: TreeStatus -> TreeStatus -> [TreeStatus]
$cenumFromThen :: TreeStatus -> TreeStatus -> [TreeStatus]
enumFrom :: TreeStatus -> [TreeStatus]
$cenumFrom :: TreeStatus -> [TreeStatus]
fromEnum :: TreeStatus -> Int
$cfromEnum :: TreeStatus -> Int
toEnum :: Int -> TreeStatus
$ctoEnum :: Int -> TreeStatus
pred :: TreeStatus -> TreeStatus
$cpred :: TreeStatus -> TreeStatus
succ :: TreeStatus -> TreeStatus
$csucc :: TreeStatus -> TreeStatus
Enum)
getGitWorkingTreeStatus :: FilePath -> PrepareM TreeStatus
getGitWorkingTreeStatus :: FilePath -> PrepareM TreeStatus
getGitWorkingTreeStatus FilePath
manifestFilePath = do
[FilePath]
output <- FilePath -> [FilePath]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> FilePath -> PrepareM FilePath
readProcess' FilePath
"git" [FilePath
"status", FilePath
"--porcelain"] FilePath
""
let untrackedPursJson :: FilePath
untrackedPursJson = FilePath
"?? " forall a. Semigroup a => a -> a -> a
<> FilePath
manifestFilePath
let filtered :: [FilePath]
filtered = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= FilePath
untrackedPursJson) [FilePath]
output
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
filtered
then TreeStatus
Clean
else TreeStatus
Dirty
checkCleanWorkingTree :: PublishOptions -> PrepareM ()
checkCleanWorkingTree :: PublishOptions -> PrepareM ()
checkCleanWorkingTree PublishOptions
opts = do
TreeStatus
status <- FilePath -> PrepareM TreeStatus
getGitWorkingTreeStatus (PublishOptions -> FilePath
publishManifestFile PublishOptions
opts)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TreeStatus
status forall a. Eq a => a -> a -> Bool
== TreeStatus
Clean) forall a b. (a -> b) -> a -> b
$
PublishOptions -> PrepareM ()
publishWorkingTreeDirty PublishOptions
opts
getVersionFromGitTag :: PrepareM (Text, Version)
getVersionFromGitTag :: PrepareM (Text, Version)
getVersionFromGitTag = do
FilePath
out <- FilePath -> [FilePath] -> FilePath -> PrepareM FilePath
readProcess' FilePath
"git" [FilePath
"tag", FilePath
"--list", FilePath
"--points-at", FilePath
"HEAD"] FilePath
""
let vs :: [FilePath]
vs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ShowS
trimWhitespace (FilePath -> [FilePath]
lines FilePath
out)
case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe (FilePath, Version)
parseMay [FilePath]
vs of
[] -> forall a. UserError -> PrepareM a
userError UserError
TagMustBeCheckedOut
[(FilePath, Version)
x] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first FilePath -> Text
T.pack (FilePath, Version)
x)
[(FilePath, Version)]
xs -> forall a. UserError -> PrepareM a
userError ([Version] -> UserError
AmbiguousVersions (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> b
snd [(FilePath, Version)]
xs))
where
trimWhitespace :: ShowS
trimWhitespace =
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. [a] -> [a]
reverse forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. [a] -> [a]
reverse
parseMay :: FilePath -> Maybe (FilePath, Version)
parseMay FilePath
str = do
FilePath
digits <- forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"v" FilePath
str
(FilePath
str,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Maybe Version
P.parseVersion' FilePath
digits
getTagTime :: Text -> PrepareM UTCTime
getTagTime :: Text -> PrepareM UTCTime
getTagTime Text
tag = do
FilePath
out <- FilePath -> [FilePath] -> FilePath -> PrepareM FilePath
readProcess' FilePath
"git" [FilePath
"log", FilePath
"-1", FilePath
"--format=%ct", Text -> FilePath
T.unpack Text
tag] FilePath
""
case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall b a. (Read b, StringConv a FilePath) => a -> Maybe b
readMaybe (FilePath -> [FilePath]
lines FilePath
out) of
[Integer
t] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> UTCTime
posixSecondsToUTCTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ Integer
t
[Integer]
_ -> forall a. InternalError -> PrepareM a
internalError (Text -> InternalError
CouldntParseGitTagDate Text
tag)
getManifestRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
getManifestRepositoryInfo :: PackageMeta -> PrepareM (GithubUser, GithubRepo)
getManifestRepositoryInfo PackageMeta
pkgMeta =
case PackageMeta -> Maybe Repository
bowerRepository PackageMeta
pkgMeta of
Maybe Repository
Nothing -> do
Maybe Text
giturl <- forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> FilePath -> PrepareM FilePath
readProcess' FilePath
"git" [FilePath
"config", FilePath
"remote.origin.url"] FilePath
"")
(forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing))
forall a. UserError -> PrepareM a
userError (RepositoryFieldError -> UserError
BadRepositoryField (Maybe Text -> RepositoryFieldError
RepositoryFieldMissing (Maybe Text
giturl forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe (GithubUser, GithubRepo)
extractGithub forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (GithubUser, GithubRepo) -> Text
format)))
Just Repository{Text
repositoryUrl :: Repository -> Text
repositoryType :: Repository -> Text
repositoryType :: Text
repositoryUrl :: Text
..} -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
repositoryType forall a. Eq a => a -> a -> Bool
== Text
"git")
(forall a. UserError -> PrepareM a
userError (RepositoryFieldError -> UserError
BadRepositoryField (Text -> RepositoryFieldError
BadRepositoryType Text
repositoryType)))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. UserError -> PrepareM a
userError (RepositoryFieldError -> UserError
BadRepositoryField RepositoryFieldError
NotOnGithub)) forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe (GithubUser, GithubRepo)
extractGithub Text
repositoryUrl)
where
format :: (D.GithubUser, D.GithubRepo) -> Text
format :: (GithubUser, GithubRepo) -> Text
format (GithubUser
user, GithubRepo
repo) = Text
"https://github.com/" forall a. Semigroup a => a -> a -> a
<> GithubUser -> Text
D.runGithubUser GithubUser
user forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> GithubRepo -> Text
D.runGithubRepo GithubRepo
repo forall a. Semigroup a => a -> a -> a
<> Text
".git"
checkLicense :: PackageMeta -> PrepareM ()
checkLicense :: PackageMeta -> PrepareM ()
checkLicense PackageMeta
pkgMeta =
case PackageMeta -> [Text]
bowerLicense PackageMeta
pkgMeta of
[] ->
forall a. UserError -> PrepareM a
userError UserError
NoLicenseSpecified
[Text]
ls ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> Bool
isValidSPDX forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack) [Text]
ls)
(forall a. UserError -> PrepareM a
userError UserError
InvalidLicense)
isValidSPDX :: String -> Bool
isValidSPDX :: FilePath -> Bool
isValidSPDX FilePath
input = case forall a. Parsec a => FilePath -> Maybe a
CabalParsec.simpleParsec FilePath
input of
Maybe License
Nothing -> Bool
False
Just License
SPDX.NONE -> Bool
False
Just License
_ -> Bool
True
extractGithub :: Text -> Maybe (D.GithubUser, D.GithubRepo)
= Text -> Maybe Text
stripGitHubPrefixes
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> [Text]
T.splitOn Text
"/")
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a. [a] -> Maybe (a, a)
takeTwo
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> GithubUser
D.GithubUser forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Text -> GithubRepo
D.GithubRepo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
dropDotGit))
where
takeTwo :: [a] -> Maybe (a, a)
takeTwo :: forall a. [a] -> Maybe (a, a)
takeTwo [a
x, a
y] = forall a. a -> Maybe a
Just (a
x, a
y)
takeTwo [a]
_ = forall a. Maybe a
Nothing
stripGitHubPrefixes :: Text -> Maybe Text
stripGitHubPrefixes :: Text -> Maybe Text
stripGitHubPrefixes = [Text] -> Text -> Maybe Text
stripPrefixes [ Text
"git://github.com/"
, Text
"https://github.com/"
, Text
"git@github.com:"
]
stripPrefixes :: [Text] -> Text -> Maybe Text
stripPrefixes :: [Text] -> Text -> Maybe Text
stripPrefixes [Text]
prefixes Text
str = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ (Text -> Text -> Maybe Text
`T.stripPrefix` Text
str) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
prefixes
dropDotGit :: Text -> Text
dropDotGit :: Text -> Text
dropDotGit Text
str
| Text
".git" Text -> Text -> Bool
`T.isSuffixOf` Text
str = Int -> Text -> Text
T.take (Text -> Int
T.length Text
str forall a. Num a => a -> a -> a
- Int
4) Text
str
| Bool
otherwise = Text
str
readProcess' :: String -> [String] -> String -> PrepareM String
readProcess' :: FilePath -> [FilePath] -> FilePath -> PrepareM FilePath
readProcess' FilePath
prog [FilePath]
args FilePath
stdin = do
Either IOException FilePath
out <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
prog [FilePath]
args FilePath
stdin)
(forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. OtherError -> PrepareM a
otherError forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> IOException -> OtherError
ProcessFailed FilePath
prog [FilePath]
args) forall (m :: * -> *) a. Monad m => a -> m a
return Either IOException FilePath
out
data DependencyStatus
= NoResolution
| ResolvedOther Text
| ResolvedVersion Version
deriving (Int -> DependencyStatus -> ShowS
[DependencyStatus] -> ShowS
DependencyStatus -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DependencyStatus] -> ShowS
$cshowList :: [DependencyStatus] -> ShowS
show :: DependencyStatus -> FilePath
$cshow :: DependencyStatus -> FilePath
showsPrec :: Int -> DependencyStatus -> ShowS
$cshowsPrec :: Int -> DependencyStatus -> ShowS
Show, DependencyStatus -> DependencyStatus -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DependencyStatus -> DependencyStatus -> Bool
$c/= :: DependencyStatus -> DependencyStatus -> Bool
== :: DependencyStatus -> DependencyStatus -> Bool
$c== :: DependencyStatus -> DependencyStatus -> Bool
Eq)
parseResolutionsFile :: FilePath -> PrepareM [(PackageName, (FilePath, DependencyStatus))]
parseResolutionsFile :: FilePath -> PrepareM [(PackageName, (FilePath, DependencyStatus))]
parseResolutionsFile FilePath
resolutionsFile = do
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
resolutionsFile)) (forall a. UserError -> PrepareM a
userError UserError
ResolutionsFileNotFound)
ByteString
depsBS <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ByteString
BL.readFile FilePath
resolutionsFile)
case forall err a.
Parse err a -> ByteString -> Either (ParseError err) a
parse Parse PackageError [(PackageName, (FilePath, DependencyStatus))]
asResolutions ByteString
depsBS of
Right [(PackageName, (FilePath, DependencyStatus))]
res ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(PackageName, (FilePath, DependencyStatus))]
res
Left ParseError PackageError
err ->
forall a. UserError -> PrepareM a
userError forall a b. (a -> b) -> a -> b
$ FilePath -> ParseError PackageError -> UserError
ResolutionsFileError FilePath
resolutionsFile ParseError PackageError
err
asResolutions :: Parse D.PackageError [(PackageName, (FilePath, DependencyStatus))]
asResolutions :: Parse PackageError [(PackageName, (FilePath, DependencyStatus))]
asResolutions =
forall (m :: * -> *) err k a.
(Functor m, Monad m) =>
(Text -> Either err k) -> ParseT err m a -> ParseT err m [(k, a)]
eachInObjectWithKey Text -> Either PackageError PackageName
parsePackageName forall a b. (a -> b) -> a -> b
$
(,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
key Text
"path" forall (m :: * -> *) err.
(Functor m, Monad m) =>
ParseT err m FilePath
asString
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall b a. b -> (a -> b) -> Maybe a -> b
maybe DependencyStatus
NoResolution Version -> DependencyStatus
ResolvedVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m (Maybe a)
keyMay Text
"version" Parse PackageError Version
asVersion)
asVersion :: Parse D.PackageError Version
asVersion :: Parse PackageError Version
asVersion =
forall (m :: * -> *) err a.
(Functor m, Monad m) =>
(FilePath -> Either err a) -> ParseT err m a
withString (forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note PackageError
D.InvalidVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Version
P.parseVersion')
parsePackageName :: Text -> Either D.PackageError PackageName
parsePackageName :: Text -> Either PackageError PackageName
parsePackageName = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ManifestError -> PackageError
D.ErrorInPackageMeta forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a' b. (a -> a') -> Either a b -> Either a' b
D.mapLeft BowerError -> ManifestError
BowerManifest forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either BowerError PackageName
Bower.parsePackageName
handleDeps
:: [PackageName]
-> [(PackageName, DependencyStatus)]
-> PrepareM [(PackageName, Version)]
handleDeps :: [PackageName]
-> [(PackageName, DependencyStatus)]
-> PrepareM [(PackageName, Version)]
handleDeps [PackageName]
declared [(PackageName, DependencyStatus)]
resolutions = do
let missing :: [PackageName]
missing = [PackageName]
declared forall a. Eq a => [a] -> [a] -> [a]
\\ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> a
fst [(PackageName, DependencyStatus)]
resolutions
case [PackageName]
missing of
(PackageName
x:[PackageName]
xs) ->
forall a. UserError -> PrepareM a
userError (NonEmpty PackageName -> UserError
MissingDependencies (PackageName
x forall a. a -> [a] -> NonEmpty a
:| [PackageName]
xs))
[] -> do
[Maybe (PackageName, Version)]
pkgs <-
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(PackageName, DependencyStatus)]
resolutions forall a b. (a -> b) -> a -> b
$ \(PackageName
pkgName, DependencyStatus
status) ->
case DependencyStatus
status of
DependencyStatus
NoResolution -> do
PackageWarning -> PrepareM ()
warn (PackageName -> PackageWarning
NoResolvedVersion PackageName
pkgName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
ResolvedOther Text
other -> do
PackageWarning -> PrepareM ()
warn ((PackageName, Text) -> PackageWarning
UnacceptableVersion (PackageName
pkgName, Text
other))
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
ResolvedVersion Version
version ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (PackageName
pkgName, Version
version))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [Maybe a] -> [a]
catMaybes [Maybe (PackageName, Version)]
pkgs)
getInputAndDepsFiles
:: [(PackageName, FilePath)]
-> IO ([FilePath], [(PackageName, FilePath)])
getInputAndDepsFiles :: [(PackageName, FilePath)]
-> IO ([FilePath], [(PackageName, FilePath)])
getInputAndDepsFiles [(PackageName, FilePath)]
depPaths = do
[FilePath]
inputFiles <- Pattern -> IO [FilePath]
globRelative Pattern
purescriptSourceFiles
let handleDep :: (t, FilePath) -> IO [(t, FilePath)]
handleDep (t
pkgName, FilePath
path) = do
[FilePath]
depFiles <- Pattern -> FilePath -> IO [FilePath]
globDir1 Pattern
purescriptSourceFiles FilePath
path
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (t
pkgName,) [FilePath]
depFiles)
[(PackageName, FilePath)]
depFiles <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {t}. (t, FilePath) -> IO [(t, FilePath)]
handleDep [(PackageName, FilePath)]
depPaths
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
inputFiles, [(PackageName, FilePath)]
depFiles)