gitlib-s3-2.1.0.0: test/Smoke.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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           Control.Applicative
import           Control.Exception (finally)
import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Default (def)
import           Data.Maybe (fromMaybe, isNothing)
import           Data.Text as T
import qualified Git as Git
import qualified Git.Libgit2 as Lg
import qualified Git.S3 as S3
import qualified Git.Smoke as Git
import           System.Environment
import           Test.Hspec.HUnit ()
import           Test.Hspec.Runner
import           System.Directory
import           System.FilePath.Posix

s3Factory :: Git.MonadGit m
          => Git.RepositoryFactory Lg.LgRepository m Lg.Repository
s3Factory = Lg.lgFactory
    { Git.runRepository = \ctxt -> Lg.runLgRepository ctxt . (s3back >>) }
  where
    s3back = do
        repo <- Lg.lgGet
        void $ liftIO $ do
            env <- getEnvironment
            let bucket    = T.pack <$> lookup "S3_BUCKET" env
                accessKey = T.pack <$> lookup "AWS_ACCESS_KEY" env
                secretKey = T.pack <$> lookup "AWS_SECRET_KEY" env
            cwd <- getCurrentDirectory
            svc <- S3.s3MockService
            let tmpDir = cwd </> "s3cache"
            createDirectoryIfMissing True tmpDir
            S3.addS3Backend
                repo
                (fromMaybe "test-bucket" bucket)
                ""
                (fromMaybe "" accessKey)
                (fromMaybe "" secretKey)
                Nothing
                (if isNothing bucket
                 then Just "127.0.0.1"
                 else Nothing)
                Error
                tmpDir
                def { -- S3.registerObject = \sha _ -> do
                    --        putStrLn $ "registerObject: " ++ show sha
                    --        modifyMVar_ objectMap
                    --            (return . Map.insert sha S3.ObjectLoose)
                    -- , S3.registerPackFile = \packBase shas -> do
                    --        putStrLn $ "registerPackFile: " ++ show packBase
                    --        modifyMVar_ objectMap
                    --            (\m -> return $ foldr
                    --                   (flip Map.insert
                    --                    (S3.ObjectInPack packBase)) m shas)
                    -- , S3.lookupObject = \sha -> do
                    --        putStrLn $ "lookupObject: " ++ show sha
                    --        Map.lookup sha <$> readMVar objectMap
                      S3.headObject = \bucket path ->
                       S3.mockHeadObject svc bucket path
                    , S3.getObject  = \bucket path range ->
                       S3.mockGetObject svc bucket path range
                    , S3.putObject  = \bucket path len bytes ->
                       S3.mockPutObject svc bucket path
                           (fromIntegral (S3.getObjectLength len)) bytes
                    }

main :: IO ()
main = do
    Git.startupBackend Lg.lgFactory
    finally
        (hspec $ Git.smokeTestSpec s3Factory s3Factory)
        (Git.shutdownBackend Lg.lgFactory)

-- Smoke.hs ends here