{-# language BangPatterns #-}
{-# language BinaryLiterals #-}
{-# language LambdaCase #-}
{-# language MagicHash #-}
{-# language TypeApplications #-}
{-# language UnliftedFFITypes #-}

module Posix.File
  ( -- * Functions
    uninterruptibleGetDescriptorFlags
  , uninterruptibleGetStatusFlags
  , uninterruptibleWriteByteArray
  , uninterruptibleWriteBytes
  , uninterruptibleWriteBytesCompletely
  , uninterruptibleWriteBytesCompletelyErrno
  , writeBytesCompletelyErrno
  , uninterruptibleOpen
  , uninterruptibleOpenMode
  , uninterruptibleOpenUntypedFlags
  , writeByteArray
  , writeMutableByteArray
  , close
  , uninterruptibleClose
  , uninterruptibleErrorlessClose
  , uninterruptibleUnlink
  , uninterruptibleLink
    -- * Types
  , AccessMode(..)
  , CreationFlags(..)
  , DescriptorFlags(..)
  , StatusFlags(..)
    -- * File Descriptor Flags
  , Types.nonblocking
  , Types.append
  , isReadOnly
  , isWriteOnly
  , isReadWrite
    -- * Open Access Mode
  , Types.readOnly
  , Types.writeOnly
  , Types.readWrite
    -- * File Creation Flags
  , Types.create
  , Types.truncate
  , Types.exclusive
  ) where

import Assertion (assertByteArrayPinned,assertMutableByteArrayPinned)
import Data.Bits ((.&.),(.|.))
import Data.Primitive (ByteArray(..))
import Foreign.C.Error (Errno(Errno),getErrno,eOK)
import Foreign.C.String.Managed (ManagedCString(..))
import Foreign.C.Types (CInt(..),CSize(..))
import GHC.Exts (ByteArray#,MutableByteArray#,RealWorld)
import Posix.File.Types (CreationFlags(..),AccessMode(..),StatusFlags(..))
import Posix.File.Types (DescriptorFlags(..))
import System.Posix.Types (Fd(..),CSsize(..),CMode(..))
import Data.Bytes.Types (Bytes(Bytes))
import Data.Primitive (MutableByteArray(MutableByteArray))

import qualified Posix.File.Types as Types

-- | Get file descriptor flags. This uses the unsafe FFI to
-- perform @fcntl(fd,F_GETFD)@.
uninterruptibleGetDescriptorFlags :: Fd -> IO (Either Errno DescriptorFlags)
uninterruptibleGetDescriptorFlags :: Fd -> IO (Either Errno DescriptorFlags)
uninterruptibleGetDescriptorFlags !Fd
fd = Fd -> IO DescriptorFlags
c_getFdFlags Fd
fd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DescriptorFlags -> IO (Either Errno DescriptorFlags)
errorsFromDescriptorFlags

-- | Get file status flags. This uses the unsafe FFI to
-- perform @fcntl(fd,F_GETFL)@.
uninterruptibleGetStatusFlags :: Fd -> IO (Either Errno StatusFlags)
uninterruptibleGetStatusFlags :: Fd -> IO (Either Errno StatusFlags)
uninterruptibleGetStatusFlags !Fd
fd = Fd -> IO StatusFlags
c_getFlFlags Fd
fd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StatusFlags -> IO (Either Errno StatusFlags)
errorsFromStatusFlags

foreign import ccall unsafe "HaskellPosix.h hs_get_fd_flags"
  c_getFdFlags :: Fd -> IO DescriptorFlags

foreign import ccall unsafe "HaskellPosix.h hs_get_fl_flags"
  c_getFlFlags :: Fd -> IO StatusFlags

foreign import ccall unsafe "HaskellPosix.h write_offset"
  c_unsafe_bytearray_write :: Fd -> ByteArray# -> Int -> CSize -> IO CSsize

foreign import ccall unsafe "HaskellPosix.h write_offset_loop"
  c_unsafe_bytearray_write_loop :: Fd -> ByteArray# -> Int -> CSize -> IO Errno

foreign import ccall safe "HaskellPosix.h write_offset_loop"
  c_safe_bytearray_write_loop :: Fd -> ByteArray# -> Int -> CSize -> IO Errno

foreign import ccall safe "HaskellPosix.h write_offset"
  c_safe_bytearray_write :: Fd -> ByteArray# -> Int -> CSize -> IO CSsize

foreign import ccall safe "HaskellPosix.h write_offset"
  c_safe_mutablebytearray_write :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> IO CSsize

foreign import ccall unsafe "HaskellPosix.h open"
  c_unsafe_open :: ByteArray# -> CInt -> IO Fd

foreign import ccall unsafe "HaskellPosix.h open"
  c_unsafe_open_mode :: ByteArray# -> CInt -> CMode -> IO Fd

foreign import ccall unsafe "HaskellPosix.h unlink"
  c_unsafe_unlink :: ByteArray# -> IO CInt

foreign import ccall unsafe "HaskellPosix.h link"
  c_unsafe_link :: ByteArray# -> ByteArray# -> IO CInt

foreign import ccall safe "unistd.h close"
  c_safe_close :: Fd -> IO CInt

foreign import ccall unsafe "unistd.h close"
  c_unsafe_close :: Fd -> IO CInt

uninterruptibleOpen ::
     ManagedCString -- ^ NULL-terminated file name
  -> AccessMode -- ^ Access mode
  -> CreationFlags -- ^ Creation flags
  -> StatusFlags -- ^ Status flags
  -> IO (Either Errno Fd)
uninterruptibleOpen :: ManagedCString
-> AccessMode
-> CreationFlags
-> StatusFlags
-> IO (Either Errno Fd)
uninterruptibleOpen (ManagedCString (ByteArray ByteArray#
name)) (AccessMode CInt
x) (CreationFlags CInt
y) (StatusFlags CInt
z) =
  ByteArray# -> CInt -> IO Fd
c_unsafe_open ByteArray#
name (CInt
x forall a. Bits a => a -> a -> a
.|. CInt
y forall a. Bits a => a -> a -> a
.|. CInt
z) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Fd -> IO (Either Errno Fd)
errorsFromFd

-- | Variant of 'uninterruptibleOpen' that does not help the caller with
-- the types of the flags.
uninterruptibleOpenUntypedFlags ::
     ManagedCString -- ^ NULL-terminated file name
  -> CInt -- ^ Flags
  -> IO (Either Errno Fd)
uninterruptibleOpenUntypedFlags :: ManagedCString -> CInt -> IO (Either Errno Fd)
uninterruptibleOpenUntypedFlags (ManagedCString (ByteArray ByteArray#
name)) CInt
x =
  ByteArray# -> CInt -> IO Fd
c_unsafe_open ByteArray#
name CInt
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Fd -> IO (Either Errno Fd)
errorsFromFd

uninterruptibleOpenMode ::
     ManagedCString -- ^ NULL-terminated file name
  -> AccessMode -- ^ Access mode, should include @O_CREAT@
  -> CreationFlags -- ^ Creation flags
  -> StatusFlags -- ^ Status flags
  -> CMode -- ^ Permissions assigned to newly created file
  -> IO (Either Errno Fd)
uninterruptibleOpenMode :: ManagedCString
-> AccessMode
-> CreationFlags
-> StatusFlags
-> CMode
-> IO (Either Errno Fd)
uninterruptibleOpenMode (ManagedCString (ByteArray ByteArray#
name)) (AccessMode CInt
x) (CreationFlags CInt
y) (StatusFlags CInt
z) !CMode
mode =
  ByteArray# -> CInt -> CMode -> IO Fd
c_unsafe_open_mode ByteArray#
name (CInt
x forall a. Bits a => a -> a -> a
.|. CInt
y forall a. Bits a => a -> a -> a
.|. CInt
z) CMode
mode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Fd -> IO (Either Errno Fd)
errorsFromFd

errorsFromDescriptorFlags :: DescriptorFlags -> IO (Either Errno DescriptorFlags)
errorsFromDescriptorFlags :: DescriptorFlags -> IO (Either Errno DescriptorFlags)
errorsFromDescriptorFlags r :: DescriptorFlags
r@(DescriptorFlags CInt
x) = if CInt
x forall a. Ord a => a -> a -> Bool
> (-CInt
1)
  then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right DescriptorFlags
r)
  else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left IO Errno
getErrno

errorsFromStatusFlags :: StatusFlags -> IO (Either Errno StatusFlags)
errorsFromStatusFlags :: StatusFlags -> IO (Either Errno StatusFlags)
errorsFromStatusFlags r :: StatusFlags
r@(StatusFlags CInt
x) = if CInt
x forall a. Ord a => a -> a -> Bool
> (-CInt
1)
  then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right StatusFlags
r)
  else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left IO Errno
getErrno

-- | Wrapper for @write(2)@ that takes a slice of bytes and an offset.
-- The byte array backing the slice does not need to be pinned.
uninterruptibleWriteBytesCompletely ::
     Fd -- ^ File descriptor
  -> Bytes -- ^ Source bytes
  -> IO (Either Errno ())
uninterruptibleWriteBytesCompletely :: Fd -> Bytes -> IO (Either Errno ())
uninterruptibleWriteBytesCompletely !Fd
fd !Bytes
b = do
  Errno
e <- Fd -> Bytes -> IO Errno
uninterruptibleWriteBytesCompletelyErrno Fd
fd Bytes
b
  if Errno
e forall a. Eq a => a -> a -> Bool
== Errno
eOK
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ())
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left Errno
e)

-- | Variant of 'uninterruptibleWriteBytesCompletely' that uses errno 0
-- to communicate success.
uninterruptibleWriteBytesCompletelyErrno ::
     Fd -- ^ File descriptor
  -> Bytes -- ^ Source bytes
  -> IO Errno
uninterruptibleWriteBytesCompletelyErrno :: Fd -> Bytes -> IO Errno
uninterruptibleWriteBytesCompletelyErrno !Fd
fd (Bytes (ByteArray ByteArray#
buf) Int
off Int
len) =
  Fd -> ByteArray# -> Int -> CSize -> IO Errno
c_unsafe_bytearray_write_loop Fd
fd ByteArray#
buf Int
off (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CSize Int
len)

-- | Wrapper for @write(2)@ that takes a slice of bytes and an offset.
-- The byte array backing the slice must be pinned.
writeBytesCompletelyErrno ::
     Fd -- ^ File descriptor
  -> Bytes -- ^ Source bytes
  -> IO Errno
writeBytesCompletelyErrno :: Fd -> Bytes -> IO Errno
writeBytesCompletelyErrno !Fd
fd (Bytes ByteArray
buf0 Int
off Int
len) =
  let !(ByteArray ByteArray#
buf1) = ByteArray -> ByteArray
assertByteArrayPinned ByteArray
buf0
   in Fd -> ByteArray# -> Int -> CSize -> IO Errno
c_safe_bytearray_write_loop Fd
fd ByteArray#
buf1 Int
off (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CSize Int
len)

-- | Wrapper for @write(2)@ that takes a slice of bytes and an offset.
-- The byte array backing the slice does not need to be pinned.
uninterruptibleWriteBytes ::
     Fd -- ^ File descriptor
  -> Bytes -- ^ Source bytes
  -> IO (Either Errno CSize) -- ^ Number of bytes written
uninterruptibleWriteBytes :: Fd -> Bytes -> IO (Either Errno CSize)
uninterruptibleWriteBytes !Fd
fd (Bytes (ByteArray ByteArray#
buf) Int
off Int
len) =
  Fd -> ByteArray# -> Int -> CSize -> IO CSsize
c_unsafe_bytearray_write Fd
fd ByteArray#
buf Int
off (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CSize Int
len)
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CSsize -> IO (Either Errno CSize)
errorsFromSize

-- | Wrapper for @write(2)@ that takes a byte array and an offset.
-- The byte array does not need to be pinned.
uninterruptibleWriteByteArray ::
     Fd -- ^ Socket
  -> ByteArray -- ^ Source byte array
  -> Int -- ^ Offset into source array
  -> CSize -- ^ Length in bytes
  -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer
uninterruptibleWriteByteArray :: Fd -> ByteArray -> Int -> CSize -> IO (Either Errno CSize)
uninterruptibleWriteByteArray !Fd
fd (ByteArray ByteArray#
buf) !Int
off !CSize
len =
  Fd -> ByteArray# -> Int -> CSize -> IO CSsize
c_unsafe_bytearray_write Fd
fd ByteArray#
buf Int
off CSize
len forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CSsize -> IO (Either Errno CSize)
errorsFromSize

-- | Wrapper for @write(2)@ that takes a byte array and an offset.
-- Uses @safe@ FFI. The byte array must be pinned.
writeByteArray ::
     Fd -- ^ File descriptor
  -> ByteArray -- ^ Source byte array
  -> Int -- ^ Offset into source array
  -> CSize -- ^ Length in bytes
  -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer
writeByteArray :: Fd -> ByteArray -> Int -> CSize -> IO (Either Errno CSize)
writeByteArray !Fd
fd !ByteArray
buf0 !Int
off !CSize
len =
  let !(ByteArray ByteArray#
buf1) = ByteArray -> ByteArray
assertByteArrayPinned ByteArray
buf0
   in Fd -> ByteArray# -> Int -> CSize -> IO CSsize
c_safe_bytearray_write Fd
fd ByteArray#
buf1 Int
off CSize
len forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CSsize -> IO (Either Errno CSize)
errorsFromSize

-- writeByteArrayCompletely ::

-- | Variant of 'writeByteArray' that operates on mutable byte array.
-- Uses @safe@ FFI. The byte array must be pinned.
writeMutableByteArray ::
     Fd -- ^ File descriptor
  -> MutableByteArray RealWorld -- ^ Source byte array
  -> Int -- ^ Offset into source array
  -> CSize -- ^ Length in bytes
  -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer
writeMutableByteArray :: Fd
-> MutableByteArray RealWorld
-> Int
-> CSize
-> IO (Either Errno CSize)
writeMutableByteArray !Fd
fd !MutableByteArray RealWorld
buf0 !Int
off !CSize
len =
  let !(MutableByteArray MutableByteArray# RealWorld
buf1) = forall s. MutableByteArray s -> MutableByteArray s
assertMutableByteArrayPinned MutableByteArray RealWorld
buf0
   in Fd -> MutableByteArray# RealWorld -> Int -> CSize -> IO CSsize
c_safe_mutablebytearray_write Fd
fd MutableByteArray# RealWorld
buf1 Int
off CSize
len forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CSsize -> IO (Either Errno CSize)
errorsFromSize

errorsFromSize :: CSsize -> IO (Either Errno CSize)
errorsFromSize :: CSsize -> IO (Either Errno CSize)
errorsFromSize CSsize
r = if CSsize
r forall a. Ord a => a -> a -> Bool
> (-CSsize
1)
  then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (CSsize -> CSize
cssizeToCSize CSsize
r))
  else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left IO Errno
getErrno

errorsFromFd :: Fd -> IO (Either Errno Fd)
errorsFromFd :: Fd -> IO (Either Errno Fd)
errorsFromFd Fd
r = if Fd
r forall a. Ord a => a -> a -> Bool
> (-Fd
1)
  then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right Fd
r)
  else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left IO Errno
getErrno

uninterruptibleLink ::
     ManagedCString -- ^ Path to existing file
  -> ManagedCString -- ^ Path to new file
  -> IO (Either Errno ())
uninterruptibleLink :: ManagedCString -> ManagedCString -> IO (Either Errno ())
uninterruptibleLink (ManagedCString (ByteArray ByteArray#
x)) (ManagedCString (ByteArray ByteArray#
y)) =
  ByteArray# -> ByteArray# -> IO CInt
c_unsafe_link ByteArray#
x ByteArray#
y forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO (Either Errno ())
errorsFromInt_

uninterruptibleUnlink ::
     ManagedCString -- ^ File name
  -> IO (Either Errno ())
uninterruptibleUnlink :: ManagedCString -> IO (Either Errno ())
uninterruptibleUnlink (ManagedCString (ByteArray ByteArray#
x)) =
  ByteArray# -> IO CInt
c_unsafe_unlink ByteArray#
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO (Either Errno ())
errorsFromInt_

-- | Close a file descriptor.
--   The <http://pubs.opengroup.org/onlinepubs/009696899/functions/close.html POSIX specification>
--   includes more details. This uses the safe FFI.
close ::
     Fd -- ^ Socket
  -> IO (Either Errno ())
close :: Fd -> IO (Either Errno ())
close Fd
fd = Fd -> IO CInt
c_safe_close Fd
fd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO (Either Errno ())
errorsFromInt_

-- | Close a file descriptor. This uses the unsafe FFI. According to the
--   <http://pubs.opengroup.org/onlinepubs/009696899/functions/close.html POSIX specification>,
--   "If @fildes@ refers to a socket, @close()@ shall cause the socket to
--   be destroyed. If the socket is in connection-mode, and the @SO_LINGER@
--   option is set for the socket with non-zero linger time, and the socket
--   has untransmitted data, then @close()@ shall block for up to the current
--   linger interval until all data is transmitted."
uninterruptibleClose ::
     Fd -- ^ Socket
  -> IO (Either Errno ())
uninterruptibleClose :: Fd -> IO (Either Errno ())
uninterruptibleClose Fd
fd = Fd -> IO CInt
c_unsafe_close Fd
fd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO (Either Errno ())
errorsFromInt_

-- | Close a file descriptor with the unsafe FFI. Do not check for errors.
--   It is only appropriate to use this when a file descriptor is being
--   closed to handle an exceptional case. Since the user will want to
--   propogate the original exception, the exception provided by
--   'uninterruptibleClose' would just be discarded. This function allows us
--   to potentially avoid an additional FFI call to 'getErrno'.
uninterruptibleErrorlessClose ::
     Fd -- ^ Socket
  -> IO ()
uninterruptibleErrorlessClose :: Fd -> IO ()
uninterruptibleErrorlessClose Fd
fd = do
  CInt
_ <- Fd -> IO CInt
c_unsafe_close Fd
fd
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- only call this when it is known that the argument is non-negative
cssizeToCSize :: CSsize -> CSize
cssizeToCSize :: CSsize -> CSize
cssizeToCSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral

isReadOnly :: StatusFlags -> Bool
isReadOnly :: StatusFlags -> Bool
isReadOnly (StatusFlags CInt
x) = CInt
x forall a. Bits a => a -> a -> a
.&. CInt
0b11 forall a. Eq a => a -> a -> Bool
== CInt
0

isWriteOnly :: StatusFlags -> Bool
isWriteOnly :: StatusFlags -> Bool
isWriteOnly (StatusFlags CInt
x) = CInt
x forall a. Bits a => a -> a -> a
.&. CInt
0b11 forall a. Eq a => a -> a -> Bool
== CInt
1

isReadWrite :: StatusFlags -> Bool
isReadWrite :: StatusFlags -> Bool
isReadWrite (StatusFlags CInt
x) = CInt
x forall a. Bits a => a -> a -> a
.&. CInt
0b11 forall a. Eq a => a -> a -> Bool
== CInt
2

-- Sometimes, functions that return an int use zero to indicate
-- success and negative one to indicate failure without including
-- additional information in the value.
errorsFromInt_ :: CInt -> IO (Either Errno ())
errorsFromInt_ :: CInt -> IO (Either Errno ())
errorsFromInt_ CInt
r = if CInt
r forall a. Eq a => a -> a -> Bool
== CInt
0
  then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ())
  else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left IO Errno
getErrno