git.iko.soy/elk
on 49f58cf help sign in
elk/builder/src/File/IO.hs
249 lines 5.7 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 Reporting.Exit as Exit
34import qualified Reporting.Exit.Assets as E
35import qualified Reporting.Task as Task
39-- BINARY
42writeBinary :: (Binary.Binary a) => FilePath -> a -> Task.Task ()
43writeBinary path value =
44 liftIO $
45 do let dir = FP.dropFileName path
46 Dir.createDirectoryIfMissing True dir
47 Binary.encodeFile path value
50readBinary :: (Binary.Binary a) => FilePath -> Task.Task a
51readBinary path =
52 do exists_ <- liftIO (Dir.doesFileExist path)
53 if not exists_
54 then throwCorruptBinary path
55 else
56 do result <- liftIO (Binary.decodeFileOrFail path)
57 case result of
58 Left _ ->
59 throwCorruptBinary path
61 Right value ->
62 return value
65throwCorruptBinary :: FilePath -> Task.Task a
66throwCorruptBinary filePath =
67 Task.throw (Exit.Assets (E.CorruptBinary filePath))
71-- WRITE UTF-8
74writeUtf8 :: FilePath -> BS.ByteString -> IO ()
75writeUtf8 filePath content =
76 withUtf8 filePath IO.WriteMode $ \handle ->
77 BS.hPut handle content
80withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
81withUtf8 filePath mode callback =
82 IO.withFile filePath mode $ \handle ->
83 do IO.hSetEncoding handle IO.utf8
84 callback handle
88-- READ UTF-8
91readUtf8 :: FilePath -> IO BS.ByteString
92readUtf8 filePath =
93 withUtf8 filePath IO.ReadMode $ \handle ->
94 modifyIOError (encodingError filePath) $
95 do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
96 let readSize = max 0 (fromIntegral fileSize) + 1
97 hGetContentsSizeHint handle readSize (max 255 readSize)
100useZeroIfNotRegularFile :: IOException -> IO Integer
101useZeroIfNotRegularFile _ =
102 return 0
105hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
106hGetContentsSizeHint handle =
107 readChunks []
108 where
109 readChunks chunks readSize incrementSize =
110 do fp <- BS.mallocByteString readSize
111 readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
112 let chunk = BS.PS fp 0 readCount
113 if readCount < readSize && readSize > 0
114 then return $! BS.concat (reverse (chunk:chunks))
115 else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
118encodingError :: FilePath -> IOError -> IOError
119encodingError filePath ioErr =
120 case ioeGetErrorType ioErr of
121 InvalidArgument ->
122 annotateIOError
123 (userError "Bad encoding; the file must be valid UTF-8")
124 ""
125 Nothing
126 (Just filePath)
128 _ ->
129 ioErr
133-- WRITE BUILDER
136writeBuilder :: FilePath -> B.Builder -> IO ()
137writeBuilder path builder =
138 IO.withBinaryFile path IO.WriteMode $ \handle ->
139 do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
140 B.hPutBuilder handle builder
144-- WRITER
147newtype Writer =
148 Writer (IO.Handle -> IO ())
151put :: FilePath -> Writer -> IO ()
152put path (Writer callback) =
153 IO.withBinaryFile path IO.WriteMode callback
156putByteString :: BS.ByteString -> Writer
157putByteString chunk =
158 Writer $ \handle ->
159 BS.hPut handle chunk
162putBuilder :: B.Builder -> Writer
163putBuilder builder =
164 Writer $ \handle ->
165 B.hPutBuilder handle builder
168putFile :: FilePath -> Writer
169putFile path =
170 Writer $ \sink ->
171 IO.withBinaryFile path IO.ReadMode $ \source ->
172 putHelp source sink
175putHelp :: IO.Handle -> IO.Handle -> IO ()
176putHelp source sink =
177 do chunk <- BS.hGet source B.defaultChunkSize
178 if BS.null chunk
179 then return ()
180 else
181 do BS.hPut sink chunk
182 putHelp source sink
186-- EXISTS
189exists :: FilePath -> Task.Task_ e Bool
190exists filePath =
191 liftIO $ Dir.doesFileExist filePath
195-- REMOVE FILES
198remove :: FilePath -> Task.Task_ e ()
199remove filePath =
200 liftIO $
201 do exists_ <- Dir.doesFileExist filePath
202 if exists_
203 then Dir.removeFile filePath
204 else return ()
207removeDir :: FilePath -> IO ()
208removeDir path =
209 do exists_ <- Dir.doesDirectoryExist path
210 if exists_
211 then Dir.removeDirectoryRecursive path
212 else return ()
216-- FIND FILES
219find :: FilePath -> IO (Maybe FilePath)
220find name =
221 do subDir <- Dir.getCurrentDirectory
222 findHelp name (FP.splitDirectories subDir)
225findHelp :: FilePath -> [String] -> IO (Maybe FilePath)
226findHelp name dirs =
227 if null dirs then
228 return Nothing
230 else
231 do exists_ <- Dir.doesFileExist (FP.joinPath dirs </> name)
232 if exists_
233 then return (Just (FP.joinPath dirs))
234 else findHelp name (init dirs)
238-- HELPER
241andM :: (Monad m) => [m Bool] -> m Bool
242andM checks =
243 case checks of
244 [] ->
245 return True
247 check : otherChecks ->
248 do bool <- check
249 if bool then andM otherChecks else return False