@@ -1,16 +1,15 @@
1−module File.IO
2− ( writeBinary, readBinary
3− , writeUtf8, readUtf8
1+module File
2+ ( Time
3+ , getTime
4+ , withLock
5+ , writeBinary
6+ , readBinary
7+ , writeUtf8
8+ , readUtf8
49 , writeBuilder
5− , Writer
6− , put
7− , putByteString
8− , putBuilder
9− , putFile
1010 , exists
11− , remove, removeDir
12− , find
13− , andM
11+ , remove
12+ , removeDir
1413 )
1514 where
1615
@@ -20,17 +19,48 @@ import qualified Data.Binary as Binary
2019import qualified Data.ByteString as BS
2120import qualified Data.ByteString.Internal as BS
2221import qualified Data.ByteString.Builder as B
23−import qualified Data.ByteString.Builder.Extra as B (defaultChunkSize)
22+import qualified Data.Fixed as Fixed
23+import qualified Data.Time.Clock.POSIX as Time
2424import qualified Foreign.ForeignPtr as FPtr
2525import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
2626import qualified System.Directory as Dir
27−import System.FilePath ((</>))
27+import qualified System.FileLock as Lock
2828import qualified System.FilePath as FP
2929import qualified System.IO as IO
3030import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
3131
3232
3333
34+-- TIME
35+
36+
37+newtype Time = Time Fixed.Pico
38+ deriving (Eq, Ord)
39+
40+
41+getTime :: FilePath -> IO Time
42+getTime path =
43+ fmap
44+ (Time . realToFrac . Time.utcTimeToPOSIXSeconds)
45+-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
46+ (Dir.getModificationTime path)
47+
48+
49+instance Binary.Binary Time where
50+ put (Time time) = Binary.put time
51+ get = Time <$> Binary.get
52+
53+
54+
55+-- LOCK
56+
57+
58+withLock :: FilePath -> IO a -> IO a
59+withLock path work =
60+ Lock.withFileLock path Lock.Exclusive (\_ -> work)
61+
62+
63+
3464-- BINARY
3565
3666
@@ -43,14 +73,10 @@ writeBinary path value =
4373
4474readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)
4575readBinary path =
46− do exists_ <- Dir.doesFileExist path
47− if not exists_
48− then return Nothing
49− else
50− do result <- Binary.decodeFileOrFail path
51− case result of
52− Left _ -> return Nothing
53− Right a -> return (Just a)
76+ do result <- Binary.decodeFileOrFail path
77+ case result of
78+ Right a -> return (Just a)
79+ Left _ -> return Nothing
5480
5581
5682
@@ -58,14 +84,14 @@ readBinary path =
5884
5985
6086writeUtf8 :: FilePath -> BS.ByteString -> IO ()
61−writeUtf8 filePath content =
62− withUtf8 filePath IO.WriteMode $ \handle ->
87+writeUtf8 path content =
88+ withUtf8 path IO.WriteMode $ \handle ->
6389 BS.hPut handle content
6490
6591
6692withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
67−withUtf8 filePath mode callback =
68− IO.withFile filePath mode $ \handle ->
93+withUtf8 path mode callback =
94+ IO.withFile path mode $ \handle ->
6995 do IO.hSetEncoding handle IO.utf8
7096 callback handle
7197
@@ -75,9 +101,9 @@ withUtf8 filePath mode callback =
75101
76102
77103readUtf8 :: FilePath -> IO BS.ByteString
78−readUtf8 filePath =
79− withUtf8 filePath IO.ReadMode $ \handle ->
80− modifyIOError (encodingError filePath) $
104+readUtf8 path =
105+ withUtf8 path IO.ReadMode $ \handle ->
106+ modifyIOError (encodingError path) $
81107 do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
82108 let readSize = max 0 (fromIntegral fileSize) + 1
83109 hGetContentsSizeHint handle readSize (max 255 readSize)
@@ -102,14 +128,14 @@ hGetContentsSizeHint handle =
102128
103129
104130encodingError :: FilePath -> IOError -> IOError
105−encodingError filePath ioErr =
131+encodingError path ioErr =
106132 case ioeGetErrorType ioErr of
107133 InvalidArgument ->
108134 annotateIOError
109135 (userError "Bad encoding; the file must be valid UTF-8")
110136 ""
111137 Nothing
112− (Just filePath)
138+ (Just path)
113139
114140 _ ->
115141 ioErr
@@ -127,54 +153,12 @@ writeBuilder path builder =
127153
128154
129155
130−-- WRITER
131−
132−
133−newtype Writer =
134− Writer (IO.Handle -> IO ())
135−
136−
137−put :: FilePath -> Writer -> IO ()
138−put path (Writer callback) =
139− IO.withBinaryFile path IO.WriteMode callback
140−
141−
142−putByteString :: BS.ByteString -> Writer
143−putByteString chunk =
144− Writer $ \handle ->
145− BS.hPut handle chunk
146−
147−
148−putBuilder :: B.Builder -> Writer
149−putBuilder builder =
150− Writer $ \handle ->
151− B.hPutBuilder handle builder
152−
153−
154−putFile :: FilePath -> Writer
155−putFile path =
156− Writer $ \sink ->
157− IO.withBinaryFile path IO.ReadMode $ \source ->
158− putHelp source sink
159−
160−
161−putHelp :: IO.Handle -> IO.Handle -> IO ()
162−putHelp source sink =
163− do chunk <- BS.hGet source B.defaultChunkSize
164− if BS.null chunk
165− then return ()
166− else
167− do BS.hPut sink chunk
168− putHelp source sink
169−
170−
171−
172156-- EXISTS
173157
174158
175159exists :: FilePath -> IO Bool
176−exists =
177− Dir.doesFileExist
160+exists path =
161+ Dir.doesFileExist path
178162
179163
180164
@@ -182,10 +166,10 @@ exists =
182166
183167
184168remove :: FilePath -> IO ()
185−remove filePath =
186− do exists_ <- Dir.doesFileExist filePath
169+remove path =
170+ do exists_ <- Dir.doesFileExist path
187171 if exists_
188− then Dir.removeFile filePath
172+ then Dir.removeFile path
189173 else return ()
190174
191175
@@ -195,40 +179,3 @@ removeDir path =
195179 if exists_
196180 then Dir.removeDirectoryRecursive path
197181 else return ()
198−
199−
200−
201−-- FIND FILES
202−
203−
204−find :: FilePath -> IO (Maybe FilePath)
205−find name =
206− do subDir <- Dir.getCurrentDirectory
207− findHelp name (FP.splitDirectories subDir)
208−
209−
210−findHelp :: FilePath -> [String] -> IO (Maybe FilePath)
211−findHelp name dirs =
212− if null dirs then
213− return Nothing
214−
215− else
216− do exists_ <- Dir.doesFileExist (FP.joinPath dirs </> name)
217− if exists_
218− then return (Just (FP.joinPath dirs))
219− else findHelp name (init dirs)
220−
221−
222−
223−-- HELPER
224−
225−
226−andM :: (Monad m) => [m Bool] -> m Bool
227−andM checks =
228− case checks of
229− [] ->
230− return True
231−
232− check : otherChecks ->
233− do bool <- check
234− if bool then andM otherChecks else return False