[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36

[John Goerzen]

The following commit has been merged in the master branch:
commit e98b3c9e9fa86c452478becf5344e89297a98e2e
Author: John Goerzen <jgoerzen at complete.org>
Date:   Wed Dec 22 09:46:33 2004 +0100

    Fixing and testing chroot
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--0.7--patch-139)

diff --git a/ChangeLog b/ChangeLog
index 28c70b3..5d858a8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,19 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
 #
 
+2004-12-22 02:46:33 GMT	John Goerzen <jgoerzen at complete.org>	patch-139
+
+    Summary:
+      Fixing and testing chroot
+    Revision:
+      missingh--head--0.7--patch-139
+
+
+    modified files:
+     ChangeLog libsrc/MissingH/IO/HVFS/Combinators.hs
+     testsrc/HVFStest.hs testsrc/Network/FTP/Parsertest.hs
+
+
 2004-12-21 22:32:36 GMT	John Goerzen <jgoerzen at complete.org>	patch-138
 
     Summary:
diff --git a/libsrc/MissingH/IO/HVFS/Combinators.hs b/libsrc/MissingH/IO/HVFS/Combinators.hs
index be1df68..01502e1 100644
--- a/libsrc/MissingH/IO/HVFS/Combinators.hs
+++ b/libsrc/MissingH/IO/HVFS/Combinators.hs
@@ -67,7 +67,9 @@ newHVFSChroot fh fp =
     do full <- getFullPath fh fp
        isdir <- vDoesDirectoryExist fh full
        if isdir
-          then return (HVFSChroot full fh)
+          then do let newobj = (HVFSChroot full fh)
+                  vSetCurrentDirectory newobj "/"
+                  return newobj
           else vRaiseError fh doesNotExistErrorType
                  ("Attempt to instantiate HVFSChroot over non-directory " ++ full)
                  (Just full)
@@ -77,15 +79,17 @@ dch (HVFSChroot _ a) = a
 
 {- | Convert a local (chroot) path to a full path. -}
 dch2fp (HVFSChroot fp h) locfp = 
-    do full <- getFullPath h locfp
-       case secureAbsNormPath fp (fp ++ "/" ++ full) of
+    do full <- case (head locfp) of
+                  '/' -> return (fp ++ locfp)
+                  x -> getFullPath h locfp
+       case secureAbsNormPath fp full of
            Nothing -> vRaiseError h doesNotExistErrorType  
                         ("Trouble normalizing path") (Just (fp ++ "/" ++ full))
            Just x -> return x
 
 {- | Convert a full path to a local (chroot) path. -}
 fp2dch (HVFSChroot fp h) locfp =
-    do newpath <- case secureAbsNormPath fp (fp ++ "/" ++ locfp) of
+    do newpath <- case secureAbsNormPath fp locfp of
                      Nothing -> vRaiseError h doesNotExistErrorType
                                   ("Unable to securely normalize path")
                                   (Just (fp ++ "/" ++ locfp))
diff --git a/testsrc/HVFStest.hs b/testsrc/HVFStest.hs
index 732b8ac..b1168dc 100644
--- a/testsrc/HVFStest.hs
+++ b/testsrc/HVFStest.hs
@@ -21,6 +21,7 @@ import HUnit
 import MissingH.IO.HVIO
 import MissingH.IO.HVFS
 import MissingH.IO.HVFS.InstanceHelpers
+import MissingH.IO.HVFS.Combinators
 import Testutil
 import System.IO
 import System.IO.Error
@@ -63,6 +64,34 @@ test_content =
          f "subdir test" "/dir1/test.txt"
         ]
 
+test_chroot =
+    let f msg testfunc = TestLabel msg $ TestCase $ 
+                         do x <- newMemoryVFS testTree
+                            vSetCurrentDirectory x "/emptydir"
+                            y <- newHVFSChroot x "/dir1"
+                            testfunc y
+        in
+        [
+         f "root" (\x -> ["file3.txt", "test.txt", "dir2"]
+                   `ioeq` vGetDirectoryContents x "/")
+        ,f "cwd" (\x -> "/" `ioeq` vGetCurrentDirectory x)
+        ,f "dir2" (\x -> [] `ioeq` vGetDirectoryContents x "/dir2")
+        ,f "dot" (\x -> ["file3.txt", "test.txt", "dir2"]
+                  `ioeq` vGetDirectoryContents x ".")
+        ,f "cwd tests" $
+          (\x -> do a <- vGetDirectoryContents x "/"
+                    ["file3.txt", "test.txt", "dir2"] @=? a
+                    vSetCurrentDirectory x "/dir2"
+                    cwd <- vGetCurrentDirectory x
+                    "/dir2" @=? cwd
+                    y <- vGetDirectoryContents x "."
+                    [] @=? y
+          )
+        --,f "test.txt" (\x -> "subdir test" `ioeq` 
+        --               (vOpen x "/test.txt" ReadMode >>= vGetContents))
+        ]
+
+
 test_structure =
     let f msg testfunc = TestLabel msg $ TestCase $ do x <- newMemoryVFS testTree
                                                        testfunc x
@@ -70,6 +99,11 @@ test_structure =
         [
          f "root" (\x -> ["test.txt", "file2.txt", "emptydir", "dir1"]
                          `ioeq` vGetDirectoryContents x "/")
+        ,f "dot" (\x -> ["test.txt", "file2.txt", "emptydir", "dir1"]
+                  `ioeq` vGetDirectoryContents x ".")
+        ,f "dot2" (\x -> ["file3.txt", "test.txt", "dir2"]
+                   `ioeq` do vSetCurrentDirectory x "./dir1"
+                             vGetDirectoryContents x ".")
         ,f "emptydir" (\x -> [] `ioeq` vGetDirectoryContents x "/emptydir")
         ,f "dir1" (\x -> ["file3.txt", "test.txt", "dir2"] `ioeq`
                    vGetDirectoryContents x "/dir1")
@@ -84,4 +118,5 @@ test_structure =
 tests = TestList [TestLabel "nice_slice" (TestList test_nice_slice)
                  ,TestLabel "structure" (TestList test_structure)
                  ,TestLabel "content" (TestList test_content)
+                 ,TestLabel "chroot" (TestList test_chroot)
                  ]
\ No newline at end of file
diff --git a/testsrc/Network/FTP/Parsertest.hs b/testsrc/Network/FTP/Parsertest.hs
index 3ef7ad0..2dd3848 100644
--- a/testsrc/Network/FTP/Parsertest.hs
+++ b/testsrc/Network/FTP/Parsertest.hs
@@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 module Network.FTP.Parsertest(tests) where
 import HUnit
-import MissingH.Network.FTP.Parser
+import MissingH.Network.FTP.ParserClient
 import Testutil
 import Network.Socket
 

-- 
haskell-testpack