{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Main where
import Control.Applicative (liftA2)
import Control.Exception.Safe (throwM, throwString)
import Control.Lens (firstOf)
import Control.Monad (void)
import Data.Aeson.Lens (key, _String)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as Bytes
import Data.ByteString.Lazy (fromStrict, toStrict)
import qualified Data.ByteString.Lazy.Char8 as Lazy
import Data.Foldable (foldlM)
import qualified Data.Git.Monad as Git
import Data.Git.Ref (SHA1)
import qualified Data.Git.Storage as Git (initRepo)
import Data.Git.Types (GitTime(..))
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy(..))
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8)
import GHC.Stack (HasCallStack)
import qualified Network.HTTP.Client as Http
import Network.IPFS.API (ApiV0KeyGen, ApiV0NamePublish)
import Servant.API
import qualified Servant.Client as Servant
import System.Entropy (getEntropy)
import System.Environment (lookupEnv)
import System.Exit (ExitCode(..))
import System.FilePath (takeBaseName, takeDirectory, (</>))
import System.Hourglass (timeCurrent, timezoneCurrent)
import System.IO.Temp (withSystemTempDirectory)
import System.Process.Typed
import Test.Tasty
import Test.Tasty.HUnit
type Step = String -> IO ()
main :: IO ()
main =
withSystemTempDirectory "git-remote-ipfs-e2e" $ \tmp -> defaultMain $
testGroup "E2E Tests"
[ testCaseSteps "Push, clone: IPFS" $ testPushCloneSimple tmp
, testCaseSteps "Push, clone: IPNS" $ testPushCloneIPNS tmp
, testCaseSteps "Push, clone: LOB IPFS" $ testLargeObjects tmp
]
testPushCloneSimple :: FilePath -> Step -> IO ()
testPushCloneSimple root step = runPushCloneTest PushCloneOpts
{ pcoRepo = root </> "simple" </> ".git"
, pcoClone = root </> "simple-clone" </> ".git"
, pcoRemoteUrl = "ipfs://"
, pcoHistory = simpleHistory
, pcoLog = step
}
testPushCloneIPNS :: FilePath -> Step -> IO ()
testPushCloneIPNS root step = do
let keyName = Text.pack (takeBaseName root) -- piggypack on randomness of tmp
step "Creating IPNS name"
ipnsName <- Text.unpack <$> ipfs (createIpnsName keyName)
runPushCloneTest PushCloneOpts
{ pcoRepo = root </> ipnsName </> ".git"
, pcoClone = root </> ipnsName ++ "-clone" </> ".git"
, pcoRemoteUrl = "ipfs://ipns/" <> ipnsName
, pcoHistory = simpleHistory
, pcoLog = step
}
where
ipfs m = servantEnv >>= Servant.runClientM m >>= either throwM pure
testLargeObjects :: FilePath -> Step -> IO ()
testLargeObjects root step = runPushCloneTest PushCloneOpts
{ pcoRepo = root </> "lobs" </> ".git"
, pcoClone = root </> "lobs-clone" </> ".git"
, pcoRemoteUrl = "ipfs://"
, pcoHistory = lobHistory
, pcoLog = step
}
data PushCloneOpts = PushCloneOpts
{ pcoRepo :: FilePath
, pcoClone :: FilePath
, pcoRemoteUrl :: String
, pcoHistory :: FilePath -> IO ()
, pcoLog :: Step
}
runPushCloneTest :: PushCloneOpts -> IO ()
runPushCloneTest PushCloneOpts{..} = do
initRepo pcoLog pcoRepo pcoHistory
url <- pushIpfs pcoLog pcoRepo pcoRemoteUrl
cloneIpfs pcoLog (takeDirectory pcoClone) url
assertSameRepos pcoLog pcoRepo pcoClone
initRepo :: HasCallStack => Step -> FilePath -> (FilePath -> IO ()) -> IO ()
initRepo step repo history = do
step $ "Initializing repo at " <> repo
let repo' = fromString repo
Git.initRepo repo'
(>>= either throwString pure) . Git.withRepo repo' $
Git.headSet $ pure "master"
history repo
pushIpfs :: Step -> FilePath -> String -> IO String
pushIpfs step repo url = do
step $ "Pushing master to " <> url
git_ repo ["remote", "add", "origin", url]
git_ repo ["push", "--quiet", "origin", "master"]
Text.unpack . Text.strip . decodeUtf8
<$> git repo ["remote", "get-url", "origin"]
cloneIpfs :: Step -> FilePath -> String -> IO ()
cloneIpfs step repo url = do
step $ "Cloning " <> url <> " to " <> repo
git_ repo ["clone", "--quiet", url, repo]
assertSameRepos :: Step -> FilePath -> FilePath -> IO ()
assertSameRepos step src clone = do
step $ "Fetching " <> src <> " to " <> clone
git_ clone ["remote", "add", "src", src]
git_ clone ["fetch", "--quiet", "src"]
step "Comparing origin/master src/master"
void $ gitAssert "Source and cloned repository differ"
clone ["diff", "--quiet", "origin/master", "src/master"]
simpleHistory :: FilePath -> IO ()
simpleHistory repo =
(>>= either throwString (const $ pure ())) . Git.withRepo (fromString repo) $ do
initial <- mkCommit Nothing Nothing 0
foldlM (\(bs, rev) i -> mkCommit bs rev i) initial [1..42]
where
mkCommit
:: Maybe Lazy.ByteString
-> Maybe String
-> Int
-> Git.GitM (Maybe Lazy.ByteString, Maybe String)
mkCommit readme branch (show -> i) = do
person <- mkPerson <$> currentTimeGit
(r, ()) <-
Git.withNewCommit person branch $ do
Git.setMessage $ "Commit " <> Bytes.pack i
Git.setFile ["README"] $
fromMaybe mempty readme <> Lazy.pack i <> "\n"
Git.branchWrite "master" r
(,Just "master") <$>
Git.withCommit ("master" :: String) (Git.getFile ["README"])
lobHistory :: FilePath -> IO ()
lobHistory repo = do
blob <- getEntropy 4096000
(>>= either throwString pure) . Git.withRepo (fromString repo) $ do
person <- mkPerson <$> currentTimeGit
(r, ()) <-
Git.withNewCommit person (Nothing :: Maybe (Git.Ref SHA1)) $ do
Git.setMessage "Huuuuge"
Git.setFile ["huge.file"] $ fromStrict blob
Git.branchWrite "master" r
mkPerson :: GitTime -> Git.Person
mkPerson = Git.Person "LeBoeuf" "le@boe.uf"
currentTimeGit :: Git.GitM GitTime
currentTimeGit = Git.liftGit $ liftA2 GitTime timeCurrent timezoneCurrent
git :: FilePath -> [String] -> IO ByteString
git = gitAssert mempty
git_ :: FilePath -> [String] -> IO ()
git_ repo args = void $ git repo args
gitAssert :: String -> FilePath -> [String] -> IO ByteString
gitAssert msg repo args = do
let cfg = proc "git" $ "--git-dir" : repo : args
readProcess cfg >>= \case
(ExitSuccess, out, _err) -> pure $ toStrict out
(failure , out, err ) -> assertFailure $ unlines
[ msg
, show failure
, show cfg
, show out
, show err
]
type IPFS = ApiV0KeyGen :<|> ApiV0NamePublish
ipfsKeyGen :<|> ipfsNamePublish = Servant.client (Proxy @IPFS)
servantEnv :: IO Servant.ClientEnv
servantEnv = liftA2 Servant.mkClientEnv mgr base
where
mgr = Http.newManager Http.defaultManagerSettings
{ Http.managerResponseTimeout = Http.responseTimeoutNone }
base =
Servant.parseBaseUrl
=<< fromMaybe "http://localhost:5001" <$> lookupEnv "IPFS_API_URL"
createIpnsName :: HasCallStack => Text -> Servant.ClientM Text
createIpnsName keyName = do
keyId <-
maybe (throwString "Missing key Id") pure
. firstOf (key "Id" . _String)
=<< ipfsKeyGen keyName (Just "ed25519") Nothing
void $
ipfsNamePublish ("/ipfs/" <> emptyRepo)
(Just True) -- resolve
(Just "5m") -- lifetime
Nothing -- caching
(Just keyId) -- key
pure keyId
where
emptyRepo = "QmUNLLsPACCz1vLxQVkXqqLX5R1X345qqfHbsf67hvA3Nn"