{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Properties.Darcs (tests) where
import Test.QuickCheck
import Control.Exception (AsyncException(..), ErrorCall(..),
SomeException, bracket, throwIO, try)
import Data.List (find, sort)
import qualified Data.Text as T
import Data.Time.Clock.POSIX (getPOSIXTime)
import System.Directory (canonicalizePath, createDirectory,
createDirectoryIfMissing,
createFileLink, createDirectoryLink,
getTemporaryDirectory,
removeDirectoryRecursive)
import System.Exit (ExitCode(..))
import System.FilePath ((</>))
import DarcsWeb.Types (TreeEntry(..), RepoInfo(..))
import DarcsWeb.Darcs (getRepoTree, getRepoBlob, listRepos, tryNonAsync,
capDiff, maxDiffChars)
-- --------------------------------------------------------------------------
-- Temporary directory helper (no extra dependency). The root is
-- canonicalised so the repo jail check compares like with like, exactly
-- as 'withRepo' hands a canonical path to the Darcs layer.
-- --------------------------------------------------------------------------
withTempDir :: (FilePath -> IO a) -> IO a
withTempDir = bracket mk removeDirectoryRecursive
where
mk = do
tmp <- getTemporaryDirectory >>= canonicalizePath
t <- getPOSIXTime
let go :: Int -> IO FilePath
go n = do
let d = tmp </> ("darcsweb-test-" ++ show t ++ "-" ++ show n)
r <- try (createDirectory d) :: IO (Either SomeException ())
case r of
Right () -> return d
Left e | n < 100 -> go (n + 1)
| otherwise -> throwIO e
go 0
writeBytes :: FilePath -> Int -> IO ()
writeBytes p n = writeFile p (replicate n 'x')
-- --------------------------------------------------------------------------
-- Behaviour 6: a dangling symlink in the working tree must not turn the
-- tree page into a 500. The listing still succeeds and regular files
-- keep their size. Pinned variant: symlinks are listed as non-directory
-- entries with size 0.
-- --------------------------------------------------------------------------
prop_tree_dangling_symlink :: Property
prop_tree_dangling_symlink = once $ ioProperty $ withTempDir $ \root -> do
let repo = root </> "repo"
createDirectoryIfMissing True (repo </> "_darcs")
writeBytes (repo </> "normal.txt") 42
createFileLink (root </> "does-not-exist") (repo </> "dangling")
r <- try (getRepoTree repo "") :: IO (Either SomeException (Maybe [TreeEntry]))
return $ case r of
Right (Just es) ->
let normal = find ((== "normal.txt") . teName) es
dangled = find ((== "dangling") . teName) es
in counterexample (show es) $
fmap teSize normal == Just 42
&& fmap teIsDir normal == Just False
&& fmap teSize dangled == Just 0
&& fmap teIsDir dangled == Just False
Right Nothing -> counterexample "getRepoTree returned Nothing" False
Left e -> counterexample ("getRepoTree threw: " ++ show e) False
-- --------------------------------------------------------------------------
-- Behaviour 7: a symlink to a file outside the repository must not leak
-- the target's size into the listing, and the blob route still refuses
-- to read it.
-- --------------------------------------------------------------------------
prop_tree_symlink_outside_no_size :: Property
prop_tree_symlink_outside_no_size = once $ ioProperty $ withTempDir $ \root -> do
let repo = root </> "repo"
outside = root </> "outside"
createDirectoryIfMissing True (repo </> "_darcs")
createDirectoryIfMissing True outside
writeBytes (outside </> "secret.txt") 1234
writeBytes (repo </> "inside.txt") 7
createFileLink (outside </> "secret.txt") (repo </> "leak")
mEs <- getRepoTree repo ""
blob <- getRepoBlob repo "leak"
return $ case mEs of
Nothing -> counterexample "getRepoTree returned Nothing" False
Just es ->
let leak = find ((== "leak") . teName) es
inside = find ((== "inside.txt") . teName) es
in counterexample (show es) $
fmap teSize leak == Just 0
&& fmap teIsDir leak == Just False
&& fmap teSize inside == Just 7
&& blob == Nothing
-- --------------------------------------------------------------------------
-- Symlink policy (second opinion, finding 3): a symlink whose canonical
-- target lies inside the repo jail is treated like its target, so
-- in-tree directory links stay navigable and file links show their real
-- size. Dangling or outside links keep the no-stat variant above
-- (non-directory, size 0); this includes a link to an outside directory.
-- --------------------------------------------------------------------------
prop_tree_symlink_inside_dir_navigable :: Property
prop_tree_symlink_inside_dir_navigable = once $ ioProperty $ withTempDir $ \root -> do
let repo = root </> "repo"
createDirectoryIfMissing True (repo </> "_darcs")
createDirectoryIfMissing True (repo </> "real" </> "sub")
writeBytes (repo </> "real" </> "inner.txt") 5
createDirectoryLink (repo </> "real") (repo </> "dlink")
mEs <- getRepoTree repo ""
mSub <- getRepoTree repo "dlink"
return $ case mEs of
Nothing -> counterexample "getRepoTree returned Nothing" False
Just es ->
let dl = find ((== "dlink") . teName) es
in counterexample (show es ++ " / " ++ show mSub) $
fmap teIsDir dl == Just True
&& fmap (map teName) mSub == Just ["sub", "inner.txt"]
prop_tree_symlink_inside_file_size :: Property
prop_tree_symlink_inside_file_size = once $ ioProperty $ withTempDir $ \root -> do
let repo = root </> "repo"
createDirectoryIfMissing True (repo </> "_darcs")
writeBytes (repo </> "target.txt") 321
createFileLink (repo </> "target.txt") (repo </> "flink")
mEs <- getRepoTree repo ""
blob <- getRepoBlob repo "flink"
return $ case mEs of
Nothing -> counterexample "getRepoTree returned Nothing" False
Just es ->
let fl = find ((== "flink") . teName) es
in counterexample (show es) $
fmap teSize fl == Just 321
&& fmap teIsDir fl == Just False
&& fmap T.length blob == Just 321
prop_tree_symlink_outside_dir_not_dir :: Property
prop_tree_symlink_outside_dir_not_dir = once $ ioProperty $ withTempDir $ \root -> do
let repo = root </> "repo"
outside = root </> "outside"
createDirectoryIfMissing True (repo </> "_darcs")
createDirectoryIfMissing True (outside </> "private")
createDirectoryLink outside (repo </> "odir")
mEs <- getRepoTree repo ""
mSub <- getRepoTree repo "odir"
return $ case mEs of
Nothing -> counterexample "getRepoTree returned Nothing" False
Just es ->
let od = find ((== "odir") . teName) es
in counterexample (show es ++ " / " ++ show mSub) $
fmap teIsDir od == Just False
&& fmap teSize od == Just 0
&& maybe True (const False) mSub
-- Fail-closed for darcs metadata: a working-tree symlink whose canonical
-- target is @_darcs@ or anything under it is opaque (non-directory, size
-- 0, not stat'ed), and neither the tree nor the blob route resolves
-- through it, also not via deeper paths below the link.
prop_tree_symlink_to_darcs_dir_opaque :: Property
prop_tree_symlink_to_darcs_dir_opaque = once $ ioProperty $ withTempDir $ \root -> do
let repo = root </> "repo"
createDirectoryIfMissing True (repo </> "_darcs" </> "prefs")
writeBytes (repo </> "_darcs" </> "prefs" </> "somefile") 99
createDirectoryLink (repo </> "_darcs") (repo </> "meta")
mEs <- getRepoTree repo ""
mMeta <- getRepoTree repo "meta"
mPrefs <- getRepoTree repo "meta/prefs"
blob <- getRepoBlob repo "meta/prefs/somefile"
return $ case mEs of
Nothing -> counterexample "getRepoTree returned Nothing" False
Just es ->
let m = find ((== "meta") . teName) es
in counterexample (show es ++ " / " ++ show mMeta ++ " / "
++ show mPrefs ++ " / " ++ show blob) $
fmap teIsDir m == Just False
&& fmap teSize m == Just 0
&& isNothing' mMeta && isNothing' mPrefs && blob == Nothing
prop_tree_symlink_to_darcs_file_opaque :: Property
prop_tree_symlink_to_darcs_file_opaque = once $ ioProperty $ withTempDir $ \root -> do
let repo = root </> "repo"
createDirectoryIfMissing True (repo </> "_darcs" </> "prefs")
writeBytes (repo </> "_darcs" </> "prefs" </> "somefile") 99
createFileLink (repo </> "_darcs" </> "prefs" </> "somefile") (repo </> "pref")
mEs <- getRepoTree repo ""
blob <- getRepoBlob repo "pref"
return $ case mEs of
Nothing -> counterexample "getRepoTree returned Nothing" False
Just es ->
let p = find ((== "pref") . teName) es
in counterexample (show es ++ " / " ++ show blob) $
fmap teIsDir p == Just False
&& fmap teSize p == Just 0
&& blob == Nothing
isNothing' :: Maybe a -> Bool
isNothing' = maybe True (const False)
-- --------------------------------------------------------------------------
-- Behaviours 8 and 9: 'tryNonAsync' captures ordinary failures but lets
-- asynchronous exceptions (Warp timeout, killThread) propagate.
-- --------------------------------------------------------------------------
prop_tryNonAsync_captures_sync :: Property
prop_tryNonAsync_captures_sync = once $ ioProperty $ do
r1 <- tryNonAsync (throwIO (userError "x") :: IO ())
r2 <- tryNonAsync (throwIO (ErrorCall "y") :: IO ())
r3 <- tryNonAsync (throwIO (ExitFailure 1) :: IO ())
r4 <- tryNonAsync (return (5 :: Int))
return $ isLeft r1 && isLeft r2 && isLeft r3 && either (const False) (== 5) r4
where
isLeft = either (const True) (const False)
prop_tryNonAsync_rethrows_async :: Property
prop_tryNonAsync_rethrows_async = once $ ioProperty $ do
r <- try (tryNonAsync (throwIO ThreadKilled :: IO ()))
return $ case r of
Left ThreadKilled -> property True
Left other -> counterexample ("wrong async: " ++ show other) False
Right inner -> counterexample
("swallowed: " ++ either show (const "Right ()") inner) False
prop_tryNonAsync_rethrows_user_interrupt :: Property
prop_tryNonAsync_rethrows_user_interrupt = once $ ioProperty $ do
r <- try (tryNonAsync (throwIO UserInterrupt :: IO ()))
return $ case r of
Left UserInterrupt -> True
_ -> False
-- --------------------------------------------------------------------------
-- Behaviour 12 (pure part): diff size cap.
-- --------------------------------------------------------------------------
prop_maxDiffChars_value :: Bool
prop_maxDiffChars_value = maxDiffChars == 2000000
prop_capDiff_short_unchanged :: Property
prop_capDiff_short_unchanged =
forAll (choose (0, 200)) $ \n ->
forAll (arbitrary :: Gen String) $ \s ->
length s <= n ==> capDiff n s == (T.pack s, False)
prop_capDiff_exact_boundary :: Property
prop_capDiff_exact_boundary =
forAll (arbitrary :: Gen String) $ \s ->
capDiff (length s) s == (T.pack s, False)
prop_capDiff_long_truncated :: Property
prop_capDiff_long_truncated =
forAll (listOf1 arbitrary) $ \s ->
forAll (choose (0, length s - 1)) $ \n ->
capDiff n s == (T.pack (take n s), True)
-- The cap must bound the work: an unbounded (lazy) rendering is only
-- consumed up to the limit, so an infinite input still terminates.
prop_capDiff_lazy :: Property
prop_capDiff_lazy = once $ within 5000000 $
let (t, cut) = capDiff 1000 (cycle "+line\n")
in T.length t == 1000 && cut
-- --------------------------------------------------------------------------
-- Behaviour 17: the index ('listRepos') respects the same jail as
-- 'withRepo': hidden repos and repos symlinked from outside are not
-- listed. A plain repo next to them still is (so the test is not
-- vacuous). The fake repos have no real darcs history; a failed read
-- must still yield a listing entry with count 0.
-- --------------------------------------------------------------------------
prop_listRepos_jail :: Property
prop_listRepos_jail = once $ ioProperty $ withTempDir $ \root -> do
let repos = root </> "repos"
outside = root </> "outside" </> "extrepo"
createDirectoryIfMissing True (repos </> "good" </> "_darcs")
createDirectoryIfMissing True (repos </> ".hidden" </> "_darcs")
createDirectoryIfMissing True (outside </> "_darcs")
createDirectoryLink outside (repos </> "linked")
-- Names that 'withRepo' rejects ('isValidRepoName') must not be
-- listed either, or the index shows dead links. A valid name with an
-- inner dot stays listed, so the filter does not over-reject.
mapM_ (\n -> createDirectoryIfMissing True (repos </> n </> "_darcs"))
[ "foo..bar", "a\\b", "a\tb", "a\DELb", "my-repo_1.0" ]
rs <- listRepos repos
let names = sort (map (T.unpack . riName) rs)
return $ counterexample (show names) (names == ["good", "my-repo_1.0"])
-- --------------------------------------------------------------------------
-- Test runner
-- --------------------------------------------------------------------------
tests :: IO Bool
tests = fmap and $ sequence
[ run "6 tree survives dangling symlink" prop_tree_dangling_symlink
, run "7 tree hides outside symlink size" prop_tree_symlink_outside_no_size
, run "tree in-repo dir symlink navigable" prop_tree_symlink_inside_dir_navigable
, run "tree in-repo file symlink real size" prop_tree_symlink_inside_file_size
, run "tree outside dir symlink not a dir" prop_tree_symlink_outside_dir_not_dir
, run "tree symlink to _darcs dir opaque" prop_tree_symlink_to_darcs_dir_opaque
, run "tree symlink to _darcs file opaque" prop_tree_symlink_to_darcs_file_opaque
, run "8 tryNonAsync captures sync errors" prop_tryNonAsync_captures_sync
, run "9 tryNonAsync rethrows ThreadKilled" prop_tryNonAsync_rethrows_async
, run "9 tryNonAsync rethrows UserInterrupt" prop_tryNonAsync_rethrows_user_interrupt
, run "12 maxDiffChars value" (property prop_maxDiffChars_value)
, run "12 capDiff short unchanged" prop_capDiff_short_unchanged
, run "12 capDiff exact boundary" prop_capDiff_exact_boundary
, run "12 capDiff long truncated" prop_capDiff_long_truncated
, run "12 capDiff is lazy" prop_capDiff_lazy
, run "17 listRepos skips hidden/outside/invalid" prop_listRepos_jail
]
where
run name prop = do
putStr $ " " ++ name ++ ": "
r <- quickCheckWithResult stdArgs { maxSuccess = 200 } prop
return (isSuccess r)
