mirror of https://github.com/voidlizard/hbs2
500 lines
15 KiB
Haskell
500 lines
15 KiB
Haskell
{-# Language UndecidableInstances #-}
|
||
{-# Language AllowAmbiguousTypes #-}
|
||
{-# Language TemplateHaskell #-}
|
||
{-# Language MultiWayIf #-}
|
||
{-# Language PatternSynonyms #-}
|
||
{-# Language ViewPatterns #-}
|
||
module HBS2.Sync.Prelude
|
||
( module HBS2.Sync.Prelude
|
||
, module Exported
|
||
) where
|
||
|
||
import HBS2.Prelude.Plated as Exported
|
||
import HBS2.Base58 as Exported
|
||
import HBS2.OrDie as Exported
|
||
import HBS2.Data.Types.Refs as Exported
|
||
import HBS2.Net.Auth.Credentials as Exported hiding (encode,decode)
|
||
import HBS2.Net.Proto.Service hiding (encode,decode)
|
||
import HBS2.Peer.Proto.RefChan.Types as Exported
|
||
import HBS2.Net.Messaging.Unix (runMessagingUnix,newMessagingUnix)
|
||
import HBS2.Storage as Exported
|
||
import HBS2.Storage.Compact as Compact
|
||
import HBS2.Peer.CLI.Detect
|
||
import HBS2.Peer.RPC.Client hiding (encode,decode) -- as Exported
|
||
import HBS2.Peer.RPC.Client.Unix (UNIX)
|
||
import HBS2.Peer.RPC.Client.RefChan (fetchRefChanHead, fetchRefChan, getRefChanValue)
|
||
import HBS2.Peer.RPC.Client.StorageClient
|
||
import HBS2.Peer.RPC.API.Peer
|
||
import HBS2.Peer.RPC.API.RefChan
|
||
import HBS2.Peer.RPC.API.Storage
|
||
import HBS2.System.Logger.Simple.ANSI as Exported
|
||
import HBS2.System.Dir
|
||
import HBS2.Misc.PrettyStuff as Exported
|
||
|
||
import HBS2.CLI.Run hiding (PeerException(..))
|
||
|
||
import HBS2.KeyMan.Keys.Direct as Exported ( runKeymanClient
|
||
, loadCredentials
|
||
, loadKeyRingEntries
|
||
, extractGroupKeySecret
|
||
, KeyManClientEnv
|
||
)
|
||
|
||
import HBS2.KeyMan.Keys.Direct qualified as KE
|
||
|
||
import Data.Config.Suckless as Exported
|
||
import Data.Config.Suckless.Script as Exported
|
||
|
||
import Codec.Serialise as Exported
|
||
import Control.Applicative
|
||
import Control.Monad.Reader as Exported
|
||
import Control.Monad.Trans.Cont as Exported
|
||
import Control.Monad.Trans.Maybe
|
||
import Data.Coerce as Exported
|
||
import Data.Either as Exported
|
||
import Data.List qualified as L
|
||
import Data.List (stripPrefix)
|
||
import Data.Map (Map)
|
||
import Data.Map qualified as Map
|
||
import Data.Maybe as Exported
|
||
import Data.Time.Clock.POSIX
|
||
import Data.Word
|
||
import Lens.Micro.Platform
|
||
import System.Console.ANSI qualified as IO
|
||
import System.Directory
|
||
import System.Exit qualified as Exit
|
||
import System.IO qualified as IO
|
||
import UnliftIO as Exported
|
||
|
||
{- HLINT ignore "Functor law" -}
|
||
{- HLINT ignore "Eta reduce" -}
|
||
|
||
type MyRefChan = PubKey 'Sign 'HBS2Basic
|
||
|
||
data DirSyncEnv =
|
||
DirSyncEnv
|
||
{ _dirSyncPath :: Maybe FilePath
|
||
, _dirSyncRefChan :: Maybe MyRefChan
|
||
, _dirSyncCreds :: Maybe (PeerCredentials 'HBS2Basic)
|
||
, _dirSyncInclude :: [FilePattern]
|
||
, _dirSyncExclude :: [FilePattern]
|
||
, _dirSyncBackup :: Bool
|
||
, _dirSyncFollowSymlinks :: Bool
|
||
}
|
||
deriving stock (Generic)
|
||
|
||
makeLenses 'DirSyncEnv
|
||
|
||
instance Monoid DirSyncEnv where
|
||
mempty = DirSyncEnv Nothing Nothing Nothing mempty defExcl False False
|
||
where
|
||
defExcl = ["**/.hbs2-sync/*"]
|
||
|
||
|
||
instance Semigroup DirSyncEnv where
|
||
(<>) a b = DirSyncEnv ( view dirSyncPath b <|> view dirSyncPath a )
|
||
( view dirSyncRefChan b <|> view dirSyncRefChan a )
|
||
( view dirSyncCreds b <|> view dirSyncCreds a )
|
||
(L.nub $ view dirSyncInclude a <> view dirSyncInclude b )
|
||
(L.nub $ view dirSyncExclude a <> view dirSyncExclude b )
|
||
( view dirSyncBackup b || view dirSyncBackup a )
|
||
( view dirSyncFollowSymlinks b || view dirSyncFollowSymlinks a )
|
||
|
||
instance Pretty DirSyncEnv where
|
||
pretty e = do
|
||
vcat $ catMaybes
|
||
[ pure ("; path" <+> pretty (view dirSyncPath e))
|
||
, view dirSyncRefChan e >>= \x -> pure $ pretty $ mkList @C [mkSym "refchan", mkSym (show $ pretty (AsBase58 x))]
|
||
, view dirSyncCreds e >>=
|
||
\x -> pure $ pretty
|
||
$ mkList @C [mkSym "sign", mkSym (show $ pretty $ AsBase58 $ view peerSignPk x)]
|
||
, pure $ vcat (fmap (mkPattern "include") (view dirSyncInclude e))
|
||
, pure $ vcat (fmap (mkPattern "exclude") (view dirSyncExclude e))
|
||
]
|
||
|
||
where
|
||
mkPattern name p = pretty $ mkList @C [mkSym name, mkSym p]
|
||
|
||
data SyncEnv =
|
||
SyncEnv
|
||
{ refchanAPI :: ServiceCaller RefChanAPI UNIX
|
||
, storageAPI :: ServiceCaller StorageAPI UNIX
|
||
, peerAPI :: ServiceCaller PeerAPI UNIX
|
||
, dirSyncEnv :: TVar (Map FilePath DirSyncEnv)
|
||
, dirThis :: TVar (Maybe FilePath)
|
||
, dirTombs :: TVar (Map FilePath (CompactStorage HbSync))
|
||
, dirCache :: TVar (Map FilePath (CompactStorage HbSync))
|
||
, keymanClientEnv :: TVar (Maybe KeyManClientEnv)
|
||
}
|
||
|
||
newtype SyncApp m a =
|
||
SyncApp { fromSyncApp :: ReaderT (Maybe SyncEnv) m a }
|
||
deriving newtype ( Applicative
|
||
, Functor
|
||
, Monad
|
||
, MonadUnliftIO
|
||
, MonadIO
|
||
, MonadReader (Maybe SyncEnv))
|
||
|
||
|
||
type SyncAppPerks m = MonadUnliftIO m
|
||
|
||
class Monad m => HasTombs m where
|
||
getTombs :: m (CompactStorage HbSync)
|
||
closeTombs :: m ()
|
||
|
||
|
||
class Monad m => HasCache m where
|
||
getCache :: m (CompactStorage HbSync)
|
||
closeCache :: m ()
|
||
|
||
class Monad m => HasKeyManClient m where
|
||
getKeyManClientEnv :: m KeyManClientEnv
|
||
|
||
instance MonadUnliftIO m => HasTombs (SyncApp m) where
|
||
getTombs = do
|
||
SyncEnv{..} <- ask >>= orThrow PeerNotConnectedException
|
||
path <- getRunDir
|
||
|
||
mbTomb <- dirTombs & readTVarIO
|
||
<&> Map.lookup path
|
||
|
||
case mbTomb of
|
||
Just tomb -> pure tomb
|
||
Nothing -> do
|
||
-- FIXME: path-hardcode
|
||
let tombsPath = path </> ".hbs2-sync" </> "state" </> "tombs"
|
||
mkdir (dropFileName tombsPath)
|
||
stoTombs <- compactStorageOpen mempty tombsPath
|
||
atomically (modifyTVar dirTombs (Map.insert path stoTombs))
|
||
pure stoTombs
|
||
|
||
closeTombs = do
|
||
path <- getRunDir
|
||
|
||
void $ runMaybeT do
|
||
|
||
SyncEnv{..} <- lift ask >>= toMPlus
|
||
|
||
tombs <- dirTombs & readTVarIO
|
||
<&> Map.lookup path
|
||
>>= toMPlus
|
||
|
||
compactStorageClose tombs
|
||
|
||
instance MonadUnliftIO m => HasCache (SyncApp m) where
|
||
getCache = do
|
||
SyncEnv{..} <- ask >>= orThrow PeerNotConnectedException
|
||
path <- getRunDir
|
||
|
||
mbCache <- dirCache & readTVarIO
|
||
<&> Map.lookup path
|
||
|
||
case mbCache of
|
||
Just tomb -> pure tomb
|
||
Nothing -> do
|
||
-- FIXME: path-hardcode
|
||
let cachePath = path </> ".hbs2-sync" </> "state" </> "txcache"
|
||
mkdir (dropFileName cachePath)
|
||
stoCache <- compactStorageOpen mempty cachePath
|
||
atomically (modifyTVar dirCache (Map.insert path stoCache))
|
||
pure stoCache
|
||
|
||
closeCache = do
|
||
path <- getRunDir
|
||
|
||
void $ runMaybeT do
|
||
|
||
SyncEnv{..} <- lift ask >>= toMPlus
|
||
|
||
cache <- dirCache & readTVarIO
|
||
<&> Map.lookup path
|
||
>>= toMPlus
|
||
|
||
compactStorageClose cache
|
||
|
||
|
||
instance MonadUnliftIO m => HasKeyManClient (SyncApp m) where
|
||
getKeyManClientEnv = do
|
||
SyncEnv{..} <- ask >>= orThrow PeerNotConnectedException
|
||
e <- readTVarIO keymanClientEnv
|
||
|
||
case e of
|
||
Just env -> pure env
|
||
-- NOTE: race-but-harmless
|
||
-- если у нас в двух потоках позовут этот метод,
|
||
-- то будет открыто два соединения, и сохранено
|
||
-- последнее. Поскольку соединение readonly это
|
||
-- безобидно. В целом, надо навести с этим порядок
|
||
Nothing -> do
|
||
env <- KE.newKeymanClientEnv
|
||
atomically $ writeTVar keymanClientEnv (Just env)
|
||
pure env
|
||
|
||
instance MonadIO m => HasClientAPI StorageAPI UNIX (SyncApp m) where
|
||
getClientAPI = ask >>= orThrow PeerNotConnectedException
|
||
<&> storageAPI
|
||
|
||
instance MonadIO m => HasClientAPI RefChanAPI UNIX (SyncApp m) where
|
||
getClientAPI = ask >>= orThrow PeerNotConnectedException
|
||
<&> refchanAPI
|
||
|
||
instance MonadIO m => HasClientAPI PeerAPI UNIX (SyncApp m) where
|
||
getClientAPI = ask >>= orThrow PeerNotConnectedException
|
||
<&> peerAPI
|
||
|
||
instance MonadIO m => HasStorage (SyncApp m) where
|
||
getStorage = do
|
||
api <- getClientAPI @StorageAPI @UNIX
|
||
pure $ AnyStorage (StorageClient api)
|
||
|
||
withSyncApp :: SyncAppPerks m => Maybe SyncEnv -> SyncApp m a -> m a
|
||
withSyncApp env action = runReaderT (fromSyncApp action) env
|
||
|
||
runSyncApp :: SyncAppPerks m => SyncApp m a -> m a
|
||
runSyncApp m = do
|
||
setupLogger
|
||
withSyncApp Nothing m `finally` flushLoggers
|
||
|
||
recover :: SyncApp IO a -> SyncApp IO a
|
||
recover what = do
|
||
catch what $ \case
|
||
PeerNotConnectedException -> do
|
||
|
||
soname <- detectRPC
|
||
`orDie` "can't locate hbs2-peer rpc"
|
||
|
||
flip runContT pure do
|
||
|
||
client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
|
||
>>= orThrowUser ("can't connect to" <+> pretty soname)
|
||
|
||
void $ ContT $ withAsync $ runMessagingUnix client
|
||
|
||
peerAPI <- makeServiceCaller @PeerAPI (fromString soname)
|
||
refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname)
|
||
storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
|
||
|
||
-- let sto = AnyStorage (StorageClient storageAPI)
|
||
|
||
let endpoints = [ Endpoint @UNIX peerAPI
|
||
, Endpoint @UNIX refChanAPI
|
||
, Endpoint @UNIX storageAPI
|
||
]
|
||
|
||
void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
||
|
||
dsync <- newTVarIO mempty
|
||
this <- newTVarIO Nothing
|
||
tombs <- newTVarIO mempty
|
||
cache <- newTVarIO mempty
|
||
dummyKeyman <- newTVarIO Nothing
|
||
|
||
let env = Just (SyncEnv refChanAPI storageAPI peerAPI dsync this tombs cache dummyKeyman)
|
||
|
||
liftIO $ withSyncApp env what
|
||
|
||
data PeerException =
|
||
PeerNotConnectedException
|
||
deriving stock (Show, Typeable)
|
||
|
||
instance Exception PeerException
|
||
|
||
data RunDirectoryException =
|
||
RefChanNotSetException
|
||
| RefChanHeadNotFoundException
|
||
| EncryptionKeysNotDefined
|
||
| SignKeyNotSet
|
||
| DirNotSet
|
||
deriving stock (Show,Typeable)
|
||
|
||
instance Exception RunDirectoryException
|
||
|
||
removePrefix :: FilePath -> FilePath -> FilePath
|
||
removePrefix prefix path =
|
||
let prefixDirs = splitDirectories $ normalise prefix
|
||
pathDirs = splitDirectories $ normalise path
|
||
in joinPath $ fromMaybe pathDirs (stripPrefix prefixDirs pathDirs)
|
||
|
||
getFileTimestamp :: MonadUnliftIO m => FilePath -> m Word64
|
||
getFileTimestamp filePath = do
|
||
t0 <- liftIO $ getModificationTime filePath
|
||
pure (round $ utcTimeToPOSIXSeconds t0)
|
||
|
||
-- FIXME: move-to-suckless-conf
|
||
class IsContext c => ToSexp c a where
|
||
toSexp :: a -> Syntax c
|
||
|
||
|
||
|
||
newtype AsSexp c a = AsSexp a
|
||
|
||
pattern TombLikeOpt :: forall {c} . Syntax c
|
||
pattern TombLikeOpt <- ListVal [StringLike "tomb:", tombLikeValue -> True]
|
||
|
||
tombLikeValue :: Syntax c -> Bool
|
||
tombLikeValue = \case
|
||
StringLike "#t" -> True
|
||
StringLike "true" -> True
|
||
StringLike "yes" -> True
|
||
StringLike "tomb" -> True
|
||
LitBoolVal True -> True
|
||
_ -> False
|
||
|
||
instance (IsContext c, ToSexp c w) => Pretty (AsSexp c w) where
|
||
pretty (AsSexp s) = pretty (toSexp @c s)
|
||
|
||
|
||
backupMode :: (MonadUnliftIO m, HasRunDir m) => m Bool
|
||
backupMode = do
|
||
d <- getRunDir
|
||
|
||
b <- runMaybeT do
|
||
env <- getRunDirEnv d >>= toMPlus
|
||
pure $ view dirSyncBackup env
|
||
|
||
pure $ fromMaybe False b
|
||
|
||
|
||
|
||
|
||
|
||
class MonadIO m => HasRunDir m where
|
||
getRunDir :: m FilePath
|
||
getRunDirEnv :: FilePath -> m (Maybe DirSyncEnv)
|
||
alterRunDirEnv :: FilePath -> ( Maybe DirSyncEnv -> Maybe DirSyncEnv ) -> m ()
|
||
|
||
instance (MonadUnliftIO m) => HasRunDir (SyncApp m) where
|
||
getRunDir = ask >>= orThrow PeerNotConnectedException
|
||
>>= readTVarIO . dirThis
|
||
>>= orThrow DirNotSet
|
||
|
||
getRunDirEnv dir = do
|
||
env <- ask >>= orThrow PeerNotConnectedException
|
||
>>= readTVarIO . dirSyncEnv
|
||
pure $ Map.lookup dir env
|
||
|
||
alterRunDirEnv dir action = do
|
||
tenv <- ask >>= orThrow PeerNotConnectedException
|
||
<&> dirSyncEnv
|
||
atomically $ modifyTVar tenv (Map.alter action dir)
|
||
|
||
instance HasRunDir m => HasRunDir (RunM c m) where
|
||
getRunDir = lift getRunDir
|
||
getRunDirEnv d = lift (getRunDirEnv d)
|
||
alterRunDirEnv d a = lift (alterRunDirEnv d a)
|
||
|
||
instance HasRunDir m => HasRunDir (MaybeT m) where
|
||
getRunDir = lift getRunDir
|
||
getRunDirEnv d = lift (getRunDirEnv d)
|
||
alterRunDirEnv d a = lift (alterRunDirEnv d a)
|
||
|
||
instance HasRunDir m => HasRunDir (ContT r m) where
|
||
getRunDir = lift getRunDir
|
||
getRunDirEnv d = lift (getRunDirEnv d)
|
||
alterRunDirEnv d a = lift (alterRunDirEnv d a)
|
||
|
||
instance HasTombs m => HasTombs (ContT r m) where
|
||
getTombs = lift getTombs
|
||
closeTombs = lift closeTombs
|
||
|
||
instance HasTombs m => HasTombs (MaybeT m) where
|
||
getTombs = lift getTombs
|
||
closeTombs = lift closeTombs
|
||
|
||
instance (Monad m, HasTombs m) => HasTombs (RunM c m) where
|
||
getTombs = lift getTombs
|
||
closeTombs = lift closeTombs
|
||
|
||
instance HasCache m => HasCache (ContT r m) where
|
||
getCache = lift getCache
|
||
closeCache = lift closeCache
|
||
|
||
instance HasCache m => HasCache (MaybeT m) where
|
||
getCache = lift getCache
|
||
closeCache = lift closeCache
|
||
|
||
instance (Monad m, HasCache m) => HasCache (RunM c m) where
|
||
getCache = lift getCache
|
||
closeCache = lift closeCache
|
||
|
||
instance (MonadUnliftIO m, HasKeyManClient m) => HasKeyManClient (RunM c m) where
|
||
getKeyManClientEnv = lift getKeyManClientEnv
|
||
|
||
-- debugPrefix :: LoggerEntry -> LoggerEntry
|
||
debugPrefix = toStderr . logPrefix "[debug] "
|
||
|
||
setupLogger :: MonadIO m => m ()
|
||
setupLogger = do
|
||
-- setLogging @DEBUG $ toStderr . logPrefix "[debug] "
|
||
setLogging @ERROR $ toStderr . logPrefix "[error] "
|
||
setLogging @WARN $ toStderr . logPrefix "[warn] "
|
||
setLogging @NOTICE $ toStdout . logPrefix ""
|
||
pure ()
|
||
|
||
flushLoggers :: MonadIO m => m ()
|
||
flushLoggers = do
|
||
silence
|
||
|
||
silence :: MonadIO m => m ()
|
||
silence = do
|
||
setLoggingOff @DEBUG
|
||
setLoggingOff @ERROR
|
||
setLoggingOff @WARN
|
||
setLoggingOff @NOTICE
|
||
|
||
|
||
quit :: forall m . MonadUnliftIO m => m ()
|
||
quit = liftIO Exit.exitSuccess
|
||
|
||
die :: forall a m . (MonadUnliftIO m, Pretty a) => a -> m ()
|
||
die what = liftIO do
|
||
hPutDoc stderr (pretty what)
|
||
Exit.exitFailure
|
||
|
||
|
||
animateSpinner :: IO (Async ())
|
||
animateSpinner =
|
||
async $ forM_ (cycle "|/-\\") $ \c -> do
|
||
IO.putChar c
|
||
IO.hFlush IO.stdout
|
||
IO.cursorBackward 1
|
||
pause (TimeoutSec 0.25)
|
||
|
||
|
||
waitForRefchan ::
|
||
( HasClientAPI PeerAPI UNIX m
|
||
, HasClientAPI RefChanAPI UNIX m
|
||
, MonadUnliftIO m
|
||
, IsTimeout t
|
||
)
|
||
=> PubKey 'Sign 'HBS2Basic
|
||
-> Timeout t
|
||
-> m (Maybe HashRef)
|
||
waitForRefchan refchan timeout = do
|
||
peerApi <- getClientAPI @PeerAPI @UNIX
|
||
|
||
callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerApi (refchan, "refchan", 17)
|
||
>>= orThrowUser "can't subscribe to refchan"
|
||
|
||
liftIO $ putStr "waiting for refchan "
|
||
spinner <- liftIO animateSpinner
|
||
result <- race (pause timeout) (wait 1)
|
||
cancel spinner
|
||
liftIO $ do
|
||
IO.setCursorColumn 0
|
||
IO.clearLine
|
||
|
||
pure $ eitherToMaybe result
|
||
where
|
||
wait seconds = do
|
||
fetchRefChanHead @UNIX refchan
|
||
fetchRefChan @UNIX refchan
|
||
getRefChanValue @UNIX refchan >>= \case
|
||
Just value ->
|
||
pure value
|
||
|
||
Nothing -> do
|
||
pause @'Seconds seconds
|
||
wait (seconds * 2)
|