{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}

module Pantry.TypesSpec
    ( spec
    ) where

import Pantry.Internal.AesonExtended
import qualified Data.ByteString.Char8 as S8
import qualified Data.Yaml as Yaml
import Distribution.Types.PackageName (mkPackageName)
import Distribution.Types.Version (mkVersion)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Pantry
import Pantry.Internal
    ( Tree(..)
    , TreeEntry(..)
    , mkSafeFilePath
    , parseTree
    , renderTree
    )
import qualified Pantry.SHA256 as SHA256
import RIO
import qualified RIO.Text as T
import Test.Hspec
import Text.RawString.QQ
import RIO.Time (Day (..))

hh :: HasCallStack => String -> Property -> Spec
hh name p = it name $ do
  result <- check p
  unless result $ throwString "Hedgehog property failed" :: IO ()

genBlobKey :: Gen BlobKey
genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 10000)))

genSha256 :: Gen SHA256
genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500)

samplePLIRepo :: ByteString
samplePLIRepo =
    [r|
subdir: wai
cabal-file:
  # This is ignored, only included to make sure we get no warnings
  size: 1765
  sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410
name: wai
version: 3.2.1.2
git: https://github.com/yesodweb/wai.git
pantry-tree:
  size: 714
  sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2
commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0
|]

samplePLIRepo2 :: ByteString
samplePLIRepo2 =
    [r|
name: merkle-log
version: 0.1.0.0
git: https://github.com/kadena-io/merkle-log.git
pantry-tree:
  size: 615
  sha256: 5a99e5e41ccd675a7721a733714ba2096f4204d9010f867c5fb7095b78e2959d
commit: a7ae61d7082afe3aa1a0fd0546fc1351a2f7c376
|]

