Publish.hs

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 Data.ByteString.Lazy qualified as BL
import Data.String (String, lines)
import Data.List (stripPrefix, (\\))
import Data.Text qualified as T
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Version (Version)
import Distribution.SPDX qualified as SPDX
import Distribution.Parsec qualified as CabalParsec

import System.Directory (doesFileExist)
import System.FilePath.Glob (globDir1)
import System.Process (readProcess)

import Web.Bower.PackageMeta (PackageMeta(..), PackageName, Repository(..))
import Web.Bower.PackageMeta qualified as Bower

import Language.PureScript.Publish.ErrorsWarnings (InternalError(..), OtherError(..), PackageError(..), PackageWarning(..), RepositoryFieldError(..), UserError(..), printError, printWarnings)
import Language.PureScript.Publish.Registry.Compat (asPursJson, toBowerPackage)
import Language.PureScript.Publish.Utils (globRelative, purescriptSourceFiles)
import Language.PureScript qualified as P (version, ModuleName)
import Language.PureScript.CoreFn.FromJSON qualified as P
import Language.PureScript.Docs qualified 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
  { -- | How to obtain the version tag and version that the data being
    -- generated will refer to.
    publishGetVersion :: PrepareM (Text, Version)
    -- | How to obtain at what time the version was committed
  , publishGetTagTime :: Text -> PrepareM UTCTime
  , -- | What to do when the working tree is dirty
    publishWorkingTreeDirty :: PrepareM ()
  , -- | Compiler output directory (which must include up-to-date docs.json
    -- files for any modules we are producing docs for).
    publishCompileOutputDir :: FilePath
  , -- | Path to the manifest file; a JSON file including information about the
    -- package, such as name, author, dependency version bounds.
    publishManifestFile :: FilePath
  , -- | Path to the resolutions file; a JSON file containing all of the
    -- package's dependencies, their versions, and their paths on the disk.
    publishResolutionsFile :: FilePath
  }

defaultPublishOptions :: PublishOptions
defaultPublishOptions = PublishOptions
  { publishGetVersion = getVersionFromGitTag
  , publishGetTagTime = getTagTime
  , publishWorkingTreeDirty = userError DirtyWorkingTree
  , publishCompileOutputDir = "output"
  , publishManifestFile = "bower.json"
  , publishResolutionsFile = "resolutions.json"
  }

-- | Attempt to retrieve package metadata from the current directory.
-- Calls exitFailure if no package metadata could be retrieved.
unsafePreparePackage :: PublishOptions -> IO D.UploadedPackage
unsafePreparePackage opts =
  either (\e -> printError e >> exitFailure) pure
    =<< preparePackage opts

