git.iko.soy/elk
on a324d58 help sign in
elk/builder/src/File.hs
226 lines 5.6 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 IO.hPutStrLn IO.stderr $ unlines $
86 [ "+-------------------------------------------------------------------------------"
87 , "| Corrupt File: " ++ path
88 , "| Byte Offset: " ++ show offset
89 , "| Message: " ++ message
90 , "| Please report this to https://github.com/elm/compiler/issues"
91 , "| Trying to continue anyway."
92 , "+-------------------------------------------------------------------------------"
93 ]
94 return Nothing
95 else
96 return Nothing
100-- WRITE UTF-8
103writeUtf8 :: FilePath -> BS.ByteString -> IO ()
104writeUtf8 path content =
105 withUtf8 path IO.WriteMode $ \handle ->
106 BS.hPut handle content
109withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
110withUtf8 path mode callback =
111 IO.withFile path mode $ \handle ->
112 do IO.hSetEncoding handle IO.utf8
113 callback handle
117-- READ UTF-8
120readUtf8 :: FilePath -> IO BS.ByteString
121readUtf8 path =
122 withUtf8 path IO.ReadMode $ \handle ->
123 modifyIOError (encodingError path) $
124 do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
125 let readSize = max 0 (fromIntegral fileSize) + 1
126 hGetContentsSizeHint handle readSize (max 255 readSize)
129useZeroIfNotRegularFile :: IOException -> IO Integer
130useZeroIfNotRegularFile _ =
131 return 0
134hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
135hGetContentsSizeHint handle =
136 readChunks []
137 where
138 readChunks chunks readSize incrementSize =
139 do fp <- BS.mallocByteString readSize
140 readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
141 let chunk = BS.PS fp 0 readCount
142 if readCount < readSize && readSize > 0
143 then return $! BS.concat (reverse (chunk:chunks))
144 else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
147encodingError :: FilePath -> IOError -> IOError
148encodingError path ioErr =
149 case ioeGetErrorType ioErr of
150 InvalidArgument ->
151 annotateIOError
152 (userError "Bad encoding; the file must be valid UTF-8")
153 ""
154 Nothing
155 (Just path)
157 _ ->
158 ioErr
162-- WRITE BUILDER
165writeBuilder :: FilePath -> B.Builder -> IO ()
166writeBuilder path builder =
167 IO.withBinaryFile path IO.WriteMode $ \handle ->
168 do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
169 B.hPutBuilder handle builder
173-- WRITE PACKAGE
176writePackage :: FilePath -> Zip.Archive -> IO ()
177writePackage destination archive =
178 case Zip.zEntries archive of
179 [] ->
180 return ()
182 entry:entries ->
183 do let root = length (Zip.eRelativePath entry)
184 mapM_ (writeEntry destination root) entries
187writeEntry :: FilePath -> Int -> Zip.Entry -> IO ()
188writeEntry destination root entry =
189 let
190 path = drop root (Zip.eRelativePath entry)
191 in
192 if path == "LICENSE" || List.isPrefixOf "src/" path then
193 if not (null path) && last path == '/'
194 then Dir.createDirectoryIfMissing True (destination </> path)
195 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
196 else
197 return ()
201-- EXISTS
204exists :: FilePath -> IO Bool
205exists path =
206 Dir.doesFileExist path
210-- REMOVE FILES
213remove :: FilePath -> IO ()
214remove path =
215 do exists_ <- Dir.doesFileExist path
216 if exists_
217 then Dir.removeFile path
218 else return ()
221removeDir :: FilePath -> IO ()
222removeDir path =
223 do exists_ <- Dir.doesDirectoryExist path
224 if exists_
225 then Dir.removeDirectoryRecursive path
226 else return ()