git.iko.soy/elk
on cc45728 help sign in
elk/builder/src/File.hs
214 lines 5.0 kB history raw
1module File
2 ( Time
3 , getTime
4 , zeroTime
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.FilePath as FP
32import System.FilePath ((</>))
33import qualified System.IO as IO
34import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
38-- TIME
41newtype Time = Time Fixed.Pico
42 deriving (Eq, Ord)
45getTime :: FilePath -> IO Time
46getTime path =
47 fmap
48 (Time . realToFrac . Time.utcTimeToPOSIXSeconds)
49-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
50 (Dir.getModificationTime path)
53zeroTime :: Time
54zeroTime =
55 Time 0
58instance Binary.Binary Time where
59 put (Time time) = Binary.put time
60 get = Time <$> Binary.get
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 pathExists <- Dir.doesFileExist path
77 if pathExists
78 then
79 do result <- Binary.decodeFileOrFail path
80 case result of
81 Right a -> return (Just a)
82 Left _ -> return Nothing
83 else
84 return Nothing
88-- WRITE UTF-8
91writeUtf8 :: FilePath -> BS.ByteString -> IO ()
92writeUtf8 path content =
93 withUtf8 path IO.WriteMode $ \handle ->
94 BS.hPut handle content
97withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
98withUtf8 path mode callback =
99 IO.withFile path mode $ \handle ->
100 do IO.hSetEncoding handle IO.utf8
101 callback handle
105-- READ UTF-8
108readUtf8 :: FilePath -> IO BS.ByteString
109readUtf8 path =
110 withUtf8 path IO.ReadMode $ \handle ->
111 modifyIOError (encodingError path) $
112 do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
113 let readSize = max 0 (fromIntegral fileSize) + 1
114 hGetContentsSizeHint handle readSize (max 255 readSize)
117useZeroIfNotRegularFile :: IOException -> IO Integer
118useZeroIfNotRegularFile _ =
119 return 0
122hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
123hGetContentsSizeHint handle =
124 readChunks []
125 where
126 readChunks chunks readSize incrementSize =
127 do fp <- BS.mallocByteString readSize
128 readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
129 let chunk = BS.PS fp 0 readCount
130 if readCount < readSize && readSize > 0
131 then return $! BS.concat (reverse (chunk:chunks))
132 else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
135encodingError :: FilePath -> IOError -> IOError
136encodingError path ioErr =
137 case ioeGetErrorType ioErr of
138 InvalidArgument ->
139 annotateIOError
140 (userError "Bad encoding; the file must be valid UTF-8")
141 ""
142 Nothing
143 (Just path)
145 _ ->
146 ioErr
150-- WRITE BUILDER
153writeBuilder :: FilePath -> B.Builder -> IO ()
154writeBuilder path builder =
155 IO.withBinaryFile path IO.WriteMode $ \handle ->
156 do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
157 B.hPutBuilder handle builder
161-- WRITE PACKAGE
164writePackage :: FilePath -> Zip.Archive -> IO ()
165writePackage destination archive =
166 case Zip.zEntries archive of
167 [] ->
168 return ()
170 entry:entries ->
171 do let root = length (Zip.eRelativePath entry)
172 mapM_ (writeEntry destination root) entries
175writeEntry :: FilePath -> Int -> Zip.Entry -> IO ()
176writeEntry destination root entry =
177 let
178 path = drop root (Zip.eRelativePath entry)
179 in
180 if path == "LICENSE" || List.isPrefixOf "src/" path then
181 if not (null path) && last path == '/'
182 then Dir.createDirectoryIfMissing True (destination </> path)
183 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
184 else
185 return ()
189-- EXISTS
192exists :: FilePath -> IO Bool
193exists path =
194 Dir.doesFileExist path
198-- REMOVE FILES
201remove :: FilePath -> IO ()
202remove path =
203 do exists_ <- Dir.doesFileExist path
204 if exists_
205 then Dir.removeFile path
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 ()