Skip to content

Commit 9825d8a

Browse files
paolinopaolino
committed
[cli] feat: download and use a directory as asset
1 parent 09bd30e commit 9825d8a

File tree

5 files changed

+110
-70
lines changed

5 files changed

+110
-70
lines changed

‎cli/src/Lib/GitHub.hs‎

Lines changed: 47 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ module Lib.GitHub
1010
, githubRepositoryExists
1111

1212
-- * Utilities for working with GitHub directories
13-
, copyGithubDirectory
13+
, githubDownloadDirectory
1414
, writeToDirectory
1515
, exitOnException
1616
, githubStreamDirectoryContents
@@ -21,7 +21,7 @@ import Control.Exception
2121
, SomeException
2222
)
2323
import Control.Monad.Fix (fix)
24-
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
24+
import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE)
2525
import Core.Types.Basic
2626
( Commit (..)
2727
, Directory (..)
@@ -52,17 +52,30 @@ import Path
5252
, File
5353
, Path
5454
, Rel
55+
, SomeBase (..)
5556
, parent
57+
, parseAbsDir
5658
, parseRelDir
5759
, parseRelFile
60+
, parseSomeDir
61+
, stripProperPrefix
5862
, toFilePath
5963
, (</>)
6064
)
6165
import Streaming
66+
( MonadIO (liftIO)
67+
, MonadTrans (lift)
68+
, Of
69+
, Stream
70+
, effect
71+
)
6272
import Streaming.Prelude (yield)
6373
import Streaming.Prelude qualified as S
64-
import System.Directory (createDirectoryIfMissing)
65-
import Text.JSON.Canonical
74+
import System.Directory
75+
( createDirectoryIfMissing
76+
, getCurrentDirectory
77+
)
78+
import Text.JSON.Canonical (ToJSON (..))
6679

6780
data GithubResponseError
6881
= GithubResponseErrorRepositoryNotFound
@@ -350,11 +363,15 @@ throwPathParsing f = case f of
350363
Right file -> pure file
351364

352365
writeToDirectory
353-
:: Path Abs Dir -> Stream (Of (Path Rel File, ByteString)) IO r -> IO r
354-
writeToDirectory targetDir = S.mapM_ writeFile'
366+
:: Path Rel Dir
367+
-> Path Abs Dir
368+
-> Stream (Of (Path Rel File, ByteString)) IO r
369+
-> IO r
370+
writeToDirectory srcDir targetDir = S.mapM_ writeFile'
355371
where
356372
writeFile' (relPath, content) = do
357-
let fullPath = targetDir </> relPath
373+
unrootedPath <- stripProperPrefix srcDir relPath
374+
let fullPath = targetDir </> unrootedPath
358375
createDirectoryIfMissing True (toFilePath $ parent fullPath)
359376
B.writeFile (toFilePath fullPath) content
360377

@@ -368,16 +385,32 @@ exitOnException strm = effect $ do
368385
Right (Right (a, rest)) -> do
369386
yield a >> exitOnException rest
370387

371-
copyGithubDirectory
388+
absolutizePath :: SomeBase x -> IO (Path Abs x)
389+
absolutizePath (Rel relPath) = do
390+
currDir <- parseAbsDir =<< getCurrentDirectory
391+
pure $ currDir </> relPath
392+
absolutizePath (Abs absPath) = pure absPath
393+
394+
githubDownloadDirectory
372395
:: Auth
373396
-> Repository
374397
-> Maybe Commit
375-
-> Path Rel Dir
398+
-> Directory
376399
-- ^ Source directory in the GitHub repository
377-
-> Path Abs Dir
400+
-> Directory
378401
-- ^ Target directory on the local filesystem
379402
-> IO (Either GetGithubFileFailure ())
380-
copyGithubDirectory auth repo commitM srcDir targetDir =
381-
githubStreamDirectoryContents auth repo commitM srcDir
382-
& exitOnException
383-
& writeToDirectory targetDir
403+
githubDownloadDirectory
404+
auth
405+
repo
406+
commitM
407+
(Directory srcDir)
408+
(Directory targetDir) = runExceptT $ do
409+
srcDirPath <- throwPathParsing $ parseRelDir srcDir
410+
-- Ensure the target directory exists
411+
targetDirPath <- throwPathParsing $ parseSomeDir targetDir
412+
targetDirAbs <- lift $ absolutizePath targetDirPath
413+
ExceptT
414+
$ githubStreamDirectoryContents auth repo commitM srcDirPath
415+
& exitOnException
416+
& writeToDirectory srcDirPath targetDirAbs

‎cli/src/Oracle/Validate/DownloadAssets.hs‎

