git.iko.soy/elk
on 2469006 help sign in
elk/builder/src/File.hs
208 lines 4.9 kB history raw
1module File
2 ( Time
3 , getTime
4 , writeBinary
5 , readBinary
6 , writeUtf8
7 , readUtf8
8 , writeBuilder
9 , writePackage
10 , exists
11 , remove
12 , removeDir
13 )
14 where
17import qualified Codec.Archive.Zip as Zip
18import Control.Exception (catch)
19import qualified Data.Binary as Binary
20import qualified Data.ByteString as BS
21import qualified Data.ByteString.Internal as BS
22import qualified Data.ByteString.Builder as B
23import qualified Data.ByteString.Lazy as LBS
24import qualified Data.Fixed as Fixed
25import qualified Data.List as List
26import qualified Data.Time.Clock.POSIX as Time
27import qualified Foreign.ForeignPtr as FPtr
28import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
29import qualified System.Directory as Dir
30import qualified System.FilePath as FP
31import System.FilePath ((</>))
32import qualified System.IO as IO
33import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
37-- TIME
40newtype Time = Time Fixed.Pico
41 deriving (Eq, Ord)
44getTime :: FilePath -> IO Time
45getTime path =
46 fmap
47 (Time . realToFrac . Time.utcTimeToPOSIXSeconds)
48-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
49 (Dir.getModificationTime path)
52instance Binary.Binary Time where
53 put (Time time) = Binary.put time
54 get = Time <$> Binary.get
58-- BINARY
61writeBinary :: (Binary.Binary a) => FilePath -> a -> IO ()
62writeBinary path value =
63 do let dir = FP.dropFileName path
64 Dir.createDirectoryIfMissing True dir
65 Binary.encodeFile path value
68readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)
69readBinary path =
70 do pathExists <- Dir.doesFileExist path
71 if pathExists
72 then
73 do result <- Binary.decodeFileOrFail path
74 case result of
75 Right a -> return (Just a)
76 Left e -> return Nothing
77 else
78 return Nothing
82-- WRITE UTF-8
85writeUtf8 :: FilePath -> BS.ByteString -> IO ()
86writeUtf8 path content =
87 withUtf8 path IO.WriteMode $ \handle ->
88 BS.hPut handle content
91withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
92withUtf8 path mode callback =
93 IO.withFile path mode $ \handle ->
94 do IO.hSetEncoding handle IO.utf8
95 callback handle
99-- READ UTF-8
102readUtf8 :: FilePath -> IO BS.ByteString
103readUtf8 path =
104 withUtf8 path IO.ReadMode $ \handle ->
105 modifyIOError (encodingError path) $
106 do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
107 let readSize = max 0 (fromIntegral fileSize) + 1
108 hGetContentsSizeHint handle readSize (max 255 readSize)
111useZeroIfNotRegularFile :: IOException -> IO Integer
112useZeroIfNotRegularFile _ =
113 return 0
116hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
117hGetContentsSizeHint handle =
118 readChunks []
119 where
120 readChunks chunks readSize incrementSize =
121 do fp <- BS.mallocByteString readSize
122 readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
123 let chunk = BS.PS fp 0 readCount
124 if readCount < readSize && readSize > 0
125 then return $! BS.concat (reverse (chunk:chunks))
126 else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
129encodingError :: FilePath -> IOError -> IOError
130encodingError path ioErr =
131 case ioeGetErrorType ioErr of
132 InvalidArgument ->
133 annotateIOError
134 (userError "Bad encoding; the file must be valid UTF-8")
135 ""
136 Nothing
137 (Just path)
139 _ ->
140 ioErr
144-- WRITE BUILDER
147writeBuilder :: FilePath -> B.Builder -> IO ()
148writeBuilder path builder =
149 IO.withBinaryFile path IO.WriteMode $ \handle ->
150 do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
151 B.hPutBuilder handle builder
155-- WRITE PACKAGE
158writePackage :: FilePath -> Zip.Archive -> IO ()
159writePackage destination archive =
160 case Zip.zEntries archive of
161 [] ->
162 return ()
164 entry:entries ->
165 do let root = length (Zip.eRelativePath entry)
166 mapM_ (writeEntry destination root) entries
169writeEntry :: FilePath -> Int -> Zip.Entry -> IO ()
170writeEntry destination root entry =
171 let
172 path = drop root (Zip.eRelativePath entry)
173 in
174 if List.isPrefixOf "src/" path then
175 if not (null path) && last path == '/'
176 then Dir.createDirectoryIfMissing True (destination </> path)
177 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
178 else
179 return ()
183-- EXISTS
186exists :: FilePath -> IO Bool
187exists path =
188 Dir.doesFileExist path
192-- REMOVE FILES
195remove :: FilePath -> IO ()
196remove path =
197 do exists_ <- Dir.doesFileExist path
198 if exists_
199 then Dir.removeFile path
200 else return ()
203removeDir :: FilePath -> IO ()
204removeDir path =
205 do exists_ <- Dir.doesDirectoryExist path
206 if exists_
207 then Dir.removeDirectoryRecursive path
208 else return ()