module Data.Conduit.VFS.Disk
( DiskVFS
, runDiskVFS
, runDiskVFS_
) where
import ClassyPrelude hiding (ByteString, handle, hash, bracket)
import Control.Monad.Catch (MonadCatch, MonadMask)
import Control.Monad.Extra (ifM)
import Control.Monad.Fail (MonadFail)
import Control.Monad.Loops (whileM_)
import Data.Conduit.VFS.Import
import System.Directory (removeFile)
import System.IO.Extra (openBinaryFile)
import System.Posix (getFileStatus, isRegularFile, isDirectory)
import UnliftIO.Directory (doesFileExist, listDirectory)
import qualified Data.ByteString as SBS
import qualified Data.ByteString.Lazy as LBS
newtype DiskVFS m a = DiskVFS { unDVFS :: m a }
deriving (Applicative, Functor, MonadFail, Monad, MonadThrow, MonadCatch, MonadMask, MonadResource, MonadIO)
instance (MonadUnliftIO m) => MonadUnliftIO (DiskVFS m) where
askUnliftIO = do
(UnliftIO interiorUnliftIO) <- lift askUnliftIO
return $ UnliftIO $ \(DiskVFS interior) -> interiorUnliftIO interior
{-# INLINEABLE askUnliftIO #-}
instance MonadTrans DiskVFS where
lift = DiskVFS
{-# INLINE lift #-}
runDiskVFS :: DiskVFS m a -> m a
runDiskVFS = unDVFS
{-# INLINE runDiskVFS #-}
runDiskVFS_ :: (Monad m) => DiskVFS m a -> m ()
runDiskVFS_ = void . runDiskVFS
{-# INLINE runDiskVFS_ #-}
instance (MonadUnliftIO m) => ReadVFSC (DiskVFS m) where
vfsTypeC = awaitForever $ \filepath -> fmap (filepath,) . liftIO $
ifM
(not <$> doesFileExist filepath)
(return Nothing)
$ getFileStatus filepath >>= \status ->
if isRegularFile status then
return $ Just VFile
else if isDirectory status then
return $ Just VDirectory
else
return Nothing
{-# INLINEABLE vfsTypeC #-}
vfsContentsEitherC = awaitForever $ \filepath ->
whenM (isExistingRegularFile filepath)
$ do
yield $ Left filepath
handle <- liftIO $ openBinaryFile filepath ReadMode
liftIO $ hSetBuffering handle (BlockBuffering Nothing)
whileM_
(hIsNotEOF handle)
(doRead handle >>= yield . Right . LBS.fromStrict)
where
hIsNotEOF handle = liftIO $ not <$> hIsEOF handle
doRead h = liftIO $ SBS.hGetSome h 1024
{-# INLINEABLE vfsContentsEitherC #-}
vfsChildrenC = awaitForever $ \filepath ->
whenM (liftIO $ doesFileExist filepath) $
ifM
(fileIsDirectory filepath)
(listChildren filepath >>= yieldMany)
(yield filepath)
where
fileIsDirectory filepath = liftIO $ isDirectory <$> getFileStatus filepath
listChildren filepath = liftIO $ do
(children::[FilePath]) <- listDirectory filepath
return $ (filepath </>) <$> children
{-# INLINEABLE vfsChildrenC #-}
instance (MonadUnliftIO m) => WriteVFSC (DiskVFS m) where
vfsWriteEitherSink = awaitForever $ \case
(Right _) -> fail "Encountered bytes without seeing a filename"
(Left filename) -> do
bytes <- readAllBytesFromUpstream
liftIO $ LBS.writeFile filename bytes
where
readAllBytesFromUpstream =
ifM
moreBytesFromUpstream
(readSomeBytesFromUpstream >>= \prev -> LBS.append prev <$> readAllBytesFromUpstream )
(return mempty)
moreBytesFromUpstream = peekC >>= \case
(Just (Right _)) -> return True
_ -> return False
readSomeBytesFromUpstream = await >>= \case
(Just (Right bytes)) -> return bytes
_ -> fail "Encountered a new filename when peeking said we had bytes"
{-# INLINEABLE vfsWriteEitherSink #-}
vfsRemoveSink = awaitForever $ \filename ->
whenM (isExistingRegularFile filename) (liftIO $ removeFile filename)
{-# INLINEABLE vfsRemoveSink #-}
isExistingRegularFile :: MonadIO m => FilePath -> m Bool
isExistingRegularFile filepath = liftIO $ liftM2 (&&) (doesFileExist filepath) (isRegularFile <$> getFileStatus filepath)
{-# INLINEABLE isExistingRegularFile #-}
instance (MonadUnliftIO m) => VFSC (DiskVFS m)