spec :: Spec
spec = do
  describe "WantedCompiler" $ do
    hh "parse/render works" $ property $ do
      wc <- forAll $
        let ghc = WCGhc <$> genVersion
            ghcjs = WCGhcjs <$> genVersion <*> genVersion
            genVersion = mkVersion <$> Gen.list (Range.linear 1 5) (Gen.int (Range.linear 0 100))
         in Gen.choice [ghc, ghcjs]
      let text = utf8BuilderToText $ display wc
      case parseWantedCompiler text of
        Left e -> throwIO e
        Right actual -> liftIO $ actual `shouldBe` wc

  describe "Tree" $ do
    hh "parse/render works" $ property $ do
      tree <- forAll $
        let sfp = do
              pieces <- Gen.list (Range.linear 1 10) sfpComponent
              let combined = T.intercalate "/" pieces
              case mkSafeFilePath combined of
                Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces
                Just sfp' -> pure sfp'
            sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum
            entry = TreeEntry
              <$> genBlobKey
              <*> Gen.choice (map pure [minBound..maxBound])
         in TreeMap <$> Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry)
      let bs = renderTree tree
      liftIO $ parseTree bs `shouldBe` Just tree

  describe "(Raw)SnapshotLayer" $ do
    let parseSl :: String -> IO RawSnapshotLayer
        parseSl str = case Yaml.decodeThrow . S8.pack $ str of
          (Just (WithJSONWarnings x _)) -> resolvePaths Nothing x
          Nothing -> fail "Can't parse RawSnapshotLayer"

    it "parses snapshot using 'resolver'" $ do
      RawSnapshotLayer{..} <- parseSl $
        "name: 'test'\n" ++
        "resolver: lts-2.10\n"
      rslParent `shouldBe` (RSLSynonym $ LTS 2 10)

    it "parses snapshot using 'snapshot'" $ do
      RawSnapshotLayer{..} <- parseSl $
        "name: 'test'\n" ++
        "snapshot: lts-2.10\n"
      rslParent `shouldBe` (RSLSynonym $ LTS 2 10)

    it "throws if both 'resolver' and 'snapshot' are present" $ do
      let go = parseSl $
                "name: 'test'\n" ++
                "resolver: lts-2.10\n" ++
                "snapshot: lts-2.10\n"
      go `shouldThrow` anyException

    it "throws if both 'snapshot' and 'compiler' are not present" $ do
      let go = parseSl "name: 'test'\n"
      go `shouldThrow` anyException

    it "works if no 'snapshot' specified" $ do
      RawSnapshotLayer{..} <- parseSl $
        "name: 'test'\n" ++
        "compiler: ghc-8.0.1\n"
      rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [8, 0, 1]))

    hh "rendering the name of an LTS to JSON" $ property $ do
      (major, minor) <- forAll $ (,)
        <$> Gen.integral (Range.linear 1 10000)
        <*> Gen.integral (Range.linear 1 10000)
      liftIO $
        Yaml.toJSON (RSLSynonym $ LTS major minor) `shouldBe`
        Yaml.String (T.pack $ concat ["lts-", show major, ".", show minor])

    hh "rendering the name of a nightly to JSON" $ property $ do
      days <- forAll $ Gen.integral $ Range.linear 1 10000000
      let day = ModifiedJulianDay days
      liftIO $
        Yaml.toJSON (RSLSynonym $ Nightly day) `shouldBe`
        Yaml.String (T.pack $ "nightly-" ++ show day)
    it "FromJSON instance for PLIRepo" $ do
      WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo
      warnings `shouldBe` []
      pli <- resolvePaths Nothing unresolvedPli
      let repoValue =
              Repo
                  { repoSubdir = "wai"
                  , repoType = RepoGit
                  , repoCommit =
                        "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0"
                  , repoUrl = "https://github.com/yesodweb/wai.git"
                  }
          pantrySha =
              SHA256.fromHexBytes
                  "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2"
      psha <- case pantrySha of
        Right psha -> pure psha
        _ -> fail "Failed decoding sha256"
      let pkgValue =
              PackageMetadata
                  { pmIdent =
                        PackageIdentifier
                            (mkPackageName "wai")
                            (mkVersion [3, 2, 1, 2])
                  , pmTreeKey = TreeKey (BlobKey psha (FileSize 714))
                  }
      pli `shouldBe` PLIRepo repoValue pkgValue

      WithJSONWarnings reparsed warnings2 <- Yaml.decodeThrow $ Yaml.encode pli
      warnings2 `shouldBe` []
      reparsed' <- resolvePaths Nothing reparsed
      reparsed' `shouldBe` pli
    it "parseHackageText parses" $ do
      let txt =
              "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058"
          hsha =
              SHA256.fromHexBytes
                  "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1"
      sha <- case hsha of
        Right sha' -> pure sha'
        _ -> fail "parseHackagetext: failed decoding the sha256"
      let Right (pkgIdentifier, blobKey) = parseHackageText txt
      blobKey `shouldBe` (BlobKey sha (FileSize 5058))
      pkgIdentifier `shouldBe`
          PackageIdentifier
              (mkPackageName "persistent")
              (mkVersion [2, 8, 2])
    it "roundtripping a PLIRepo" $ do
      WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo2
      warnings `shouldBe` []
      pli <- resolvePaths Nothing unresolvedPli
      WithJSONWarnings unresolvedPli2 warnings2 <- Yaml.decodeThrow $ Yaml.encode pli
      warnings2 `shouldBe` []
      pli2 <- resolvePaths Nothing unresolvedPli2
      pli2 `shouldBe` (pli :: PackageLocationImmutable)

  describe "completeSnapshotLocation" $ do
    let sameUrl (SLUrl txt _) (RSLUrl txt' _) txt'' =
          do
          txt `shouldBe` txt'
          txt `shouldBe` txt''
        sameUrl _ _ _ = liftIO $ error "Snapshot synonym did not complete as expected"

    it "default location for nightly-2020-01-01" $ do
      let sn = Nightly $ ModifiedJulianDay 58849
      loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn
      sameUrl loc (defaultSnapshotLocation sn)
        "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/1/1.yaml"

    it "default location for lts-15.1" $ do
      let sn = LTS 15 1
      loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn
      sameUrl loc (defaultSnapshotLocation sn)
        "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/1.yaml"