[cli] internal: add github copy directrory functionality

Author: paolino

cli/anti.cabal

@@ -449,3 +449,39 @@ library test-lib
 
   -- Base language which the package is written in.
   default-language: Haskell2010
+
+test-suite anti-integration-test
+  -- Import common warning flags.
+  import:             warnings
+
+  -- Base language which the package is written in.
+  default-language:   Haskell2010
+
+  -- Modules included in this executable, other than Main.
+  other-modules:
+    Lib.GitHubSpec
+
+  -- LANGUAGE extensions used by modules in this package.
+  -- other-extensions:
+
+  -- The interface type and version of the test suite.
+  type:               exitcode-stdio-1.0
+
+  -- Directories containing source files.
+  hs-source-dirs:     test-integration
+
+  -- The entrypoint to the test suite.
+  main-is:            Main.hs
+
+  -- Test dependencies.
+  build-depends:
+    , anti
+    , base
+    , bytestring
+    , directory
+    , hspec
+    , github
+    , path
+    , temporary
+
+  build-tool-depends: hspec-discover:hspec-discover

cli/justfile

@@ -7,7 +7,7 @@ format:
     #!/usr/bin/env bash
     # shellcheck disable=SC2034
     for i in {1..3}; do
-        fourmolu -i src app test test-E2E test-lib CI/rewrite-libs
+        fourmolu -i src app test test-E2E test-integration test-lib CI/rewrite-libs
     done
     cabal-fmt -i anti.cabal CI/rewrite-libs/rewrite-libs.cabal
     nixfmt *.nix
@@ -36,6 +36,18 @@ build:
     #!/usr/bin/env bash
     cabal build all --enable-tests
 
+integration match="":
+    #!/usr/bin/env bash
+    # shellcheck disable=SC2050
+    if [[ '{{ match }}' == "" ]]; then
+      cabal test anti-integration-test \
+          --test-show-details=direct
+    else
+      cabal test anti-integration-test \
+          --test-show-details=direct \
+          --test-option=--match \
+          --test-option="{{ match }}"
+    fi
 E2E match="":
     #!/usr/bin/env bash
     mkdir -p tmp/bin
@@ -121,6 +133,7 @@ CI:
     set -euo pipefail
     just build
     just unit
+    just integration
     just E2E
     cabal-fmt -c anti.cabal CI/rewrite-libs/rewrite-libs.cabal
     fourmolu -m check src app test CI/rewrite-libs

cli/src/Lib/GitHub.hs

@@ -8,20 +8,32 @@ module Lib.GitHub
     , githubGetFile
     , githubGetCodeOwnersFile
     , githubRepositoryExists
+
+      -- * Utilities for working with GitHub directories
+    , copyGithubDirectory
+    , writeToDirectory
+    , exitOnException
+    , githubStreamDirectoryContents
     ) where
 
 import Control.Exception
     ( Exception
+    , SomeException
     )
+import Control.Monad.Fix (fix)
+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
 import Core.Types.Basic
     ( Commit (..)
     , Directory (..)
     , FileName (..)
     , Repository (..)
     , Username (..)
     )
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as B
 import Data.ByteString.Base64 qualified as B64
-import Data.Foldable (Foldable (..))
+import Data.Foldable (Foldable (..), forM_)
+import Data.Function ((&))
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
 import GitHub (Auth (..), FetchCount (..), github)
@@ -34,7 +46,22 @@ import Network.HTTP.Client
     , Response (..)
     )
 import Network.HTTP.Types (Status (..))
+import Path
+    ( Abs
+    , Dir
+    , File
+    , Path
+    , Rel
+
+    , parseRelFile
+    , toFilePath
+    , (</>), parseRelDir, parent
+    )
+import Streaming
+import Streaming.Prelude (yield)
+import Streaming.Prelude qualified as S
 import Text.JSON.Canonical
+import System.Directory (createDirectoryIfMissing)
 
 data GithubResponseError
     = GithubResponseErrorRepositoryNotFound
@@ -179,6 +206,7 @@ data GetGithubFileFailure
     | GetGithubFileUnsupportedEncoding String
     | GetGithubFileOtherFailure FilePath String
     | GetGithubFileCodeError GithubResponseStatusCodeError
+    | GithubPathParsingError String
     deriving (Eq, Show)
 
 instance Exception GetGithubFileFailure
