{-# LANGUAGE CPP #-}

module Erebos.Storage.Internal where

import Codec.Compression.Zlib

import Control.Arrow
import Control.Concurrent
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Control.Monad.Identity

import Crypto.Hash

import Data.Bits
import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes)
import qualified Data.ByteArray as BA
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import Data.Char
import Data.Function
import Data.Hashable
import qualified Data.HashTable.IO as HT
import Data.Kind
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Data.UUID (UUID)

import Foreign.Storable (peek)

import System.Directory
import System.FilePath
import System.INotify (INotify)
import System.IO
import System.IO.Error
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Files
import System.Posix.IO


data Storage' c = Storage
    { forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking :: StorageBacking c
    , forall (c :: * -> *). Storage' c -> Maybe (Storage' Identity)
stParent :: Maybe (Storage' Identity)
    , forall (c :: * -> *).
Storage' c -> MVar (BasicHashTable RefDigest Generation)
stRefGeneration :: MVar (HT.BasicHashTable RefDigest Generation)
    , forall (c :: * -> *).
Storage' c -> MVar (BasicHashTable RefDigest [RefDigest])
stRefRoots :: MVar (HT.BasicHashTable RefDigest [RefDigest])
    }

instance Eq (Storage' c) where
    == :: Storage' c -> Storage' c -> Bool
(==) = (StorageBacking c, Maybe (Storage' Identity))
-> (StorageBacking c, Maybe (Storage' Identity)) -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((StorageBacking c, Maybe (Storage' Identity))
 -> (StorageBacking c, Maybe (Storage' Identity)) -> Bool)
-> (Storage' c -> (StorageBacking c, Maybe (Storage' Identity)))
-> Storage' c
-> Storage' c
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Storage' c -> StorageBacking c
forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking (Storage' c -> StorageBacking c)
-> (Storage' c -> Maybe (Storage' Identity))
-> Storage' c
-> (StorageBacking c, Maybe (Storage' Identity))
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Storage' c -> Maybe (Storage' Identity)
forall (c :: * -> *). Storage' c -> Maybe (Storage' Identity)
stParent)

instance Show (Storage' c) where
    show :: Storage' c -> String
show st :: Storage' c
st@(Storage { stBacking :: forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking = StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> String
dirPath = String
path }}) = String
"dir" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Storage' c -> String
forall (c :: * -> *). Storage' c -> String
showParentStorage Storage' c
st String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
path
    show st :: Storage' c
st@(Storage { stBacking :: forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking = StorageMemory {} }) = String
"mem" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Storage' c -> String
forall (c :: * -> *). Storage' c -> String
showParentStorage Storage' c
st

showParentStorage :: Storage' c -> String
showParentStorage :: forall (c :: * -> *). Storage' c -> String
showParentStorage Storage { stParent :: forall (c :: * -> *). Storage' c -> Maybe (Storage' Identity)
stParent = Maybe (Storage' Identity)
Nothing } = String
""
showParentStorage Storage { stParent :: forall (c :: * -> *). Storage' c -> Maybe (Storage' Identity)
stParent = Just Storage' Identity
st } = String
"@" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Storage' Identity -> String
forall a. Show a => a -> String
show Storage' Identity
st

data StorageBacking c
         = StorageDir { forall (c :: * -> *). StorageBacking c -> String
dirPath :: FilePath
                      , forall (c :: * -> *).
StorageBacking c -> MVar ([(HeadTypeID, INotify)], WatchList c)
dirWatchers :: MVar ([(HeadTypeID, INotify)], WatchList c)
                      }
         | StorageMemory { forall (c :: * -> *).
StorageBacking c -> MVar [((HeadTypeID, HeadID), Ref' c)]
memHeads :: MVar [((HeadTypeID, HeadID), Ref' c)]
                         , forall (c :: * -> *).
StorageBacking c -> MVar (Map RefDigest ByteString)
memObjs :: MVar (Map RefDigest BL.ByteString)
                         , forall (c :: * -> *).
StorageBacking c -> MVar (Map RefDigest ScrubbedBytes)
memKeys :: MVar (Map RefDigest ScrubbedBytes)
                         , forall (c :: * -> *). StorageBacking c -> MVar (WatchList c)
memWatchers :: MVar (WatchList c)
                         }
    deriving (StorageBacking c -> StorageBacking c -> Bool
(StorageBacking c -> StorageBacking c -> Bool)
-> (StorageBacking c -> StorageBacking c -> Bool)
-> Eq (StorageBacking c)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (c :: * -> *). StorageBacking c -> StorageBacking c -> Bool
$c== :: forall (c :: * -> *). StorageBacking c -> StorageBacking c -> Bool
== :: StorageBacking c -> StorageBacking c -> Bool
$c/= :: forall (c :: * -> *). StorageBacking c -> StorageBacking c -> Bool
/= :: StorageBacking c -> StorageBacking c -> Bool
Eq)

newtype WatchID = WatchID Int
    deriving (WatchID -> WatchID -> Bool
(WatchID -> WatchID -> Bool)
-> (WatchID -> WatchID -> Bool) -> Eq WatchID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WatchID -> WatchID -> Bool
== :: WatchID -> WatchID -> Bool
$c/= :: WatchID -> WatchID -> Bool
/= :: WatchID -> WatchID -> Bool
Eq, Eq WatchID
Eq WatchID =>
(WatchID -> WatchID -> Ordering)
-> (WatchID -> WatchID -> Bool)
-> (WatchID -> WatchID -> Bool)
-> (WatchID -> WatchID -> Bool)
-> (WatchID -> WatchID -> Bool)
-> (WatchID -> WatchID -> WatchID)
-> (WatchID -> WatchID -> WatchID)
-> Ord WatchID
WatchID -> WatchID -> Bool
WatchID -> WatchID -> Ordering
WatchID -> WatchID -> WatchID
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: WatchID -> WatchID -> Ordering
compare :: WatchID -> WatchID -> Ordering
$c< :: WatchID -> WatchID -> Bool
< :: WatchID -> WatchID -> Bool
$c<= :: WatchID -> WatchID -> Bool
<= :: WatchID -> WatchID -> Bool
$c> :: WatchID -> WatchID -> Bool
> :: WatchID -> WatchID -> Bool
$c>= :: WatchID -> WatchID -> Bool
>= :: WatchID -> WatchID -> Bool
$cmax :: WatchID -> WatchID -> WatchID
max :: WatchID -> WatchID -> WatchID
$cmin :: WatchID -> WatchID -> WatchID
min :: WatchID -> WatchID -> WatchID
Ord, Integer -> WatchID
WatchID -> WatchID
WatchID -> WatchID -> WatchID
(WatchID -> WatchID -> WatchID)
-> (WatchID -> WatchID -> WatchID)
-> (WatchID -> WatchID -> WatchID)
-> (WatchID -> WatchID)
-> (WatchID -> WatchID)
-> (WatchID -> WatchID)
-> (Integer -> WatchID)
-> Num WatchID
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: WatchID -> WatchID -> WatchID
+ :: WatchID -> WatchID -> WatchID
$c- :: WatchID -> WatchID -> WatchID
- :: WatchID -> WatchID -> WatchID
$c* :: WatchID -> WatchID -> WatchID
* :: WatchID -> WatchID -> WatchID
$cnegate :: WatchID -> WatchID
negate :: WatchID -> WatchID
$cabs :: WatchID -> WatchID
abs :: WatchID -> WatchID
$csignum :: WatchID -> WatchID
signum :: WatchID -> WatchID
$cfromInteger :: Integer -> WatchID
fromInteger :: Integer -> WatchID
Num)

data WatchList c = WatchList
    { forall (c :: * -> *). WatchList c -> WatchID
wlNext :: WatchID
    , forall (c :: * -> *). WatchList c -> [WatchListItem c]
wlList :: [WatchListItem c]
    }

data WatchListItem c = WatchListItem
    { forall (c :: * -> *). WatchListItem c -> WatchID
wlID :: WatchID
    , forall (c :: * -> *). WatchListItem c -> (HeadTypeID, HeadID)
wlHead :: (HeadTypeID, HeadID)
    , forall (c :: * -> *). WatchListItem c -> Ref' c -> IO ()
wlFun :: Ref' c -> IO ()
    }


newtype RefDigest = RefDigest (Digest Blake2b_256)
    deriving (RefDigest -> RefDigest -> Bool
(RefDigest -> RefDigest -> Bool)
-> (RefDigest -> RefDigest -> Bool) -> Eq RefDigest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RefDigest -> RefDigest -> Bool
== :: RefDigest -> RefDigest -> Bool
$c/= :: RefDigest -> RefDigest -> Bool
/= :: RefDigest -> RefDigest -> Bool
Eq, Eq RefDigest
Eq RefDigest =>
(RefDigest -> RefDigest -> Ordering)
-> (RefDigest -> RefDigest -> Bool)
-> (RefDigest -> RefDigest -> Bool)
-> (RefDigest -> RefDigest -> Bool)
-> (RefDigest -> RefDigest -> Bool)
-> (RefDigest -> RefDigest -> RefDigest)
-> (RefDigest -> RefDigest -> RefDigest)
-> Ord RefDigest
RefDigest -> RefDigest -> Bool
RefDigest -> RefDigest -> Ordering
RefDigest -> RefDigest -> RefDigest
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RefDigest -> RefDigest -> Ordering
compare :: RefDigest -> RefDigest -> Ordering
$c< :: RefDigest -> RefDigest -> Bool
< :: RefDigest -> RefDigest -> Bool
$c<= :: RefDigest -> RefDigest -> Bool
<= :: RefDigest -> RefDigest -> Bool
$c> :: RefDigest -> RefDigest -> Bool
> :: RefDigest -> RefDigest -> Bool
$c>= :: RefDigest -> RefDigest -> Bool
>= :: RefDigest -> RefDigest -> Bool
$cmax :: RefDigest -> RefDigest -> RefDigest
max :: RefDigest -> RefDigest -> RefDigest
$cmin :: RefDigest -> RefDigest -> RefDigest
min :: RefDigest -> RefDigest -> RefDigest
Ord, RefDigest -> ()
(RefDigest -> ()) -> NFData RefDigest
forall a. (a -> ()) -> NFData a
$crnf :: RefDigest -> ()
rnf :: RefDigest -> ()
NFData, RefDigest -> Int
(RefDigest -> Int)
-> (forall p a. RefDigest -> (Ptr p -> IO a) -> IO a)
-> (forall p. RefDigest -> Ptr p -> IO ())
-> ByteArrayAccess RefDigest
forall p. RefDigest -> Ptr p -> IO ()
forall ba.
(ba -> Int)
-> (forall p a. ba -> (Ptr p -> IO a) -> IO a)
-> (forall p. ba -> Ptr p -> IO ())
-> ByteArrayAccess ba
forall p a. RefDigest -> (Ptr p -> IO a) -> IO a
$clength :: RefDigest -> Int
length :: RefDigest -> Int
$cwithByteArray :: forall p a. RefDigest -> (Ptr p -> IO a) -> IO a
withByteArray :: forall p a. RefDigest -> (Ptr p -> IO a) -> IO a
$ccopyByteArrayToPtr :: forall p. RefDigest -> Ptr p -> IO ()
copyByteArrayToPtr :: forall p. RefDigest -> Ptr p -> IO ()
ByteArrayAccess)

instance Show RefDigest where
    show :: RefDigest -> String
show = ByteString -> String
BC.unpack (ByteString -> String)
-> (RefDigest -> ByteString) -> RefDigest -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefDigest -> ByteString
showRefDigest

data Ref' c = Ref (Storage' c) RefDigest

instance Eq (Ref' c) where
    Ref Storage' c
_ RefDigest
d1 == :: Ref' c -> Ref' c -> Bool
== Ref Storage' c
_ RefDigest
d2  =  RefDigest
d1 RefDigest -> RefDigest -> Bool
forall a. Eq a => a -> a -> Bool
== RefDigest
d2

instance Show (Ref' c) where
    show :: Ref' c -> String
show ref :: Ref' c
ref@(Ref Storage' c
st RefDigest
_) = Storage' c -> String
forall a. Show a => a -> String
show Storage' c
st String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BC.unpack (Ref' c -> ByteString
forall (c :: * -> *). Ref' c -> ByteString
showRef Ref' c
ref)

instance ByteArrayAccess (Ref' c) where
    length :: Ref' c -> Int
length (Ref Storage' c
_ RefDigest
dgst) = RefDigest -> Int
forall ba. ByteArrayAccess ba => ba -> Int
BA.length RefDigest
dgst
    withByteArray :: forall p a. Ref' c -> (Ptr p -> IO a) -> IO a
withByteArray (Ref Storage' c
_ RefDigest
dgst) = RefDigest -> (Ptr p -> IO a) -> IO a
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. RefDigest -> (Ptr p -> IO a) -> IO a
BA.withByteArray RefDigest
dgst

instance Hashable RefDigest where
    hashWithSalt :: Int -> RefDigest -> Int
hashWithSalt Int
salt RefDigest
ref = Int
salt Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` IO Int -> Int
forall a. IO a -> a
unsafePerformIO (RefDigest -> (Ptr Int -> IO Int) -> IO Int
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. RefDigest -> (Ptr p -> IO a) -> IO a
BA.withByteArray RefDigest
ref Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek)

instance Hashable (Ref' c) where
    hashWithSalt :: Int -> Ref' c -> Int
hashWithSalt Int
salt Ref' c
ref = Int
salt Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` IO Int -> Int
forall a. IO a -> a
unsafePerformIO (Ref' c -> (Ptr Int -> IO Int) -> IO Int
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. Ref' c -> (Ptr p -> IO a) -> IO a
BA.withByteArray Ref' c
ref Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek)

refStorage :: Ref' c -> Storage' c
refStorage :: forall (c :: * -> *). Ref' c -> Storage' c
refStorage (Ref Storage' c
st RefDigest
_) = Storage' c
st

refDigest :: Ref' c -> RefDigest
refDigest :: forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref Storage' c
_ RefDigest
dgst) = RefDigest
dgst

showRef :: Ref' c -> ByteString
showRef :: forall (c :: * -> *). Ref' c -> ByteString
showRef = RefDigest -> ByteString
showRefDigest (RefDigest -> ByteString)
-> (Ref' c -> RefDigest) -> Ref' c -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest

showRefDigestParts :: RefDigest -> (ByteString, ByteString)
showRefDigestParts :: RefDigest -> (ByteString, ByteString)
showRefDigestParts RefDigest
x = (String -> ByteString
BC.pack String
"blake2", RefDigest -> ByteString
forall ba. ByteArrayAccess ba => ba -> ByteString
showHex RefDigest
x)

showRefDigest :: RefDigest -> ByteString
showRefDigest :: RefDigest -> ByteString
showRefDigest = RefDigest -> (ByteString, ByteString)
showRefDigestParts (RefDigest -> (ByteString, ByteString))
-> ((ByteString, ByteString) -> ByteString)
-> RefDigest
-> ByteString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \(ByteString
alg, ByteString
hex) -> ByteString
alg ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BC.pack String
"#" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
hex

readRefDigest :: ByteString -> Maybe RefDigest
readRefDigest :: ByteString -> Maybe RefDigest
readRefDigest ByteString
x = case Char -> ByteString -> [ByteString]
BC.split Char
'#' ByteString
x of
                       [ByteString
alg, ByteString
dgst] | ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert ByteString
alg ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"blake2" ->
                           ByteString -> Maybe RefDigest
forall ba. ByteArrayAccess ba => ba -> Maybe RefDigest
refDigestFromByteString (ByteString -> Maybe RefDigest)
-> Maybe ByteString -> Maybe RefDigest
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall ba. ByteArray ba => ByteString -> Maybe ba
readHex @ByteString ByteString
dgst
                       [ByteString]
_ -> Maybe RefDigest
forall a. Maybe a
Nothing

refDigestFromByteString :: ByteArrayAccess ba => ba -> Maybe RefDigest
refDigestFromByteString :: forall ba. ByteArrayAccess ba => ba -> Maybe RefDigest
refDigestFromByteString = (Digest Blake2b_256 -> RefDigest)
-> Maybe (Digest Blake2b_256) -> Maybe RefDigest
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Digest Blake2b_256 -> RefDigest
RefDigest (Maybe (Digest Blake2b_256) -> Maybe RefDigest)
-> (ba -> Maybe (Digest Blake2b_256)) -> ba -> Maybe RefDigest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ba -> Maybe (Digest Blake2b_256)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString

hashToRefDigest :: BL.ByteString -> RefDigest
hashToRefDigest :: ByteString -> RefDigest
hashToRefDigest = Digest Blake2b_256 -> RefDigest
RefDigest (Digest Blake2b_256 -> RefDigest)
-> (ByteString -> Digest Blake2b_256) -> ByteString -> RefDigest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context Blake2b_256 -> Digest Blake2b_256
forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize (Context Blake2b_256 -> Digest Blake2b_256)
-> (ByteString -> Context Blake2b_256)
-> ByteString
-> Digest Blake2b_256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context Blake2b_256 -> [ByteString] -> Context Blake2b_256
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates Context Blake2b_256
forall a. HashAlgorithm a => Context a
hashInit ([ByteString] -> Context Blake2b_256)
-> (ByteString -> [ByteString])
-> ByteString
-> Context Blake2b_256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BL.toChunks

showHex :: ByteArrayAccess ba => ba -> ByteString
showHex :: forall ba. ByteArrayAccess ba => ba -> ByteString
showHex = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (ba -> [ByteString]) -> ba -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> ByteString) -> [Word8] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> ByteString
showHexByte ([Word8] -> [ByteString]) -> (ba -> [Word8]) -> ba -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ba -> [Word8]
forall a. ByteArrayAccess a => a -> [Word8]
BA.unpack
    where showHexChar :: Word8 -> Word8
showHexChar Word8
x | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
10    = Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Char -> Word8
o Char
'0'
                        | Bool
otherwise = Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Char -> Word8
o Char
'a' Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
10
          showHexByte :: Word8 -> ByteString
showHexByte Word8
x = [Word8] -> ByteString
B.pack [ Word8 -> Word8
showHexChar (Word8
x Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` Word8
16), Word8 -> Word8
showHexChar (Word8
x Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`mod` Word8
16) ]
          o :: Char -> Word8
o = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord

readHex :: ByteArray ba => ByteString -> Maybe ba
readHex :: forall ba. ByteArray ba => ByteString -> Maybe ba
readHex = ba -> Maybe ba
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (ba -> Maybe ba)
-> ([ByteString] -> ba) -> [ByteString] -> Maybe ba
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ba
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
[bin] -> bout
BA.concat ([ByteString] -> Maybe ba)
-> (ByteString -> Maybe [ByteString]) -> ByteString -> Maybe ba
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> Maybe [ByteString]
readHex'
    where readHex' :: ByteString -> Maybe [ByteString]
readHex' ByteString
bs | ByteString -> Bool
B.null ByteString
bs = [ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
Just []
          readHex' ByteString
bs = do (Word8
bx, ByteString
bs') <- ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs
                           (Word8
by, ByteString
bs'') <- ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs'
                           Word8
x <- Word8 -> Maybe Word8
hexDigit Word8
bx
                           Word8
y <- Word8 -> Maybe Word8
hexDigit Word8
by
                           (Word8 -> ByteString
B.singleton (Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
16 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
y) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> Maybe [ByteString] -> Maybe [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe [ByteString]
readHex' ByteString
bs''
          hexDigit :: Word8 -> Maybe Word8
hexDigit Word8
x | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Char -> Word8
o Char
'0' Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Word8
o Char
'9' = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Word8 -> Maybe Word8) -> Word8 -> Maybe Word8
forall a b. (a -> b) -> a -> b
$ Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Char -> Word8
o Char
'0'
                     | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Char -> Word8
o Char
'a' Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Word8
o Char
'z' = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Word8 -> Maybe Word8) -> Word8 -> Maybe Word8
forall a b. (a -> b) -> a -> b
$ Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Char -> Word8
o Char
'a' Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
10
                     | Bool
otherwise                = Maybe Word8
forall a. Maybe a
Nothing
          o :: Char -> Word8
o = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord


newtype Generation = Generation Int
    deriving (Generation -> Generation -> Bool
(Generation -> Generation -> Bool)
-> (Generation -> Generation -> Bool) -> Eq Generation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Generation -> Generation -> Bool
== :: Generation -> Generation -> Bool
$c/= :: Generation -> Generation -> Bool
/= :: Generation -> Generation -> Bool
Eq, Int -> Generation -> ShowS
[Generation] -> ShowS
Generation -> String
(Int -> Generation -> ShowS)
-> (Generation -> String)
-> ([Generation] -> ShowS)
-> Show Generation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Generation -> ShowS
showsPrec :: Int -> Generation -> ShowS
$cshow :: Generation -> String
show :: Generation -> String
$cshowList :: [Generation] -> ShowS
showList :: [Generation] -> ShowS
Show)

data Head' c a = Head HeadID (Stored' c a)
    deriving (Head' c a -> Head' c a -> Bool
(Head' c a -> Head' c a -> Bool)
-> (Head' c a -> Head' c a -> Bool) -> Eq (Head' c a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (c :: * -> *) a. Head' c a -> Head' c a -> Bool
$c== :: forall (c :: * -> *) a. Head' c a -> Head' c a -> Bool
== :: Head' c a -> Head' c a -> Bool
$c/= :: forall (c :: * -> *) a. Head' c a -> Head' c a -> Bool
/= :: Head' c a -> Head' c a -> Bool
Eq, Int -> Head' c a -> ShowS
[Head' c a] -> ShowS
Head' c a -> String
(Int -> Head' c a -> ShowS)
-> (Head' c a -> String)
-> ([Head' c a] -> ShowS)
-> Show (Head' c a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (c :: * -> *) a. Show a => Int -> Head' c a -> ShowS
forall (c :: * -> *) a. Show a => [Head' c a] -> ShowS
forall (c :: * -> *) a. Show a => Head' c a -> String
$cshowsPrec :: forall (c :: * -> *) a. Show a => Int -> Head' c a -> ShowS
showsPrec :: Int -> Head' c a -> ShowS
$cshow :: forall (c :: * -> *) a. Show a => Head' c a -> String
show :: Head' c a -> String
$cshowList :: forall (c :: * -> *) a. Show a => [Head' c a] -> ShowS
showList :: [Head' c a] -> ShowS
Show)

newtype HeadID = HeadID UUID
    deriving (HeadID -> HeadID -> Bool
(HeadID -> HeadID -> Bool)
-> (HeadID -> HeadID -> Bool) -> Eq HeadID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeadID -> HeadID -> Bool
== :: HeadID -> HeadID -> Bool
$c/= :: HeadID -> HeadID -> Bool
/= :: HeadID -> HeadID -> Bool
Eq, Eq HeadID
Eq HeadID =>
(HeadID -> HeadID -> Ordering)
-> (HeadID -> HeadID -> Bool)
-> (HeadID -> HeadID -> Bool)
-> (HeadID -> HeadID -> Bool)
-> (HeadID -> HeadID -> Bool)
-> (HeadID -> HeadID -> HeadID)
-> (HeadID -> HeadID -> HeadID)
-> Ord HeadID
HeadID -> HeadID -> Bool
HeadID -> HeadID -> Ordering
HeadID -> HeadID -> HeadID
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HeadID -> HeadID -> Ordering
compare :: HeadID -> HeadID -> Ordering
$c< :: HeadID -> HeadID -> Bool
< :: HeadID -> HeadID -> Bool
$c<= :: HeadID -> HeadID -> Bool
<= :: HeadID -> HeadID -> Bool
$c> :: HeadID -> HeadID -> Bool
> :: HeadID -> HeadID -> Bool
$c>= :: HeadID -> HeadID -> Bool
>= :: HeadID -> HeadID -> Bool
$cmax :: HeadID -> HeadID -> HeadID
max :: HeadID -> HeadID -> HeadID
$cmin :: HeadID -> HeadID -> HeadID
min :: HeadID -> HeadID -> HeadID
Ord, Int -> HeadID -> ShowS
[HeadID] -> ShowS
HeadID -> String
(Int -> HeadID -> ShowS)
-> (HeadID -> String) -> ([HeadID] -> ShowS) -> Show HeadID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeadID -> ShowS
showsPrec :: Int -> HeadID -> ShowS
$cshow :: HeadID -> String
show :: HeadID -> String
$cshowList :: [HeadID] -> ShowS
showList :: [HeadID] -> ShowS
Show)

newtype HeadTypeID = HeadTypeID UUID
    deriving (HeadTypeID -> HeadTypeID -> Bool
(HeadTypeID -> HeadTypeID -> Bool)
-> (HeadTypeID -> HeadTypeID -> Bool) -> Eq HeadTypeID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeadTypeID -> HeadTypeID -> Bool
== :: HeadTypeID -> HeadTypeID -> Bool
$c/= :: HeadTypeID -> HeadTypeID -> Bool
/= :: HeadTypeID -> HeadTypeID -> Bool
Eq, Eq HeadTypeID
Eq HeadTypeID =>
(HeadTypeID -> HeadTypeID -> Ordering)
-> (HeadTypeID -> HeadTypeID -> Bool)
-> (HeadTypeID -> HeadTypeID -> Bool)
-> (HeadTypeID -> HeadTypeID -> Bool)
-> (HeadTypeID -> HeadTypeID -> Bool)
-> (HeadTypeID -> HeadTypeID -> HeadTypeID)
-> (HeadTypeID -> HeadTypeID -> HeadTypeID)
-> Ord HeadTypeID
HeadTypeID -> HeadTypeID -> Bool
HeadTypeID -> HeadTypeID -> Ordering
HeadTypeID -> HeadTypeID -> HeadTypeID
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HeadTypeID -> HeadTypeID -> Ordering
compare :: HeadTypeID -> HeadTypeID -> Ordering
$c< :: HeadTypeID -> HeadTypeID -> Bool
< :: HeadTypeID -> HeadTypeID -> Bool
$c<= :: HeadTypeID -> HeadTypeID -> Bool
<= :: HeadTypeID -> HeadTypeID -> Bool
$c> :: HeadTypeID -> HeadTypeID -> Bool
> :: HeadTypeID -> HeadTypeID -> Bool
$c>= :: HeadTypeID -> HeadTypeID -> Bool
>= :: HeadTypeID -> HeadTypeID -> Bool
$cmax :: HeadTypeID -> HeadTypeID -> HeadTypeID
max :: HeadTypeID -> HeadTypeID -> HeadTypeID
$cmin :: HeadTypeID -> HeadTypeID -> HeadTypeID
min :: HeadTypeID -> HeadTypeID -> HeadTypeID
Ord)

data Stored' c a = Stored (Ref' c) a
    deriving (Int -> Stored' c a -> ShowS
[Stored' c a] -> ShowS
Stored' c a -> String
(Int -> Stored' c a -> ShowS)
-> (Stored' c a -> String)
-> ([Stored' c a] -> ShowS)
-> Show (Stored' c a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (c :: * -> *) a. Show a => Int -> Stored' c a -> ShowS
forall (c :: * -> *) a. Show a => [Stored' c a] -> ShowS
forall (c :: * -> *) a. Show a => Stored' c a -> String
$cshowsPrec :: forall (c :: * -> *) a. Show a => Int -> Stored' c a -> ShowS
showsPrec :: Int -> Stored' c a -> ShowS
$cshow :: forall (c :: * -> *) a. Show a => Stored' c a -> String
show :: Stored' c a -> String
$cshowList :: forall (c :: * -> *) a. Show a => [Stored' c a] -> ShowS
showList :: [Stored' c a] -> ShowS
Show)

instance Eq (Stored' c a) where
    Stored Ref' c
r1 a
_ == :: Stored' c a -> Stored' c a -> Bool
== Stored Ref' c
r2 a
_  =  Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
r1 RefDigest -> RefDigest -> Bool
forall a. Eq a => a -> a -> Bool
== Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
r2

instance Ord (Stored' c a) where
    compare :: Stored' c a -> Stored' c a -> Ordering
compare (Stored Ref' c
r1 a
_) (Stored Ref' c
r2 a
_) = RefDigest -> RefDigest -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
r1) (Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
r2)

storedStorage :: Stored' c a -> Storage' c
storedStorage :: forall (c :: * -> *) a. Stored' c a -> Storage' c
storedStorage (Stored (Ref Storage' c
st RefDigest
_) a
_) = Storage' c
st


type Complete = Identity
type Partial = Either RefDigest

class (Traversable compl, Monad compl) => StorageCompleteness compl where
    type LoadResult compl a :: Type
    returnLoadResult :: compl a -> LoadResult compl a
    ioLoadBytes :: Ref' compl -> IO (compl BL.ByteString)

instance StorageCompleteness Complete where
    type LoadResult Complete a = a
    returnLoadResult :: forall a. Complete a -> LoadResult Identity a
returnLoadResult = Identity a -> a
Identity a -> LoadResult Identity a
forall a. Identity a -> a
runIdentity
    ioLoadBytes :: Ref' Identity -> IO (Complete ByteString)
ioLoadBytes ref :: Ref' Identity
ref@(Ref Storage' Identity
st RefDigest
dgst) = Complete ByteString
-> (ByteString -> Complete ByteString)
-> Maybe ByteString
-> Complete ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Complete ByteString
forall a. HasCallStack => String -> a
error (String -> Complete ByteString) -> String -> Complete ByteString
forall a b. (a -> b) -> a -> b
$ String
"Ref not found in complete storage: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Ref' Identity -> String
forall a. Show a => a -> String
show Ref' Identity
ref) ByteString -> Complete ByteString
forall a. a -> Identity a
Identity
        (Maybe ByteString -> Complete ByteString)
-> IO (Maybe ByteString) -> IO (Complete ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Storage' Identity -> RefDigest -> IO (Maybe ByteString)
forall (c :: * -> *).
Storage' c -> RefDigest -> IO (Maybe ByteString)
ioLoadBytesFromStorage Storage' Identity
st RefDigest
dgst

instance StorageCompleteness Partial where
    type LoadResult Partial a = Either RefDigest a
    returnLoadResult :: forall a. Partial a -> LoadResult Partial a
returnLoadResult = Partial a -> Partial a
Partial a -> LoadResult Partial a
forall a. a -> a
id
    ioLoadBytes :: Ref' Partial -> IO (Partial ByteString)
ioLoadBytes (Ref Storage' Partial
st RefDigest
dgst) = Partial ByteString
-> (ByteString -> Partial ByteString)
-> Maybe ByteString
-> Partial ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RefDigest -> Partial ByteString
forall a b. a -> Either a b
Left RefDigest
dgst) ByteString -> Partial ByteString
forall a b. b -> Either a b
Right (Maybe ByteString -> Partial ByteString)
-> IO (Maybe ByteString) -> IO (Partial ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Storage' Partial -> RefDigest -> IO (Maybe ByteString)
forall (c :: * -> *).
Storage' c -> RefDigest -> IO (Maybe ByteString)
ioLoadBytesFromStorage Storage' Partial
st RefDigest
dgst

unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
unsafeStoreRawBytes :: forall (c :: * -> *). Storage' c -> ByteString -> IO (Ref' c)
unsafeStoreRawBytes Storage' c
st ByteString
raw = do
    let dgst :: RefDigest
dgst = ByteString -> RefDigest
hashToRefDigest ByteString
raw
    case Storage' c -> StorageBacking c
forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking Storage' c
st of
         StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> String
dirPath = String
sdir } -> String -> ByteString -> IO ()
writeFileOnce (String -> RefDigest -> String
refPath String
sdir RefDigest
dgst) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
compress ByteString
raw
         StorageMemory { memObjs :: forall (c :: * -> *).
StorageBacking c -> MVar (Map RefDigest ByteString)
memObjs = MVar (Map RefDigest ByteString)
tobjs } ->
             RefDigest
dgst RefDigest -> IO () -> IO ()
forall a b. NFData a => a -> b -> b
`deepseq` -- the TVar may be accessed when evaluating the data to be written
                 MVar (Map RefDigest ByteString)
-> (Map RefDigest ByteString -> IO (Map RefDigest ByteString))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map RefDigest ByteString)
tobjs (Map RefDigest ByteString -> IO (Map RefDigest ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map RefDigest ByteString -> IO (Map RefDigest ByteString))
-> (Map RefDigest ByteString -> Map RefDigest ByteString)
-> Map RefDigest ByteString
-> IO (Map RefDigest ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefDigest
-> ByteString
-> Map RefDigest ByteString
-> Map RefDigest ByteString
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert RefDigest
dgst ByteString
raw)
    Ref' c -> IO (Ref' c)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ref' c -> IO (Ref' c)) -> Ref' c -> IO (Ref' c)
forall a b. (a -> b) -> a -> b
$ Storage' c -> RefDigest -> Ref' c
forall (c :: * -> *). Storage' c -> RefDigest -> Ref' c
Ref Storage' c
st RefDigest
dgst

ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString)
ioLoadBytesFromStorage :: forall (c :: * -> *).
Storage' c -> RefDigest -> IO (Maybe ByteString)
ioLoadBytesFromStorage Storage' c
st RefDigest
dgst = Storage' c -> IO (Maybe ByteString)
loadCurrent Storage' c
st IO (Maybe ByteString)
-> (Maybe ByteString -> IO (Maybe ByteString))
-> IO (Maybe ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \case Just ByteString
bytes -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bytes
          Maybe ByteString
Nothing | Just Storage' Identity
parent <- Storage' c -> Maybe (Storage' Identity)
forall (c :: * -> *). Storage' c -> Maybe (Storage' Identity)
stParent Storage' c
st -> Storage' Identity -> RefDigest -> IO (Maybe ByteString)
forall (c :: * -> *).
Storage' c -> RefDigest -> IO (Maybe ByteString)
ioLoadBytesFromStorage Storage' Identity
parent RefDigest
dgst
                  | Bool
otherwise                  -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
    where loadCurrent :: Storage' c -> IO (Maybe ByteString)
loadCurrent Storage { stBacking :: forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking = StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> String
dirPath = String
spath } } = (IOError -> Maybe ())
-> (() -> IO (Maybe ByteString))
-> IO (Maybe ByteString)
-> IO (Maybe ByteString)
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (IO (Maybe ByteString) -> () -> IO (Maybe ByteString)
forall a b. a -> b -> a
const (IO (Maybe ByteString) -> () -> IO (Maybe ByteString))
-> IO (Maybe ByteString) -> () -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing) (IO (Maybe ByteString) -> IO (Maybe ByteString))
-> IO (Maybe ByteString) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
              ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (ByteString -> ByteString) -> ByteString -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
decompress (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BL.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[]) (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO ByteString
B.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> RefDigest -> String
refPath String
spath RefDigest
dgst)
          loadCurrent Storage { stBacking :: forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking = StorageMemory { memObjs :: forall (c :: * -> *).
StorageBacking c -> MVar (Map RefDigest ByteString)
memObjs = MVar (Map RefDigest ByteString)
tobjs } } = RefDigest -> Map RefDigest ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RefDigest
dgst (Map RefDigest ByteString -> Maybe ByteString)
-> IO (Map RefDigest ByteString) -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Map RefDigest ByteString) -> IO (Map RefDigest ByteString)
forall a. MVar a -> IO a
readMVar MVar (Map RefDigest ByteString)
tobjs

refPath :: FilePath -> RefDigest -> FilePath
refPath :: String -> RefDigest -> String
refPath String
spath RefDigest
rdgst = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" [String
spath, String
"objects", ByteString -> String
BC.unpack ByteString
alg, String
pref, String
rest]
    where (ByteString
alg, ByteString
dgst) = RefDigest -> (ByteString, ByteString)
showRefDigestParts RefDigest
rdgst
          (String
pref, String
rest) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
2 (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BC.unpack ByteString
dgst


openLockFile :: FilePath -> IO Handle
openLockFile :: String -> IO Handle
openLockFile String
path = do
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory String
path)
    Fd
fd <- Int -> IO Fd -> IO Fd
forall a. Int -> IO a -> IO a
retry Int
10 (IO Fd -> IO Fd) -> IO Fd -> IO Fd
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_unix(2,8,0)
        String -> OpenMode -> OpenFileFlags -> IO Fd
openFd String
path OpenMode
WriteOnly OpenFileFlags
defaultFileFlags
            { creat = Just $ unionFileModes ownerReadMode ownerWriteMode
            , exclusive = True
            }
#else
        openFd path WriteOnly (Just $ unionFileModes ownerReadMode ownerWriteMode) (defaultFileFlags { exclusive = True })
#endif
    Fd -> IO Handle
fdToHandle Fd
fd
  where
    retry :: Int -> IO a -> IO a
    retry :: forall a. Int -> IO a -> IO a
retry Int
0 IO a
act = IO a
act
    retry Int
n IO a
act = (IOError -> Maybe ()) -> IO a -> (() -> IO a) -> IO a
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust (\IOError
e -> if IOError -> Bool
isAlreadyExistsError IOError
e then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing)
                      IO a
act (\()
_ -> Int -> IO ()
threadDelay (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO a -> IO a
forall a. Int -> IO a -> IO a
retry (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) IO a
act)

writeFileOnce :: FilePath -> BL.ByteString -> IO ()
writeFileOnce :: String -> ByteString -> IO ()
writeFileOnce String
file ByteString
content = IO Handle -> (Handle -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO Handle
openLockFile String
locked)
    Handle -> IO ()
hClose ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        String -> IO Bool
fileExist String
file IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True  -> String -> IO ()
removeLink String
locked
            Bool
False -> do Handle -> ByteString -> IO ()
BL.hPut Handle
h ByteString
content
                        Handle -> IO ()
hFlush Handle
h
                        String -> String -> IO ()
rename String
locked String
file
    where locked :: String
locked = String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".lock"

writeFileChecked :: FilePath -> Maybe ByteString -> ByteString -> IO (Either (Maybe ByteString) ())
writeFileChecked :: String
-> Maybe ByteString
-> ByteString
-> IO (Either (Maybe ByteString) ())
writeFileChecked String
file Maybe ByteString
prev ByteString
content = IO Handle
-> (Handle -> IO ())
-> (Handle -> IO (Either (Maybe ByteString) ()))
-> IO (Either (Maybe ByteString) ())
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO Handle
openLockFile String
locked)
    Handle -> IO ()
hClose ((Handle -> IO (Either (Maybe ByteString) ()))
 -> IO (Either (Maybe ByteString) ()))
-> (Handle -> IO (Either (Maybe ByteString) ()))
-> IO (Either (Maybe ByteString) ())
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        (Maybe ByteString
prev,) (Bool -> (Maybe ByteString, Bool))
-> IO Bool -> IO (Maybe ByteString, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
fileExist String
file IO (Maybe ByteString, Bool)
-> ((Maybe ByteString, Bool) -> IO (Either (Maybe ByteString) ()))
-> IO (Either (Maybe ByteString) ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            (Maybe ByteString
Nothing, Bool
True) -> do
                ByteString
current <- String -> IO ByteString
B.readFile String
file
                String -> IO ()
removeLink String
locked
                Either (Maybe ByteString) () -> IO (Either (Maybe ByteString) ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe ByteString) () -> IO (Either (Maybe ByteString) ()))
-> Either (Maybe ByteString) ()
-> IO (Either (Maybe ByteString) ())
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Either (Maybe ByteString) ()
forall a b. a -> Either a b
Left (Maybe ByteString -> Either (Maybe ByteString) ())
-> Maybe ByteString -> Either (Maybe ByteString) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
current
            (Maybe ByteString
Nothing, Bool
False) -> do Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
content
                                   Handle -> IO ()
hFlush Handle
h
                                   String -> String -> IO ()
rename String
locked String
file
                                   Either (Maybe ByteString) () -> IO (Either (Maybe ByteString) ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe ByteString) () -> IO (Either (Maybe ByteString) ()))
-> Either (Maybe ByteString) ()
-> IO (Either (Maybe ByteString) ())
forall a b. (a -> b) -> a -> b
$ () -> Either (Maybe ByteString) ()
forall a b. b -> Either a b
Right ()
            (Just ByteString
expected, Bool
True) -> do
                ByteString
current <- String -> IO ByteString
B.readFile String
file
                if ByteString
current ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
expected then do Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
content
                                               Handle -> IO ()
hFlush Handle
h
                                               String -> String -> IO ()
rename String
locked String
file
                                               Either (Maybe ByteString) () -> IO (Either (Maybe ByteString) ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe ByteString) () -> IO (Either (Maybe ByteString) ()))
-> Either (Maybe ByteString) ()
-> IO (Either (Maybe ByteString) ())
forall a b. (a -> b) -> a -> b
$ () -> Either (Maybe ByteString) ()
forall a. a -> Either (Maybe ByteString) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                       else do String -> IO ()
removeLink String
locked
                                               Either (Maybe ByteString) () -> IO (Either (Maybe ByteString) ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe ByteString) () -> IO (Either (Maybe ByteString) ()))
-> Either (Maybe ByteString) ()
-> IO (Either (Maybe ByteString) ())
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Either (Maybe ByteString) ()
forall a b. a -> Either a b
Left (Maybe ByteString -> Either (Maybe ByteString) ())
-> Maybe ByteString -> Either (Maybe ByteString) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
current
            (Just ByteString
_, Bool
False) -> do
                String -> IO ()
removeLink String
locked
                Either (Maybe ByteString) () -> IO (Either (Maybe ByteString) ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe ByteString) () -> IO (Either (Maybe ByteString) ()))
-> Either (Maybe ByteString) ()
-> IO (Either (Maybe ByteString) ())
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Either (Maybe ByteString) ()
forall a b. a -> Either a b
Left Maybe ByteString
forall a. Maybe a
Nothing
    where locked :: String
locked = String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".lock"