gitlib-s3-0.2.1: test/Smoke.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
{-# OPTIONS_GHC -fno-warn-wrong-do-bind #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module Main where

import           Aws
import           Aws.Core
import           Aws.S3 hiding (bucketName)
import           Control.Applicative
import           Control.Concurrent.ParallelIO
import           Control.Monad
import           Data.Git
import           Data.Git.Backend
import           Data.Git.Backend.S3
import           Data.Git.Backend.Trace
import           Data.Map
import           Data.Maybe
import           Data.Text as T hiding (map)
import qualified Data.Text.Encoding as E
import           Data.Time.Clock.POSIX
import           Data.Traversable
import           Filesystem (removeTree, isDirectory)
import           Filesystem.Path.CurrentOS
import           Network.HTTP.Conduit
import qualified Prelude
import           Prelude (putStrLn)
import           Prelude hiding (FilePath, putStr, putStrLn)
import           System.Environment
import           System.Exit
import           Test.HUnit

default (Text)

main :: IO ()
main = do
  counts' <- runTestTT tests
  case counts' of
    Counts _ _ errors' failures' ->
      if errors' > 0 || failures' > 0
      then exitFailure
      else exitSuccess
  stopGlobalPool

catBlob :: Repository -> Text -> IO (Maybe Text)
catBlob repo sha = do
  hash <- parseOid sha
  for hash $ \hash' -> do
    obj <- lookupObject repo hash'
    case obj of
      Just (BlobObj b) -> do
        (_, contents) <- getBlobContents b
        str <- blobSourceToString contents
        case str of
          Nothing   -> return T.empty
          Just str' -> return (E.decodeUtf8 str')

      Just _  -> error "Found something else..."
      Nothing -> error "Didn't find anything :("

withRepository :: Text -> (Repository -> Assertion) -> Assertion
withRepository n f = do
  let p = fromText n
  exists <- isDirectory p
  when exists $ removeTree p

  -- we want exceptions to leave the repo behind
  f =<< createRepository p True

  removeTree p

oid :: Updatable a => a -> IO Text
oid = objectId >=> return . oidToText

oidToText :: Oid -> Text
oidToText = T.pack . show

sampleCommit :: Repository -> Tree -> Signature -> Commit
sampleCommit repo tr sig =
    (createCommit repo sig) { commitTree = ObjRef tr
                            , commitLog  = "Sample log message." }

tests :: Test
tests = test [

  "createTwoCommits" ~:

  withRepository "createTwoCommits.git" $ \repo' -> do
    -- Store Git objects in S3
    s3Bucket     <- T.pack <$> getEnv "S3_BUCKET"
    awsAccessKey <- T.pack <$> getEnv "AWS_ACCESS_KEY"
    awsSecretKey <- T.pack <$> getEnv "AWS_SECRET_KEY"
    repo <- createS3backend s3Bucket "" awsAccessKey awsSecretKey
                            Nothing Nothing Error True repo'

    let hello = createBlob repo (E.encodeUtf8 "Hello, world!\n")
    tr <- updateTree (createTree repo) "hello/world.txt" (blobRef hello)

    let goodbye = createBlob repo (E.encodeUtf8 "Goodbye, world!\n")
    tr <- updateTree tr "goodbye/files/world.txt" (blobRef goodbye)
    x  <- oid tr
    x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a"

    -- The Oid has been cleared in tr, so this tests that it gets written as
    -- needed.
    let sig = Signature {
            signatureName  = "John Wiegley"
          , signatureEmail = "johnw@newartisans.com"
          , signatureWhen  = posixSecondsToUTCTime 1348980883 }
        c   = sampleCommit repo tr sig
    x <- oid c
    x @?= "44381a5e564d19893d783a5d5c59f9c745155b56"

    let goodbye2 = createBlob repo (E.encodeUtf8 "Goodbye, world again!\n")
    tr <- updateTree tr "goodbye/files/world.txt" (blobRef goodbye2)
    x  <- oid tr
    x @?= "f2b42168651a45a4b7ce98464f09c7ec7c06d706"

    let sig = Signature {
            signatureName  = "John Wiegley"
          , signatureEmail = "johnw@newartisans.com"
          , signatureWhen  = posixSecondsToUTCTime 1348981883 }
        c2  = (sampleCommit repo tr sig) {
                  commitLog       = "Second sample log message."
                , commitParents   = [ObjRef c] }
    x <- oid c2
    x @?= "2506e7fcc2dbfe4c083e2bd741871e2e14126603"

    putStrLn "Refs before creation..."
    mapAllRefs repo (\name -> Prelude.putStrLn $ "Ref: " ++ unpack name)
    putStrLn "Refs before creation...done"

    cid <- objectId c2
    writeRef $ createRef repo "refs/heads/master" (RefTargetId cid)
    writeRef $ createRef repo "HEAD" (RefTargetSymbolic "refs/heads/master")

    x <- fmap oidToText <$> resolveRef repo "refs/heads/master"
    x @?= Just "2506e7fcc2dbfe4c083e2bd741871e2e14126603"

    putStrLn "Refs after creation..."
    mapAllRefs repo (\name -> Prelude.putStrLn $ "Ref: " ++ unpack name)
    putStrLn "Refs after creation...done"

    return()

  ]

-- Main.hs ends here