@@ -237,3 +265,118 @@ githubGetFile auth (Repository owner repo) commitM (FileName filename) = do
   where
     owner' = N $ T.pack owner
     repo' = N $ T.pack repo
+
+githubStreamDirectoryContents
+    :: Auth
+    -> Repository
+    -> Maybe Commit
+    -> Path Rel Dir
+    -> Stream
+        (Of (Path Rel File, ByteString))
+        (ExceptT GetGithubFileFailure IO)
+        ()
+githubStreamDirectoryContents
+    auth
+    (Repository owner repo)
+    commitM
+    startDir =
+        ($ startDir) $ fix $ \go dir -> do
+            -- Get the contents of the source directory
+            response <-
+                liftIO
+                    $ github auth
+                    $ GH.contentsForR
+                        owner'
+                        repo'
+                        (T.dropEnd 1 $ T.pack $ toFilePath dir)
+                        ((\(Commit c) -> T.pack c) <$> commitM)
+            case response of
+                Left e -> do
+                    res <- liftIO $ onStatusCodeOfException e $ \c -> do
+                        case c of
+                            404 ->
+                                pure
+                                    . Just
+                                    $ GetGithubFileDirectoryNotFound
+                            _ ->
+                                pure
+                                    . Just
+                                    . GetGithubFileOtherFailure (toFilePath dir)
+                                    $ show e
+                    case res of
+                        Left err -> lift $ throwE $ GetGithubFileCodeError err
+                        Right a -> lift $ throwE a
+                Right (GH.ContentFile contents) -> do
+                    let content = GH.contentFileContent contents
+                    ebytes <- case GH.contentFileEncoding contents of
+                        "base64" ->
+                            pure
+                                . Right
+                                . B64.decodeLenient
+                                . T.encodeUtf8
+                                $ content
+                        enc ->
+                            pure
+                                . Left
+                                . GetGithubFileUnsupportedEncoding
+                                $ T.unpack enc
+                    case ebytes of
+                        Left err -> lift $ throwE err
+                        Right t -> lift (dirToFile dir) >>= yield . (,t)
+                Right (GH.ContentDirectory vis) -> forM_ vis $ \case
+                    GH.ContentItem _ctype GH.ContentInfo{contentPath} -> do
+                        dir' <-
+                            lift
+                                $ throwPathParsing
+                                $ parseRelDir (T.unpack contentPath)
+                        go dir'
+      where
+        owner' = N $ T.pack owner
+        repo' = N $ T.pack repo
+
+dirToFile
+    :: Monad m => Path b t -> ExceptT GetGithubFileFailure m (Path Rel File)
+dirToFile = throwPathParsing . parseRelFile . tailU . toFilePath
+  where
+    tailU = T.unpack . T.dropWhileEnd (== '/') . T.dropWhile (== '/') . T.pack
+
+throwPathParsing
+    :: (Monad m)
+    => Either SomeException a
+    -> ExceptT GetGithubFileFailure m a
+throwPathParsing f = case f of
+    Left err -> throwE . GithubPathParsingError . show $ err
+    Right file -> pure file
+
+writeToDirectory
+    :: Path Abs Dir -> Stream (Of (Path Rel File, ByteString)) IO r -> IO r
+writeToDirectory targetDir = S.mapM_ writeFile'
+  where
+    writeFile' (relPath, content) = do
+        let fullPath = targetDir </> relPath
+        createDirectoryIfMissing True (toFilePath $ parent fullPath)
+        B.writeFile (toFilePath fullPath) content
+
+exitOnException
+    :: Stream (Of a) (ExceptT e IO) r -> Stream (Of a) IO (Either e r)
+exitOnException strm = effect $ do
+    x <- runExceptT $ S.next strm
+    pure $ case x of
+        Left e -> pure $ Left e
+        Right (Left r) -> pure $ Right r
+        Right (Right (a, rest)) -> do
+            yield a >> exitOnException rest
+
+copyGithubDirectory
+    :: Auth
+    -> Repository
+    -> Maybe Commit
+    -> Path Rel Dir
+    -- ^ Source directory in the GitHub repository
+    -> Path Abs Dir
+    -- ^ Target directory on the local filesystem
+    -> IO (Either GetGithubFileFailure ())
+copyGithubDirectory auth repo commitM srcDir targetDir =
+    githubStreamDirectoryContents auth repo commitM srcDir
+        & exitOnException
+        & writeToDirectory targetDir

