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