1 module Databrary.Files
    2   ( RawFilePath
    3   , (</>)
    4   , catchDoesNotExist
    5   , modificationTimestamp
    6   , fileInfo
    7   , setFileTimestamps
    8   , removeFile
    9   , createDir
   10   , compareFiles
   11   , hashFile
   12   , rawFilePath
   13   , unRawFilePath
   14   ) where
   15 
   16 import Control.Arrow ((&&&))
   17 import Control.Exception (handleJust)
   18 import Control.Monad (guard, liftM2)
   19 import Crypto.Hash (HashAlgorithm, hashInit, hashUpdate, hashFinalize, Digest)
   20 import Data.ByteArray (MemView(..))
   21 import qualified Data.ByteString as BS
   22 import Data.ByteString.Lazy.Internal (defaultChunkSize)
   23 import Data.Maybe (isJust)
   24 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
   25 import Foreign.Marshal.Alloc (allocaBytes)
   26 import qualified GHC.Foreign as GHC
   27 import GHC.IO.Encoding (getFileSystemEncoding)
   28 import System.Posix.ByteString.FilePath (RawFilePath)
   29 import System.Posix.FilePath ((</>))
   30 import qualified System.Posix as P
   31 import qualified System.Posix.ByteString as RP
   32 import System.Posix.Types (FileMode)
   33 import System.IO (withBinaryFile, IOMode(ReadMode), hGetBufSome)
   34 import System.Posix.Types (FileOffset)
   35 import System.IO.Error (isDoesNotExistError, isAlreadyExistsError)
   36 
   37 import Databrary.Ops
   38 import Databrary.Model.Time
   39 
   40 rawFilePath :: FilePath -> IO RawFilePath
   41 rawFilePath s = do
   42   enc <- getFileSystemEncoding
   43   GHC.withCStringLen enc s BS.packCStringLen
   44 
   45 unRawFilePath :: RawFilePath -> IO FilePath
   46 unRawFilePath b = do
   47   enc <- getFileSystemEncoding
   48   BS.useAsCStringLen b $ GHC.peekCStringLen enc
   49 
   50 catchOnlyIO :: (IOError -> Bool) -> IO a -> IO (Maybe a)
   51 catchOnlyIO c f = handleJust (guard . c) (\_ -> return Nothing) $ Just <$> f
   52 
   53 catchDoesNotExist :: IO a -> IO (Maybe a)
   54 catchDoesNotExist = catchOnlyIO isDoesNotExistError
   55 
   56 catchAlreadyExists :: IO a -> IO (Maybe a)
   57 catchAlreadyExists = catchOnlyIO isAlreadyExistsError
   58 
   59 modificationTimestamp :: P.FileStatus -> Timestamp
   60 modificationTimestamp = posixSecondsToUTCTime . P.modificationTimeHiRes
   61 
   62 fileInfo :: RawFilePath -> IO (Maybe (FileOffset, Timestamp))
   63 fileInfo f =
   64   (=<<) (liftM2 thenUse P.isRegularFile $ P.fileSize &&& modificationTimestamp)
   65   <$> catchDoesNotExist (RP.getFileStatus f)
   66 
   67 setFileTimestamps :: RawFilePath -> Timestamp -> Timestamp -> IO ()
   68 setFileTimestamps f a m = RP.setFileTimesHiRes f (utcTimeToPOSIXSeconds a) (utcTimeToPOSIXSeconds m)
   69 
   70 removeFile :: RawFilePath -> IO Bool
   71 removeFile f = isJust <$> catchDoesNotExist (RP.removeLink f)
   72 
   73 createDir :: RawFilePath -> FileMode -> IO Bool
   74 createDir f m = isJust <$> catchAlreadyExists (RP.createDirectory f m)
   75 
   76 -- | Returns 'True' if files are identical
   77 compareFiles :: RawFilePath -> RawFilePath -> IO Bool
   78 compareFiles f1 f2 = do
   79   s1 <- RP.getFileStatus f1
   80   s2 <- RP.getFileStatus f2
   81   f1p <- unRawFilePath f1
   82   f2p <- unRawFilePath f2
   83   if P.deviceID s1 == P.deviceID s2 && P.fileID s1 == P.fileID s2 then return True
   84     else if P.fileSize s1 /= P.fileSize s2 then return False
   85     else withBinaryFile f1p ReadMode $ withBinaryFile f2p ReadMode . cmp where
   86     cmp h1 h2 = do
   87       b1 <- BS.hGet h1 defaultChunkSize
   88       b2 <- BS.hGet h2 defaultChunkSize
   89       if b1 == b2
   90         then if BS.null b1 then return True else cmp h1 h2
   91         else return False
   92 
   93 hashFile :: (HashAlgorithm a) => RawFilePath -> IO (Digest a)
   94 hashFile f = do
   95   f' <- unRawFilePath f
   96   withBinaryFile f' ReadMode $ \h ->
   97     allocaBytes z $ \b ->
   98       run h b hashInit where
   99   run h b s = do
  100     n <- hGetBufSome h b z
  101     if n == 0
  102       then return $! hashFinalize s
  103       else run h b $! hashUpdate s (MemView b n)
  104   z = 32786