RefSpec.hs

{-# LANGUAGE OverloadedStrings #-}

module Tests.RefSpec (tests) where

import Control.Monad
import Control.Monad.IO.Class
import qualified Data.ByteString as B
import Data.Foldable
import Data.Maybe
import qualified Data.Set as S

import TestUtil
import Data.Git.Hash
import Data.Git.Monad
import Data.Git.Object
import Data.Git.Ref
import Data.Git.RefName

tests :: TestTree
tests = testGroup "Ref"
  [ readRefSpec
  , refIsString
  , writeBranchSpec
  , writeHeadSpec
  , readHeadSpec
  , refPathSpec
  , readBranchSpec
  , listBranchesSpec
  , peelRefSpec
  , peeledSpec
  , writeSymRefSpec
  , detachHeadSpec
  ]

readRefSpec :: TestTree
readRefSpec = testGroup "readRef"
  [ testCase "reads \"HEAD\"" $ mkRef "HEAD" @?= (Just HEAD)
  , testCase "reads branches" $
      mkRef "refs/heads/foo./bar" @?= (Just $ Branch "foo./bar")
      -- pendingWith "do a better job here (a la RefName)"
  , testCase "reads tags" $
      mkRef "refs/tags/foo./bar" @?= (Just $ TagRef "foo./bar" Nothing)
  , testCase "reads remotes" $
      mkRef "refs/remotes/origin/foo./bar" @?= (Just $ RemRef "origin" "foo./bar")
  , testCase "Can fail" $
      mkRef "" @?= Nothing
  ]

refIsString :: TestTree
refIsString = testGroup "IsString Ref"
  [ testCase "HEAD" $ "HEAD" @?= HEAD
  , testCase "branches" $
      "refs/heads/foo./bar" @?= (Branch "foo./bar")
  , testCase "tags" $
      "refs/tags/foo./bar" @?= (TagRef "foo./bar" Nothing)
  , testCase "remotes" $
      "refs/remotes/origin/foo./bar" @?= (RemRef "origin" "foo./bar")
  , testBottom "can fail" (""::Ref)
  ]

writeBranchSpec :: TestTree
writeBranchSpec = testGroup "writeBranch" $
  [ testWithRepo "writes master" $ do
      writeBranch "master" emptyTreeSha
      readBranch "master" `shouldReturn` Just emptyTreeSha
  , testWithRepo "overwrites branches" $ do
       writeBranch "master" emptyTreeSha
       writeBranch "master" notTheEmptyTreeSha
       readBranch "master" `shouldReturn` Just notTheEmptyTreeSha
  , testWithRepo "writes branches with slashes in them" $ do
      writeBranch "branch/with/slashes" emptyTreeSha
      readBranch "branch/with/slashes" `shouldReturn` Just emptyTreeSha
  ]

writeHeadSpec :: TestTree
writeHeadSpec = testGroup "writeHead"
  [ testWithRepo "writes to HEAD" $ do
      writeBranch "test_branch0" emptyTreeSha
      writeBranch "test_branch1" notTheEmptyTreeSha
      writeHead (Branch "test_branch0")
      readHead `shouldReturn` Just emptyTreeSha
      writeHead (Branch "test_branch1")
      readHead `shouldReturn` Just notTheEmptyTreeSha
  ]

readHeadSpec :: TestTree
readHeadSpec = testGroup "writeHead"
  [ testWithRepo "writes to HEAD" $ do
      writeBranch "master" emptyTreeSha
      readHead `shouldReturn` Just emptyTreeSha
  ]

refPathSpec :: TestTree
refPathSpec = testGroup "repoPath instance for Ref"
  [ testCase "finds HEAD" $ do
      findRefPath HEAD `shouldReturn` ".git/HEAD"
  , testCase "finds a branch" $ do
      findRefPath (Branch "github-pages") `shouldReturn` ".git/refs/heads/github-pages"
  , testCase "finds a tag" $ do
      findRefPath (TagRef "github-pages" Nothing) `shouldReturn` ".git/refs/tags/github-pages"
  , testCase "finds an ExpRef" $ do
      findRefPath (ExpRef "github-pages") `shouldReturn` ".git/github-pages"
  , testCase "finds remotes" $ do
      findRefPath (RemRef "github" "github-pages") `shouldReturn` ".git/refs/remotes/github/github-pages"
  ]
  where findRefPath = runGit ".git" . repoPath

readBranchSpec :: TestTree
readBranchSpec = testGroup "readBranch"
  [ testWithRepo "reads branches" $ do
      let branches = ["foo", "bar", "baz/bar"]
          shas     = sha1 . getRefName <$> branches
      zipWithM_ writeBranch branches shas
      mapM readBranch branches `shouldReturn` (Just <$> shas)
  ]

listBranchesSpec :: TestTree
listBranchesSpec = testGroup "listBranches"
  [ testWithRepo "can handle the absence of branches" $ do
      listBranches `shouldReturn` mempty
  , testWithRepo "lists all and only the branches" $ do
      let names    = ["foo", "bar", "baz/quux", "whiz", "bang"]
          branches = fromJust . refName <$> names
          tags     = fromJust . refName . B.append "tag" <$> names
          remotes  = fromJust . refName . B.append "rem" <$> names
          exps     = fromJust . refName . B.append "exp" <$> names
      traverse_ ((`writeRef` emptyTreeSha) . Branch)             $ branches
      traverse_ ((`writeRef` emptyTreeSha) . (`TagRef` Nothing)) $ tags
      traverse_ ((`writeRef` emptyTreeSha) . RemRef "origin")    $ remotes
      traverse_ ((`writeRef` emptyTreeSha) . ExpRef)             $ exps
      listBranches `shouldReturn` S.fromList branches
  ]

peelRefSpec :: TestTree
peelRefSpec = testGroup "peelRef"
  [ withPeelRefTestRepo "dereferences non-tags" $ do
      peelRef HEAD              `shouldReturn` Just emptyTreeSha
      peelRef (Branch "master") `shouldReturn` Just emptyTreeSha
      peelRef (ExpRef "exp")    `shouldReturn` Just emptyTreeSha
  , withPeelRefTestRepo "trusts peeled tags" $ do
      peelRef (TagRef "thingy" (Just emptyTreeSha)) `shouldReturn` Just emptyTreeSha
  , withPeelRefTestRepo "handles unpeeled tags" $ do
      peelRef (TagRef "tagref" Nothing) `shouldReturn` Just emptyTreeSha
  ]

withPeelRefTestRepo :: TestName -> Git () -> TestTree
withPeelRefTestRepo name git =
    testWithRepo name $ do
      writeBranch "master" emptyTreeSha
      writeRef    (ExpRef "exp") emptyTreeSha
      s <- writeTag testTag
      writeRef    (TagRef "tagref" Nothing) s
      git

peeledSpec :: TestTree
peeledSpec = testGroup "peeled"
  [ withPeelRefTestRepo "is identity non-tags" $ do
      peeled `shouldNotChange` HEAD
      peeled `shouldNotChange` Branch "master"
      peeled `shouldNotChange` RemRef "origin" "master"
      peeled `shouldNotChange` ExpRef "thingy"
  , withPeelRefTestRepo "is identity on peeled tags" $ do
      peeled `shouldNotChange` TagRef "thingy" (Just emptyTreeSha)
  , withPeelRefTestRepo "peels unpeeled tags" $ do
      peeled (TagRef "tagref" Nothing) `shouldReturn` TagRef "tagref" (Just emptyTreeSha)
  ]


writeSymRefSpec :: TestTree
writeSymRefSpec = testGroup "writeSymRef"
  [ testWithRepo "writes symrefs" $ do
      writeBranch "target" emptyTreeSha
      writeSymRef HEAD (Branch "target")
      readPath HEAD `shouldReturn` Just (SymRef (Branch "target"))

      writeSymRef (TagRef "symtag" Nothing) (Branch "target")
      readPath (TagRef "symtag" Nothing) `shouldReturn` Just (SymRef (Branch "target"))

      writeSymRef (ExpRef "symexp") (Branch "target")
      readPath (ExpRef "symexp") `shouldReturn` Just (SymRef (Branch "target"))
  ]
  where readPath = liftIO . readRefFile <=< repoPath

detachHeadSpec :: TestTree
detachHeadSpec = testGroup "detachHead"
  [ testWithRepo "writes a sha to HEAD" $ do
      detachHead emptyTreeSha
      (liftIO . readRefFile <=< repoPath $ HEAD) `shouldReturn` Just (ShaRef emptyTreeSha)
  ]