{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
module General.Chunks(
Chunks,
readChunk, readChunkMax, usingWriteChunks, writeChunk,
restoreChunksBackup, usingChunks, resetChunksCompact, resetChunksCorrupt
) where
import System.Time.Extra
import System.FilePath
import Control.Concurrent.Extra
import Control.Monad.Extra
import Control.Exception
import System.IO
import System.Directory
import qualified Data.ByteString as BS
import Data.Word
import Data.Monoid
import General.Binary
import General.Extra
import General.Cleanup
import General.Thread
import Prelude
data Chunks = Chunks
{Chunks -> FilePath
chunksFileName :: FilePath
,Chunks -> Maybe Seconds
chunksFlush :: Maybe Seconds
,Chunks -> MVar Handle
chunksHandle :: MVar Handle
}
readChunk :: Chunks -> IO (Either BS.ByteString BS.ByteString)
readChunk :: Chunks -> IO (Either ByteString ByteString)
readChunk Chunks
c = Chunks -> Word32 -> IO (Either ByteString ByteString)
readChunkMax Chunks
c forall a. Bounded a => a
maxBound
readChunkMax :: Chunks -> Word32 -> IO (Either BS.ByteString BS.ByteString)
readChunkMax :: Chunks -> Word32 -> IO (Either ByteString ByteString)
readChunkMax Chunks{FilePath
Maybe Seconds
MVar Handle
chunksHandle :: MVar Handle
chunksFlush :: Maybe Seconds
chunksFileName :: FilePath
chunksHandle :: Chunks -> MVar Handle
chunksFlush :: Chunks -> Maybe Seconds
chunksFileName :: Chunks -> FilePath
..} Word32
mx = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
chunksHandle forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Word32 -> IO (Either ByteString ByteString)
readChunkDirect Handle
h Word32
mx
readChunkDirect :: Handle -> Word32 -> IO (Either BS.ByteString BS.ByteString)
readChunkDirect :: Handle -> Word32 -> IO (Either ByteString ByteString)
readChunkDirect Handle
h Word32
mx = do
let slop :: ByteString -> IO (Either ByteString b)
slop ByteString
x = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
x) forall a b. (a -> b) -> a -> b
$ Handle -> Integer -> IO ()
hSetFileSize Handle
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract (forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
x) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO Integer
hFileSize Handle
h
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ByteString
x
ByteString
n <- Handle -> Int -> IO ByteString
BS.hGet Handle
h Int
4
if ByteString -> Int
BS.length ByteString
n forall a. Ord a => a -> a -> Bool
< Int
4 then forall {b}. ByteString -> IO (Either ByteString b)
slop ByteString
n else do
let count :: Int
count = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min Word32
mx forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. Storable a => ByteString -> (a, ByteString)
unsafeBinarySplit ByteString
n
ByteString
v <- Handle -> Int -> IO ByteString
BS.hGet Handle
h Int
count
if ByteString -> Int
BS.length ByteString
v forall a. Ord a => a -> a -> Bool
< Int
count then forall {b}. ByteString -> IO (Either ByteString b)
slop (ByteString
n ByteString -> ByteString -> ByteString
`BS.append` ByteString
v) else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ByteString
v
writeChunkDirect :: Handle -> Builder -> IO ()
writeChunkDirect :: Handle -> Builder -> IO ()
writeChunkDirect Handle
h Builder
x = ByteString
bs seq :: forall a b. a -> b -> b
`seq` Handle -> ByteString -> IO ()
BS.hPut Handle
h ByteString
bs
where bs :: ByteString
bs = Builder -> ByteString
runBuilder forall a b. (a -> b) -> a -> b
$ forall a. BinaryEx a => a -> Builder
putEx (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Builder -> Int
sizeBuilder Builder
x :: Word32) forall a. Semigroup a => a -> a -> a
<> Builder
x
usingWriteChunks :: Cleanup -> Chunks -> IO (Builder -> IO ())
usingWriteChunks :: Cleanup -> Chunks -> IO (Builder -> IO ())
usingWriteChunks Cleanup
cleanup Chunks{FilePath
Maybe Seconds
MVar Handle
chunksHandle :: MVar Handle
chunksFlush :: Maybe Seconds
chunksFileName :: FilePath
chunksHandle :: Chunks -> MVar Handle
chunksFlush :: Chunks -> Maybe Seconds
chunksFileName :: Chunks -> FilePath
..} = do
Handle
h <- forall a. Cleanup -> IO a -> (a -> IO ()) -> IO a
allocate Cleanup
cleanup (forall a. MVar a -> IO a
takeMVar MVar Handle
chunksHandle) (forall a. MVar a -> a -> IO ()
putMVar MVar Handle
chunksHandle)
Chan (IO Bool)
chan <- forall a. IO (Chan a)
newChan
MVar ()
kick <- forall a. IO (MVar a)
newEmptyMVar
Barrier Any
died <- forall a. IO (Barrier a)
newBarrier
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Seconds
chunksFlush forall a b. (a -> b) -> a -> b
$ \Seconds
flush ->
Cleanup -> IO () -> IO ()
allocateThread Cleanup
cleanup forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
forall a. MVar a -> IO a
takeMVar MVar ()
kick
Seconds -> IO ()
sleep Seconds
flush
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
kick
forall a. Chan a -> a -> IO ()
writeChan Chan (IO Bool)
chan forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Cleanup -> IO () -> IO ()
allocateThread Cleanup
cleanup forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => m Bool -> m ()
whileM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> IO a
readChan Chan (IO Bool)
chan
Cleanup -> IO () -> IO ReleaseKey
register Cleanup
cleanup forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> a -> IO ()
writeChan Chan (IO Bool)
chan forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Builder
s -> do
IO ()
out <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ Handle -> Builder -> IO ()
writeChunkDirect Handle
h Builder
s
forall a. Chan a -> a -> IO ()
writeChan Chan (IO Bool)
chan forall a b. (a -> b) -> a -> b
$ IO ()
out forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
kick () forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
writeChunk :: Chunks -> Builder -> IO ()
writeChunk :: Chunks -> Builder -> IO ()
writeChunk Chunks{FilePath
Maybe Seconds
MVar Handle
chunksHandle :: MVar Handle
chunksFlush :: Maybe Seconds
chunksFileName :: FilePath
chunksHandle :: Chunks -> MVar Handle
chunksFlush :: Chunks -> Maybe Seconds
chunksFileName :: Chunks -> FilePath
..} Builder
x = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
chunksHandle forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Builder -> IO ()
writeChunkDirect Handle
h Builder
x
backup :: FilePath -> FilePath
backup FilePath
x = FilePath
x FilePath -> FilePath -> FilePath
<.> FilePath
"backup"
restoreChunksBackup :: FilePath -> IO Bool
restoreChunksBackup :: FilePath -> IO Bool
restoreChunksBackup FilePath
file = do
Bool
b <- FilePath -> IO Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
backup FilePath
file
if Bool -> Bool
not Bool
b then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False else do
FilePath -> IO ()
removeFile_ FilePath
file
FilePath -> FilePath -> IO ()
renameFile (FilePath -> FilePath
backup FilePath
file) FilePath
file
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
usingChunks :: Cleanup -> FilePath -> Maybe Seconds -> IO Chunks
usingChunks :: Cleanup -> FilePath -> Maybe Seconds -> IO Chunks
usingChunks Cleanup
cleanup FilePath
file Maybe Seconds
flush = do
MVar Handle
h <- forall a. IO (MVar a)
newEmptyMVar
forall a. Cleanup -> IO a -> (a -> IO ()) -> IO a
allocate Cleanup
cleanup
(forall a. MVar a -> a -> IO ()
putMVar MVar Handle
h forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IOMode -> IO Handle
openFile FilePath
file IOMode
ReadWriteMode)
(forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. MVar a -> IO a
takeMVar MVar Handle
h)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe Seconds -> MVar Handle -> Chunks
Chunks FilePath
file Maybe Seconds
flush MVar Handle
h
resetChunksCompact :: Chunks -> ((Builder -> IO ()) -> IO a) -> IO a
resetChunksCompact :: forall a. Chunks -> ((Builder -> IO ()) -> IO a) -> IO a
resetChunksCompact Chunks{FilePath
Maybe Seconds
MVar Handle
chunksHandle :: MVar Handle
chunksFlush :: Maybe Seconds
chunksFileName :: FilePath
chunksHandle :: Chunks -> MVar Handle
chunksFlush :: Chunks -> Maybe Seconds
chunksFileName :: Chunks -> FilePath
..} (Builder -> IO ()) -> IO a
act = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
Handle
h <- forall a. MVar a -> IO a
takeMVar MVar Handle
chunksHandle
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> IO b -> IO a
onException (forall a. MVar a -> a -> IO ()
putMVar MVar Handle
chunksHandle Handle
h) forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ do
Handle -> IO ()
hClose Handle
h
FilePath -> FilePath -> IO ()
copyFile FilePath
chunksFileName forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
backup FilePath
chunksFileName
Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
chunksFileName IOMode
ReadWriteMode
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> IO b -> IO a
finally (forall a. MVar a -> a -> IO ()
putMVar MVar Handle
chunksHandle Handle
h) forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ do
Handle -> Integer -> IO ()
hSetFileSize Handle
h Integer
0
Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
0
a
res <- (Builder -> IO ()) -> IO a
act forall a b. (a -> b) -> a -> b
$ Handle -> Builder -> IO ()
writeChunkDirect Handle
h
Handle -> IO ()
hFlush Handle
h
FilePath -> IO ()
removeFile forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
backup FilePath
chunksFileName
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
resetChunksCorrupt :: Maybe FilePath -> Chunks -> IO ()
resetChunksCorrupt :: Maybe FilePath -> Chunks -> IO ()
resetChunksCorrupt Maybe FilePath
copy Chunks{FilePath
Maybe Seconds
MVar Handle
chunksHandle :: MVar Handle
chunksFlush :: Maybe Seconds
chunksFileName :: FilePath
chunksHandle :: Chunks -> MVar Handle
chunksFlush :: Chunks -> Maybe Seconds
chunksFileName :: Chunks -> FilePath
..} = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
Handle
h <- forall a. MVar a -> IO a
takeMVar MVar Handle
chunksHandle
Handle
h <- case Maybe FilePath
copy of
Maybe FilePath
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h
Just FilePath
copy -> do
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> IO b -> IO a
onException (forall a. MVar a -> a -> IO ()
putMVar MVar Handle
chunksHandle Handle
h) forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ do
Handle -> IO ()
hClose Handle
h
FilePath -> FilePath -> IO ()
copyFile FilePath
chunksFileName FilePath
copy
FilePath -> IOMode -> IO Handle
openFile FilePath
chunksFileName IOMode
ReadWriteMode
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> IO b -> IO a
finally (forall a. MVar a -> a -> IO ()
putMVar MVar Handle
chunksHandle Handle
h) forall a b. (a -> b) -> a -> b
$ do
Handle -> Integer -> IO ()
hSetFileSize Handle
h Integer
0
Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
0