{-# OPTIONS_GHC -cpp -fvia-C -fglasgow-exts #-}
{- |
   Module     : System.FD
   Copyright  : Copyright (C) 2006 Bulat Ziganshin
   License    : BSD3

   Maintainer : Bulat Ziganshin <bulatz@HotPOP.com>
   Stability  : experimental
   Portability: Hugs/GHC

Raw POSIX files support

Based on: The standard IO library (c) The University of Glasgow, 1992-2002
-}

module System.FD where

import Control.Monad
import Data.Bits
import Data.Int
import Data.Word
import Foreign.C.Types
import Foreign.C.Error
import Foreign.C.String
import Foreign.Marshal.Alloc
import Foreign.Ptr
import System.IO
import System.IO.Error
import System.Posix.Types

#ifdef __GLASGOW_HASKELL__
import System.Posix.Internals
#else
import System.Posix.Internals hiding (FD)
#endif

#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || defined(_MSC_VER)
import System.Win32
#endif

type FD = Int                 -- handle of open file
type CWFilePath   = CString   -- filename in C land
type CWFileOffset = COff      -- filesize or filepos in C land
type FileSize     = Integer   -- filesize or filepos in Haskell land
withCWFilePath = withCString  -- FilePath->CWFilePath conversion
peekCWFilePath = peekCString  -- CWFilePath->FilePath conversion

-- Standard File Descriptors
fdStdIn  = 0::FD
fdStdOut = 1::FD
fdStdErr = 2::FD

-- ---------------------------------------------------------------------------
-- Opening and Closing Files

-- | Computation 'openRawFD' @file mode@ allocates and returns a new, open
-- handle to manage the file @file@.  It manages input if @mode@
-- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
-- and both input and output if mode is 'ReadWriteMode'.
--
-- If the file does not exist and it is opened for output, it should be
-- created as a new file.  If @mode@ is 'WriteMode' and the file
-- already exists, then it should be truncated to zero length.
-- Some operating systems delete empty files, so there is no guarantee
-- that the file will exist following an 'openFile' with @mode@
-- 'WriteMode' unless it is subsequently written to successfully.
-- The handle is positioned at the end of the file if @mode@ is
-- 'AppendMode', and otherwise at the beginning (in which case its
-- internal position is 0).
-- The initial buffer mode is implementation-dependent.
--
-- This operation may fail with:
--
--  * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
--
--  * 'isDoesNotExistError' if the file does not exist; or
--
--  * 'isPermissionError' if the user does not have permission to open the file.
--
-- Note: if you will be working with files containing binary data, you'll want to
-- be using 'openRawBinaryFD'.
openRawFD :: FilePath -> IOMode -> IO FD
openRawFD fp im =
  modifyIOError
    (\e -> annotateIOError e "openRawFD" Nothing (Just fp))
    (openRawFD' fp im dEFAULT_OPEN_IN_BINARY_MODE)

-- | Like 'openRawFD', but open the file in binary mode.
-- On Windows, reading a file in text mode (which is the default)
-- will translate CRLF to LF, and writing will translate LF to CRLF.
-- This is usually what you want with text files.  With binary files
-- this is undesirable; also, as usual under Microsoft operating systems,
-- text mode treats control-Z as EOF.  Binary mode turns off all special
-- treatment of end-of-line and end-of-file characters.
-- (See also 'hSetBinaryMode'.)

openRawBinaryFD :: FilePath -> IOMode -> IO FD
openRawBinaryFD fp m =
  modifyIOError
    (\e -> annotateIOError e "openRawBinaryFD" Nothing (Just fp))
    (openRawFD' fp m True)

openRawFD' :: FilePath -> IOMode -> Bool -> IO FD
openRawFD' filepath mode binary =
    let
      oflags1 = case mode of
                  ReadMode      -> read_flags
#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || defined(_MSC_VER)
                  WriteMode     -> write_flags .|. o_TRUNC
#else
                  WriteMode     -> write_flags
#endif
                  ReadWriteMode -> rw_flags
                  AppendMode    -> append_flags

      binary_flags
          | binary    = o_BINARY
          | otherwise = 0

      oflags = oflags1 .|. binary_flags

    in do

    -- the old implementation had a complicated series of three opens,
    -- which is perhaps because we have to be careful not to open
    -- directories.  However, the man pages I've read say that open()
    -- always returns EISDIR if the file is a directory and was opened
    -- for writing, so I think we're ok with a single open() here...
    fd <- fdOpen filepath oflags 0o666

#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || defined(_MSC_VER)
    fd_type <- fdType fd
        -- we want to truncate() if this is an open in WriteMode, but only
        -- if the target is a RegularFile.  ftruncate() fails on special files
        -- like /dev/null.
    when (mode == WriteMode && fd_type == RegularFile) $ do
        fdSetFileSize fd 0
#endif
    return fd

-- | Are files opened by default in text or binary mode, if the user doesn't
-- specify?
dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool

-- Flags for fdOpen
std_flags    = o_NONBLOCK   .|. o_NOCTTY
output_flags = std_flags    .|. o_CREAT
read_flags   = std_flags    .|. o_RDONLY
write_flags  = output_flags .|. o_WRONLY
rw_flags     = output_flags .|. o_RDWR
append_flags = write_flags  .|. o_APPEND

-- -----------------------------------------------------------------------------
-- Low-level functions

fdOpen :: String -> CInt -> CMode -> IO FD
fdOpen name access mode =
  toFD $
    modifyIOError (`ioeSetFileName` name) $
      withCWFilePath name $ \ p_name ->
        throwErrnoIfMinus1Retry "fdOpen" $
          c_open p_name access mode

fdClose :: FD -> IO ()
fdClose fd =
  throwErrnoIfMinus1Retry_ "fdClose" $
    c_close (unFD fd)

fdGetBuf :: FD -> Ptr a -> Int -> IO Int
fdGetBuf fd buf size =
  fromIntegral `liftM`
    (throwErrnoIfMinus1Retry "fdGetBuf" $
      c_read (unFD fd) (castPtr buf) (fromIntegral size))

fdPutBuf :: FD -> Ptr a -> Int -> IO ()
fdPutBuf fd buf size =
  throwErrnoIfMinus1Retry_ "fdPutBuf" $
    c_write (unFD fd) (castPtr buf) (fromIntegral size)           -- to do: check that result==size?

fdTell :: FD -> IO FileSize
fdTell fd =
  fromIntegral `liftM`
    throwErrnoIfMinus1Retry "fdTell"
      (c_tell (unFD fd))

fdSeek :: FD -> SeekMode -> FileSize -> IO ()
fdSeek fd mode offset =
  throwErrnoIfMinus1Retry_ "fdSeek" $
    c_lseek (unFD fd) (fromIntegral offset) whence
  where whence = case mode of
                   AbsoluteSeek -> sEEK_SET
                   RelativeSeek -> sEEK_CUR
                   SeekFromEnd  -> sEEK_END

fdFileSize :: FD -> IO FileSize
fdFileSize fd =
  fromIntegral `liftM`
    throwErrnoIfMinus1Retry "fdFileSize"
      (c_filelength (unFD fd))

fdSetFileSize :: FD -> FileSize -> IO ()
fdSetFileSize fd size =
  throwErrnoIfMinus1Retry_ "fdSetFileSize" $
    c_ftruncate (unFD fd) (fromIntegral size)

fdIsEOF :: FD -> IO Bool
fdIsEOF fd =
  (toEnum.fromIntegral) `liftM`
    throwErrnoIfMinus1Retry "fdEOF"
      (c_eof (unFD fd))

fdFlush :: FD -> IO ()
fdFlush fd = do
#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || defined(_MSC_VER)
  fh <- get_osfhandle fd
  flushFileBuffers fh
#else
  return ()
#endif


{-open/close/truncate/dup

  new_fd <- throwErrnoIfMinus1 "dupHandle" $
                c_dup (fromIntegral (haFD h_))
  new_fd <- throwErrnoIfMinus1 "dupHandleTo" $
                c_dup2 (fromIntegral (haFD h_)) (fromIntegral (haFD hto_))
-}

foreign import ccall unsafe "HsBase.h tell"
   c_tell :: CInt -> IO COff

foreign import ccall unsafe "HsBase.h filelength"
   c_filelength :: CInt -> IO COff

foreign import ccall unsafe "HsBase.h eof"
   c_eof :: CInt -> IO CInt

foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int
foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt

i=fromIntegral
unFD = fromIntegral
toFD = liftM fromIntegral


#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || defined(_MSC_VER)

get_osfhandle :: Int -> IO HANDLE
get_osfhandle fd = do
    failIfNull "get_osfhandle" $ c_get_osfhandle (fromIntegral fd)
foreign import ccall unsafe "HsBase.h _get_osfhandle"
    c_get_osfhandle :: CInt -> IO HANDLE

#endif