-- | Attempt to retrieve package metadata from the current directory.
-- Returns a PackageError on failure
preparePackage :: PublishOptions -> IO (Either PackageError D.UploadedPackage)
preparePackage opts =
  runPrepareM (preparePackage' opts)
    >>= either (pure . Left) (fmap Right . handleWarnings)

  where
  handleWarnings (result, warns) = do
    printWarnings warns
    return result

newtype PrepareM a =
  PrepareM { unPrepareM :: WriterT [PackageWarning] (ExceptT PackageError IO) a }
  deriving (Functor, Applicative, Monad,
            MonadWriter [PackageWarning],
            MonadError PackageError)

-- This MonadIO instance ensures that IO errors don't crash the program.
instance MonadIO PrepareM where
  liftIO act =
    lift' (try act) >>= either (otherError . IOExceptionThrown) return
    where
    lift' :: IO a -> PrepareM a
    lift' = PrepareM . lift . lift

runPrepareM :: PrepareM a -> IO (Either PackageError (a, [PackageWarning]))
runPrepareM = runExceptT . runWriterT . unPrepareM

warn :: PackageWarning -> PrepareM ()
warn w = tell [w]

userError :: UserError -> PrepareM a
userError = throwError . UserError

internalError :: InternalError -> PrepareM a
internalError = throwError . InternalError

otherError :: OtherError -> PrepareM a
otherError = throwError . OtherError

catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
catchLeft a f = either f pure a

preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage
preparePackage' opts = do
  checkCleanWorkingTree opts

  let manifestPath = publishManifestFile opts
  pkgMeta <- liftIO (try (BL.readFile manifestPath)) >>= \case
    Left (_ :: IOException) ->
      userError $ PackageManifestNotFound manifestPath
    Right found -> do
      -- We can determine the type of the manifest file based on the file path,
      -- as both the PureScript and Bower registries require their manifest
      -- files to have specific names.
      let isPursJson = "purs.json" `T.isInfixOf` T.pack manifestPath
      if isPursJson then do
        pursJson <- catchLeft (parse (mapError PursManifest asPursJson) found) (userError . CouldntDecodePackageManifest)
        catchLeft (toBowerPackage pursJson) (userError . CouldntConvertPackageManifest)
      else
        catchLeft (parse (mapError BowerManifest Bower.asPackageMeta) found) (userError . CouldntDecodePackageManifest)

  checkLicense pkgMeta

  (pkgVersionTag, pkgVersion) <- publishGetVersion opts
  pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag
  pkgGithub <- getManifestRepositoryInfo pkgMeta

  resolvedDeps <- parseResolutionsFile (publishResolutionsFile opts)

  (pkgModules, pkgModuleMap)  <- getModules opts (map (second fst) resolvedDeps)

  let declaredDeps = map fst $ Bower.bowerDependencies pkgMeta
  pkgResolvedDependencies <- handleDeps declaredDeps (map (second snd) resolvedDeps)

  let pkgUploader = D.NotYetKnown
  let pkgCompilerVersion = P.version

  return D.Package{..}

getModules
  :: PublishOptions
  -> [(PackageName, FilePath)]
  -> PrepareM ([D.Module], Map P.ModuleName PackageName)
getModules opts paths = do
  (inputFiles, depsFiles) <- liftIO (getInputAndDepsFiles paths)

  (modules, moduleMap) <-
    liftIO (runExceptT (D.collectDocs (publishCompileOutputDir opts) inputFiles depsFiles))
    >>= either (userError . CompileError) return

  pure (map snd modules, moduleMap)

data TreeStatus = Clean | Dirty deriving (Show, Eq, Ord, Enum)

getGitWorkingTreeStatus :: FilePath -> PrepareM TreeStatus
getGitWorkingTreeStatus manifestFilePath = do
  output <- lines <$> readProcess' "git" ["status", "--porcelain"] ""
  -- The PureScript registry generates purs.json files when publishing legacy
  -- packages. To ensure these packages can also be published to Pursuit, we
  -- include an exemption to the working tree status check that will ignore
  -- untracked purs.json files. Note that _modified_ purs.json files will
  -- still fail this check.
  let untrackedPursJson = "?? " <> manifestFilePath
  let filtered = filter (/= untrackedPursJson) output
  return $
    if all null filtered
      then Clean
      else Dirty

checkCleanWorkingTree :: PublishOptions -> PrepareM ()
checkCleanWorkingTree opts = do
  status <- getGitWorkingTreeStatus (publishManifestFile opts)
  unless (status == Clean) $
    publishWorkingTreeDirty opts

getVersionFromGitTag :: PrepareM (Text, Version)
getVersionFromGitTag = do
  out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] ""
  let vs = map trimWhitespace (lines out)
  case mapMaybe parseMay vs of
    []  -> userError TagMustBeCheckedOut
    [x] -> return (first T.pack x)
    xs  -> userError (AmbiguousVersions (map snd xs))
  where
  trimWhitespace =
    dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
  parseMay str = do
    digits <- stripPrefix "v" str
    (str,) <$> P.parseVersion' digits

-- | Given a git tag, get the time it was created.
getTagTime :: Text -> PrepareM UTCTime
getTagTime tag = do
  out <- readProcess' "git" ["log", "-1", "--format=%ct", T.unpack tag] ""
  case mapMaybe readMaybe (lines out) of
    [t] -> pure . posixSecondsToUTCTime . fromInteger $ t
    _ -> internalError (CouldntParseGitTagDate tag)

getManifestRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
getManifestRepositoryInfo pkgMeta =
  case bowerRepository pkgMeta of
    Nothing -> do
      giturl <- catchError (Just . T.strip . T.pack <$> readProcess' "git" ["config", "remote.origin.url"] "")
                  (const (return Nothing))
      userError (BadRepositoryField (RepositoryFieldMissing (giturl >>= extractGithub <&> format)))
    Just Repository{..} -> do
      unless (repositoryType == "git")
        (userError (BadRepositoryField (BadRepositoryType repositoryType)))
      maybe (userError (BadRepositoryField NotOnGithub)) return (extractGithub repositoryUrl)

  where
    format :: (D.GithubUser, D.GithubRepo) -> Text
    format (user, repo) = "https://github.com/" <> D.runGithubUser user <> "/" <> D.runGithubRepo repo <> ".git"

checkLicense :: PackageMeta -> PrepareM ()
checkLicense pkgMeta =
  case bowerLicense pkgMeta of
    [] ->
      userError NoLicenseSpecified
    ls ->
      unless (any (isValidSPDX . T.unpack) ls)
        (userError InvalidLicense)

-- |
-- Check if a string is a valid SPDX license expression.
--
isValidSPDX :: String -> Bool
isValidSPDX input = case CabalParsec.simpleParsec input of
  Nothing -> False
  Just SPDX.NONE -> False
  Just _ -> True


extractGithub :: Text -> Maybe (D.GithubUser, D.GithubRepo)
extractGithub = stripGitHubPrefixes
   >>> fmap (T.splitOn "/")
   >=> takeTwo
   >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))

  where
  takeTwo :: [a] -> Maybe (a, a)
  takeTwo [x, y] = Just (x, y)
  takeTwo _ = Nothing

  stripGitHubPrefixes :: Text -> Maybe Text
  stripGitHubPrefixes = stripPrefixes [ "git://github.com/"
                                      , "https://github.com/"
                                      , "git@github.com:"
                                      ]

  stripPrefixes :: [Text] -> Text -> Maybe Text
  stripPrefixes prefixes str = msum $ (`T.stripPrefix` str) <$> prefixes

  dropDotGit :: Text -> Text
  dropDotGit str
    | ".git" `T.isSuffixOf` str = T.take (T.length str - 4) str
    | otherwise = str