Lines changed: 32 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -7,14 +7,17 @@ module Oracle.Validate.DownloadAssets
77
)
88
where
99

10-
import Control.Monad (filterM, forM_)
10+
import Control.Monad (filterM)
1111
import Control.Monad.Trans.Class (lift)
12-
import Core.Types.Basic (Directory (..), FileName (..))
12+
import Core.Types.Basic (Directory (..))
1313
import Core.Types.Fact
1414
( Fact (..)
1515
, keyHash
1616
)
17-
import Lib.GitHub (GithubResponseStatusCodeError)
17+
import Lib.GitHub
18+
( GetGithubFileFailure
19+
, GithubResponseStatusCodeError
20+
)
1821
import Lib.JSON.Canonical.Extra (object, (.=))
1922
import Oracle.Validate.Types
2023
( Validate
@@ -42,34 +45,30 @@ import Validation
4245
( Validation (..)
4346
, hoistValidation
4447
)
45-
import Validation.DownloadFile
46-
( DownloadedFileFailure (..)
47-
, renderDownloadedFileFailure
48-
)
4948

5049
data AssetValidationFailure
5150
= AssetValidationSourceFailure SourceDirFailure
52-
| AssetValidationParseError DownloadedFileFailure
5351
| DownloadAssetsTargetDirNotFound
5452
| DownloadAssetsTargetDirNotWritable
53+
| DownloadAssetsGithubError GetGithubFileFailure
5554
deriving (Show, Eq)
5655

5756
instance Monad m => ToJSON m AssetValidationFailure where
5857
toJSON (AssetValidationSourceFailure failure) =
5958
object
6059
["error" .= ("Source directory validation failed: " <> show failure)]
61-
toJSON (AssetValidationParseError failure) =
62-
object
63-
[ "error"
64-
.= ( "Downloaded file validation failed: "
65-
<> renderDownloadedFileFailure failure
66-
)
67-
]
6860
toJSON DownloadAssetsTargetDirNotFound =
6961
object ["error" .= ("There is no target local directory" :: String)]
7062
toJSON DownloadAssetsTargetDirNotWritable =
7163
object
7264
["error" .= ("The target local directory is not writable" :: String)]
65+
toJSON (DownloadAssetsGithubError failure) =
66+
object
67+
[ "error"
68+
.= ( "GitHub error when downloading directory: "
69+
<> show failure
70+
)
71+
]
7372

7473
data DownloadAssetsFailure
7574
= DownloadAssetsTestRunIdNotFound TestRunId
@@ -113,30 +112,26 @@ checkSourceDirectory
113112
then Nothing
114113
else Just SourceDirFailureDirAbsent
115114

116-
downloadFileAndWriteLocally
115+
downloadAssetsDirectory
117116
:: Monad m
118117
=> Validation m
119118
-> TestRun
120119
-> Directory
121-
-> FileName
122-
-> m (Maybe AssetValidationFailure)
123-
downloadFileAndWriteLocally
124-
Validation{githubGetFile, withCurrentDirectory, writeTextFile}
125-
testRun
126-
(Directory targetDir)
127-
(FileName filename) = do
128-
let (Directory sourceDir) = directory testRun
129-
contentE <-
130-
githubGetFile
131-
(repository testRun)
132-
(Just $ commitId testRun)
133-
(FileName $ sourceDir <> "/" <> filename)
134-
case contentE of
135-
Left err -> pure $ Just $ AssetValidationParseError err
136-
Right txt -> do
137-
withCurrentDirectory targetDir
138-
$ writeTextFile filename txt
139-
pure Nothing
120+
-> m (Maybe GetGithubFileFailure)
121+
downloadAssetsDirectory validation testRun dir = do
122+
let sourceDir = directory testRun
123+
commit = commitId testRun
124+
repository' = repository testRun
125+
r <-
126+
githubDownloadDirectory
127+
validation
128+
repository'
129+
(Just commit)
130+
sourceDir
131+
dir
132+
pure $ case r of
133+
Left err -> Just err
134+
Right () -> Nothing
140135

141136
validateDownloadAssets
142137
:: Monad m
@@ -190,15 +185,5 @@ validateAssets dir validation testRun = do
190185
liftMaybe DownloadAssetsTargetDirNotFound targetDirValidation
191186
Validated <-
192187
throwFalse (writable permissions) DownloadAssetsTargetDirNotWritable
193-
194-
forM_ ["README.md", "docker-compose.yaml", "testnet.yaml"] $ \filename -> do
195-
fileValidation <-
196-
lift
197-
$ downloadFileAndWriteLocally
198-
validation
199-
testRun
200-
dir
201-
(FileName filename)
202-
throwJusts fileValidation
203-
204-
pure Validated
188+
downloadTry <- lift $ downloadAssetsDirectory validation testRun dir
189+
mapFailure DownloadAssetsGithubError $ throwJusts downloadTry

‎cli/src/Validation.hs‎

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -99,6 +99,12 @@ data Validation m = Validation
9999
-> Maybe Commit
100100
-> FileName
101101
-> m (Either DownloadedFileFailure Text)
102+
, githubDownloadDirectory
103+
:: Repository
104+
-> Maybe Commit
105+
-> Directory
106+
-> Directory
107+
-> m (Either GitHub.GetGithubFileFailure ())
102108
, withSystemTempDirectory
103109
:: forall a
104110
. String
@@ -125,6 +131,7 @@ hoistValidation
125131
, githubRepositoryExists
126132
, githubRepositoryRole
127133
, githubGetFile
134+
, githubDownloadDirectory
128135
, withSystemTempDirectory
129136
, withCurrentDirectory
130137
, writeTextFile
@@ -147,6 +154,10 @@ hoistValidation
147154
\username repository -> f $ githubRepositoryRole username repository
148155
, githubGetFile =
149156
\repository commit filename -> f $ githubGetFile repository commit filename
157+
, githubDownloadDirectory =
158+
\repository commit sourceDir targetDir ->
159+
f
160+
$ githubDownloadDirectory repository commit sourceDir targetDir
150161
, withSystemTempDirectory =
151162
\template action -> controlT
152163
$ \run -> withSystemTempDirectory template (run . action)
@@ -196,6 +207,14 @@ mkValidation auth mpfs tk = do
196207
liftIO $ inspectRepoRoleForUser auth username repository
197208
, githubGetFile = \repository commit filename ->
198209
liftIO $ inspectDownloadedFile auth repository commit filename
210+
, githubDownloadDirectory = \repository commit sourceDir targetDir ->
211+
liftIO
212+
$ GitHub.githubDownloadDirectory
213+
auth
214+
repository
215+
commit
216+
sourceDir
217+
targetDir
199218
, withSystemTempDirectory = \template action ->
200219
control
201220
(\run -> Temp.withSystemTempDirectory template (run . action))

‎cli/test-integration/Lib/GitHubSpec.hs‎

Lines changed: 11 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -2,9 +2,9 @@
22

33
module Lib.GitHubSpec (githubSpec) where
44

5-
import Core.Types.Basic (Commit (..), Repository (..))
5+
import Core.Types.Basic (Commit (..), Directory (..), Repository (..))
66
import GitHub (Auth)
7-
import Lib.GitHub (copyGithubDirectory)
7+
import Lib.GitHub (githubDownloadDirectory)
88
import Path
99
( Dir
1010
, File
@@ -52,15 +52,17 @@ githubSpec = describe "Lib.GitHub" $ do
5252
it "downloads a directory" $ \pat ->
5353
withSystemTempDirectory "github-test" $ \targetPath -> do
5454
targetDir <- parseAbsDir targetPath
55-
copyGithubDirectory pat repo commit srcPath targetDir
55+
githubDownloadDirectory
56+
pat
57+
repo
58+
commit
59+
(Directory $ toFilePath srcPath)
60+
(Directory targetPath)
5661
`shouldReturn` Right ()
57-
let readmeAbsPath = targetDir </> srcPath </> readmePath
62+
let readmeAbsPath = targetDir </> readmePath
5863
doesFileExist (toFilePath readmeAbsPath) `shouldReturn` True
59-
let dockerComposeAbsPath =
60-
targetDir
61-
</> srcPath
62-
</> dockerComposePath
64+
let dockerComposeAbsPath = targetDir </> dockerComposePath
6365
doesFileExist (toFilePath dockerComposeAbsPath)
6466
`shouldReturn` True
65-
let testnetAbsPath = targetDir </> srcPath </> testnetPath
67+
let testnetAbsPath = targetDir </> testnetPath
6668
doesFileExist (toFilePath testnetAbsPath) `shouldReturn` True

‎cli/test/Oracle/Validate/Requests/TestRun/Lib.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -192,6 +192,7 @@ mkValidation
192192
$ GetGithubFileOtherFailure name "file not present"
193193
Just filecontent ->
194194
pure $ analyzeDownloadedFile filename (Right filecontent)
195+
, githubDownloadDirectory = \_ _ _ _ -> pure $ Right ()
195196
, directoryExists = \dir ->
196197
pure
197198
$ dir

0 commit comments

Comments
 (0)