mirror of https://github.com/voidlizard/hbs2
139 lines
4.0 KiB
Haskell
139 lines
4.0 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# Language RecordWildCards #-}
|
|
{-# Language UndecidableInstances #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
{-# Language PatternSynonyms #-}
|
|
{-# Language FunctionalDependencies #-}
|
|
module HBS2.Git3.Prelude
|
|
( module HBS2.Git3.Prelude
|
|
, module Exported
|
|
, module HBS2.Peer.RPC.Client
|
|
, module HBS2.Peer.RPC.Client.Unix
|
|
, module Codec.Serialise
|
|
, runExceptT
|
|
, pattern SignPubKeyLike
|
|
, pattern GitHashLike
|
|
, maxCLevel
|
|
) where
|
|
|
|
import HBS2.Prelude.Plated as Exported
|
|
import HBS2.Defaults as Exported
|
|
import HBS2.OrDie as Exported
|
|
import HBS2.Data.Types.Refs as Exported
|
|
import HBS2.Base58 as Exported
|
|
import HBS2.Merkle as Exported
|
|
import HBS2.Misc.PrettyStuff as Exported
|
|
import HBS2.Net.Auth.Credentials
|
|
import HBS2.Peer.Proto.LWWRef as Exported
|
|
import HBS2.Peer.Proto.RefLog as Exported
|
|
import HBS2.Peer.RPC.API.RefLog as Exported
|
|
import HBS2.Peer.RPC.API.Peer as Exported
|
|
import HBS2.Peer.RPC.API.LWWRef as Exported
|
|
import HBS2.Peer.RPC.API.Storage as Exported
|
|
import HBS2.Peer.RPC.Client hiding (encode,decode)
|
|
import HBS2.Peer.RPC.Client.Unix hiding (encode,decode)
|
|
import HBS2.Peer.RPC.Client.StorageClient
|
|
import HBS2.Data.Types.SignedBox as Exported
|
|
import HBS2.Storage as Exported
|
|
import HBS2.Storage.Operations.Class as Exported
|
|
import HBS2.System.Logger.Simple.ANSI as Exported
|
|
|
|
import HBS2.Git3.Types as Exported
|
|
import HBS2.Git3.Logger as Exported
|
|
-- import HBS2.Git3.State.Types as Exported
|
|
|
|
import HBS2.System.Dir
|
|
|
|
import Data.Config.Suckless.Syntax
|
|
|
|
import Codec.Compression.Zstd (maxCLevel)
|
|
import Codec.Serialise
|
|
import Control.Monad.Except (runExceptT)
|
|
import Control.Monad.Reader as Exported
|
|
import Control.Monad.Trans.Cont as Exported
|
|
import Control.Monad.Trans.Maybe as Exported
|
|
import Data.ByteString qualified as BS
|
|
import Data.Coerce as Exported
|
|
import Data.HashPSQ qualified as HPSQ
|
|
import Data.HashMap.Strict (HashMap)
|
|
import Data.HashMap.Strict qualified as HM
|
|
import Data.HashPSQ (HashPSQ)
|
|
import Data.Kind
|
|
import System.Exit qualified as Q
|
|
import System.IO.MMap as Exported
|
|
import System.FilePattern as Exported
|
|
|
|
import GHC.Natural as Exported
|
|
import UnliftIO as Exported
|
|
|
|
|
|
|
|
class Cached cache k v | cache -> k, cache -> v where
|
|
isCached :: forall m . MonadIO m => cache -> k -> m Bool
|
|
cached :: forall m . MonadIO m => cache -> k -> m v -> m v
|
|
uncache :: forall m . MonadIO m => cache -> k -> m ()
|
|
|
|
|
|
newtype CacheTVH k v = CacheTVH (TVar (HashMap k v))
|
|
|
|
instance Hashable k => Cached (CacheTVH k v) k v where
|
|
isCached (CacheTVH t) k = readTVarIO t <&> HM.member k
|
|
uncache (CacheTVH t) k = atomically (modifyTVar t (HM.delete k))
|
|
cached (CacheTVH t) k a = do
|
|
what <- readTVarIO t <&> HM.lookup k
|
|
case what of
|
|
Just x -> pure x
|
|
Nothing -> do
|
|
r <- a
|
|
atomically $ modifyTVar t (HM.insert k r)
|
|
pure r
|
|
|
|
data CacheFixedHPSQ k v =
|
|
CacheFixedHPSQ
|
|
{ _cacheSize :: Int
|
|
, _theCache :: TVar (HashPSQ k TimeSpec v)
|
|
}
|
|
|
|
newCacheFixedHPSQ :: MonadIO m => Int -> m (CacheFixedHPSQ k v)
|
|
newCacheFixedHPSQ l = CacheFixedHPSQ l <$> newTVarIO HPSQ.empty
|
|
|
|
instance (Ord k, Hashable k) => Cached (CacheFixedHPSQ k v) k v where
|
|
|
|
isCached CacheFixedHPSQ{..} k = readTVarIO _theCache <&> HPSQ.member k
|
|
|
|
uncache CacheFixedHPSQ{..} k = atomically $ modifyTVar _theCache (HPSQ.delete k)
|
|
|
|
cached CacheFixedHPSQ{..} k a = do
|
|
w <- readTVarIO _theCache <&> HPSQ.lookup k
|
|
case w of
|
|
Just (_,e) -> pure e
|
|
Nothing -> do
|
|
v <- a
|
|
|
|
t <- getTimeCoarse
|
|
|
|
atomically do
|
|
s <- readTVar _theCache <&> HPSQ.size
|
|
|
|
when (s >= _cacheSize) do
|
|
modifyTVar _theCache HPSQ.deleteMin
|
|
|
|
modifyTVar _theCache (HPSQ.insert k t v)
|
|
|
|
pure v
|
|
|
|
quit :: MonadUnliftIO m => m ()
|
|
quit = liftIO Q.exitSuccess
|
|
|
|
die :: (MonadUnliftIO m, Pretty a) => a -> m ()
|
|
die x = liftIO $ Q.die (show $ pretty x)
|
|
|
|
pattern GitHashLike:: forall {c} . GitHash -> Syntax c
|
|
pattern GitHashLike x <- (
|
|
\case
|
|
LitIntVal 0 -> Just $ GitHash (BS.replicate 20 0)
|
|
StringLike s -> fromStringMay @GitHash s
|
|
_ -> Nothing
|
|
-> Just x )
|
|
|