|
| 1 | +{-# LANGUAGE TypeApplications #-} |
| 2 | +{-# LANGUAGE BangPatterns #-} |
| 3 | + |
| 4 | +module System.File.OsPath.Internal where |
| 5 | + |
| 6 | + |
| 7 | +import qualified System.File.Platform as P |
| 8 | + |
| 9 | +import Prelude ((.), ($), String, IO, ioError, pure, either, const, flip, Maybe(..), fmap, (<$>), id, Bool(..), FilePath, (++), return, show, (>>=)) |
| 10 | +import GHC.IO (catchException) |
| 11 | +import GHC.IO.Exception (IOException(..)) |
| 12 | +import GHC.IO.Handle (hClose_help) |
| 13 | +import GHC.IO.Handle.Internals (debugIO) |
| 14 | +import GHC.IO.Handle.Types (Handle__, Handle(..)) |
| 15 | +import Control.Concurrent.MVar |
| 16 | +import Control.Monad (void, when) |
| 17 | +import Control.DeepSeq (force) |
| 18 | +import Control.Exception (SomeException, try, evaluate, mask, onException) |
| 19 | +import System.IO (IOMode(..), hSetBinaryMode, hClose) |
| 20 | +import System.IO.Unsafe (unsafePerformIO) |
| 21 | +import System.OsPath as OSP |
| 22 | +import System.OsString.Internal.Types |
| 23 | + |
| 24 | +import qualified Data.ByteString as BS |
| 25 | +import qualified Data.ByteString.Lazy as BSL |
| 26 | + |
| 27 | +-- | Like 'openFile', but open the file in binary mode. |
| 28 | +-- On Windows, reading a file in text mode (which is the default) |
| 29 | +-- will translate CRLF to LF, and writing will translate LF to CRLF. |
| 30 | +-- This is usually what you want with text files. With binary files |
| 31 | +-- this is undesirable; also, as usual under Microsoft operating systems, |
| 32 | +-- text mode treats control-Z as EOF. Binary mode turns off all special |
| 33 | +-- treatment of end-of-line and end-of-file characters. |
| 34 | +-- (See also 'System.IO.hSetBinaryMode'.) |
| 35 | + |
| 36 | +-- On POSIX systems, 'openBinaryFile' is an /interruptible operation/ as |
| 37 | +-- described in "Control.Exception". |
| 38 | +openBinaryFile :: OsPath -> IOMode -> IO Handle |
| 39 | +openBinaryFile osfp iomode = augmentError "openBinaryFile" osfp $ withOpenFile' osfp iomode True False False pure False |
| 40 | + |
| 41 | + |
| 42 | +-- | Run an action on a file. |
| 43 | +-- |
| 44 | +-- The 'Handle' is automatically closed afther the action. |
| 45 | +withFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r |
| 46 | +withFile osfp iomode act = (augmentError "withFile" osfp |
| 47 | + $ withOpenFile' osfp iomode False False False (try . act) True) |
| 48 | + >>= either ioError pure |
| 49 | + |
| 50 | +withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r |
| 51 | +withBinaryFile osfp iomode act = (augmentError "withBinaryFile" osfp |
| 52 | + $ withOpenFile' osfp iomode True False False (try . act) True) |
| 53 | + >>= either ioError pure |
| 54 | + |
| 55 | +-- | Run an action on a file. |
| 56 | +-- |
| 57 | +-- The 'Handle' is not automatically closed to allow lazy IO. Use this |
| 58 | +-- with caution. |
| 59 | +withFile' |
| 60 | + :: OsPath -> IOMode -> (Handle -> IO r) -> IO r |
| 61 | +withFile' osfp iomode act = (augmentError "withFile'" osfp |
| 62 | + $ withOpenFile' osfp iomode False False False (try . act) False) |
| 63 | + >>= either ioError pure |
| 64 | + |
| 65 | +withBinaryFile' |
| 66 | + :: OsPath -> IOMode -> (Handle -> IO r) -> IO r |
| 67 | +withBinaryFile' osfp iomode act = (augmentError "withBinaryFile'" osfp |
| 68 | + $ withOpenFile' osfp iomode True False False (try . act) False) |
| 69 | + >>= either ioError pure |
| 70 | + |
| 71 | +-- | The 'readFile' function reads a file and returns the contents of the file |
| 72 | +-- as a 'ByteString'. The file is read lazily, on demand. |
| 73 | +readFile :: OsPath -> IO BSL.ByteString |
| 74 | +readFile fp = withFile' fp ReadMode BSL.hGetContents |
| 75 | + |
| 76 | +-- | The 'readFile'' function reads a file and returns the contents of the file |
| 77 | +-- as a 'ByteString'. The file is fully read before being returned. |
| 78 | +readFile' |
| 79 | + :: OsPath -> IO BS.ByteString |
| 80 | +readFile' fp = withFile fp ReadMode BS.hGetContents |
| 81 | + |
| 82 | +-- | The computation 'writeFile' @file str@ function writes the lazy 'ByteString' @str@, |
| 83 | +-- to the file @file@. |
| 84 | +writeFile :: OsPath -> BSL.ByteString -> IO () |
| 85 | +writeFile fp contents = withFile fp WriteMode (`BSL.hPut` contents) |
| 86 | + |
| 87 | +-- | The computation 'writeFile' @file str@ function writes the strict 'ByteString' @str@, |
| 88 | +-- to the file @file@. |
| 89 | +writeFile' |
| 90 | + :: OsPath -> BS.ByteString -> IO () |
| 91 | +writeFile' fp contents = withFile fp WriteMode (`BS.hPut` contents) |
| 92 | + |
| 93 | +-- | The computation 'appendFile' @file str@ function appends the lazy 'ByteString' @str@, |
| 94 | +-- to the file @file@. |
| 95 | +appendFile :: OsPath -> BSL.ByteString -> IO () |
| 96 | +appendFile fp contents = withFile fp AppendMode (`BSL.hPut` contents) |
| 97 | + |
| 98 | +-- | The computation 'appendFile' @file str@ function appends the strict 'ByteString' @str@, |
| 99 | +-- to the file @file@. |
| 100 | +appendFile' |
| 101 | + :: OsPath -> BS.ByteString -> IO () |
| 102 | +appendFile' fp contents = withFile fp AppendMode (`BS.hPut` contents) |
| 103 | + |
| 104 | +-- | Open a file and return the 'Handle'. |
| 105 | +openFile :: OsPath -> IOMode -> IO Handle |
| 106 | +openFile osfp iomode = augmentError "openFile" osfp $ withOpenFile' osfp iomode False False False pure False |
| 107 | + |
| 108 | + |
| 109 | +-- | Open an existing file and return the 'Handle'. |
| 110 | +openExistingFile :: OsPath -> IOMode -> IO Handle |
| 111 | +openExistingFile osfp iomode = augmentError "openExistingFile" osfp $ withOpenFile' osfp iomode False True False pure False |
| 112 | + |
| 113 | +-- | Open a file and return the 'Handle'. |
| 114 | +-- |
| 115 | +-- Sets @O_CLOEXEC@ on posix. |
| 116 | +-- |
| 117 | +-- @since 0.1.2 |
| 118 | +openFileWithCloseOnExec :: OsPath -> IOMode -> IO Handle |
| 119 | +openFileWithCloseOnExec osfp iomode = augmentError "openFileWithCloseOnExec" osfp $ withOpenFile' osfp iomode False False True pure False |
| 120 | + |
| 121 | + |
| 122 | +-- | Open an existing file and return the 'Handle'. |
| 123 | +-- |
| 124 | +-- Sets @O_CLOEXEC@ on posix. |
| 125 | +-- |
| 126 | +-- @since 0.1.2 |
| 127 | +openExistingFileWithCloseOnExec :: OsPath -> IOMode -> IO Handle |
| 128 | +openExistingFileWithCloseOnExec osfp iomode = augmentError "openExistingFileWithCloseOnExec" osfp $ withOpenFile' osfp iomode False True True pure False |
| 129 | + |
| 130 | +-- --------------------------------------------------------------------------- |
| 131 | +-- Internals |
| 132 | + |
| 133 | +handleFinalizer :: FilePath -> MVar Handle__ -> IO () |
| 134 | +handleFinalizer _fp m = do |
| 135 | + handle_ <- takeMVar m |
| 136 | + (handle_', _) <- hClose_help handle_ |
| 137 | + putMVar m handle_' |
| 138 | + return () |
| 139 | + |
| 140 | +type HandleFinalizer = FilePath -> MVar Handle__ -> IO () |
| 141 | + |
| 142 | +-- | Add a finalizer to a 'Handle'. Specifically, the finalizer |
| 143 | +-- will be added to the 'MVar' of a file handle or the write-side |
| 144 | +-- 'MVar' of a duplex handle. See Handle Finalizers for details. |
| 145 | +addHandleFinalizer :: Handle -> HandleFinalizer -> IO () |
| 146 | +addHandleFinalizer hndl finalizer = do |
| 147 | + debugIO $ "Registering finalizer: " ++ show filepath |
| 148 | + void $ mkWeakMVar mv (finalizer filepath mv) |
| 149 | + where |
| 150 | + !(filepath, !mv) = case hndl of |
| 151 | + FileHandle fp m -> (fp, m) |
| 152 | + DuplexHandle fp _ write_m -> (fp, write_m) |
| 153 | + |
| 154 | +withOpenFile' :: OsPath -> IOMode -> Bool -> Bool -> Bool -> (Handle -> IO r) -> Bool -> IO r |
| 155 | +withOpenFile' (OsString fp) iomode binary existing cloExec action close_finally = mask $ \restore -> do |
| 156 | + hndl <- case (existing, cloExec) of |
| 157 | + (True, False) -> P.openExistingFile fp iomode |
| 158 | + (False, False) -> P.openFile fp iomode |
| 159 | + (True, True) -> P.openExistingFileWithCloseOnExec fp iomode |
| 160 | + (False, True) -> P.openFileWithCloseOnExec fp iomode |
| 161 | + addHandleFinalizer hndl handleFinalizer |
| 162 | + when binary $ hSetBinaryMode hndl True |
| 163 | + r <- restore (action hndl) `onException` hClose hndl |
| 164 | + when close_finally $ hClose hndl |
| 165 | + pure r |
| 166 | + |
| 167 | +addFilePathToIOError :: String -> OsPath -> IOException -> IOException |
| 168 | +addFilePathToIOError fun fp ioe = unsafePerformIO $ do |
| 169 | + fp' <- either (const (fmap OSP.toChar . OSP.unpack $ fp)) id <$> try @SomeException (OSP.decodeFS fp) |
| 170 | + fp'' <- evaluate $ force fp' |
| 171 | + pure $ ioe{ ioe_location = fun, ioe_filename = Just fp'' } |
| 172 | + |
| 173 | +augmentError :: String -> OsPath -> IO a -> IO a |
| 174 | +augmentError str osfp = flip catchException (ioError . addFilePathToIOError str osfp) |
| 175 | + |
0 commit comments