HVFS.hs

{-# LANGUAGE CPP                  #-}
{-# LANGUAGE TypeSynonymInstances #-}
{- arch-tag: HVFS main file
Copyright (c) 2004-2011 John Goerzen <jgoerzen@complete.org>

All rights reserved.

For license and copyright information, see the file LICENSE
-}

{- |
   Module     : System.IO.HVFS
   Copyright  : Copyright (C) 2004-2011 John Goerzen
   SPDX-License-Identifier: BSD-3-Clause

   Stability  : stable
   Portability: portable

Haskell Virtual FS -- generic support for real or virtual filesystem in Haskell

Copyright (c) 2004-2005 John Goerzen, jgoerzen\@complete.org

The idea of this module is to provide virtualization of filesystem calls.
In addition to the \"real\" system filesystem, you can also provide access
to other, virtual, filesystems using the same set of calls.  Examples of
such virtual filesystems might include a remote FTP server, WebDAV server,
a local Hashtable, a ConfigParser object, or any other data structure
you can represent as a tree of named nodes containing strings.

Each 'HVFS' function takes a 'HVFS' \"handle\" ('HVFS' instance) as its
first parameter.  If you wish to operate on the standard system filesystem,
you can just use 'SystemFS'.

The "MissingH.HVFS.IO.InstanceHelpers" module contains some code to help
you make your own HVFS instances.

The 'HVFSOpenable' class works together with the "System.IO.HVIO" module
to provide a complete virtual filesystem and I\/O model that allows you
to open up virtual filesystem files and act upon them in a manner similar
to standard Handles.
-}

module System.IO.HVFS(-- * Implementation Classes \/ Types
                        HVFS(..), HVFSStat(..),
                        HVFSOpenable(..), HVFSOpenEncap(..),HVFSStatEncap(..),
                        withStat, withOpen,
                        SystemFS(..),
                        -- * Re-exported types from other modules
                        FilePath, DeviceID, FileID, FileMode, LinkCount,
                        UserID, GroupID, FileOffset, EpochTime,
                        IOMode
                    )
where

import qualified Control.Exception (catch, IOException)
import System.IO.HVIO ( HVIO(vGetContents, vPutStr, vClose) )
import System.Time.Utils ( epochToClockTime )
import System.IO
    ( openBinaryFile, openFile, IOMode(ReadMode, WriteMode) )
import System.IO.Error
    ( IOErrorType, illegalOperationErrorType, mkIOError )
import System.IO.PlafCompat
    ( DeviceID,
      EpochTime,
      FileID,
      FileMode,
      FileOffset,
      GroupID,
      LinkCount,
      UserID,
#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
      createLink,
      createSymbolicLink,
      getSymbolicLinkStatus,
      readSymbolicLink,
#endif
      accessTime,
      deviceID,
      fileGroup,
      fileID,
      fileMode,
      fileOwner,
      fileSize,
      getFileStatus,
      isBlockDevice,
      isCharacterDevice,
      isDirectory,
      isNamedPipe,
      isRegularFile,
      isSocket,
      isSymbolicLink,
      linkCount,
      modificationTime,
      specialDeviceID,
      statusChangeTime,
      FileStatus )
import System.Time ( ClockTime(..) )
import qualified System.Directory as D

#if MIN_VERSION_directory(1,2,0)
import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds )
#endif

{- | Encapsulate a 'HVFSStat' result.  This is required due to Haskell
typing restrictions.  You can get at it with:

> case encap of
>    HVFSStatEncap x -> -- now use x
-}
data HVFSStatEncap = forall a. HVFSStat a => HVFSStatEncap a

{- | Convenience function for working with stat -- takes a stat result
and a function that uses it, and returns the result.

Here is an example from the HVFS source:

>    vGetModificationTime fs fp =
>       do s <- vGetFileStatus fs fp
>          return $ epochToClockTime (withStat s vModificationTime)

See 'System.Time.Utils.epochToClockTime' for more information.
-}
withStat :: forall b. HVFSStatEncap -> (forall a. HVFSStat a => a -> b) -> b
withStat s f =
    case s of
           HVFSStatEncap x -> f x

{- | Similar to 'HVFSStatEncap', but for 'vOpen' result.
-}
data HVFSOpenEncap = forall a. HVIO a => HVFSOpenEncap a

{- | Similar to 'withStat', but for the 'vOpen' result. -}
withOpen :: forall b. HVFSOpenEncap -> (forall a. HVIO a => a -> b) -> b
withOpen s f =
    case s of
           HVFSOpenEncap x -> f x

{- | Evaluating types of files and information about them.

This corresponds to the System.Posix.Types.FileStatus type, and indeed,
that is one instance of this class.

Inplementators must, at minimum, implement 'vIsDirectory' and
'vIsRegularFile'.

Default implementations of everything else are provided, returning
reasonable values.

A default implementation of this is not currently present on Windows.
-}

class (Show a) => HVFSStat a where
    vDeviceID :: a -> DeviceID
    vFileID :: a -> FileID

    {- | Refers to file permissions, NOT the st_mode field from stat(2) -}
    vFileMode :: a -> FileMode

    vLinkCount :: a -> LinkCount
    vFileOwner :: a -> UserID
    vFileGroup :: a -> GroupID

    vSpecialDeviceID :: a -> DeviceID
    vFileSize :: a -> FileOffset
    vAccessTime :: a -> EpochTime
    vModificationTime :: a -> EpochTime
    vStatusChangeTime :: a -> EpochTime
    vIsBlockDevice :: a -> Bool
    vIsCharacterDevice :: a -> Bool
    vIsNamedPipe :: a -> Bool
    vIsRegularFile :: a -> Bool
    vIsDirectory :: a -> Bool
    vIsSymbolicLink :: a -> Bool
    vIsSocket :: a -> Bool

    vDeviceID _ = 0
    vFileID _ = 0
    vFileMode x = if vIsDirectory x then 0x755 else 0o0644
    vLinkCount _ = 1
    vFileOwner _ = 0
    vFileGroup _ = 0
    vSpecialDeviceID _ = 0
    vFileSize _ = 0
    vAccessTime _ = 0
    vModificationTime _ = 0
    vStatusChangeTime _ = 0
    vIsBlockDevice _ = False
    vIsCharacterDevice _ = False
    vIsNamedPipe _ = False
    vIsSymbolicLink _ = False
    vIsSocket _ = False

{- | The main HVFS class.

Default implementations of these functions are provided:

 * 'vGetModificationTime' -- implemented in terms of 'vGetFileStatus'

 * 'vRaiseError'

 * 'vDoesFileExist' -- implemented in terms of 'vGetFileStatus'

 * 'vDoesDirectoryExist' -- implemented in terms of 'vGetFileStatus'

 * 'vDoesExist' -- implemented in terms of 'vGetSymbolicLinkStatus'

 * 'vGetSymbolicLinkStatus' -- set to call 'vGetFileStatus'.

Default implementations of all other functions
will generate an isIllegalOperation error, since they are assumed to be
un-implemented.

You should always provide at least a 'vGetFileStatus' call, and almost
certainly several of the others.

Most of these functions correspond to functions in System.Directory or
System.Posix.Files.  Please see detailed documentation on them there.
 -}
class (Show a) => HVFS a where
    vGetCurrentDirectory :: a -> IO FilePath
    vSetCurrentDirectory :: a -> FilePath -> IO ()
    vGetDirectoryContents :: a -> FilePath -> IO [FilePath]
    vDoesFileExist :: a -> FilePath -> IO Bool
    vDoesDirectoryExist :: a -> FilePath -> IO Bool
    {- | True if the file exists, regardless of what type it is.
       This is even True if the given path is a broken symlink. -}
    vDoesExist :: a -> FilePath -> IO Bool
    vCreateDirectory :: a -> FilePath -> IO ()
    vRemoveDirectory :: a -> FilePath -> IO ()
    vRenameDirectory :: a -> FilePath -> FilePath -> IO ()
    vRemoveFile :: a -> FilePath -> IO ()
    vRenameFile :: a -> FilePath -> FilePath -> IO ()
    vGetFileStatus :: a -> FilePath -> IO HVFSStatEncap
    vGetSymbolicLinkStatus :: a -> FilePath -> IO HVFSStatEncap
    vGetModificationTime :: a -> FilePath -> IO ClockTime
    {- | Raise an error relating to actions on this class. -}
    vRaiseError :: a -> IOErrorType -> String -> Maybe FilePath -> IO c
    vCreateSymbolicLink :: a -> FilePath -> FilePath -> IO ()
    vReadSymbolicLink :: a -> FilePath -> IO FilePath
    vCreateLink :: a -> FilePath -> FilePath -> IO ()

    vGetModificationTime fs fp =
        do s <- vGetFileStatus fs fp
           return $ epochToClockTime (withStat s vModificationTime)
    vRaiseError _ et desc mfp =
        ioError $ mkIOError et desc Nothing mfp

    vGetCurrentDirectory fs = eh fs "vGetCurrentDirectory"
    vSetCurrentDirectory fs _ = eh fs "vSetCurrentDirectory"
    vGetDirectoryContents fs _ = eh fs "vGetDirectoryContents"
    vDoesFileExist fs fp =
        Control.Exception.catch (do s <- vGetFileStatus fs fp
                                    return $ withStat s vIsRegularFile
              ) (\(_ :: Control.Exception.IOException) -> return False)
    vDoesDirectoryExist fs fp =
        Control.Exception.catch (do s <- vGetFileStatus fs fp
                                    return $ withStat s vIsDirectory
              ) (\(_ :: Control.Exception.IOException) -> return False)
    vDoesExist fs fp =
        Control.Exception.catch (do _ <- vGetSymbolicLinkStatus fs fp
                                    return True
              ) (\(_ :: Control.Exception.IOException) -> return False)
    vCreateDirectory fs _ = eh fs "vCreateDirectory"
    vRemoveDirectory fs _ = eh fs "vRemoveDirectory"
    vRemoveFile fs _ = eh fs "vRemoveFile"
    vRenameFile fs _ _ = eh fs "vRenameFile"
    vRenameDirectory fs _ _ = eh fs "vRenameDirectory"
    vCreateSymbolicLink fs _ _ = eh fs "vCreateSymbolicLink"
    vReadSymbolicLink fs _ = eh fs "vReadSymbolicLink"
    vCreateLink fs _ _ = eh fs "vCreateLink"
    vGetSymbolicLinkStatus = vGetFileStatus

-- | Error handler helper
eh :: HVFS a => a -> String -> IO c
eh fs desc = vRaiseError fs illegalOperationErrorType
             (desc ++ " is not implemented in this HVFS class") Nothing

{- | Types that can open a HVIO object should be instances of this class.
You need only implement 'vOpen'. -}

class HVFS a => HVFSOpenable a where
    vOpen :: a -> FilePath -> IOMode -> IO HVFSOpenEncap
    vReadFile :: a -> FilePath -> IO String
    vWriteFile :: a -> FilePath -> String -> IO ()
    vOpenBinaryFile :: a -> FilePath -> IOMode -> IO HVFSOpenEncap

    vReadFile h fp =
        do oe <- vOpen h fp ReadMode
           withOpen oe (\fh -> vGetContents fh)

    vWriteFile h fp s =
        do oe <- vOpen h fp WriteMode
           withOpen oe (\fh -> do vPutStr fh s
                                  vClose fh)

    -- | Open a file in binary mode.
    vOpenBinaryFile = vOpen

instance Show FileStatus where
    show _ = "<FileStatus>"

----------------------------------------------------------------------
-- Standard implementations
----------------------------------------------------------------------
instance HVFSStat FileStatus where
    vDeviceID = deviceID
    vFileID = fileID
    vFileMode = fileMode
    vLinkCount = linkCount
    vFileOwner = fileOwner
    vFileGroup = fileGroup
    vSpecialDeviceID = specialDeviceID
    vFileSize = fileSize
    vAccessTime = accessTime
    vModificationTime = modificationTime
    vStatusChangeTime = statusChangeTime
    vIsBlockDevice = isBlockDevice
    vIsCharacterDevice = isCharacterDevice
    vIsNamedPipe = isNamedPipe
    vIsRegularFile = isRegularFile
    vIsDirectory = isDirectory
    vIsSymbolicLink = isSymbolicLink
    vIsSocket = isSocket

data SystemFS = SystemFS
              deriving (Eq, Show)

instance HVFS SystemFS where
    vGetCurrentDirectory _ = D.getCurrentDirectory
    vSetCurrentDirectory _ = D.setCurrentDirectory
    vGetDirectoryContents _ = D.getDirectoryContents
    vDoesFileExist _ = D.doesFileExist
    vDoesDirectoryExist _ = D.doesDirectoryExist
    vCreateDirectory _ = D.createDirectory
    vRemoveDirectory _ = D.removeDirectory
    vRenameDirectory _ = D.renameDirectory
    vRemoveFile _ = D.removeFile
    vRenameFile _ = D.renameFile
    vGetFileStatus _ fp = getFileStatus fp >>= return . HVFSStatEncap
#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
    vGetSymbolicLinkStatus _ fp = getSymbolicLinkStatus fp >>= return . HVFSStatEncap
#else
    -- No symlinks on Windows; just get the file status directly
    vGetSymbolicLinkStatus = vGetFileStatus
#endif

#if MIN_VERSION_directory(1,2,0)
    vGetModificationTime _ p = D.getModificationTime p >>= (\modUTCTime -> return $ TOD ((toEnum . fromEnum . utcTimeToPOSIXSeconds) modUTCTime) 0)
#else
    vGetModificationTime _ = D.getModificationTime
#endif
#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
    vCreateSymbolicLink _ = createSymbolicLink
    vReadSymbolicLink _ = readSymbolicLink
    vCreateLink _ = createLink
#else
    vCreateSymbolicLink _ _ _ = fail "Symbolic link creation not supported by Windows"
    vReadSymbolicLink _ _ = fail "Symbolic link reading not supported by Widnows"
    vCreateLink _ _ _ = fail "Hard link creation not supported by Windows"
#endif

instance HVFSOpenable SystemFS where
    vOpen _ fp iomode = openFile fp iomode >>= return . HVFSOpenEncap
    vOpenBinaryFile _ fp iomode = openBinaryFile fp iomode >>= return . HVFSOpenEncap