[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 7efe4fe2729e6f8ad5e45c76a9c7273b2410510c
Author: John Goerzen <jgoerzen at complete.org>
Date:   Tue Dec 21 22:17:53 2004 +0100

    Checkpointing HVFSChroot (compiles)
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--0.7--patch-120)

diff --git a/ChangeLog b/ChangeLog
index 1beae68..be8e635 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,21 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
 #
 
+2004-12-21 15:17:53 GMT	John Goerzen <jgoerzen at complete.org>	patch-120
+
+    Summary:
+      Checkpointing HVFSChroot (compiles)
+    Revision:
+      missingh--head--0.7--patch-120
+
+
+    new files:
+     libsrc/MissingH/IO/HVFS/Combinators.hs
+
+    modified files:
+     ChangeLog
+
+
 2004-12-21 03:54:03 GMT	John Goerzen <jgoerzen at complete.org>	patch-119
 
     Summary:
diff --git a/libsrc/MissingH/IO/HVFS/Combinators.hs b/libsrc/MissingH/IO/HVFS/Combinators.hs
new file mode 100644
index 0000000..748fae5
--- /dev/null
+++ b/libsrc/MissingH/IO/HVFS/Combinators.hs
@@ -0,0 +1,120 @@
+{- arch-tag: HVFS Combinators
+Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+-}
+
+{- |
+   Module     : MissingH.IO.HVFS.Combinators
+   Copyright  : Copyright (C) 2004 John Goerzen
+   License    : GNU GPL, version 2 or above
+
+   Maintainer : John Goerzen, 
+   Maintainer : jgoerzen at complete.org
+   Stability  : provisional
+   Portability: portable
+
+Support for combining different HVFS modules together
+
+Copyright (c) 2004 John Goerzen, jgoerzen\@complete.org
+
+-}
+
+module MissingH.IO.HVFS.Combinators(
+                                    -- * Restrictions
+                                   )
+where
+
+import MissingH.IO.HVFS
+import MissingH.IO.HVIO
+import MissingH.IO.HVFS.InstanceHelpers
+import System.IO
+import System.IO.Error
+import System.Posix.Files
+import System.Posix.Types
+import System.Time
+import System.Directory
+import MissingH.Path
+import MissingH.Path.NameManip
+
+----------------------------------------------------------------------
+-- Restricting to a subdirectory
+----------------------------------------------------------------------
+
+{- | Access a subdirectory of a real filesystem as if it was the root
+of that filesystem. -}
+data HVFS a => HVFSChroot a = HVFSChroot String a
+                            deriving (Eq, Show)
+
+{- | Get the embedded object -}
+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
+           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
+                     Nothing -> vRaiseError h doesNotExistErrorType
+                                  ("Unable to securely normalize path")
+                                  (Just (fp ++ "/" ++ locfp))
+                     Just x -> return x
+       if (take (length fp) newpath /= fp)
+               then vRaiseError h doesNotExistErrorType
+                        ("Local path is not subdirectory of parent path")
+                        (Just newpath)
+               else let newpath2 = drop (length fp) newpath
+                        in return $ normalise_path ("/" ++ newpath2)
+
+dch2fph func fh@(HVFSChroot fp h) locfp =
+    do newfp <- dch2fp fh locfp
+       func h newfp
+instance HVFS a => HVFS (HVFSChroot a) where
+    vGetCurrentDirectory x = do fp <- vGetCurrentDirectory (dch x)
+                                fp2dch x fp
+    vSetCurrentDirectory = dch2fph vSetCurrentDirectory
+    vGetDirectoryContents = dch2fph vGetDirectoryContents
+    vDoesFileExist = dch2fph vDoesFileExist
+    vDoesDirectoryExist = dch2fph vDoesDirectoryExist
+    vCreateDirectory = dch2fph vCreateDirectory
+    vRemoveDirectory = dch2fph vRemoveDirectory
+    vRenameDirectory fh old new = do old' <- dch2fp fh old
+                                     new' <- dch2fp fh new
+                                     vRenameDirectory (dch fh) old' new'
+    vRemoveFile = dch2fph vRemoveFile
+    vRenameFile fh old new = do old' <- dch2fp fh old
+                                new' <- dch2fp fh new
+                                vRenameFile (dch fh) old' new'
+    vGetFileStatus = dch2fph vGetFileStatus
+    vGetSymbolicLinkStatus = dch2fph vGetSymbolicLinkStatus
+    vGetModificationTime = dch2fph vGetModificationTime
+    -- vRaiseError
+    vCreateSymbolicLink fh old new = do old' <- dch2fp fh old
+                                        new' <- dch2fp fh new
+                                        vCreateSymbolicLink (dch fh) old' new'
+    vReadSymbolicLink fh fp = do result <- dch2fph vReadSymbolicLink fh fp
+                                 fp2dch fh result
+    vCreateLink fh old new = do old' <- dch2fp fh old
+                                new' <- dch2fp fh new
+                                vCreateLink (dch fh) old' new'
+
+instance HVFSOpenable a => HVFSOpenable (HVFSChroot a) where
+    vOpen fh fp mode = do newfile <- dch2fp fh fp
+                          vOpen (dch fh) newfile mode

-- 
haskell-testpack