[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 6e4682186f9876452e4abd8ff572c4a7053fe41c
Author: John Goerzen <jgoerzen at complete.org>
Date:   Fri Dec 24 00:33:24 2004 +0100

    Added HVFSReadOnly
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--0.7--patch-156)

diff --git a/ChangeLog b/ChangeLog
index e32ef68..f3a635a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,18 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
 #
 
+2004-12-23 17:33:24 GMT	John Goerzen <jgoerzen at complete.org>	patch-156
+
+    Summary:
+      Added HVFSReadOnly
+    Revision:
+      missingh--head--0.7--patch-156
+
+
+    modified files:
+     ChangeLog libsrc/MissingH/IO/HVFS/Combinators.hs
+
+
 2004-12-23 17:21:02 GMT	John Goerzen <jgoerzen at complete.org>	patch-155
 
     Summary:
diff --git a/libsrc/MissingH/IO/HVFS/Combinators.hs b/libsrc/MissingH/IO/HVFS/Combinators.hs
index 5e07d62..362b510 100644
--- a/libsrc/MissingH/IO/HVFS/Combinators.hs
+++ b/libsrc/MissingH/IO/HVFS/Combinators.hs
@@ -34,6 +34,7 @@ Copyright (c) 2004 John Goerzen, jgoerzen\@complete.org
 
 module MissingH.IO.HVFS.Combinators(
                                     -- * Restrictions
+                                    HVFSReadOnly,
                                     HVFSChroot, newHVFSChroot
                                    )
 where
@@ -51,6 +52,49 @@ import MissingH.Path
 import MissingH.Path.NameManip
 
 ----------------------------------------------------------------------
+-- Providing read-only access
+----------------------------------------------------------------------
+
+{- | Restrict access to the underlying filesystem to be strictly
+read-only.  Any write-type operations will cause an error.
+
+No constructor is required; just say @HVFSReadOnly fs@ to make a
+new read-only wrapper around the 'HVFS' instance @fs at .
+-}
+data HVFS a => HVFSReadOnly a = HVFSReadOnly a
+                              deriving (Eq, Show)
+withro :: HVFS a => (a -> b) -> HVFSReadOnly a -> b
+withro f (HVFSReadOnly x) = f x
+
+roerror h = 
+    let err x = vRaiseError x permissionErrorType "Read-only virtual filesystem"
+                  Nothing
+        in withro err h
+
+instance HVFS a => HVFS (HVFSReadOnly a) where
+    vGetCurrentDirectory = withro vGetCurrentDirectory
+    vSetCurrentDirectory = withro vSetCurrentDirectory
+    vGetDirectoryContents = withro vGetDirectoryContents
+    vDoesFileExist = withro vDoesFileExist
+    vDoesDirectoryExist = withro vDoesDirectoryExist
+    vCreateDirectory h _ = roerror h
+    vRemoveDirectory h _ = roerror h
+    vRenameDirectory h _ _ = roerror h
+    vRenameFile h _ _ = roerror h
+    vGetFileStatus = withro vGetFileStatus
+    vGetSymbolicLinkStatus = withro vGetSymbolicLinkStatus
+    vGetModificationTime = withro vGetModificationTime
+    vRaiseError = withro vRaiseError
+    vCreateSymbolicLink h _ _ = roerror h
+    vReadSymbolicLink = withro vReadSymbolicLink
+    vCreateLink h _ _ = roerror h
+
+instance HVFSOpenable a => HVFSOpenable (HVFSReadOnly a) where
+    vOpen fh fp mode = 
+        case mode of ReadMode -> withro (\h -> vOpen h fp mode) fh
+                     _ -> roerror fh
+
+----------------------------------------------------------------------
 -- Restricting to a subdirectory
 ----------------------------------------------------------------------
 

-- 
haskell-testpack