git.iko.soy/elk
on 6ea473d help sign in
elk/builder/src/File.hs
181 lines 4.1 kB history raw
1module File
2 ( Time
3 , getTime
4 , withLock
5 , writeBinary
6 , readBinary
7 , writeUtf8
8 , readUtf8
9 , writeBuilder
10 , exists
11 , remove
12 , removeDir
13 )
14 where
17import Control.Exception (catch)
18import qualified Data.Binary as Binary
19import qualified Data.ByteString as BS
20import qualified Data.ByteString.Internal as BS
21import qualified Data.ByteString.Builder as B
22import qualified Data.Fixed as Fixed
23import qualified Data.Time.Clock.POSIX as Time
24import qualified Foreign.ForeignPtr as FPtr
25import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
26import qualified System.Directory as Dir
27import qualified System.FileLock as Lock
28import qualified System.FilePath as FP
29import qualified System.IO as IO
30import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
34-- TIME
37newtype Time = Time Fixed.Pico
38 deriving (Eq, Ord)
41getTime :: FilePath -> IO Time
42getTime path =
43 fmap
44 (Time . realToFrac . Time.utcTimeToPOSIXSeconds)
45-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
46 (Dir.getModificationTime path)
49instance Binary.Binary Time where
50 put (Time time) = Binary.put time
51 get = Time <$> Binary.get
55-- LOCK
58withLock :: FilePath -> IO a -> IO a
59withLock path work =
60 Lock.withFileLock path Lock.Exclusive (\_ -> work)
64-- BINARY
67writeBinary :: (Binary.Binary a) => FilePath -> a -> IO ()
68writeBinary path value =
69 do let dir = FP.dropFileName path
70 Dir.createDirectoryIfMissing True dir
71 Binary.encodeFile path value
74readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)
75readBinary path =
76 do result <- Binary.decodeFileOrFail path
77 case result of
78 Right a -> return (Just a)
79 Left _ -> return Nothing
83-- WRITE UTF-8
86writeUtf8 :: FilePath -> BS.ByteString -> IO ()
87writeUtf8 path content =
88 withUtf8 path IO.WriteMode $ \handle ->
89 BS.hPut handle content
92withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
93withUtf8 path mode callback =
94 IO.withFile path mode $ \handle ->
95 do IO.hSetEncoding handle IO.utf8
96 callback handle
100-- READ UTF-8
103readUtf8 :: FilePath -> IO BS.ByteString
104readUtf8 path =
105 withUtf8 path IO.ReadMode $ \handle ->
106 modifyIOError (encodingError path) $
107 do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
108 let readSize = max 0 (fromIntegral fileSize) + 1
109 hGetContentsSizeHint handle readSize (max 255 readSize)
112useZeroIfNotRegularFile :: IOException -> IO Integer
113useZeroIfNotRegularFile _ =
114 return 0
117hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
118hGetContentsSizeHint handle =
119 readChunks []
120 where
121 readChunks chunks readSize incrementSize =
122 do fp <- BS.mallocByteString readSize
123 readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
124 let chunk = BS.PS fp 0 readCount
125 if readCount < readSize && readSize > 0
126 then return $! BS.concat (reverse (chunk:chunks))
127 else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
130encodingError :: FilePath -> IOError -> IOError
131encodingError path ioErr =
132 case ioeGetErrorType ioErr of
133 InvalidArgument ->
134 annotateIOError
135 (userError "Bad encoding; the file must be valid UTF-8")
136 ""
137 Nothing
138 (Just path)
140 _ ->
141 ioErr
145-- WRITE BUILDER
148writeBuilder :: FilePath -> B.Builder -> IO ()
149writeBuilder path builder =
150 IO.withBinaryFile path IO.WriteMode $ \handle ->
151 do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
152 B.hPutBuilder handle builder
156-- EXISTS
159exists :: FilePath -> IO Bool
160exists path =
161 Dir.doesFileExist path
165-- REMOVE FILES
168remove :: FilePath -> IO ()
169remove path =
170 do exists_ <- Dir.doesFileExist path
171 if exists_
172 then Dir.removeFile path
173 else return ()
176removeDir :: FilePath -> IO ()
177removeDir path =
178 do exists_ <- Dir.doesDirectoryExist path
179 if exists_
180 then Dir.removeDirectoryRecursive path
181 else return ()