git.iko.soy/elk
on 436f495 help sign in
elk/builder/src/File.hs
219 lines 5.1 kB history raw
1module File
2 ( Time
3 , getTime
4 , withLock
5 , writeBinary
6 , readBinary
7 , writeUtf8
8 , readUtf8
9 , writeBuilder
10 , writePackage
11 , exists
12 , remove
13 , removeDir
14 )
15 where
18import qualified Codec.Archive.Zip as Zip
19import Control.Exception (catch)
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.Lazy as LBS
25import qualified Data.Fixed as Fixed
26import qualified Data.List as List
27import qualified Data.Time.Clock.POSIX as Time
28import qualified Foreign.ForeignPtr as FPtr
29import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
30import qualified System.Directory as Dir
31import qualified System.FileLock as Lock
32import qualified System.FilePath as FP
33import System.FilePath ((</>))
34import qualified System.IO as IO
35import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
39-- TIME
42newtype Time = Time Fixed.Pico
43 deriving (Eq, Ord)
46getTime :: FilePath -> IO Time
47getTime path =
48 fmap
49 (Time . realToFrac . Time.utcTimeToPOSIXSeconds)
50-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
51 (Dir.getModificationTime path)
54instance Binary.Binary Time where
55 put (Time time) = Binary.put time
56 get = Time <$> Binary.get
60-- LOCK
63withLock :: FilePath -> IO a -> IO a
64withLock path work =
65 Lock.withFileLock path Lock.Exclusive (\_ -> work)
69-- BINARY
72writeBinary :: (Binary.Binary a) => FilePath -> a -> IO ()
73writeBinary path value =
74 do let dir = FP.dropFileName path
75 Dir.createDirectoryIfMissing True dir
76 Binary.encodeFile path value
79readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)
80readBinary path =
81 do pathExists <- Dir.doesFileExist path
82 if pathExists
83 then
84 do result <- Binary.decodeFileOrFail path
85 case result of
86 Right a -> return (Just a)
87 Left e -> return Nothing
88 else
89 return Nothing
93-- WRITE UTF-8
96writeUtf8 :: FilePath -> BS.ByteString -> IO ()
97writeUtf8 path content =
98 withUtf8 path IO.WriteMode $ \handle ->
99 BS.hPut handle content
102withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
103withUtf8 path mode callback =
104 IO.withFile path mode $ \handle ->
105 do IO.hSetEncoding handle IO.utf8
106 callback handle
110-- READ UTF-8
113readUtf8 :: FilePath -> IO BS.ByteString
114readUtf8 path =
115 withUtf8 path IO.ReadMode $ \handle ->
116 modifyIOError (encodingError path) $
117 do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
118 let readSize = max 0 (fromIntegral fileSize) + 1
119 hGetContentsSizeHint handle readSize (max 255 readSize)
122useZeroIfNotRegularFile :: IOException -> IO Integer
123useZeroIfNotRegularFile _ =
124 return 0
127hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
128hGetContentsSizeHint handle =
129 readChunks []
130 where
131 readChunks chunks readSize incrementSize =
132 do fp <- BS.mallocByteString readSize
133 readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
134 let chunk = BS.PS fp 0 readCount
135 if readCount < readSize && readSize > 0
136 then return $! BS.concat (reverse (chunk:chunks))
137 else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
140encodingError :: FilePath -> IOError -> IOError
141encodingError path ioErr =
142 case ioeGetErrorType ioErr of
143 InvalidArgument ->
144 annotateIOError
145 (userError "Bad encoding; the file must be valid UTF-8")
146 ""
147 Nothing
148 (Just path)
150 _ ->
151 ioErr
155-- WRITE BUILDER
158writeBuilder :: FilePath -> B.Builder -> IO ()
159writeBuilder path builder =
160 IO.withBinaryFile path IO.WriteMode $ \handle ->
161 do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
162 B.hPutBuilder handle builder
166-- WRITE PACKAGE
169writePackage :: FilePath -> Zip.Archive -> IO ()
170writePackage destination archive =
171 case Zip.zEntries archive of
172 [] ->
173 return ()
175 entry:entries ->
176 do let root = length (Zip.eRelativePath entry)
177 mapM_ (writeEntry destination root) entries
180writeEntry :: FilePath -> Int -> Zip.Entry -> IO ()
181writeEntry destination root entry =
182 let
183 path = drop root (Zip.eRelativePath entry)
184 in
185 if List.isPrefixOf "src/" path then
186 if not (null path) && last path == '/'
187 then Dir.createDirectoryIfMissing True (destination </> path)
188 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
189 else
190 return ()
194-- EXISTS
197exists :: FilePath -> IO Bool
198exists path =
199 Dir.doesFileExist path
203-- REMOVE FILES
206remove :: FilePath -> IO ()
207remove path =
208 do exists_ <- Dir.doesFileExist path
209 if exists_
210 then Dir.removeFile path
211 else return ()
214removeDir :: FilePath -> IO ()
215removeDir path =
216 do exists_ <- Dir.doesDirectoryExist path
217 if exists_
218 then Dir.removeDirectoryRecursive path
219 else return ()