cli/src/User/Agent/PushTest.hs

@@ -70,8 +70,7 @@ ENV TZ="UTC"
 RUN ln -snf /usr/share/zoneinfo/${TZ} /etc/localtime && \
     echo ${TZ} > /etc/timezone
 
-ADD docker-compose.yaml /docker-compose.yaml
-ADD testnet.yaml /testnet.yaml
+COPY . /
 
 RUN sed -i 's/${INTERNAL_NETWORK}/false/g' /docker-compose.yaml
     |]

cli/src/Validation.hs

@@ -104,9 +104,9 @@ data Validation m = Validation
          . String
         -> (FilePath -> m a)
         -> m a
-    , writeTextFile :: FilePath -> Text -> m () -- Added writeFile to Validation
+    , writeTextFile :: FilePath -> Text -> m ()
     , withCurrentDirectory :: forall a. FilePath -> m a -> m a
-    , directoryExists :: Directory -> m (Maybe Permissions) -- Added directoryExists to Validation
+    , directoryExists :: Directory -> m (Maybe Permissions)
     , decodePrivateSSHFile :: SSHClient 'WithSelector -> m (Maybe KeyPair)
     }
 

cli/test-integration/Lib/GitHubSpec.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Lib.GitHubSpec (spec) where
+
+import Control.Monad (void)
+import Core.Types.Basic (Commit (..), Repository (..))
+import Data.ByteString.Char8 qualified as BC
+import GitHub (Auth (OAuth))
+import Lib.GitHub (copyGithubDirectory)
+import Path
+    ( Dir,
+      Path,
+      parseAbsDir,
+      toFilePath,
+      (</>),
+      mkRelDir,
+      mkRelFile,
+      parseRelFile,
+      File,
+      Rel )
+import System.Directory (doesFileExist)
+import System.Environment (getEnv)
+import System.IO.Temp (withSystemTempDirectory)
+import Test.Hspec
+    ( Spec
+    , beforeAll
+    , describe
+    , it
+    , shouldReturn
+    )
+
+boot :: IO Auth
+boot = OAuth . BC.pack <$> getEnv "ANTI_GITHUB_PAT"
+
+repo :: Repository
+repo =
+    Repository
+        { organization = "cardano-foundation"
+        , project = "hal-fixture-sin"
+        }
+
+commit :: Maybe Commit
+commit = Just $ Commit "a2572c4c9c37c3aa5f21e3ac8ce7ea9b96d833e5"
+
+srcPath :: Path Rel Dir
+srcPath = $(mkRelDir "antithesis-test")
+
+readmePath :: Path Rel File
+readmePath = $(mkRelFile "README.md")
+
+dockerComposePath :: Path Rel File
+dockerComposePath = $(mkRelFile "docker-compose.yaml")
+
+testnetPath :: Path Rel File
+testnetPath = $(mkRelFile "testnet.yaml")
+
+spec :: Spec
+spec = do
+    describe "Path lib" $ do
+        it "parses relative directory" $ do
+            void $ parseRelFile @IO "antithesis-test/somefile.txt"
+    beforeAll boot $ do
+        describe "Lib.GitHub" $ do
+            it "downloads a directory" $ \pat ->
+                withSystemTempDirectory "github-test" $ \targetPath -> do
+                    targetDir <- parseAbsDir targetPath
+                    copyGithubDirectory pat repo commit srcPath targetDir
+                        `shouldReturn` Right ()
+                    let readmeAbsPath = targetDir </> srcPath </> readmePath
+                    print $ "Checking for file: " ++ toFilePath readmeAbsPath
+                    doesFileExist (toFilePath readmeAbsPath) `shouldReturn` True
+                    let dockerComposeAbsPath =
+                            targetDir
+                                </> srcPath
+                                </> dockerComposePath
+                    doesFileExist (toFilePath dockerComposeAbsPath)
+                        `shouldReturn` True
+                    let testnetAbsPath = targetDir </> srcPath </> testnetPath
+                    doesFileExist (toFilePath testnetAbsPath) `shouldReturn` True

cli/test-integration/Main.hs

@@ -0,0 +1 @@
+ {-# OPTIONS_GHC -F -pgmF hspec-discover #-}