File.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  System.RawDevice.File
--
-- Maintainer  :  Isaac Jones <ijones@galois.com>
-- Stability   :  alpha
-- Portability :  GHC
--
-- Explanation: A raw device which can be opened, read from, and
-- written to.  In the basic Halfs filesystem, this is just a file.

module System.RawDevice.File
        ( RawDevice -- no constructor
        , makeRawDevice
        , blocksInDevice
        , finalizeDevice
        , newDevice
        , devBufferRead
        , devBufferWrite
        ) where

import Control.Exception(assert)
-- import Control.Concurrent(MVar, newMVar)
import System.IO(SeekMode(AbsoluteSeek), hFileSize)
import System.Directory(doesFileExist)
import System.Posix.IO(openFd, closeFd, defaultFileFlags,
                       OpenMode(..),  fdWrite, fdSeek)
import Data.Integral ( INInt, intToINInt, fromIntegral'' )
import System.RawDevice.Base ( DiskAddress, bytesPerBlock, locationOfBlock,  BufferBlockHandle,checkBufferBlockHandleSize )
import Binary(openBinIO, copyBytes, seekBin, resetBin)

import System.Posix.Internals (fdGetMode, FDType(RegularFile))
import System.Posix.Files(unionFileModes, ownerReadMode, ownerWriteMode, groupReadMode)
import System.Posix.Types (Fd(Fd))
import qualified GHC.Handle
import GHC.IOBase

-- import Network.BSD
-- import Network.Socket

data RawDevice = RawDevice {rawDevPath   :: FilePath
                           ,rawDevHandle :: Fd
                           }

instance Ord RawDevice where
  compare (RawDevice{rawDevPath=f1}) (RawDevice{rawDevPath=f2})
      = compare f1 f2

instance Eq RawDevice where
  (==) (RawDevice{rawDevPath=f1}) (RawDevice{rawDevPath=f2})
      =  f1 == f2

instance Show RawDevice where
  show rd = "dev_" ++ rawDevPath rd

------------------------------------------------------------
fdToHandle2 :: Fd -> IO Handle
fdToHandle2 (Fd fd) = do
   -- can't avoid fromIntegral'' because of the types returned by these functions
   let fd' = fromIntegral'' fd
   mode <- fdGetMode fd'
   let fd_str = "<file descriptor: " ++ show fd' ++ ">"
--   h <- GHC.Handle.openFd fd' (Just RegularFile) False fd_str mode True{-bin
--   mode-}
   h <- GHC.Handle.fdToHandle' fd' (Just RegularFile) False fd_str mode True{-bin mode-}

   return h

-- |Smart constructor for a raw device.  Opens this file as a device,
-- but does not initialize a filesystem on it or anything like that.
-- FIX: just for testing...
makeRawDevice :: Maybe RawDevice
              -> FilePath -- or whatever
              -> IO RawDevice
makeRawDevice _ path = do
  fd <- openFd path ReadWrite Nothing defaultFileFlags
  return $
         RawDevice { rawDevPath = path
                   , rawDevHandle = fd
                   }

-- newDevice _ = newDevice' "/tmp/foo" Always returns Just FIX: just for testing...
newDevice :: Maybe RawDevice
          -> FilePath -- ^Or whatever
          -> INInt    -- ^length in blocks
          -> IO RawDevice
newDevice _ path fileLen = do
--  let path = "/tmp/blah/disk.data-1" -- ptg
  existsP <- doesFileExist path
  fd <- if existsP
        then openFd path ReadWrite Nothing defaultFileFlags
        else openFd path -- creates it:
                    ReadWrite
                    (Just (foldl1 unionFileModes [ ownerReadMode
                                                 , ownerWriteMode
                                                 , groupReadMode]))
                    defaultFileFlags
  fdSeek fd AbsoluteSeek (fromIntegral'' $ fileLen * (intToINInt bytesPerBlock) - 1)
  fdWrite fd "!"
  return $
         RawDevice { rawDevPath = path
                   , rawDevHandle = fd
                   }

blocksInDevice :: RawDevice
               -> IO DiskAddress
blocksInDevice (RawDevice{rawDevHandle=fd}) = do
-- return (256 * (2 ^ 10) `div` (fromIntegral' bytesPerBlock)) -- FIX: Hard coded...
  h <- fdToHandle2 fd
  s <- hFileSize h
  -- moderately safe due to div.
  return $ fromIntegral'' $ s `div` (toInteger bytesPerBlock)

-- |Closes the device, if necessary.
finalizeDevice :: RawDevice -> IO ()
finalizeDevice (RawDevice{rawDevHandle=h }) = closeFd h

------------------------------------------------------------

devBufferRead :: RawDevice   -- ^which disk?
              -> DiskAddress -- ^Block number
              -> BufferBlockHandle s -- ^Buffer!
              -> IO ()
devBufferRead (RawDevice{rawDevHandle=h}) blockNum buffer = do
  () <- assert (blockNum >= 0) $ return ()
  checkBufferBlockHandleSize buffer
  fileHandle <- openBinIO h
  seekBin fileHandle (locationOfBlock (abs blockNum))
  resetBin buffer
  copyBytes fileHandle
            buffer  bytesPerBlock

devBufferWrite :: RawDevice    -- ^which disk?
               -> DiskAddress  -- ^Block number
               -> BufferBlockHandle s  -- ^Buffer!
               -> IO ()
devBufferWrite (RawDevice{rawDevHandle=h}) blockNum buffer = do
  () <- assert (blockNum >= 0) $ return ()
  checkBufferBlockHandleSize buffer
  -- buffSize <- sizeFixedBinMem buffer
  -- TODO: ???  () <- assert (bytesPerBlock <= buffSize) $ return ()
  fileHandle <- openBinIO h
  seekBin fileHandle (locationOfBlock (abs blockNum))
  resetBin buffer
  copyBytes buffer
            fileHandle bytesPerBlock