1 {-# LANGUAGE GADTs, ViewPatterns, ScopedTypeVariables, MultiParamTypeClasses,
    2              FlexibleInstances, OverloadedStrings, CPP, FunctionalDependencies #-}
    3 -- | This module implements relative paths within a Tree. All paths are
    4 -- anchored at a certain root (this is usually the Tree root). They are
    5 -- represented by a list of Names (these are just strict bytestrings).
    6 module Storage.Hashed.Path
    7     ( Path, Relative, Absolute, (</>), Split(..), isPrefix, root, isRoot
    8     , absolute, relative, directory, singleton, parent, parents, file, Name, (+/+), suffix
    9     , pathToBS, pathToString, unsafePathFromBS, unsafePathFromString
   10     , parsePath, parsePathBS, eitherPath, test_S_H_Path ) where
   11 
   12 import qualified Data.ByteString.Char8 as BS
   13 import Data.Char( isPrint )
   14 import Data.List( isPrefixOf, inits )
   15 import Data.Maybe( fromJust )
   16 
   17 import Test.QuickCheck
   18 import Test.Framework.Providers.QuickCheck2
   19 import Test.Framework( Test )
   20 
   21 -------------------------------
   22 -- Path utilities
   23 --
   24 
   25 separators :: [Char]
   26 #if mingw32_HOST_OS
   27 separators = [ '/', '\\' ]
   28 #else
   29 separators = [ '/' ]
   30 #endif
   31 
   32 type Name = BS.ByteString
   33 
   34 class Path p where
   35   root :: p
   36 
   37   unpath :: p -> BS.ByteString
   38   path :: BS.ByteString -> p
   39 
   40   parsePathBS :: BS.ByteString -> Maybe p
   41   pathToBS :: p -> BS.ByteString
   42 
   43   goUp :: p -> Maybe p
   44 
   45 newtype Relative = Relative BS.ByteString deriving (Show, Eq, Ord)
   46 newtype Absolute = Absolute BS.ByteString deriving (Show, Eq, Ord)
   47 
   48 isRoot :: (Path p) => p -> Bool
   49 isRoot = BS.null . unpath
   50 
   51 parse :: (Show p, Path p) => BS.ByteString -> p
   52 parse path
   53   | BS.null path = root
   54   | BS.take 2 path == "./" = parse $ BS.drop 2 path
   55   | BS.take 1 path == "/" = parse $ BS.drop 1 path
   56   | otherwise = case BS.span (/= '/') path of
   57                  (head, tail) -> root </> head +/+ parse (BS.drop 1 tail)
   58 
   59 instance Path Relative where
   60   root = Relative BS.empty
   61   unpath (Relative x) = x
   62   path = Relative
   63 
   64   pathToBS (unpath -> p) | BS.null p = "."
   65                          | otherwise = p
   66 
   67   parsePathBS path
   68      | BS.null path = Just root
   69      | BS.head path `elem` separators = Nothing
   70      | otherwise = Just $ parse path
   71 
   72   goUp p | Just pp <- parent p, _ :/: last <- file p, last /= ".." = Just pp
   73          | otherwise = Nothing
   74 
   75 instance Path Absolute where
   76   root = Absolute $ BS.singleton '/'
   77   unpath (Absolute x) = BS.drop 1 x
   78   path = Absolute . BS.cons '/'
   79 
   80   parsePathBS path
   81      | BS.null path = Nothing
   82      | BS.head path `notElem` separators = Nothing
   83      | otherwise = Just $ parse path
   84 
   85   pathToBS (Absolute p) = p
   86 
   87   goUp p | Nothing <- parent p = Just root
   88          | Just pp <- parent p, _ :/: last <- file p, last /= ".." = Just pp
   89          | otherwise = Nothing
   90 
   91 relative :: Relative
   92 relative = root
   93 
   94 absolute :: Absolute
   95 absolute = root
   96 
   97 -- | Check whether a path is a prefix of another path.
   98 isPrefix :: Path p => p -> p -> Bool
   99 isPrefix (unpath -> a) (unpath -> b)
  100   | BS.null a = True
  101   | BS.length a == BS.length b = a == b
  102   | BS.isPrefixOf a b = BS.index b (BS.length a) == '/'
  103   | otherwise = False
  104 
  105 (</>) :: forall p. (Show p, Path p) => p -> Name -> p
  106 (unpath -> p) </> n
  107   | n == BS.pack "." = path p
  108   | n == BS.pack "..", Just pp <- goUp (path p) = pp
  109   | BS.null p = path $ BS.concat [unpath (root :: p), n]
  110   | BS.null n = path p
  111   | BS.elem '/' n = error $ "BUG: Path components may not contain slashes: "
  112                     ++ show (BS.unpack p) ++ ", " ++ BS.unpack n
  113   | otherwise = path $ BS.concat [p, BS.singleton '/', n]
  114 
  115 (+/+) :: (Show p, Path p) => p -> Relative -> p
  116 p@(unpath -> p') +/+ q@(unpath -> q')
  117   | ".." :/: _ <- directory q, Just pp <- goUp p = pp +/+ path (BS.drop 3 q')
  118   | BS.null q' = p
  119   | BS.null p' = path q'
  120   | otherwise = path $ BS.concat [ p', BS.singleton '/', q' ]
  121 
  122 data Split a b = a :/: b | Atomic
  123 
  124 singleton :: Path p => p -> Maybe BS.ByteString
  125 singleton (file -> dir :/: file)
  126   | isRoot dir = Just file
  127 singleton _ = Nothing
  128 
  129 directory :: Path p => p -> Split BS.ByteString Relative
  130 directory (unpath -> p) = case BS.break (=='/') p of
  131   _ | BS.null p -> Atomic
  132   (dir, p') -> dir :/: path (BS.drop 1 p')
  133 
  134 file :: Path p => p -> Split p BS.ByteString
  135 file (unpath -> p) = case BS.breakEnd (=='/') p of
  136   _ | BS.null p -> Atomic
  137   (p', file) | BS.null p' -> root :/: file
  138              | otherwise -> (path $ BS.init p') :/: file
  139 
  140 suffix :: (Show p, Path p) => p -> p -> Maybe Relative
  141 suffix x@(unpath -> x') y@(unpath -> y')
  142   | BS.null x' = Just $ path y'
  143   | x `isPrefix` y = Just $ path $ BS.drop (BS.length x' + 1) y'
  144   | otherwise = Nothing -- error $ "BUG: Path " ++ show x ++ " is not a prefix of " ++ show y ++ "!"
  145 
  146 -- unsafe
  147 toNames (unpath -> p) = BS.split '/' p
  148 fromNames names = path $ BS.intercalate (BS.singleton '/') names
  149 
  150 parent :: Path p => p -> Maybe p
  151 parent (file -> parent :/: _) = Just parent
  152 parent path@(file -> Atomic) = Nothing
  153 
  154 parents :: forall p. Path p => p -> [p]
  155 parents (file -> dir :/: _) = dir : parents dir
  156 parents (file -> Atomic) = []
  157 
  158 pathToString :: (Path p) => p -> String
  159 pathToString = BS.unpack . pathToBS
  160 
  161 unsafePathFromBS :: (Path p) => BS.ByteString -> p
  162 unsafePathFromBS = path
  163 
  164 unsafePathFromString :: (Path p) => String -> p
  165 unsafePathFromString = path . BS.pack
  166 
  167 parsePath :: Path a => String -> Maybe a
  168 parsePath = parsePathBS . BS.pack
  169 
  170 -- | Project "path" under a rename of "from" to "to".
  171 renamePath :: Relative -> Relative -> Relative -> Relative
  172 renamePath from to path
  173   | Just suff <- suffix from path = to +/+ suff
  174   | otherwise = path
  175 
  176 eitherPath :: String -> Either Absolute Relative
  177 eitherPath p = case (parsePath p, parsePath p) of
  178   (Nothing, Nothing) -> error $ "BUG: The path " ++ p ++ " is neither relative nor absolute."
  179   (Just x, Nothing) -> Left x
  180   (Nothing, Just x) -> Right x
  181   (Just _, Just _) -> error $ "BUG: The path " ++ p ++ " is both relative and absolute."
  182 
  183 ---------------- TESTING -------------------
  184 
  185 checkInvariants :: (Path p) => p -> Bool
  186 checkInvariants p'@(unpath -> p)
  187   | ".." `elem` (dropWhile (== "..") $ toNames p') = False
  188   | "/./" `BS.isInfixOf` p = False
  189   | "//" `BS.isInfixOf` p = False
  190   | ".." `BS.isSuffixOf` p && not (BS.null $ BS.filter (`notElem` ('.':separators)) p) = False
  191   | otherwise = True
  192 
  193 newtype RawAbsPath = RawAbsPath BS.ByteString deriving (Eq)
  194 newtype RawRelPath = RawRelPath BS.ByteString deriving (Eq)
  195 newtype Component = Component BS.ByteString deriving (Eq, Show)
  196 
  197 instance Show RawAbsPath where
  198   show p@(RawAbsPath p') = "RawAbsPath " ++ show (p', cook p)
  199 instance Show RawRelPath where
  200   show p@(RawRelPath p') = "RawRelPath " ++ show (p', cook p)
  201 
  202 arb_rawpath = sized $ \n ->
  203   dropWhile BS.null `fmap` sequence [ x >>= \(Component y) -> return y | x <- replicate n arbitrary ]
  204 
  205 instance Arbitrary Component where
  206   arbitrary = Component `fmap` frequency
  207                   [ (1, return "."), (2, return "..")
  208                   , (3, BS.filter (`notElem` separators) `fmap` bytestring) ]
  209     where bytestring = BS.pack `fmap` filter isPrint `fmap` arbitrary
  210 
  211 instance Arbitrary RawAbsPath where
  212   arbitrary = do raw <- arb_rawpath
  213                  return $ RawAbsPath $ BS.concat
  214                    [ "/", BS.intercalate "/" $ dropWhile (== "..") raw ]
  215 instance Arbitrary RawRelPath where
  216   arbitrary = do raw <- arb_rawpath
  217                  return $ RawRelPath $ BS.intercalate "/" raw
  218 
  219 class Cook raw cooked | raw -> cooked, raw -> cooked where
  220   cook :: raw -> cooked
  221 
  222 instance Cook RawAbsPath Absolute where
  223   cook (RawAbsPath x) = case parsePathBS x of
  224     Nothing -> error $ "Parse failed on path: " ++ show x
  225     Just y -> y
  226 instance Cook RawRelPath Relative where
  227   cook (RawRelPath x) = case parsePathBS x of
  228     Nothing -> error $ "Parse failed on path: " ++ show x
  229     Just y -> y
  230 
  231 test_S_H_Path = parametric "Absolute" (undefined :: RawAbsPath) ++
  232                 parametric "Relative" (undefined :: RawRelPath) ++
  233                 [ testProperty "leading .. count" prop_leaddotdot ]
  234      where parametric :: forall r p. (Cook r p, Show p, Path p, Arbitrary r, Show r)
  235                       => String -> r -> [Test]
  236            parametric name _ =
  237              [ prop "parsePathBS invariants" (prop_parse :: r -> Bool)
  238              , prop "</> invariants" (prop_append :: (r, Component) -> Bool)
  239              , prop "+/+ invariants" (prop_cat :: (r, RawRelPath) -> Bool)
  240              , prop "a == suffix b (b +/+ a)" (prop_suff :: (RawRelPath, r) -> Property)
  241              , prop "suffix invariants" (prop_suffinv :: (RawRelPath, r) -> Property)
  242              , prop "+/+, no inner .." (prop_catdot_inside :: (r, RawRelPath) -> Bool)
  243              , prop "+/+, leading .. count" (prop_catdot_lead1 :: (r, RawRelPath) -> Bool) ]
  244                where prop n p = testProperty (name ++ " " ++ n) p
  245            prop_parse raw = checkInvariants $ cook raw
  246            prop_cat (r1, r2) = checkInvariants $ cook r1 +/+ cook r2
  247            prop_append (raw, Component comp) = checkInvariants $ cook raw </> comp
  248            prop_leaddotdot raw@(RawRelPath raw') = upcount (cook raw) >= upcount' raw'
  249              where upcount = length . takeWhile (== "..") . toNames
  250                    upcount' = length . takeWhile (== "..") . breakup
  251                    breakup = filter (/= ".") . filter (/= "") . BS.split '/'
  252 
  253            nondot p = length (dropWhile (=="..") $ toNames p)
  254            leaddot p = length (takeWhile (=="..") $ toNames p)
  255 
  256            prop_catdot_inside (cook -> a, cook -> b) =
  257              ".." `notElem` (dropWhile (== "..") $ toNames $ a +/+ b)
  258            prop_catdot_lead1 (cook -> a, cook -> b) = leaddot (a +/+ b) >= leaddot a
  259            -- prop_catdot_lead2 (cook -> a, cook -> b) = leaddot (a +/+ b) == leaddot a
  260 
  261            with_suff :: (Show c, Path c, Cook r c) =>
  262                         (Relative -> c -> Maybe Relative -> Bool) -> (RawRelPath, r) -> Property
  263            with_suff prop (cook -> a, cook -> b)
  264              | ".." :/: _ <- directory a = False ==> False
  265              | otherwise = True ==> prop a b (suffix b (b +/+ a))
  266            prop_suff :: (Cook r c, Path c, Show c) => (RawRelPath, r) -> Property
  267            prop_suff = with_suff $ \a _ suff -> Just a == suff
  268            prop_suffinv :: (Cook r c, Path c, Show c) => (RawRelPath, r) -> Property
  269            prop_suffinv = with_suff $ \_ _ suff -> checkInvariants (fromJust suff)
  270