purescript-0.15.15: tests/TestPscPublish.hs

module TestPscPublish where

import Prelude

import Control.Exception (tryJust)
import Control.Monad (void, guard)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString.Lazy (ByteString)
import Data.Time.Clock (getCurrentTime)
import Data.Aeson qualified as A
import Data.Version (Version(..))
import Data.Foldable (forM_)
import Text.PrettyPrint.Boxes qualified as Boxes
import System.Directory (listDirectory, removeDirectoryRecursive)
import System.FilePath ((</>))
import System.IO.Error (isDoesNotExistError)

import Language.PureScript.Docs (UploadedPackage, VerifiedPackage)
import Language.PureScript.Publish (PublishOptions(..), defaultPublishOptions)
import Language.PureScript.Publish qualified as Publish
import Language.PureScript.Publish.ErrorsWarnings qualified as Publish

import Test.Hspec (Expectation, Spec, context, expectationFailure, it, runIO)
import TestUtils (pushd)

spec :: Spec
spec = do
  context "preparePackage with json roundtrips" $ do
    it "purescript-prelude" $ do
      testPackage
        "tests/support/bower_components/purescript-prelude"
        "bower.json"
        "../../prelude-resolutions.json"

    it "basic example (bower.json)" $ do
      testPackage
        "tests/purs/publish/basic-example"
        "bower.json"
        "resolutions.json"

    it "basic example (purs.json)" $ do
      testPackage
        "tests/purs/publish/basic-example"
        "purs.json"
        "resolutions.json"

  context "json compatibility" $ do
    let compatDir = "tests" </> "json-compat"
    versions <- runIO $ listDirectory compatDir
    forM_ versions $ \version -> do
      context ("json produced by " ++ version) $ do
        files <- runIO $ listDirectory (compatDir </> version)
        forM_ files $ \file -> do
          it file $ do
            result <- A.eitherDecodeFileStrict' (compatDir </> version </> file)
            case result of
              Right (_ :: VerifiedPackage) ->
                pure ()
              Left err ->
                expectationFailure ("JSON parsing failed: " ++ err)

data TestResult
  = ParseFailed String
  | Mismatch ByteString ByteString -- ^ encoding before, encoding after
  | Pass ByteString
  deriving (Show)

roundTrip :: UploadedPackage -> TestResult
roundTrip pkg =
  let before' = A.encode pkg
  in case A.eitherDecode before' of
       Left err -> ParseFailed err
       Right parsed -> do
         let after' = A.encode (parsed :: UploadedPackage)
         if before' == after'
           then Pass before'
           else Mismatch before' after'

testRunOptions :: FilePath -> FilePath -> PublishOptions
testRunOptions manifestFile resolutionsFile = defaultPublishOptions
  { publishResolutionsFile = resolutionsFile
  , publishManifestFile = manifestFile
  , publishGetVersion = return testVersion
  , publishGetTagTime = const (liftIO getCurrentTime)
  , publishWorkingTreeDirty = return ()
  }
  where testVersion = ("v999.0.0", Version [999,0,0] [])

-- | Given a directory which contains a package, produce JSON from it, and then
-- | attempt to parse it again, and ensure that it doesn't change.
testPackage :: FilePath -> FilePath -> FilePath -> Expectation
testPackage packageDir manifestFile resolutionsFile = do
  res <- preparePackage packageDir manifestFile resolutionsFile
  case res of
    Left err ->
      expectationFailure $
        "Failed to produce JSON from " ++ packageDir ++ ":\n" ++
        Boxes.render (Publish.renderError err)
    Right package ->
      case roundTrip package of
        Pass _ ->
          pure ()
        ParseFailed msg ->
          expectationFailure ("Failed to re-parse: " ++ msg)
        Mismatch _ _ ->
          expectationFailure "JSON did not match"

-- A version of Publish.preparePackage suitable for use in tests. We remove the
-- output directory each time to ensure that we are actually testing the docs
-- code in the working tree as it is now (as opposed to how it was at some
-- point in the past when the tests were previously successfully run).
preparePackage :: FilePath -> FilePath -> FilePath -> IO (Either Publish.PackageError UploadedPackage)
preparePackage packageDir manifestFile resolutionsFile =
  pushd packageDir $ do
    removeDirectoryRecursiveIfPresent "output"
    Publish.preparePackage (testRunOptions manifestFile resolutionsFile)

removeDirectoryRecursiveIfPresent :: FilePath -> IO ()
removeDirectoryRecursiveIfPresent =
  void . tryJust (guard . isDoesNotExistError) . removeDirectoryRecursive