mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

avoid head

Browse source 
While in some sense this is better, the use of NE.fromList is still
partial.
This commit is contained in:
Joey Hess 2024-09-26 17:53:00 -04:00
parent c8fcd97626
commit 936f22273e
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
2 changed files with 16 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
Command/TestRemote.hs
View file

@ -42,6 +42,7 @@ import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import Data.Either
import Control.Concurrent.STM hiding (check)
import qualified Data.List.NonEmpty as NE
cmd :: Command
cmd = command "testremote" SectionTesting
@ -83,8 +84,10 @@ start o = starting "testremote" (ActionItemOther (Just (UnquotedString (testRemo
then giveup "This remote is readonly, so you need to use the --test-readonly option."
else do
showAction "generating test keys"
mapM randKey (keySizes basesz fast)
fs -> mapM (getReadonlyKey r . toRawFilePath) fs
NE.fromList
<$> mapM randKey (keySizes basesz fast)
fs -> NE.fromList
<$> mapM (getReadonlyKey r . toRawFilePath) fs
let r' = if null (testReadonlyFile o)
then r
else r { Remote.readonly = True }
@ -100,7 +103,7 @@ start o = starting "testremote" (ActionItemOther (Just (UnquotedString (testRemo
basesz = fromInteger $ sizeOption o
si = SeekInput [testRemote o]
perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> [Key] -> CommandPerform
perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> NE.NonEmpty Key -> CommandPerform
perform drs unavailr exportr ks = do
st <- liftIO . newTVarIO =<< (,)
<$> Annex.getState id
@ -110,12 +113,12 @@ perform drs unavailr exportr ks = do
drs
(pure unavailr)
exportr
(map (\k -> Described (desck k) (pure k)) ks)
(NE.map (\k -> Described (desck k) (pure k)) ks)
ok <- case tryIngredients [consoleTestReporter] mempty tests of
Nothing -> error "No tests found!?"
Just act -> liftIO act
rs <- catMaybes <$> mapM getVal drs
next $ cleanup rs ks ok
next $ cleanup rs (NE.toList ks) ok
where
desck k = unwords [ "key size", show (fromKey keySize k) ]
@ -216,12 +219,12 @@ mkTestTrees
-> [Described (Annex (Maybe Remote))]
-> Annex (Maybe Remote)
-> Annex (Maybe Remote)
-> [Described (Annex Key)]
-> (NE.NonEmpty (Described (Annex Key)))
-> [TestTree]
mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $
[ [ testGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (Prelude.head mkks))) ]
, [ testGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- mkks, mkr <- mkrs ]
, [ testGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 mkks, mkk2 <- take 2 (reverse mkks) ]
[ [ testGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (NE.head mkks))) ]
, [ testGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- NE.toList mkks, mkr <- mkrs ]
, [ testGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 (NE.toList mkks), mkk2 <- take 2 (reverse (NE.toList mkks)) ]
]
where
desc r k = intercalate "; " $ map unwords

7
Test.hs
View file

@ -23,11 +23,12 @@ import Options.Applicative (switch, long, short, help, internal, maybeReader, op
import qualified Data.Map as M
import qualified Data.ByteString.Lazy.UTF8 as BU8
import Control.Concurrent.STM hiding (check)
import qualified Utility.RawFilePath as R
import qualified Data.List.NonEmpty as NE
import Data.String
import Common
import CmdLine.GitAnnex.Options
import qualified Utility.RawFilePath as R
import Data.String
import qualified Utility.ShellEscape
import qualified Annex
@ -251,7 +252,7 @@ testRemote testvariants remotetype setupremote =
cv <- annexeval cache
liftIO $ atomically $ putTMVar v
(r, (unavailr, (exportr, (ks, cv))))
go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr mkks
go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr (NE.fromList mkks)
where
runannex = inmainrepo . annexeval
mkrs = if testvariants