git.iko.soy/elk
on f229831 help sign in
elk/builder/src/File.hs
228 lines 5.7 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 as Time
28import qualified Data.Time.Clock.POSIX as Time
29import qualified Foreign.ForeignPtr as FPtr
30import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
31import qualified System.Directory as Dir
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 . 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 ->
82 return (Just a)
84 Left (offset, message) ->
85 do Dir.copyFile path "bad.dat"
86 IO.hPutStrLn IO.stderr $ unlines $
87 [ "+-------------------------------------------------------------------------------"
88 , "| Corrupt File: " ++ path
89 , "| Byte Offset: " ++ show offset
90 , "| Message: " ++ message
91 , "|"
92 , "| Please report this to https://github.com/elm/compiler/issues"
93 , "| Trying to continue anyway."
94 , "+-------------------------------------------------------------------------------"
95 ]
96 return Nothing
97 else
98 return Nothing
102-- WRITE UTF-8
105writeUtf8 :: FilePath -> BS.ByteString -> IO ()
106writeUtf8 path content =
107 withUtf8 path IO.WriteMode $ \handle ->
108 BS.hPut handle content
111withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
112withUtf8 path mode callback =
113 IO.withFile path mode $ \handle ->
114 do IO.hSetEncoding handle IO.utf8
115 callback handle
119-- READ UTF-8
122readUtf8 :: FilePath -> IO BS.ByteString
123readUtf8 path =
124 withUtf8 path IO.ReadMode $ \handle ->
125 modifyIOError (encodingError path) $
126 do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
127 let readSize = max 0 (fromIntegral fileSize) + 1
128 hGetContentsSizeHint handle readSize (max 255 readSize)
131useZeroIfNotRegularFile :: IOException -> IO Integer
132useZeroIfNotRegularFile _ =
133 return 0
136hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
137hGetContentsSizeHint handle =
138 readChunks []
139 where
140 readChunks chunks readSize incrementSize =
141 do fp <- BS.mallocByteString readSize
142 readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
143 let chunk = BS.PS fp 0 readCount
144 if readCount < readSize && readSize > 0
145 then return $! BS.concat (reverse (chunk:chunks))
146 else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
149encodingError :: FilePath -> IOError -> IOError
150encodingError path ioErr =
151 case ioeGetErrorType ioErr of
152 InvalidArgument ->
153 annotateIOError
154 (userError "Bad encoding; the file must be valid UTF-8")
155 ""
156 Nothing
157 (Just path)
159 _ ->
160 ioErr
164-- WRITE BUILDER
167writeBuilder :: FilePath -> B.Builder -> IO ()
168writeBuilder path builder =
169 IO.withBinaryFile path IO.WriteMode $ \handle ->
170 do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
171 B.hPutBuilder handle builder
175-- WRITE PACKAGE
178writePackage :: FilePath -> Zip.Archive -> IO ()
179writePackage destination archive =
180 case Zip.zEntries archive of
181 [] ->
182 return ()
184 entry:entries ->
185 do let root = length (Zip.eRelativePath entry)
186 mapM_ (writeEntry destination root) entries
189writeEntry :: FilePath -> Int -> Zip.Entry -> IO ()
190writeEntry destination root entry =
191 let
192 path = drop root (Zip.eRelativePath entry)
193 in
194 if path == "LICENSE" || List.isPrefixOf "src/" path then
195 if not (null path) && last path == '/'
196 then Dir.createDirectoryIfMissing True (destination </> path)
197 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
198 else
199 return ()
203-- EXISTS
206exists :: FilePath -> IO Bool
207exists path =
208 Dir.doesFileExist path
212-- REMOVE FILES
215remove :: FilePath -> IO ()
216remove path =
217 do exists_ <- Dir.doesFileExist path
218 if exists_
219 then Dir.removeFile path
220 else return ()
223removeDir :: FilePath -> IO ()
224removeDir path =
225 do exists_ <- Dir.doesDirectoryExist path
226 if exists_
227 then Dir.removeDirectoryRecursive path
228 else return ()