{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
module General.Chunks(
Chunks,
readChunk, readChunkMax, writeChunks, writeChunk,
restoreChunksBackup, withChunks, 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 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 c :: Chunks
c = Chunks -> Word32 -> IO (Either ByteString ByteString)
readChunkMax Chunks
c Word32
forall a. Bounded a => a
maxBound
readChunkMax :: Chunks -> Word32 -> IO (Either BS.ByteString BS.ByteString)
readChunkMax :: Chunks -> Word32 -> IO (Either ByteString ByteString)
readChunkMax Chunks{..} mx :: Word32
mx = MVar Handle
-> (Handle -> IO (Either ByteString ByteString))
-> IO (Either ByteString ByteString)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
chunksHandle ((Handle -> IO (Either ByteString ByteString))
-> IO (Either ByteString ByteString))
-> (Handle -> IO (Either ByteString ByteString))
-> IO (Either ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
let slop :: ByteString -> IO (Either ByteString b)
slop x :: ByteString
x = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
x) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Integer -> IO ()
hSetFileSize Handle
h (Integer -> IO ()) -> (Integer -> Integer) -> Integer -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
subtract (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
x) (Integer -> IO ()) -> IO Integer -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO Integer
hFileSize Handle
h
Either ByteString b -> IO (Either ByteString b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString b -> IO (Either ByteString b))
-> Either ByteString b -> IO (Either ByteString b)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString b
forall a b. a -> Either a b
Left ByteString
x
ByteString
n <- Handle -> Int -> IO ByteString
BS.hGet Handle
h 4
if ByteString -> Int
BS.length ByteString
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 4 then ByteString -> IO (Either ByteString ByteString)
forall b. ByteString -> IO (Either ByteString b)
slop ByteString
n else do
let count :: Int
count = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
min Word32
mx (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ (Word32, ByteString) -> Word32
forall a b. (a, b) -> a
fst ((Word32, ByteString) -> Word32) -> (Word32, ByteString) -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> (Word32, ByteString)
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
count then ByteString -> IO (Either ByteString ByteString)
forall b. ByteString -> IO (Either ByteString b)
slop (ByteString
n ByteString -> ByteString -> ByteString
`BS.append` ByteString
v) else Either ByteString ByteString -> IO (Either ByteString ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString ByteString -> IO (Either ByteString ByteString))
-> Either ByteString ByteString
-> IO (Either ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString ByteString
forall a b. b -> Either a b
Right ByteString
v
writeChunkDirect :: Handle -> Builder -> IO ()
writeChunkDirect :: Handle -> Builder -> IO ()
writeChunkDirect h :: Handle
h x :: Builder
x = ByteString
bs ByteString -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Handle -> ByteString -> IO ()
BS.hPut Handle
h ByteString
bs
where bs :: ByteString
bs = Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Word32 -> Builder
forall a. BinaryEx a => a -> Builder
putEx (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Builder -> Int
sizeBuilder Builder
x :: Word32) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
x
writeChunks :: Chunks -> ((Builder -> IO ()) -> IO a) -> IO a
writeChunks :: Chunks -> ((Builder -> IO ()) -> IO a) -> IO a
writeChunks Chunks{..} act :: (Builder -> IO ()) -> IO a
act = MVar Handle -> (Handle -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
chunksHandle ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
Chan (IO Bool)
chan <- IO (Chan (IO Bool))
forall a. IO (Chan a)
newChan
MVar ()
kick <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
Barrier ()
died <- IO (Barrier ())
forall a. IO (Barrier a)
newBarrier
Maybe ThreadId
flusher <- case Maybe Seconds
chunksFlush of
Nothing -> Maybe ThreadId -> IO (Maybe ThreadId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ThreadId
forall a. Maybe a
Nothing
Just flush :: Seconds
flush -> (ThreadId -> Maybe ThreadId) -> IO ThreadId -> IO (Maybe ThreadId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just (IO ThreadId -> IO (Maybe ThreadId))
-> IO ThreadId -> IO (Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
kick
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Seconds -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Seconds -> Int) -> Seconds -> Int
forall a b. (a -> b) -> a -> b
$ Seconds
flush Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
* 1000000
MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
kick
Chan (IO Bool) -> IO Bool -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (IO Bool)
chan (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
h IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
ThreadId
root <- IO ThreadId
myThreadId
ThreadId
writer <- (IO () -> (Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO () -> IO ThreadId
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (\e :: Either SomeException ()
e -> do Barrier () -> () -> IO ()
forall a. Partial => Barrier a -> a -> IO ()
signalBarrier Barrier ()
died (); Either SomeException () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a b.
Applicative m =>
Either a b -> (a -> m ()) -> m ()
whenLeft Either SomeException ()
e (ThreadId -> SomeException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
root)) (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
IO Bool -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m ()
whileM (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (IO Bool) -> IO Bool
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO Bool) -> IO Bool) -> IO (IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ Chan (IO Bool) -> IO (IO Bool)
forall a. Chan a -> IO a
readChan Chan (IO Bool)
chan
((Builder -> IO ()) -> IO a
act ((Builder -> IO ()) -> IO a) -> (Builder -> IO ()) -> IO a
forall a b. (a -> b) -> a -> b
$ \s :: Builder
s -> do
IO ()
out <- IO () -> IO (IO ())
forall a. a -> IO a
evaluate (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ Handle -> Builder -> IO ()
writeChunkDirect Handle
h Builder
s
Chan (IO Bool) -> IO Bool -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (IO Bool)
chan (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
out IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
kick () IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` do
IO () -> (ThreadId -> IO ()) -> Maybe ThreadId -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ThreadId -> IO ()
killThread Maybe ThreadId
flusher
Chan (IO Bool) -> IO Bool -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (IO Bool)
chan (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Barrier () -> IO ()
forall a. Barrier a -> IO a
waitBarrier Barrier ()
died
writeChunk :: Chunks -> Builder -> IO ()
writeChunk :: Chunks -> Builder -> IO ()
writeChunk Chunks{..} x :: Builder
x = MVar Handle -> (Handle -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
chunksHandle ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> Handle -> Builder -> IO ()
writeChunkDirect Handle
h Builder
x
backup :: FilePath -> FilePath
backup x :: FilePath
x = FilePath
x FilePath -> FilePath -> FilePath
<.> "backup"
restoreChunksBackup :: FilePath -> IO Bool
restoreChunksBackup :: FilePath -> IO Bool
restoreChunksBackup file :: FilePath
file = do
Bool
b <- FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
backup FilePath
file
if Bool -> Bool
not Bool
b then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else do
FilePath -> IO ()
removeFile_ FilePath
file
FilePath -> FilePath -> IO ()
renameFile (FilePath -> FilePath
backup FilePath
file) FilePath
file
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
withChunks :: FilePath -> Maybe Seconds -> (Chunks -> IO a) -> IO a
withChunks :: FilePath -> Maybe Seconds -> (Chunks -> IO a) -> IO a
withChunks file :: FilePath
file flush :: Maybe Seconds
flush act :: Chunks -> IO a
act = do
MVar Handle
h <- IO (MVar Handle)
forall a. IO (MVar a)
newEmptyMVar
IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
(MVar Handle -> Handle -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Handle
h (Handle -> IO ()) -> IO Handle -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IOMode -> IO Handle
openFile FilePath
file IOMode
ReadWriteMode)
(Handle -> IO ()
hClose (Handle -> IO ()) -> IO Handle -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MVar Handle -> IO Handle
forall a. MVar a -> IO a
takeMVar MVar Handle
h) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
Chunks -> IO a
act (Chunks -> IO a) -> Chunks -> IO a
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 :: Chunks -> ((Builder -> IO ()) -> IO a) -> IO a
resetChunksCompact Chunks{..} act :: (Builder -> IO ()) -> IO a
act = ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \restore :: forall a. IO a -> IO a
restore -> do
Handle
h <- MVar Handle -> IO Handle
forall a. MVar a -> IO a
takeMVar MVar Handle
chunksHandle
(IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
onException (MVar Handle -> Handle -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Handle
chunksHandle Handle
h) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> IO ()
hClose Handle
h
FilePath -> FilePath -> IO ()
copyFile FilePath
chunksFileName (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
backup FilePath
chunksFileName
Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
chunksFileName IOMode
ReadWriteMode
(IO a -> IO () -> IO a) -> IO () -> IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
finally (MVar Handle -> Handle -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Handle
chunksHandle Handle
h) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
restore (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
Handle -> Integer -> IO ()
hSetFileSize Handle
h 0
Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek 0
a
res <- (Builder -> IO ()) -> IO a
act ((Builder -> IO ()) -> IO a) -> (Builder -> IO ()) -> IO a
forall a b. (a -> b) -> a -> b
$ Handle -> Builder -> IO ()
writeChunkDirect Handle
h
Handle -> IO ()
hFlush Handle
h
FilePath -> IO ()
removeFile (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
backup FilePath
chunksFileName
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
resetChunksCorrupt :: Maybe FilePath -> Chunks -> IO ()
resetChunksCorrupt :: Maybe FilePath -> Chunks -> IO ()
resetChunksCorrupt copy :: Maybe FilePath
copy Chunks{..} = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \restore :: forall a. IO a -> IO a
restore -> do
Handle
h <- MVar Handle -> IO Handle
forall a. MVar a -> IO a
takeMVar MVar Handle
chunksHandle
case Maybe FilePath
copy of
Nothing -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h
Just copy :: FilePath
copy -> do
(IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
onException (MVar Handle -> Handle -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Handle
chunksHandle Handle
h) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
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
(IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally (MVar Handle -> Handle -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Handle
chunksHandle Handle
h) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> Integer -> IO ()
hSetFileSize Handle
h 0
Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek 0