module Git.Smoke where
import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
import Data.List (sort)
import Data.Monoid
import Data.Tagged
import qualified Data.Text as T (Text, pack)
import qualified Data.Text.Encoding as T (decodeUtf8)
import Data.Time
import Data.Time.Clock.POSIX
import Data.Typeable
import Filesystem.Path.CurrentOS (FilePath, fromText, toText,
filename)
import Git
import Prelude hiding (FilePath, putStr)
import Test.HUnit
import Test.Hspec (Spec, Example, describe, it)
import Test.Hspec.Expectations
import Test.Hspec.HUnit ()
sampleCommit :: Repository m => TreeRef m -> Signature -> m (Commit m)
sampleCommit tr sig =
createCommit [] tr sig sig "Sample log message.\n" Nothing
smokeTestSpec :: (Repository (t IO), MonadGit (t IO), MonadTrans t,
Repository (t2 (t IO)), MonadGit (t2 (t IO)), MonadTrans t2,
MonadBaseControl IO (t IO))
=> RepositoryFactory t IO c
-> RepositoryFactory t2 (t IO) c2
-> Spec
smokeTestSpec pr _pr2 = describe "Smoke tests" $ do
it "create a single blob" $ withNewRepository pr "singleBlob.git" $ do
createBlobUtf8 "Hello, world!\n"
x <- catBlob "af5626b4a114abcb82d63db7c8082c3c4756e51b"
liftIO $ x @?= "Hello, world!\n"
it "create a single tree" $ withNewRepository pr "singleTree.git" $ do
hello <- createBlobUtf8 "Hello, world!\n"
tr <- createTree $ putBlob "hello/world.txt" hello
let x = renderObjOid (treeRefOid tr)
liftIO $ x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271"
toid <- Git.parseOid "c0c848a2737a6a8533a18e6bd4d04266225e0271"
tr <- lookupTree (Tagged toid)
let x = renderObjOid $ treeOid tr
liftIO $ x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271"
it "create two trees" $ withNewRepository pr "twoTrees.git" $ do
hello <- createBlobUtf8 "Hello, world!\n"
tr <- createTree $ putBlob "hello/world.txt" hello
let x = renderObjOid (treeRefOid tr)
liftIO $ x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271"
goodbye <- createBlobUtf8 "Goodbye, world!\n"
tr <- mutateTreeRef tr $ putBlob "goodbye/files/world.txt" goodbye
let x = renderObjOid (treeRefOid tr)
liftIO $ x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a"
it "delete an item from a tree" $ withNewRepository pr "deleteTree.git" $ do
hello <- createBlobUtf8 "Hello, world!\n"
tr <- createTree $ putBlob "hello/world.txt" hello
let x = renderObjOid (treeRefOid tr)
liftIO $ x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271"
tr <- mutateTreeRef tr $
putBlob "goodbye/files/world.txt"
=<< lift (createBlobUtf8 "Goodbye, world!\n")
let x = renderObjOid (treeRefOid tr)
liftIO $ x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a"
tr <- mutateTreeRef tr $ dropEntry "goodbye/files/world.txt"
let x = renderObjOid (treeRefOid tr)
liftIO $ x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271"
it "create a single commit" $ withNewRepository pr "createCommit.git" $ do
hello <- createBlobUtf8 "Hello, world!\n"
tr <- createTree $ putBlob "hello/world.txt" hello
goodbye <- createBlobUtf8 "Goodbye, world!\n"
tr <- mutateTreeRef tr $ putBlob "goodbye/files/world.txt" goodbye
let x = renderObjOid (treeRefOid tr)
liftIO $ x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a"
let sig = Signature {
signatureName = "John Wiegley"
, signatureEmail = "johnw@fpcomplete.com"
, signatureWhen = fakeTime 1348980883 }
c <- sampleCommit tr sig
let x = renderObjOid (commitOid c)
liftIO $ x @?= "4e0529eb30f53e65c1e13836e73023c9d23c25ae"
coid <- Git.parseOid "4e0529eb30f53e65c1e13836e73023c9d23c25ae"
c <- lookupCommit (Tagged coid)
let x = renderObjOid (commitOid c)
liftIO $ x @?= "4e0529eb30f53e65c1e13836e73023c9d23c25ae"
it "modify a commit" $ withNewRepository pr "modifyCommit.git" $ do
hello <- createBlobUtf8 "Hello, world!\n"
tr <- createTree $ putBlob "hello/world.txt" hello
let x = renderObjOid (treeRefOid tr)
liftIO $ x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271"
let sig = Signature {
signatureName = "John Wiegley"
, signatureEmail = "johnw@fpcomplete.com"
, signatureWhen = fakeTime 1348980883 }
c <- sampleCommit tr sig
let x = renderObjOid (commitOid c)
liftIO $ x @?= "d592871f56aa949d726fcc211370d1af305e9597"
goodbye <- createBlobUtf8 "Goodbye, world!\n"
tr' <- mutateTreeRef (Git.commitTree c) $
putBlob "hello/goodbye.txt" goodbye
let x = renderObjOid (treeRefOid tr')
liftIO $ x @?= "19974fde643bddd26c46052f7a8bdf87f7772c1e"
let sig = Signature {
signatureName = "John Wiegley"
, signatureEmail = "johnw@fpcomplete.com"
, signatureWhen = fakeTime 1348980883 }
c <- createCommit [commitRef c] tr' sig sig
"Sample log message 2.\n" (Just "refs/heads/master")
let x = renderObjOid (commitOid c)
liftIO $ x @?= "61a2c6425d2e60a480d272aa921d4f4ffe5dd20f"
it "create two commits" $ withNewRepository pr "createTwoCommits.git" $ do
hello <- createBlobUtf8 "Hello, world!\n"
tr <- createTree $ putBlob "hello/world.txt" hello
goodbye <- createBlobUtf8 "Goodbye, world!\n"
tr <- mutateTreeRef tr $ putBlob "goodbye/files/world.txt" goodbye
let x = renderObjOid (treeRefOid tr)
liftIO $ x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a"
let sig = Signature {
signatureName = "John Wiegley"
, signatureEmail = "johnw@fpcomplete.com"
, signatureWhen = fakeTime 1348980883 }
c <- sampleCommit tr sig
let x = renderObjOid (commitOid c)
liftIO $ x @?= "4e0529eb30f53e65c1e13836e73023c9d23c25ae"
goodbye2 <- createBlobUtf8 "Goodbye, world again!\n"
tr <- mutateTreeRef tr $ putBlob "goodbye/files/world.txt" goodbye2
let x = renderObjOid (treeRefOid tr)
liftIO $ x @?= "f2b42168651a45a4b7ce98464f09c7ec7c06d706"
let sig = Signature {
signatureName = "John Wiegley"
, signatureEmail = "johnw@fpcomplete.com"
, signatureWhen = fakeTime 1348981883 }
c2 <- createCommit [commitRef c] tr sig sig
"Second sample log message.\n" Nothing
let x = renderObjOid (commitOid c2)
liftIO $ x @?= "967b647bd11990d1bb15ff5209ad44a002779454"
updateReference_ "refs/heads/master" (RefObj (commitRef c2))
hasSymRefs <- hasSymbolicReferences <$> facts
when hasSymRefs $
updateReference_ "HEAD" (RefSymbolic "refs/heads/master")
Just c3 <- resolveReference "refs/heads/master"
c3 <- resolveCommitRef c3
let x = renderObjOid (commitOid c3)
liftIO $ x @?= "967b647bd11990d1bb15ff5209ad44a002779454"
refs <- allReferenceNames
liftIO $ show refs @?= "[\"refs/heads/master\"]"
return ()
it "another small test" $ withNewRepository pr "smallTest1.git" $ do
let masterRef = "refs/heads/master"
sig = Signature { signatureName = "First Name"
, signatureEmail = "user1@email.org"
, signatureWhen = fakeTime 1348981883 }
blob <- createBlobUtf8 "# Auto-createdsitory for tutorial contents\n"
tree <- createTree $ putBlob "README.md" blob
commit <- createCommit [] tree sig sig "Initial commit" Nothing
blob <- createBlobUtf8 "This is some content."
tree <- mutateTreeRef tree $ putBlob "foo.txt" blob
createCommit [commitRef commit] tree sig sig
"This is another log message." (Just masterRef)
liftIO $ True @?= True
it "traversal test" $ withNewRepository pr "traversalTest.git" $ do
let masterRef = "refs/heads/master"
sig = Signature
{ signatureName = "First Name"
, signatureEmail = "user1@email.org"
, signatureWhen = fakeTime 1348981883 }
tree <- createTree $ do
putBlob "One" =<< lift (createBlobUtf8 "One\n")
putBlob "Two" =<< lift (createBlobUtf8 "Two\n")
putBlob "Files/Three" =<< lift (createBlobUtf8 "Three\n")
putBlob "More/Four" =<< lift (createBlobUtf8 "Four\n")
putBlob "Five/More/Four" =<< lift (createBlobUtf8 "Five\n")
createCommit [] tree sig sig "Initial commit" (Just masterRef)
tree' <- resolveTreeRef tree
paths <- traverseEntries (const . return) tree'
liftIO $ sort paths @?= [ "Files"
, "Five"
, "More"
, "One"
, "Two"
, "Files/Three"
, "Five/More"
, "Five/More/Four"
, "More/Four"
]
treeit "adds a file" pr
[ Bl "one"
] $ do
putBlob "one" =<< lift (createBlobUtf8 "one\n")
treeit "adds two files" pr
[ Bl "one"
, Bl "two"
] $ do
putBlob "one" =<< lift (createBlobUtf8 "one\n")
putBlob "two" =<< lift (createBlobUtf8 "two\n")
treeit "adds three files" pr
[ Bl "one"
, Bl "three"
, Bl "two"
] $ do
putBlob "one" =<< lift (createBlobUtf8 "one\n")
putBlob "two" =<< lift (createBlobUtf8 "two\n")
putBlob "three" =<< lift (createBlobUtf8 "three\n")
treeit "adds a file at a subpath" pr
[ Tr "a"
, Bl "a/one"
] $ do
putBlob "a/one" =<< lift (createBlobUtf8 "one\n")
treeit "adds a file at a deep subpath" pr
[ Tr "a"
, Tr "a/b"
, Tr "a/b/c"
, Tr "a/b/c/d"
, Tr "a/b/c/d/e"
, Bl "a/b/c/d/e/one"
] $ do
putBlob "a/b/c/d/e/one" =<< lift (createBlobUtf8 "one\n")
treeit "adds files at multiple depths" pr
[ Tr "a"
, Tr "a/b"
, Bl "a/one"
, Tr "a/b/c"
, Bl "a/b/two"
, Tr "a/b/c/d"
, Bl "a/b/c/three"
, Tr "a/b/c/d/e"
, Bl "a/b/c/d/four"
, Bl "a/b/c/d/e/five"
] $ do
putBlob "a/one" =<< lift (createBlobUtf8 "one\n")
putBlob "a/b/two" =<< lift (createBlobUtf8 "two\n")
putBlob "a/b/c/three" =<< lift (createBlobUtf8 "three\n")
putBlob "a/b/c/d/four" =<< lift (createBlobUtf8 "four\n")
putBlob "a/b/c/d/e/five" =<< lift (createBlobUtf8 "five\n")
treeit "adds files at mixed depths" pr
[ Tr "a"
, Tr "b"
, Tr "d"
, Tr "g"
, Tr "k"
, Bl "a/one"
, Tr "b/c"
, Bl "b/c/two"
, Tr "d/e"
, Tr "d/e/f"
, Bl "d/e/f/three"
, Tr "g/h"
, Tr "g/h/i"
, Tr "g/h/i/j"
, Bl "g/h/i/j/four"
, Tr "k/l"
, Tr "k/l/m"
, Tr "k/l/m/n"
, Tr "k/l/m/n/o"
, Bl "k/l/m/n/o/five"
] $ do
putBlob "a/one" =<< lift (createBlobUtf8 "one\n")
putBlob "b/c/two" =<< lift (createBlobUtf8 "two\n")
putBlob "d/e/f/three" =<< lift (createBlobUtf8 "three\n")
putBlob "g/h/i/j/four" =<< lift (createBlobUtf8 "four\n")
putBlob "k/l/m/n/o/five" =<< lift (createBlobUtf8 "five\n")
treeit "adds and drops a file" pr
[] $ do
putBlob "one" =<< lift (createBlobUtf8 "one\n")
dropEntry "one"
treeit "adds two files and drops one" pr
[ Bl "one"
] $ do
putBlob "one" =<< lift (createBlobUtf8 "one\n")
putBlob "two" =<< lift (createBlobUtf8 "two\n")
dropEntry "two"
treeit "adds and drops files at mixed depths" pr
[ Tr "a"
, Tr "b"
, Tr "g"
, Bl "a/one"
, Tr "b/c"
, Bl "b/c/two"
, Tr "g/h"
, Tr "g/h/i"
, Tr "g/h/i/j"
, Bl "g/h/i/j/four"
] $ do
putBlob "a/one" =<< lift (createBlobUtf8 "one\n")
putBlob "b/c/two" =<< lift (createBlobUtf8 "two\n")
putBlob "b/c/three" =<< lift (createBlobUtf8 "three\n")
putBlob "d/e/f/three" =<< lift (createBlobUtf8 "three\n")
putBlob "g/h/i/j/four" =<< lift (createBlobUtf8 "four\n")
putBlob "k/l/m/n/o/five" =<< lift (createBlobUtf8 "five\n")
dropEntry "b/c/three"
dropEntry "d/e/f/three"
dropEntry "k/l"
where
fakeTime secs = utcToZonedTime utc (posixSecondsToUTCTime secs)
data Kind = Bl FilePath | Tr FilePath deriving (Eq, Show)
isBlobKind :: Kind -> Bool
isBlobKind (Bl _) = True
isBlobKind _ = False
kindPath :: Kind -> FilePath
kindPath (Bl path) = path
kindPath (Tr path) = path
data TreeitException = TreeitException T.Text deriving (Eq, Show, Typeable)
instance Exception TreeitException
mkBlob :: Repository m => FilePath -> TreeT m ()
mkBlob path =
putBlob path =<< lift (createBlobUtf8 (baseFilename path <> "\n"))
baseFilename :: FilePath -> T.Text
baseFilename = either id id . toText . filename
doTreeit :: (MonadBaseControl IO m, MonadIO m,
MonadTrans t, MonadGit (t m), Repository (t m))
=> String -> RepositoryFactory t m c -> [Kind] -> TreeT (t m) a -> m ()
doTreeit label pr kinds action = withNewRepository pr fullPath $ do
tref <- createTree $ action
tree <- resolveTreeRef tref
forM_ kinds $ \kind -> do
let path = kindPath kind
entry <- getTreeEntry tree path
case entry of
Just (BlobEntry boid _) -> do
liftIO $ isBlobKind kind @?= True
bs <- lookupBlob boid >>= blobToByteString
liftIO $ T.decodeUtf8 bs @?= baseFilename path <> "\n"
Just (TreeEntry _) ->
liftIO $ isBlobKind kind @?= False
Nothing ->
liftIO $ throwIO (TreeitException "Expected entry not found")
_ -> do
liftIO $ isBlobKind kind @?= False
liftIO $ throwIO (TreeitException "Entry is of unexpected kind")
kinds' <- traverseEntries (const . return) tree
liftIO $ sort kinds' @?= map kindPath kinds
where
fullPath = fromText (T.pack (normalize label)) <> ".git"
normalize = map (\x -> if x == ' ' then '-' else x)
treeit :: (Example (m ()), MonadTrans t, MonadGit m,
MonadGit (t m), Repository (t m))
=> String -> RepositoryFactory t m c -> [Kind] -> TreeT (t m) a -> Spec
treeit label pr kinds action = it label $ doTreeit label pr kinds action
treeitFail :: (MonadTrans t,
MonadGit (t IO), Repository (t IO))
=> String -> RepositoryFactory t IO c -> [Kind] -> TreeT (t IO) a
-> Spec
treeitFail label pr kinds action =
it label $ doTreeit label pr kinds action
`shouldThrow` (\(_ :: TreeitException) -> True)