- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE GeneralizedNewtypeDeriving, PackageImports, BangPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns #-}
module Annex (
Annex,
) where
import Annex.Common
+import Utility.QuickCheck
import qualified Data.ByteString as S
[] -> sep l curr cs
| otherwise = sep l (c:curr) cs
-prop_viewedFile_roundtrips :: FilePath -> Bool
-prop_viewedFile_roundtrips f
+prop_viewedFile_roundtrips :: TestableFilePath -> Bool
+prop_viewedFile_roundtrips tf
-- Relative filenames wanted, not directories.
| any (isPathSeparator) (end f ++ beginning f) = True
| isAbsolute f = True
| otherwise = dir == dirFromViewedFile (viewedFileFromReference f)
where
+ f = fromTestableFilePath tf
dir = joinPath $ beginning $ splitDirectories f
-{-# LANGUAGE PackageImports #-}
-
module Common (module X) where
import Control.Monad as X
import Utility.Exception as X
import Utility.DebugLocks as X
import Utility.SafeCommand as X
+import Utility.ShellEscape as X
import Utility.Process as X
import Utility.Path as X
import Utility.Path.AbsRel as X
import Common
import Utility.Format (decode_c, encode_c)
+import Utility.QuickCheck
import Data.Char
import Data.Word
encode :: RawFilePath -> S.ByteString
encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\""
-prop_encode_decode_roundtrip :: FilePath -> Bool
-prop_encode_decode_roundtrip s = s' ==
- fromRawFilePath (decode (encode (toRawFilePath s')))
+-- Encoding and then decoding roundtrips only when the string does not
+-- contain high unicode, because eg, both "\12345" and "\227\128\185"
+-- are encoded to "\343\200\271".
+--
+-- That is not a real-world problem, and using TestableFilePath
+-- limits what's tested to ascii, so avoids running into it.
+prop_encode_decode_roundtrip :: TestableFilePath -> Bool
+prop_encode_decode_roundtrip ts =
+ s == fromRawFilePath (decode (encode (toRawFilePath s)))
where
- s' = nonul (nohigh s)
- -- Encoding and then decoding roundtrips only when
- -- the string does not contain high unicode, because eg,
- -- both "\12345" and "\227\128\185" are encoded to
- -- "\343\200\271".
- --
- -- This property papers over the problem, by only
- -- testing ascii
- nohigh = filter isAscii
- -- A String can contain a NUL, but toRawFilePath
- -- truncates on the NUL, which is generally fine
- -- because unix filenames cannot contain NUL.
- -- So the encoding only roundtrips when there is no nul.
- nonul = filter (/= '\NUL')
+ s = fromTestableFilePath ts
prop_isomorphic_key_encode
) where
-import Data.Char
import qualified Data.Text as T
import qualified Data.ByteString as S
import qualified Data.Attoparsec.ByteString as A
<*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative
<*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative
--- AssociatedFile cannot be empty, and cannot contain a NUL
--- (but can be Nothing).
instance Arbitrary AssociatedFile where
- arbitrary = (AssociatedFile . fmap conv <$> arbitrary)
- `suchThat` (/= AssociatedFile (Just S.empty))
- `suchThat` (\(AssociatedFile f) -> maybe True (S.notElem 0) f)
- where
- -- Generating arbitrary unicode leads to encoding errors
- -- when LANG=C, so limit to ascii.
- conv = toRawFilePath . filter isAscii
+ arbitrary = AssociatedFile
+ . fmap (toRawFilePath . fromTestableFilePath)
+ <$> arbitrary
instance Arbitrary Key where
arbitrary = mkKey . const <$> arbitrary
import Types.ProposedAccepted
import Logs.UUIDBased
import Annex.SpecialRemote.Config
+import Utility.QuickCheck
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
rest = drop 1 r
{- for quickcheck -}
-prop_isomorphic_configEscape :: String -> Bool
-prop_isomorphic_configEscape s = s == (configUnEscape . configEscape) s
+prop_isomorphic_configEscape :: TestableString -> Bool
+prop_isomorphic_configEscape ts = s == (configUnEscape . configEscape) s
+ where
+ s = fromTestableString ts
prop_parse_show_Config :: RemoteConfig -> Bool
prop_parse_show_Config c
import Annex.Locations
import Utility.Rsync
import Utility.SafeCommand
+import Utility.ShellEscape
import Utility.FileSystemEncoding
import Annex.DirHashes
#ifdef mingw32_HOST_OS
import Common
import CmdLine.GitAnnex.Options
-import qualified Utility.SafeCommand
+import qualified Utility.ShellEscape
import qualified Utility.RawFilePath as R
import qualified Annex
import qualified Git.Filename
import qualified Annex.View.ViewedFile
import qualified Logs.View
import qualified Command.TestRemote
-import qualified Utility.Path
+import qualified Utility.Path.Tests
import qualified Utility.FileMode
import qualified BuildInfo
import qualified Utility.Format
[ testProperty "prop_encode_decode_roundtrip" Git.Filename.prop_encode_decode_roundtrip
, testProperty "prop_encode_c_decode_c_roundtrip" Utility.Format.prop_encode_c_decode_c_roundtrip
, testProperty "prop_isomorphic_key_encode" Key.prop_isomorphic_key_encode
- , testProperty "prop_isomorphic_shellEscape" Utility.SafeCommand.prop_isomorphic_shellEscape
- , testProperty "prop_isomorphic_shellEscape_multiword" Utility.SafeCommand.prop_isomorphic_shellEscape_multiword
+ , testProperty "prop_isomorphic_shellEscape" Utility.ShellEscape.prop_isomorphic_shellEscape
+ , testProperty "prop_isomorphic_shellEscape_multiword" Utility.ShellEscape.prop_isomorphic_shellEscape_multiword
, testProperty "prop_isomorphic_configEscape" Logs.Remote.prop_isomorphic_configEscape
, testProperty "prop_parse_show_Config" Logs.Remote.prop_parse_show_Config
- , testProperty "prop_upFrom_basics" Utility.Path.prop_upFrom_basics
- , testProperty "prop_relPathDirToFileAbs_basics" Utility.Path.prop_relPathDirToFileAbs_basics
- , testProperty "prop_relPathDirToFileAbs_regressionTest" Utility.Path.prop_relPathDirToFileAbs_regressionTest
+ , testProperty "prop_upFrom_basics" Utility.Path.Tests.prop_upFrom_basics
+ , testProperty "prop_relPathDirToFileAbs_basics" Utility.Path.Tests.prop_relPathDirToFileAbs_basics
+ , testProperty "prop_relPathDirToFileAbs_regressionTest" Utility.Path.Tests.prop_relPathDirToFileAbs_regressionTest
, testProperty "prop_cost_sane" Config.Cost.prop_cost_sane
, testProperty "prop_matcher_sane" Utility.Matcher.prop_matcher_sane
, testProperty "prop_HmacSha1WithCipher_sane" Crypto.prop_HmacSha1WithCipher_sane
module Utility.Base64 where
import Utility.FileSystemEncoding
+import Utility.QuickCheck
import qualified "sandi" Codec.Binary.Base64 as B64
import Data.Maybe
-- Only ascii strings are tested, because an arbitrary string may contain
-- characters not encoded using the FileSystemEncoding, which would thus
-- not roundtrip, as decodeBS always generates an output encoded that way.
-prop_b64_roundtrips :: String -> Bool
-prop_b64_roundtrips s
+prop_b64_roundtrips :: TestableString -> Bool
+prop_b64_roundtrips ts
| all (isAscii) s = s == decodeBS (fromB64' (toB64' (encodeBS s)))
| otherwise = True
+ where
+ s = fromTestableString ts
dotfile,
splitShortExtensions,
relPathDirToFileAbs,
-
- prop_upFrom_basics,
- prop_relPathDirToFileAbs_basics,
- prop_relPathDirToFileAbs_regressionTest,
) where
import System.FilePath.ByteString
import Utility.Monad
import Utility.SystemDirectory
-import Utility.FileSystemEncoding
{- Simplifies a path, removing any "." component, collapsing "dir/..",
- and removing the trailing path separator.
(drive, path) = splitDrive dir
dirs = filter (not . B.null) $ B.splitWith isPathSeparator path
-prop_upFrom_basics :: FilePath -> Bool
-prop_upFrom_basics dir
- | null dir = True
- | '\NUL' `elem` dir = True -- not a legal filename
- | dir == "/" = p == Nothing
- | otherwise = p /= Just dir
- where
- p = fromRawFilePath <$> upFrom (toRawFilePath dir)
-
{- Checks if the first RawFilePath is, or could be said to contain the second.
- For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
- are all equivilant.
#ifdef mingw32_HOST_OS
normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive
#endif
-
-prop_relPathDirToFileAbs_basics :: FilePath -> FilePath -> Bool
-prop_relPathDirToFileAbs_basics from to
- | null from || null to = True
- | '\NUL' `elem` from || '\NUL' `elem` to = True -- not a legal filename
- | from == to = null r
- | otherwise = not (null r)
- where
- r = fromRawFilePath $ relPathDirToFileAbs
- (toRawFilePath from)
- (toRawFilePath to)
-
-prop_relPathDirToFileAbs_regressionTest :: Bool
-prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference
- where
- {- Two paths have the same directory component at the same
- - location, but it's not really the same directory.
- - Code used to get this wrong. -}
- same_dir_shortcurcuits_at_difference =
- relPathDirToFileAbs (joinPath [pathSeparator `B.cons` "tmp", "r", "lll", "xxx", "yyy", "18"])
- (joinPath [pathSeparator `B.cons` "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
- == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
--- /dev/null
+{- Tests for Utility.Path. Split into a separate module to avoid it needing
+ - QuickCheck.
+ -
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Path.Tests (
+ prop_upFrom_basics,
+ prop_relPathDirToFileAbs_basics,
+ prop_relPathDirToFileAbs_regressionTest,
+) where
+
+import System.FilePath.ByteString
+import qualified Data.ByteString as B
+import Data.List
+import Data.Maybe
+import Control.Applicative
+import Prelude
+
+import Utility.Path
+import Utility.FileSystemEncoding
+import Utility.QuickCheck
+
+prop_upFrom_basics :: TestableFilePath -> Bool
+prop_upFrom_basics tdir
+ | dir == "/" = p == Nothing
+ | otherwise = p /= Just dir
+ where
+ p = fromRawFilePath <$> upFrom (toRawFilePath dir)
+ dir = fromTestableFilePath tdir
+
+prop_relPathDirToFileAbs_basics :: TestableFilePath -> TestableFilePath -> Bool
+prop_relPathDirToFileAbs_basics fromt tot
+ | from == to = null r
+ | otherwise = not (null r)
+ where
+ from = fromTestableFilePath fromt
+ to = fromTestableFilePath tot
+ r = fromRawFilePath $ relPathDirToFileAbs
+ (toRawFilePath from)
+ (toRawFilePath to)
+
+prop_relPathDirToFileAbs_regressionTest :: Bool
+prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference
+ where
+ {- Two paths have the same directory component at the same
+ - location, but it's not really the same directory.
+ - Code used to get this wrong. -}
+ same_dir_shortcurcuits_at_difference =
+ relPathDirToFileAbs (joinPath [pathSeparator `B.cons` "tmp", "r", "lll", "xxx", "yyy", "18"])
+ (joinPath [pathSeparator `B.cons` "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
+ == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
{- QuickCheck with additional instances
-
- - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
module Utility.QuickCheck
( module X
- , module Utility.QuickCheck
+ , TestableString
+ , fromTestableString
+ , TestableFilePath
+ , fromTestableFilePath
+ , nonNegative
+ , positive
) where
import Test.QuickCheck as X
import Data.Time.Clock.POSIX
import Data.Ratio
+import Data.Char
import System.Posix.Types
import Data.List.NonEmpty (NonEmpty(..))
import Prelude
+{- A String, but Arbitrary is limited to ascii.
+ -
+ - When in a non-utf8 locale, String does not normally contain any non-ascii
+ - characters, except for ones in surrogate plane. Converting a string that
+ - does contain other unicode characters to a ByteString using the
+ - filesystem encoding (see GHC.IO.Encoding) will throw an exception,
+ - so use this instead to avoid quickcheck tests breaking unncessarily.
+ -}
+newtype TestableString = TestableString
+ { fromTestableString :: String }
+ deriving (Show)
+
+instance Arbitrary TestableString where
+ arbitrary = TestableString . filter isAscii <$> arbitrary
+
+{- FilePath constrained to not be the empty string, not contain a NUL,
+ - and contain only ascii.
+ -
+ - No real-world filename can be empty or contain a NUL. So code can
+ - well be written that assumes that and using this avoids quickcheck
+ - tests breaking unncessarily.
+ -}
+newtype TestableFilePath = TestableFilePath
+ { fromTestableFilePath :: FilePath }
+ deriving (Show)
+
+instance Arbitrary TestableFilePath where
+ arbitrary = (TestableFilePath . fromTestableString <$> arbitrary)
+ `suchThat` (not . null . fromTestableFilePath)
+ `suchThat` (not . any (== '\NUL') . fromTestableFilePath)
+
{- Times before the epoch are excluded. Half with decimal and half without. -}
instance Arbitrary POSIXTime where
arbitrary = do
safeSystem,
safeSystem',
safeSystemEnv,
- shellWrap,
- shellEscape,
- shellUnEscape,
segmentXargsOrdered,
segmentXargsUnordered,
- prop_isomorphic_shellEscape,
- prop_isomorphic_shellEscape_multiword,
) where
-import System.Exit
import Utility.Process
-import Utility.Split
+
+import System.Exit
import System.FilePath
import Data.Char
import Data.List
safeSystemEnv command params environ = safeSystem' command params $
\p -> p { env = environ }
--- | Wraps a shell command line inside sh -c, allowing it to be run in a
--- login shell that may not support POSIX shell, eg csh.
-shellWrap :: String -> String
-shellWrap cmdline = "sh -c " ++ shellEscape cmdline
-
--- | Escapes a filename or other parameter to be safely able to be exposed to
--- the shell.
---
--- This method works for POSIX shells, as well as other shells like csh.
-shellEscape :: String -> String
-shellEscape f = "'" ++ escaped ++ "'"
- where
- -- replace ' with '"'"'
- escaped = intercalate "'\"'\"'" $ splitc '\'' f
-
--- | Unescapes a set of shellEscaped words or filenames.
-shellUnEscape :: String -> [String]
-shellUnEscape [] = []
-shellUnEscape s = word : shellUnEscape rest
- where
- (word, rest) = findword "" s
- findword w [] = (w, "")
- findword w (c:cs)
- | c == ' ' = (w, cs)
- | c == '\'' = inquote c w cs
- | c == '"' = inquote c w cs
- | otherwise = findword (w++[c]) cs
- inquote _ w [] = (w, "")
- inquote q w (c:cs)
- | c == q = findword w cs
- | otherwise = inquote q (w++[c]) cs
-
--- | For quickcheck.
-prop_isomorphic_shellEscape :: String -> Bool
-prop_isomorphic_shellEscape s = [s] == (shellUnEscape . shellEscape) s
-prop_isomorphic_shellEscape_multiword :: [String] -> Bool
-prop_isomorphic_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s
-
-- | Segments a list of filenames into groups that are all below the maximum
-- command-line length limit.
segmentXargsOrdered :: [FilePath] -> [[FilePath]]
--- /dev/null
+{- shell escaping
+ -
+ - Copyright 2010-2015 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.ShellEscape (
+ shellWrap,
+ shellEscape,
+ shellUnEscape,
+ prop_isomorphic_shellEscape,
+ prop_isomorphic_shellEscape_multiword,
+) where
+
+import Utility.QuickCheck
+import Utility.Split
+
+import Data.List
+import Prelude
+
+-- | Wraps a shell command line inside sh -c, allowing it to be run in a
+-- login shell that may not support POSIX shell, eg csh.
+shellWrap :: String -> String
+shellWrap cmdline = "sh -c " ++ shellEscape cmdline
+
+-- | Escapes a filename or other parameter to be safely able to be exposed to
+-- the shell.
+--
+-- This method works for POSIX shells, as well as other shells like csh.
+shellEscape :: String -> String
+shellEscape f = "'" ++ escaped ++ "'"
+ where
+ -- replace ' with '"'"'
+ escaped = intercalate "'\"'\"'" $ splitc '\'' f
+
+-- | Unescapes a set of shellEscaped words or filenames.
+shellUnEscape :: String -> [String]
+shellUnEscape [] = []
+shellUnEscape s = word : shellUnEscape rest
+ where
+ (word, rest) = findword "" s
+ findword w [] = (w, "")
+ findword w (c:cs)
+ | c == ' ' = (w, cs)
+ | c == '\'' = inquote c w cs
+ | c == '"' = inquote c w cs
+ | otherwise = findword (w++[c]) cs
+ inquote _ w [] = (w, "")
+ inquote q w (c:cs)
+ | c == q = findword w cs
+ | otherwise = inquote q (w++[c]) cs
+
+prop_isomorphic_shellEscape :: TestableString -> Bool
+prop_isomorphic_shellEscape ts = [s] == (shellUnEscape . shellEscape) s
+ where
+ s = fromTestableString ts
+
+prop_isomorphic_shellEscape_multiword :: [TestableString] -> Bool
+prop_isomorphic_shellEscape_multiword ts =
+ l == (shellUnEscape . unwords . map shellEscape) l
+ where
+ l = map fromTestableString ts
import qualified Data.ByteString as S
import Utility.Hash
+import Utility.QuickCheck
type Secret = S.ByteString
type HMACDigest = String
calcDigest :: String -> Secret -> HMACDigest
calcDigest v secret = calcMac HmacSha1 secret (fromString v)
-{- for quickcheck -}
-prop_verifiable_sane :: String -> String -> Bool
-prop_verifiable_sane a s = verify (mkVerifiable a secret) secret
+prop_verifiable_sane :: TestableString -> TestableString -> Bool
+prop_verifiable_sane v ts =
+ verify (mkVerifiable (fromTestableString v) secret) secret
where
- secret = fromString s
+ secret = fromString (fromTestableString ts)
[[!meta author=yoh]]
[[!tag projects/datalad]]
+
+[[!fixed|done]] --[[Joey]]
Utility.Path
Utility.Path.AbsRel
Utility.Path.Max
+ Utility.Path.Tests
Utility.Percentage
Utility.Process
Utility.Process.Shim
Utility.Scheduled
Utility.Scheduled.QuickCheck
Utility.Shell
+ Utility.ShellEscape
Utility.SimpleProtocol
Utility.Split
Utility.SshConfig
projects / git-annex.git / commitdiff