git.iko.soy/elk
on 5fbf3b1 help sign in
elk/builder/src/File/IO.hs
251 lines 5.8 kB history raw
1module File.IO
2 ( writeBinary, readBinary
3 , writeUtf8, readUtf8
4 , writeBuilder
5 , Writer
6 , put
7 , putByteString
8 , putBuilder
9 , putFile
10 , exists
11 , remove, removeDir
12 , find
13 , andM
14 )
15 where
18import Control.Exception (catch)
19import Control.Monad.Trans (liftIO)
20import qualified Data.Binary as Binary
21import qualified Data.ByteString as BS
22import qualified Data.ByteString.Internal as BS
23import qualified Data.ByteString.Builder as B
24import qualified Data.ByteString.Builder.Extra as B (defaultChunkSize)
25import qualified Foreign.ForeignPtr as FPtr
26import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
27import qualified System.Directory as Dir
28import System.FilePath ((</>))
29import qualified System.FilePath as FP
30import qualified System.IO as IO
31import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
33import qualified Elm.PerUserCache as PerUserCache
34import qualified Reporting.Exit as Exit
35import qualified Reporting.Exit.Assets as E
36import qualified Reporting.Task as Task
40-- BINARY
43writeBinary :: (Binary.Binary a) => FilePath -> a -> Task.Task ()
44writeBinary path value =
45 liftIO $
46 do let dir = FP.dropFileName path
47 Dir.createDirectoryIfMissing True dir
48 Binary.encodeFile path value
51readBinary :: (Binary.Binary a) => FilePath -> Task.Task a
52readBinary path =
53 do exists_ <- liftIO (Dir.doesFileExist path)
54 if not exists_
55 then throwCorruptBinary path
56 else
57 do result <- liftIO (Binary.decodeFileOrFail path)
58 case result of
59 Left _ ->
60 throwCorruptBinary path
62 Right value ->
63 return value
66throwCorruptBinary :: FilePath -> Task.Task a
67throwCorruptBinary filePath =
68 do elmHome <- liftIO PerUserCache.getElmHome
69 Task.throw (Exit.Assets (E.CorruptBinary elmHome filePath))
73-- WRITE UTF-8
76writeUtf8 :: FilePath -> BS.ByteString -> IO ()
77writeUtf8 filePath content =
78 withUtf8 filePath IO.WriteMode $ \handle ->
79 BS.hPut handle content
82withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
83withUtf8 filePath mode callback =
84 IO.withFile filePath mode $ \handle ->
85 do IO.hSetEncoding handle IO.utf8
86 callback handle
90-- READ UTF-8
93readUtf8 :: FilePath -> IO BS.ByteString
94readUtf8 filePath =
95 withUtf8 filePath IO.ReadMode $ \handle ->
96 modifyIOError (encodingError filePath) $
97 do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
98 let readSize = max 0 (fromIntegral fileSize) + 1
99 hGetContentsSizeHint handle readSize (max 255 readSize)
102useZeroIfNotRegularFile :: IOException -> IO Integer
103useZeroIfNotRegularFile _ =
104 return 0
107hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
108hGetContentsSizeHint handle =
109 readChunks []
110 where
111 readChunks chunks readSize incrementSize =
112 do fp <- BS.mallocByteString readSize
113 readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
114 let chunk = BS.PS fp 0 readCount
115 if readCount < readSize && readSize > 0
116 then return $! BS.concat (reverse (chunk:chunks))
117 else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
120encodingError :: FilePath -> IOError -> IOError
121encodingError filePath ioErr =
122 case ioeGetErrorType ioErr of
123 InvalidArgument ->
124 annotateIOError
125 (userError "Bad encoding; the file must be valid UTF-8")
126 ""
127 Nothing
128 (Just filePath)
130 _ ->
131 ioErr
135-- WRITE BUILDER
138writeBuilder :: FilePath -> B.Builder -> IO ()
139writeBuilder path builder =
140 IO.withBinaryFile path IO.WriteMode $ \handle ->
141 do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
142 B.hPutBuilder handle builder
146-- WRITER
149newtype Writer =
150 Writer (IO.Handle -> IO ())
153put :: FilePath -> Writer -> IO ()
154put path (Writer callback) =
155 IO.withBinaryFile path IO.WriteMode callback
158putByteString :: BS.ByteString -> Writer
159putByteString chunk =
160 Writer $ \handle ->
161 BS.hPut handle chunk
164putBuilder :: B.Builder -> Writer
165putBuilder builder =
166 Writer $ \handle ->
167 B.hPutBuilder handle builder
170putFile :: FilePath -> Writer
171putFile path =
172 Writer $ \sink ->
173 IO.withBinaryFile path IO.ReadMode $ \source ->
174 putHelp source sink
177putHelp :: IO.Handle -> IO.Handle -> IO ()
178putHelp source sink =
179 do chunk <- BS.hGet source B.defaultChunkSize
180 if BS.null chunk
181 then return ()
182 else
183 do BS.hPut sink chunk
184 putHelp source sink
188-- EXISTS
191exists :: FilePath -> Task.Task_ e Bool
192exists filePath =
193 liftIO $ Dir.doesFileExist filePath
197-- REMOVE FILES
200remove :: FilePath -> Task.Task_ e ()
201remove filePath =
202 liftIO $
203 do exists_ <- Dir.doesFileExist filePath
204 if exists_
205 then Dir.removeFile filePath
206 else return ()
209removeDir :: FilePath -> IO ()
210removeDir path =
211 do exists_ <- Dir.doesDirectoryExist path
212 if exists_
213 then Dir.removeDirectoryRecursive path
214 else return ()
218-- FIND FILES
221find :: FilePath -> IO (Maybe FilePath)
222find name =
223 do subDir <- Dir.getCurrentDirectory
224 findHelp name (FP.splitDirectories subDir)
227findHelp :: FilePath -> [String] -> IO (Maybe FilePath)
228findHelp name dirs =
229 if null dirs then
230 return Nothing
232 else
233 do exists_ <- Dir.doesFileExist (FP.joinPath dirs </> name)
234 if exists_
235 then return (Just (FP.joinPath dirs))
236 else findHelp name (init dirs)
240-- HELPER
243andM :: (Monad m) => [m Bool] -> m Bool
244andM checks =
245 case checks of
246 [] ->
247 return True
249 check : otherChecks ->
250 do bool <- check
251 if bool then andM otherChecks else return False