mirror of https://github.com/voidlizard/hbs2
851 lines
24 KiB
Haskell
851 lines
24 KiB
Haskell
{-# Language MultiWayIf #-}
|
|
module HBS2.Share.App
|
|
( module HBS2.Share.App.Types
|
|
, AppOption(..)
|
|
, Command
|
|
, AppPerks
|
|
, runApp
|
|
, runSync
|
|
) where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Base58
|
|
import HBS2.Merkle
|
|
import HBS2.Data.Detect
|
|
import HBS2.Defaults (defBlockSize)
|
|
import HBS2.Hash
|
|
import HBS2.Clock
|
|
import HBS2.OrDie
|
|
import HBS2.Peer.Proto.RefChan.Types
|
|
import HBS2.Net.Auth.Credentials
|
|
import HBS2.Net.Auth.Credentials.Sigil
|
|
import HBS2.Data.Types.SignedBox
|
|
import HBS2.Net.Auth.GroupKeySymm
|
|
import HBS2.Net.Auth.GroupKeySymm qualified as Symm
|
|
import HBS2.Peer.Proto.RefChan
|
|
|
|
import HBS2.Net.Messaging.Unix
|
|
import HBS2.Net.Proto.Service
|
|
import HBS2.Storage
|
|
import HBS2.Storage.Operations.ByteString
|
|
import HBS2.Storage.Operations.Missed (findMissedBlocks,findMissedBlocks2)
|
|
|
|
import HBS2.Peer.CLI.Detect (detectRPC)
|
|
import HBS2.Peer.RPC.Client.StorageClient
|
|
|
|
import HBS2.KeyMan.Keys.Direct
|
|
|
|
import HBS2.Share.App.Types
|
|
import HBS2.Share.Config hiding (key)
|
|
import HBS2.Share.State
|
|
import HBS2.Share.Files qualified as F
|
|
import HBS2.Share.Keys
|
|
import HBS2.Share.MetaData
|
|
import HBS2.Share.LocalHash
|
|
|
|
import HBS2.System.Logger.Simple.ANSI
|
|
import DBPipe.SQLite
|
|
|
|
import Control.Applicative
|
|
import Control.Concurrent.STM (flushTQueue)
|
|
import Control.Monad.Except (runExceptT)
|
|
import Control.Monad.Trans.Maybe
|
|
import Data.ByteArray.Hash qualified as BA
|
|
import Data.ByteArray.Hash (SipHash(..), SipKey(..))
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Data.ByteString qualified as BS
|
|
import Data.HashSet qualified as HashSet
|
|
import Data.HashMap.Strict qualified as HashMap
|
|
import Data.List qualified as List
|
|
import Data.Maybe
|
|
import Data.Set qualified as Set
|
|
import Data.Set (Set)
|
|
import Data.Either
|
|
import System.Directory
|
|
import System.FilePath
|
|
|
|
import Codec.Serialise
|
|
import Codec.Compression.GZip as GZip
|
|
import System.AtomicWrite.Writer.LazyByteString qualified as AwL
|
|
|
|
import System.TimeIt
|
|
|
|
import Streaming.Prelude qualified as S
|
|
|
|
|
|
type Command m = m ()
|
|
|
|
|
|
runApp :: MonadUnliftIO m => [AppOption] -> ShareCLI m () -> m ()
|
|
runApp opts action = do
|
|
|
|
getLocalConfigDir' >>=
|
|
liftIO . createDirectoryIfMissing True
|
|
|
|
getLocalConfigFile >>= \fn -> do
|
|
here <- liftIO $ doesFileExist fn
|
|
|
|
unless here do
|
|
liftIO $ appendFile fn ""
|
|
|
|
env <- liftIO (newAppEnv opts)
|
|
let db = view appDb env
|
|
|
|
setLogging @INFO defLog
|
|
setLogging @ERROR (logPrefix "" . toStderr)
|
|
setLogging @WARN (logPrefix "" . toStdout)
|
|
setLogging @NOTICE (logPrefix "" . toStdout)
|
|
|
|
when ( AppDebugOpt `elem` opts || AppTraceOpt `elem` opts) do
|
|
setLogging @DEBUG (logPrefix "" . toStderr)
|
|
|
|
when (AppTraceOpt `elem` opts) do
|
|
setLogging @TRACE (logPrefix "" . toStderr)
|
|
|
|
flip runContT pure $ do
|
|
void $ ContT $ bracket (async (runPipe db)) cancel
|
|
|
|
lift $ withAppEnv env do
|
|
withState populateState
|
|
loadAllEncryptionStuff
|
|
action
|
|
|
|
setLoggingOff @INFO
|
|
setLoggingOff @ERROR
|
|
setLoggingOff @WARN
|
|
setLoggingOff @NOTICE
|
|
setLoggingOff @DEBUG
|
|
setLoggingOff @TRACE
|
|
|
|
|
|
withAppEnv :: MonadIO m => AppEnv -> ShareCLI m a -> m a
|
|
withAppEnv env action = do
|
|
runReaderT (fromShareCLI action) env
|
|
|
|
|
|
newAppEnv :: forall m . MonadUnliftIO m => [AppOption] -> m AppEnv
|
|
newAppEnv opts = do
|
|
let dbOpts = dbPipeOptsDef
|
|
|
|
w <- getWorkingDir
|
|
|
|
conf <- readConfig
|
|
|
|
let sonameOpt = runReader (cfgValue @RpcUnixOpt @(Maybe String) @(Reader [Syntax C])) conf
|
|
|
|
rchan <- orThrowUser "refchan not set" (runReader (cfgValue @RefChanOpt @(Maybe RChan)) conf)
|
|
|
|
sonameDetect <- detectRPC
|
|
|
|
soname <- orThrowUser "rpc not detected" (sonameOpt <|> sonameDetect)
|
|
|
|
AppEnv opts conf rchan
|
|
<$> (getLocalStatePath >>= newDBPipeEnv dbOpts)
|
|
<*> pure w
|
|
<*> pure soname
|
|
<*> newIORef Nothing
|
|
|
|
withState :: (MonadReader AppEnv m, MonadIO m)
|
|
=> DBPipeM m b
|
|
-> m b
|
|
|
|
withState m = do
|
|
d <- asks (view appDb)
|
|
withDB d m
|
|
|
|
|
|
makeGK0Key :: forall e s m . ( AppPerks m
|
|
, HasProtocol e (ServiceProto StorageAPI e)
|
|
, s ~ Encryption L4Proto
|
|
)
|
|
=> RpcEndpoints e
|
|
-> ShareCLI m (Maybe GK0Key)
|
|
|
|
makeGK0Key rpc = runMaybeT do
|
|
lift (getOwnRefChanHeadRef rpc)
|
|
>>= toMPlus
|
|
<&> GK0Key
|
|
|
|
|
|
getGK0 :: forall e s m . ( AppPerks m
|
|
, HasProtocol e (ServiceProto StorageAPI e)
|
|
, ForGroupKeySymm 'HBS2Basic
|
|
, s ~ 'HBS2Basic
|
|
)
|
|
=> RpcEndpoints e
|
|
-> ShareCLI m (GK0 s)
|
|
getGK0 rpc = do
|
|
|
|
rchan <- asks (view appRefChan)
|
|
|
|
let sto = AnyStorage (StorageClient (rpcStorage rpc))
|
|
|
|
gk0key <- makeGK0Key @e rpc
|
|
>>= orThrowUser "makeGK0Key(1): refchan not available"
|
|
|
|
mgk <- runMaybeT do
|
|
gkh <- toMPlus =<< lift (withState $ selectGK0 gk0key)
|
|
|
|
debug $ "found gk!" <+> pretty gkh
|
|
|
|
runExceptT (readFromMerkle sto (SimpleKey (fromHashRef gkh)))
|
|
>>= toMPlus
|
|
<&> deserialiseOrFail @(GK0 s)
|
|
>>= toMPlus
|
|
|
|
case mgk of
|
|
Just x -> do
|
|
pure x
|
|
|
|
Nothing -> do
|
|
hd <- getRefChanHead @L4Proto sto (RefChanHeadKey (toRefChanId rchan))
|
|
>>= orThrowUser "makeGK0Key(2): refchan not available"
|
|
|
|
let readers = view refChanHeadReaders hd & HashSet.toList
|
|
gk <- generateGroupKey @s Nothing readers
|
|
href <- writeAsMerkle sto (serialise gk) <&> HashRef
|
|
|
|
withState (insertGK0 gk0key href >> commitAll)
|
|
|
|
debug $ "generated gk0!" <+> pretty href
|
|
|
|
pure gk
|
|
|
|
getOwnRefChanHeadRef :: forall e s m . ( AppPerks m
|
|
, HasProtocol e (ServiceProto StorageAPI e)
|
|
, s ~ Encryption L4Proto
|
|
)
|
|
=> RpcEndpoints e
|
|
-> ShareCLI m (Maybe HashRef)
|
|
getOwnRefChanHeadRef rpc = do
|
|
|
|
let sto = AnyStorage (StorageClient (rpcStorage rpc))
|
|
|
|
runMaybeT do
|
|
rchan <- toMPlus =<< lift (cfgValue @RefChanOpt @(Maybe RChan))
|
|
let puk = toRefChanId rchan
|
|
getRef sto (RefChanHeadKey @s puk)
|
|
>>= toMPlus
|
|
<&> HashRef
|
|
|
|
withRpcClientUnix :: forall a e m . ( MonadUnliftIO m
|
|
, HasProtocol e (ServiceProto PeerAPI e)
|
|
, HasProtocol e (ServiceProto StorageAPI e)
|
|
, HasProtocol e (ServiceProto RefChanAPI e)
|
|
, e ~ UNIX
|
|
, MonadReader AppEnv m
|
|
)
|
|
=> ( RpcEndpoints e -> m a )
|
|
-> m a
|
|
|
|
withRpcClientUnix action = do
|
|
|
|
-- FIXME: use-ContT
|
|
|
|
soname <- asks (view appRpcSock)
|
|
|
|
client <- race ( pause @'Seconds 1) (newMessagingUnix False 1.0 soname) `orDie` "hbs2-peer rpc timeout!"
|
|
|
|
messaging <- async $ runMessagingUnix client
|
|
link messaging
|
|
|
|
rpcPeer <- makeServiceCaller @PeerAPI @e (fromString soname)
|
|
rpcStorage <- makeServiceCaller @StorageAPI @e (fromString soname)
|
|
rpcRefChan <- makeServiceCaller @RefChanAPI @e (fromString soname)
|
|
|
|
let endpoints = [ Endpoint @e rpcPeer
|
|
, Endpoint @e rpcStorage
|
|
, Endpoint @e rpcRefChan
|
|
]
|
|
|
|
c1 <- async $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
|
|
|
link c1
|
|
|
|
r <- action $ RpcEndpoints rpcPeer rpcStorage rpcRefChan
|
|
|
|
pause @'Seconds 0.1
|
|
|
|
cancel c1
|
|
|
|
void $ waitAnyCatchCancel [c1, messaging]
|
|
|
|
pure r
|
|
|
|
|
|
loadSigil :: forall s m . ( ForSigil s
|
|
, AppPerks m
|
|
) => ShareCLI m (PubKey 'Sign s, SigilData s)
|
|
loadSigil = do
|
|
|
|
dir <- getLocalConfigDir
|
|
|
|
path' <- cfgValue @SigilPathOpt @(Maybe String)
|
|
>>= orThrowUser "sigil not set"
|
|
|
|
let nonLocalPath = List.isPrefixOf "./" path' || List.isPrefixOf "/" path'
|
|
|
|
path <- if not nonLocalPath then do
|
|
pure $ dir </> path'
|
|
else do
|
|
pure path'
|
|
|
|
trace $ "SIGIL PATH" <+> pretty path
|
|
|
|
sigil <- liftIO $ (BS.readFile path <&> parseSerialisableFromBase58 @(Sigil s))
|
|
>>= orThrowUser ("invalid sigil format" <+> pretty path)
|
|
|
|
w@(_,sd) <- orThrowUser "malformed sigil" (unboxSignedBox0 @(SigilData s) (sigilData sigil))
|
|
|
|
pure w
|
|
|
|
loadAllEncryptionStuff :: AppPerks m => ShareCLI m ()
|
|
loadAllEncryptionStuff = do
|
|
|
|
-- 1. загружаем sigil
|
|
(pk, sd) <- loadSigil @'HBS2Basic
|
|
|
|
trace $ "sigil loaded" <+> pretty (AsBase58 pk)
|
|
|
|
enc <- runKeymanClient do
|
|
cr <- loadCredentials pk
|
|
>>= orThrowUser "can't find credentials"
|
|
|
|
enc <- loadKeyRingEntry (sigilDataEncKey sd)
|
|
>>= orThrowUser "can't find keyring entry"
|
|
|
|
pure $ EncryptionStuff cr enc
|
|
|
|
encIO <- asks (view appEnc)
|
|
|
|
writeIORef encIO (Just enc)
|
|
debug "encryption data loaded ok"
|
|
|
|
|
|
data UpdateFileMethod = UpdateFileForce
|
|
| UpdateFileSync
|
|
|
|
updateFile :: (AppPerks m, HasProtocol e (ServiceProto StorageAPI e))
|
|
=> RpcEndpoints e
|
|
-> RemoteFile
|
|
-> ShareCLI m ()
|
|
updateFile rpc fe = do
|
|
dir <- asks (view appWorkDir)
|
|
replica <- isReplica
|
|
if replica then do
|
|
updateFileMethod UpdateFileForce rpc fe
|
|
else do
|
|
updateFileMethod UpdateFileSync rpc fe
|
|
|
|
updateFileMethod :: (AppPerks m, HasProtocol e (ServiceProto StorageAPI e))
|
|
=> UpdateFileMethod
|
|
-> RpcEndpoints e
|
|
-> RemoteFile
|
|
-> ShareCLI m ()
|
|
updateFileMethod UpdateFileForce rpc fe = do
|
|
|
|
dir <- asks (view appWorkDir)
|
|
|
|
let key = _remoteFileKey fe
|
|
|
|
let fn = dir </> toFilePath key
|
|
|
|
let sto = AnyStorage (StorageClient (rpcStorage rpc))
|
|
|
|
encStuff <- asks (view appEnc)
|
|
>>= readIORef
|
|
>>= orThrowUser "credentials not available"
|
|
|
|
let kr = [view kre encStuff]
|
|
|
|
for_ (getDirs key) $ \d -> do
|
|
let fpath = dir </> d
|
|
here <- liftIO $ doesFileExist fpath
|
|
when here do
|
|
liftIO (removeFile fpath)
|
|
liftIO $ createDirectoryIfMissing True fpath
|
|
|
|
here <- liftIO $ doesFileExist fn
|
|
|
|
l <- withState (selectLocalFile key)
|
|
|
|
let lh = view localFileHash <$> l
|
|
|
|
when (lh /= Just (_remoteLocalHash fe) || not here) do
|
|
info $ "update file" <+> pretty key
|
|
|
|
let h = view remoteTree fe & fromHashRef
|
|
|
|
lbs <- runExceptT (readFromMerkle sto (ToDecryptBS kr h))
|
|
>>= orThrowUser ("can't read file" <+> pretty h <+> pretty key)
|
|
|
|
liftIO $ AwL.atomicWriteFile fn lbs
|
|
|
|
updateFileMethod UpdateFileSync rpc fe = do
|
|
w <- asks (view appWorkDir)
|
|
let sto = AnyStorage (StorageClient (rpcStorage rpc))
|
|
|
|
encStuff <- asks (view appEnc)
|
|
>>= readIORef
|
|
>>= orThrowUser "credentials not available"
|
|
|
|
let kr = [view kre encStuff]
|
|
|
|
let key = _remoteFileKey fe
|
|
|
|
(doUpdate, mt) <- withState do
|
|
let fn = _remoteFileKey fe
|
|
lf <- selectLocalFile (_remoteFileKey fe)
|
|
-- floc <- selectLocalFile (_remoteFileKey fe)
|
|
let tLoc = _localFileModTime <$> lf
|
|
let tRem = Just (_remoteFileTime fe)
|
|
|
|
let rhash = Just $ _remoteLocalHash fe
|
|
let lhash = _localFileHash <$> lf
|
|
|
|
pure (tRem > tLoc && rhash /= lhash, tRem)
|
|
|
|
dont <- dontPost
|
|
|
|
when (doUpdate && not dont) do
|
|
|
|
let dirs = getDirs key
|
|
|
|
info $ "U" <+> pretty key <+> pretty (_remoteTree fe)
|
|
|
|
for_ dirs $ \d -> do
|
|
let fpath = w </> d
|
|
isFile <- liftIO $ doesFileExist fpath
|
|
|
|
when isFile do
|
|
-- TODO: unique-rename?
|
|
fnew <- renameFileUniq fpath
|
|
info $ "renamed" <+> pretty fpath <+> pretty fnew
|
|
|
|
debug $ "create dir" <+> pretty fpath
|
|
liftIO $ createDirectoryIfMissing True fpath
|
|
|
|
let h = view remoteTree fe & fromHashRef
|
|
|
|
lbs <- runExceptT (readFromMerkle sto (ToDecryptBS kr h))
|
|
>>= orThrowUser ("can't read file" <+> pretty h <+> pretty key)
|
|
|
|
let fn = w </> toFilePath key
|
|
|
|
liftIO $ AwL.atomicWriteFile fn lbs
|
|
forM_ mt (liftIO . setModificationTime fn)
|
|
|
|
renameFileUniq :: MonadUnliftIO m => FilePath -> m FilePath
|
|
renameFileUniq fs = do
|
|
|
|
fnew' <- S.head_ do
|
|
for_ [1..] $ \i -> do
|
|
let new = fs <> "~" <> show i
|
|
here <- liftIO (doesFileExist new)
|
|
unless here do
|
|
S.yield new
|
|
|
|
fnew <- orThrowUser ("can't rename file" <> pretty fs) fnew'
|
|
|
|
liftIO $ renameFile fs fnew
|
|
|
|
pure fnew
|
|
|
|
isMissed :: (AppPerks m, MonadReader AppEnv m)
|
|
=> AnyStorage
|
|
-> HashRef
|
|
-> m Bool
|
|
|
|
isMissed sto h = do
|
|
miss <- withState (selectMissed h)
|
|
case miss of
|
|
Just False -> pure False
|
|
_ -> do
|
|
missed <- S.head_ (findMissedBlocks2 sto h) <&> isJust
|
|
withState (insertMissed h missed)
|
|
pure missed
|
|
|
|
scanState :: forall e m . ( AppPerks m
|
|
, HasProtocol e (ServiceProto StorageAPI e)
|
|
, HasProtocol e (ServiceProto RefChanAPI e)
|
|
)
|
|
=> RpcEndpoints e
|
|
-> ShareCLI m HashRef
|
|
|
|
scanState rpc = do
|
|
|
|
debug "scanState"
|
|
|
|
encStuff <- asks (view appEnc)
|
|
>>= readIORef
|
|
>>= orThrowUser "credentials not available"
|
|
|
|
let kr = view kre encStuff
|
|
|
|
let sto = AnyStorage (StorageClient (rpcStorage rpc))
|
|
refchan <- asks (toRefChanId . view appRefChan)
|
|
|
|
debug $ "scan state for" <+> pretty (AsBase58 refchan)
|
|
|
|
rv <- callService @RpcRefChanGet (rpcRefChan rpc) refchan
|
|
>>= orThrowUser "getRefchan: rpc failure"
|
|
>>= orThrowUser "refchan not found"
|
|
|
|
debug $ "refchan value" <+> pretty rv
|
|
|
|
withState do
|
|
seen <- selectSeen rv
|
|
unless seen do
|
|
scanTx sto rv
|
|
commitAll
|
|
|
|
props <- withState selectProposes
|
|
|
|
-- FIXME: cache-somehow
|
|
((px,e), meta) <- findGoodNewBlock kr sto props
|
|
>>= orThrowUser "no meta block found"
|
|
|
|
withState do
|
|
for_ (mdFiles meta) $ \fe -> do
|
|
insertRemoteFile px (realToFrac e) meta fe
|
|
commitAll
|
|
|
|
rfs <- withState $ selectRemoteFiles px
|
|
|
|
for_ rfs $ \rf -> do
|
|
updateFile rpc rf
|
|
|
|
withState $ insertSeen rv
|
|
|
|
pure px
|
|
|
|
where
|
|
|
|
findGoodNewBlock kr sto props = do
|
|
runMaybeT (go props)
|
|
|
|
where
|
|
|
|
go [] = mzero
|
|
go (p:ps) = do
|
|
|
|
let btx = fst p
|
|
missed <- lift $ isMissed sto btx
|
|
if missed then
|
|
go ps
|
|
else do
|
|
|
|
what <- S.head_ do
|
|
walkMerkle (fromHashRef btx) (getBlock sto) $ \case
|
|
Right ( (hx:_) :: [HashRef] ) -> do
|
|
S.yield hx
|
|
|
|
_ -> pure ()
|
|
|
|
hmeta <- toMPlus what
|
|
|
|
meta <- runExceptT (readFromMerkle sto (ToDecryptBS [kr] (fromHashRef hmeta)))
|
|
>>= toMPlus
|
|
<&> GZip.decompress
|
|
<&> deserialiseOrFail @MetaData
|
|
>>= toMPlus
|
|
|
|
if List.null (mdFiles meta) then do
|
|
go ps
|
|
else
|
|
pure (p,meta)
|
|
|
|
scanTx sto rv =
|
|
-- FIXME: dont-process-twice
|
|
walkMerkle (fromHashRef rv) (getBlock sto) $ \case
|
|
Left h -> warn $ "missed block" <+> pretty h
|
|
|
|
Right (hs ::[HashRef]) -> void $ runMaybeT do
|
|
trace $ "got some" <+> pretty (length hs)
|
|
|
|
for_ hs $ \htx -> void $ runMaybeT do
|
|
|
|
seen <- lift $ lift $ selectSeen htx
|
|
|
|
-- debug $ "SEEN" <+> pretty seen <+> pretty htx
|
|
guard (not seen)
|
|
|
|
bs <- toMPlus =<< getBlock sto (fromHashRef htx)
|
|
tx <- toMPlus $ deserialiseOrFail @(RefChanUpdate L4Proto) bs
|
|
|
|
case tx of
|
|
Accept _ box -> do
|
|
(_, txx@(AcceptTran mt _ hp)) <- toMPlus $ unboxSignedBox0 box
|
|
trace $ "tx accept" <+> pretty htx <+> pretty hp <+> pretty mt
|
|
t <- toMPlus mt
|
|
lift $ lift $ insertAccept htx hp (fromIntegral t)
|
|
|
|
Propose _ box -> do
|
|
(_, ProposeTran _ pbox :: ProposeTran L4Proto) <- toMPlus $ unboxSignedBox0 box
|
|
(_, bs2) <- toMPlus $ unboxSignedBox0 pbox
|
|
|
|
let wtf = [ tryDetect (hashObject bs) (LBS.fromStrict bs2) ]
|
|
|
|
mytx <- [ ha | AnnotatedHashRef _ ha <- universeBi wtf ] & listToMaybe & toMPlus
|
|
|
|
trace $ "tx propose" <+> pretty htx <+> pretty mytx
|
|
lift $ lift $ insertPropose htx mytx
|
|
|
|
lift $ lift $ insertSeen htx
|
|
|
|
dontPost :: AppPerks m => ShareCLI m Bool
|
|
dontPost = do
|
|
opts <- asks ( view appOpts )
|
|
replica <- isReplica
|
|
pure $ replica || or [ True | AppDontPostOpt <- opts ]
|
|
|
|
isReplica :: AppPerks m => ShareCLI m Bool
|
|
isReplica = do
|
|
re <- asks _appOpts <&> (AppReplicaOpt `elem`)
|
|
conf <- getConf
|
|
pure $ re || or [ True | ListVal [SymbolVal "replica"] <- conf ]
|
|
|
|
updateLocalState :: AppPerks m => ShareCLI m ()
|
|
updateLocalState = do
|
|
|
|
debug "updateLocalState"
|
|
|
|
skip <- cfgValue @IgnoreOpt @(Set String) <&> Set.toList
|
|
|
|
dir <- asks (view appWorkDir)
|
|
|
|
let d = makeEntryKey mempty dir
|
|
|
|
q <- newTQueueIO
|
|
|
|
es <- liftIO (F.listFiles skip dir (atomically . writeTQueue q . makeEntryKey d))
|
|
>> atomically (flushTQueue q)
|
|
|
|
withState do
|
|
for_ es $ \e -> do
|
|
let fn = toFilePath e
|
|
t <- liftIO $ getModificationTime fn
|
|
|
|
lf <- selectLocalFile e
|
|
|
|
let newF = isNothing lf || (view localFileModTime <$> lf) /= Just t
|
|
|
|
when newF do
|
|
h <- localHash (toFilePath e)
|
|
insertLocalFile e t h
|
|
|
|
commitAll
|
|
|
|
postState :: forall e s m . ( AppPerks m
|
|
, HasProtocol e (ServiceProto RefChanAPI e)
|
|
, HasProtocol e (ServiceProto StorageAPI e)
|
|
, s ~ 'HBS2Basic
|
|
)
|
|
|
|
=> RpcEndpoints e
|
|
-> HashRef -- ^ current state
|
|
-> ShareCLI m ()
|
|
postState rpc px = do
|
|
|
|
debug "postState"
|
|
|
|
encStuff <- asks (view appEnc)
|
|
>>= readIORef
|
|
>>= orThrowUser "credentials not available"
|
|
|
|
let kr = view kre encStuff
|
|
|
|
let (KeyringKeys pk sk) = view kre encStuff
|
|
|
|
let sto = AnyStorage (StorageClient (rpcStorage rpc))
|
|
refchan <- asks (toRefChanId . view appRefChan)
|
|
|
|
-- генерим gk0 если нету:
|
|
gk0key <- makeGK0Key rpc
|
|
>>= orThrowUser "can't make gk0key (perhaps refchan is not available)"
|
|
|
|
debug $ "gk0 key" <+> pretty gk0key
|
|
|
|
gk0 <- getGK0 rpc
|
|
gkh <- writeAsMerkle sto (serialise gk0)
|
|
|
|
debug $ "got GK0, okay"
|
|
|
|
gks <- Symm.lookupGroupKey sk pk gk0
|
|
& orThrow (userError $ show ("*** Can't decrypt group key" <+> pretty gkh))
|
|
|
|
w <- asks (view appWorkDir)
|
|
locals <- withState selectLocalFiles
|
|
|
|
withState do
|
|
fee <- S.toList_ $ for_ locals $ \l -> do
|
|
let key = _localFileKey l
|
|
let fpath = w </> toFilePath key
|
|
r <- lift $ selectRemoteFile px key
|
|
|
|
let rhash = _remoteLocalHash <$> r
|
|
let rtree = _remoteTree <$> r
|
|
let lhash = _localFileHash l
|
|
|
|
here <- liftIO $ doesFileExist fpath
|
|
|
|
when here do
|
|
if Just lhash == rhash && isJust r then do
|
|
|
|
-- FIXME: only-if-readers-are-chanhed
|
|
-- делать только если поменялись читатели,
|
|
-- иначе будет тормозить на большом числе файлов
|
|
override <- genTreeOverride sto encStuff gk0 (fromJust rtree)
|
|
|
|
case override of
|
|
Just (Left{}) -> do
|
|
-- nothing happen, no action required
|
|
S.yield $ Left $ FileEntry key lhash (fromJust rtree)
|
|
|
|
Just (Right new) -> do
|
|
-- tree is overriden with new gk0
|
|
S.yield $ Right $ FileEntry key lhash new
|
|
|
|
Nothing -> do
|
|
-- errors during tree overriding, post new file
|
|
warn $ "errors while overriding tree" <+> pretty rtree
|
|
tree <- writeEncryptedFile gks gk0 sto fpath lhash
|
|
S.yield $ Right $ FileEntry key lhash tree
|
|
|
|
else do
|
|
tree <- writeEncryptedFile gks gk0 sto fpath lhash
|
|
S.yield $ Right $ FileEntry key lhash tree
|
|
|
|
let fe = List.sortOn (view feKey) (lefts fee <> rights fee)
|
|
|
|
let updated = not $ List.null (rights fee)
|
|
|
|
when updated do
|
|
|
|
let gk1 = mempty
|
|
|
|
let base = Just px
|
|
|
|
let md = MetaData base gk1 fe
|
|
|
|
-- можно брать только правые
|
|
let hashes = [ t | FileEntry _ _ t <- fe ]
|
|
|
|
for_ (rights fee) $ \f -> do
|
|
info $ "M" <+> pretty (_feTree f) <+> pretty (_feKey f)
|
|
|
|
let metabs = serialise md
|
|
& GZip.compressWith (defaultCompressParams { compressLevel = bestCompression })
|
|
|
|
manifest <- getLocalConfigDir <&> (</> "manifest")
|
|
liftIO $ AwL.atomicWriteFile manifest metabs
|
|
|
|
lh <- localHash manifest
|
|
mfhash <- writeEncryptedFile gks gk0 sto manifest lh
|
|
|
|
let pt = toPTree (MaxSize 1024) (MaxNum 1024) (mfhash : hashes) -- FIXME: settings
|
|
|
|
metaHash <- makeMerkle 0 pt $ \(_,_,bss) -> do
|
|
void $ liftIO (putBlock sto bss)
|
|
|
|
info $ "entries:" <+> pretty (length hashes) <+> pretty metaHash
|
|
|
|
let tx = AnnotatedHashRef Nothing (HashRef metaHash)
|
|
let ssk = view (creds . peerSignSk) encStuff
|
|
let spk = view (creds . peerSignPk) encStuff
|
|
|
|
let box = makeSignedBox spk ssk (LBS.toStrict $ serialise tx)
|
|
|
|
dont <- lift dontPost
|
|
|
|
unless dont do
|
|
debug "POST TX"
|
|
r <- callService @RpcRefChanPropose (rpcRefChan rpc) (refchan, box)
|
|
pure ()
|
|
|
|
where
|
|
-- genTreeOverride :: AnyStorage -> EncryptionStuff -> GK0 'HBS2Basic -> HashRef -> m ()
|
|
genTreeOverride sto enc gk0 tree = do
|
|
let (KeyringKeys pk sk) = view kre enc
|
|
runMaybeT do
|
|
obj <- MaybeT $ getBlock sto (fromHashRef tree)
|
|
case tryDetect (fromHashRef tree) obj of
|
|
MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm2 o gkh0 nonce}) -> do
|
|
|
|
gk0old <- runExceptT (readFromMerkle sto (SimpleKey gkh0))
|
|
>>= toMPlus
|
|
<&> deserialiseOrFail @(GroupKey 'Symm s)
|
|
>>= toMPlus
|
|
|
|
let rcptOld = HashMap.keysSet (recipients gk0old)
|
|
let rcptNew = HashMap.keysSet (recipients gk0)
|
|
|
|
if rcptOld == rcptNew then do
|
|
pure (Left tree)
|
|
else do
|
|
|
|
gksOld <- toMPlus $ Symm.lookupGroupKey sk pk gk0old
|
|
|
|
gk1 <- generateGroupKey @s (Just gksOld) (HashSet.toList rcptNew)
|
|
|
|
gk1h <- writeAsMerkle sto (serialise gk1)
|
|
|
|
let newCrypt = EncryptGroupNaClSymm2 o gk1h nonce
|
|
let newTreeBlock = ann { _mtaCrypt = newCrypt }
|
|
|
|
newTree <- enqueueBlock sto (serialise newTreeBlock)
|
|
>>= toMPlus
|
|
<&> HashRef
|
|
|
|
pure (Right newTree)
|
|
|
|
_ -> mzero
|
|
|
|
|
|
runSync :: AppPerks m => ShareCLI m ()
|
|
runSync = do
|
|
|
|
replica <- isReplica
|
|
info $ "replica:" <+> pretty replica
|
|
|
|
flip runContT pure $ do
|
|
|
|
rpc <- ContT $ withRpcClientUnix
|
|
|
|
lift do
|
|
updateLocalState
|
|
px <- scanState rpc
|
|
updateLocalState
|
|
postState rpc px
|
|
|
|
writeEncryptedFile :: forall m s nonce . (MonadIO m, Serialise nonce, s ~ 'HBS2Basic)
|
|
=> GroupSecret
|
|
-> GroupKey 'Symm s
|
|
-> AnyStorage
|
|
-> FilePath
|
|
-> nonce
|
|
-> m HashRef
|
|
writeEncryptedFile gks gk0 sto fn h = do
|
|
let nonce = LBS.drop 1 (serialise h) & LBS.toStrict
|
|
|
|
let sk1 = SipKey 2716310006254639645 507093936407764973
|
|
let sk2 = SipKey 9209724780415729085 2720900864410773155
|
|
let (SipHash a) = BA.sipHash sk1 nonce
|
|
let (SipHash b) = BA.sipHash sk2 nonce
|
|
|
|
let bsStream = flip readChunkedBS defBlockSize =<< liftIO (LBS.readFile fn)
|
|
|
|
-- TODO: fix-metadata
|
|
let source = ToEncryptSymmBS @s gks
|
|
(Right gk0)
|
|
nonce
|
|
bsStream
|
|
NoMetaData
|
|
(Just (EncryptGroupNaClSymmBlockSIP (a,b)))
|
|
|
|
th <- runExceptT (writeAsMerkle sto source)
|
|
>>= orThrowUser "can't encrypt data"
|
|
|
|
pure $ HashRef th
|
|
|