{-# LANGUAGE CPP #-}{- arch-tag: HVFS Combinators
Copyright (C) 2004-2005 John Goerzen <jgoerzen@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 : System.IO.HVFS.Combinators
Copyright : Copyright (C) 2004-2005 John Goerzen
License : GNU GPL, version 2 or above
Maintainer : John Goerzen <jgoerzen@complete.org>
Stability : provisional
Portability: portable
Support for combining different HVFS modules together
Copyright (c) 2004-2005 John Goerzen, jgoerzen\@complete.org
-}moduleSystem.IO.HVFS.Combinators(-- * RestrictionsHVFSReadOnly(..),HVFSChroot,newHVFSChroot)whereimportSystem.IOimportSystem.IO.ErrorimportSystem.IO.HVFSimportSystem.IO.HVFS.InstanceHelpers(getFullPath)#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))importSystem.Posix.Files-- This actually needed? -Wall doesn't seem to think-- so, but I'm not sure...#endifimportSystem.Path(secureAbsNormPath)importSystem.Path.NameManip(normalise_path)------------------------------------------------------------------------ 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@.
-}dataHVFSa=>HVFSReadOnlya=HVFSReadOnlyaderiving(Eq,Show)withro::HVFSa=>(a->b)->HVFSReadOnlya->bwithrof(HVFSReadOnlyx)=fxroerror::(HVFSa)=>HVFSReadOnlya->IOcroerrorh=leterrx=vRaiseErrorxpermissionErrorType"Read-only virtual filesystem"NothinginwithroerrhinstanceHVFSa=>HVFS(HVFSReadOnlya)wherevGetCurrentDirectory=withrovGetCurrentDirectoryvSetCurrentDirectory=withrovSetCurrentDirectoryvGetDirectoryContents=withrovGetDirectoryContentsvDoesFileExist=withrovDoesFileExistvDoesDirectoryExist=withrovDoesDirectoryExistvCreateDirectoryh_=roerrorhvRemoveDirectoryh_=roerrorhvRenameDirectoryh__=roerrorhvRenameFileh__=roerrorhvGetFileStatus=withrovGetFileStatusvGetSymbolicLinkStatus=withrovGetSymbolicLinkStatusvGetModificationTime=withrovGetModificationTimevRaiseError=withrovRaiseErrorvCreateSymbolicLinkh__=roerrorhvReadSymbolicLink=withrovReadSymbolicLinkvCreateLinkh__=roerrorhinstanceHVFSOpenablea=>HVFSOpenable(HVFSReadOnlya)wherevOpenfhfpmode=casemodeofReadMode->withro(\h->vOpenhfpmode)fh_->roerrorfh------------------------------------------------------------------------ Restricting to a subdirectory----------------------------------------------------------------------{- | Access a subdirectory of a real filesystem as if it was the root
of that filesystem. -}dataHVFSa=>HVFSChroota=HVFSChrootStringaderiving(Eq,Show){- | Create a new 'HVFSChroot' object. -}newHVFSChroot::HVFSa=>a-- ^ The object to pass requests on to->FilePath-- ^ The path of the directory to make root->IO(HVFSChroota)-- ^ The resulting new objectnewHVFSChrootfhfp=dofull<-getFullPathfhfpisdir<-vDoesDirectoryExistfhfullifisdirthendoletnewobj=(HVFSChrootfullfh)vSetCurrentDirectorynewobj"/"returnnewobjelsevRaiseErrorfhdoesNotExistErrorType("Attempt to instantiate HVFSChroot over non-directory "++full)(Justfull){- | Get the embedded object -}dch::(HVFSt)=>HVFSChroott->tdch(HVFSChroot_a)=a{- | Convert a local (chroot) path to a full path. -}dch2fp,fp2dch::(HVFSt)=>HVFSChroott->String->IOStringdch2fpmainh@(HVFSChrootfph)locfp=dofull<-case(headlocfp)of'/'->return(fp++locfp)_->doy<-getFullPathmainhlocfpreturn$fp++ycasesecureAbsNormPathfpfullofNothing->vRaiseErrorhdoesNotExistErrorType("Trouble normalizing path in chroot")(Just(fp++","++full))Justx->returnx{- | Convert a full path to a local (chroot) path. -}fp2dch(HVFSChrootfph)locfp=donewpath<-casesecureAbsNormPathfplocfpofNothing->vRaiseErrorhdoesNotExistErrorType("Unable to securely normalize path")(Just(fp++"/"++locfp))Justx->returnxif(take(lengthfp)newpath/=fp)thenvRaiseErrorhdoesNotExistErrorType("Local path is not subdirectory of parent path")(Justnewpath)elseletnewpath2=drop(lengthfp)newpathinreturn$normalise_path("/"++newpath2)dch2fph::(HVFSt)=>(t->String->IOt1)->HVFSChroott->[Char]->IOt1dch2fphfuncfh@(HVFSChroot_h)locfp=donewfp<-dch2fpfhlocfpfunchnewfpinstanceHVFSa=>HVFS(HVFSChroota)wherevGetCurrentDirectoryx=dofp<-vGetCurrentDirectory(dchx)fp2dchxfpvSetCurrentDirectory=dch2fphvSetCurrentDirectoryvGetDirectoryContents=dch2fphvGetDirectoryContentsvDoesFileExist=dch2fphvDoesFileExistvDoesDirectoryExist=dch2fphvDoesDirectoryExistvCreateDirectory=dch2fphvCreateDirectoryvRemoveDirectory=dch2fphvRemoveDirectoryvRenameDirectoryfholdnew=doold'<-dch2fpfholdnew'<-dch2fpfhnewvRenameDirectory(dchfh)old'new'vRemoveFile=dch2fphvRemoveFilevRenameFilefholdnew=doold'<-dch2fpfholdnew'<-dch2fpfhnewvRenameFile(dchfh)old'new'vGetFileStatus=dch2fphvGetFileStatusvGetSymbolicLinkStatus=dch2fphvGetSymbolicLinkStatusvGetModificationTime=dch2fphvGetModificationTime-- vRaiseErrorvCreateSymbolicLinkfholdnew=doold'<-dch2fpfholdnew'<-dch2fpfhnewvCreateSymbolicLink(dchfh)old'new'vReadSymbolicLinkfhfp=doresult<-dch2fphvReadSymbolicLinkfhfpfp2dchfhresultvCreateLinkfholdnew=doold'<-dch2fpfholdnew'<-dch2fpfhnewvCreateLink(dchfh)old'new'instanceHVFSOpenablea=>HVFSOpenable(HVFSChroota)wherevOpenfhfpmode=donewfile<-dch2fpfhfpvOpen(dchfh)newfilemode