readProcess' :: String -> [String] -> String -> PrepareM String
readProcess' prog args stdin = do
  out <- liftIO (catch (Right <$> readProcess prog args stdin)
                       (return . Left))
  either (otherError . ProcessFailed prog args) return out

data DependencyStatus
  = NoResolution
    -- ^ In the resolutions file, there was no _resolution key.
  | ResolvedOther Text
    -- ^ Resolved, but to something other than a version. The Text argument
    -- is the resolution type. The values it can take that I'm aware of are
    -- "commit" and "branch". Note: this constructor is deprecated, and is only
    -- used when parsing legacy resolutions files.
  | ResolvedVersion Version
    -- ^ Resolved to a version.
  deriving (Show, Eq)

parseResolutionsFile :: FilePath -> PrepareM [(PackageName, (FilePath, DependencyStatus))]
parseResolutionsFile resolutionsFile = do
  unlessM (liftIO (doesFileExist resolutionsFile)) (userError ResolutionsFileNotFound)
  depsBS <- liftIO (BL.readFile resolutionsFile)

  case parse asResolutions depsBS of
    Right res ->
      pure res
    Left err ->
      userError $ ResolutionsFileError resolutionsFile err

-- | Parser for resolutions files, which contain information about the packages
-- which this package depends on. A resolutions file should look something like
-- this:
--
-- {
--   "purescript-prelude": {
--      "version": "4.0.0",
--      "path": "bower_components/purescript-prelude"
--   },
--   "purescript-lists": {
--      "version": "6.0.0",
--      "path": "bower_components/purescript-lists"
--   },
--   ...
-- }
--
-- where the version is used for generating links between packages on Pursuit,
-- and the path is used to obtain the source files while generating
-- documentation: all files matching the glob "src/**/*.purs" relative to the
-- `path` directory will be picked up.
--
-- The "version" field is optional, but omitting it will mean that no links
-- will be generated for any declarations from that package on Pursuit. The
-- "path" field is required.
asResolutions :: Parse D.PackageError [(PackageName, (FilePath, DependencyStatus))]
asResolutions =
  eachInObjectWithKey parsePackageName $
    (,) <$> key "path" asString
        <*> (maybe NoResolution ResolvedVersion <$> keyMay "version" asVersion)

asVersion :: Parse D.PackageError Version
asVersion =
  withString (note D.InvalidVersion . P.parseVersion')

parsePackageName :: Text -> Either D.PackageError PackageName
parsePackageName = first D.ErrorInPackageMeta . D.mapLeft BowerManifest . Bower.parsePackageName

handleDeps
  :: [PackageName]
      -- ^ dependencies declared in package manifest file; we should emit
      -- warnings for any package name in this list which is not in the
      -- resolutions file.
  -> [(PackageName, DependencyStatus)]
      -- ^ Contents of resolutions file
  -> PrepareM [(PackageName, Version)]
handleDeps declared resolutions = do
  let missing = declared \\ map fst resolutions
  case missing of
    (x:xs) ->
      userError (MissingDependencies (x :| xs))
    [] -> do
      pkgs <-
        for resolutions $ \(pkgName, status) ->
          case status of
            NoResolution -> do
              warn (NoResolvedVersion pkgName)
              pure Nothing
            ResolvedOther other -> do
              warn (UnacceptableVersion (pkgName, other))
              pure Nothing
            ResolvedVersion version ->
              pure (Just (pkgName, version))
      pure (catMaybes pkgs)

getInputAndDepsFiles
  :: [(PackageName, FilePath)]
  -> IO ([FilePath], [(PackageName, FilePath)])
getInputAndDepsFiles depPaths = do
  inputFiles <- globRelative purescriptSourceFiles
  let handleDep (pkgName, path) = do
        depFiles <- globDir1 purescriptSourceFiles path
        return (map (pkgName,) depFiles)
  depFiles <- concat <$> traverse handleDep depPaths
  return (inputFiles, depFiles)