diff --git a/hbs2-cli/lib/Data/Config/Suckless/Script/File.hs b/hbs2-cli/lib/Data/Config/Suckless/Script/File.hs index 83d70ebd..893243bd 100644 --- a/hbs2-cli/lib/Data/Config/Suckless/Script/File.hs +++ b/hbs2-cli/lib/Data/Config/Suckless/Script/File.hs @@ -48,7 +48,7 @@ glob pat ignore dir action = do if not isD then do isF <- doesFileExist f - when (isF && matches pat f) do + when (isF && matches pat f && not (skip f)) do atomically $ writeTQueue q (Just f) else do co' <- (try @_ @IOError $ listDirectory f) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs index 166a321d..599f6759 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs @@ -1,6 +1,9 @@ {-# Language MultiWayIf #-} -module HBS2.CLI.Run.MetaData (metaDataEntries) where +module HBS2.CLI.Run.MetaData + ( metaDataEntries + , createTreeWithMetadata + ) where import HBS2.CLI.Prelude import HBS2.CLI.Run.Internal diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs index 73ea27e5..e864bc5e 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs @@ -9,6 +9,7 @@ import HBS2.Peer.CLI.Detect import HBS2.Peer.RPC.Client.Unix import HBS2.Peer.RPC.API.Peer import HBS2.Peer.RPC.API.RefChan +import HBS2.Peer.RPC.Client.RefChan as Client import HBS2.Storage.Operations.ByteString @@ -106,24 +107,13 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr callCC $ \exit -> do - api <- getClientAPI @RefChanAPI @UNIX - sto <- getStorage - - w <- callService @RpcRefChanHeadGet api puk - >>= orThrowUser "can't get refchan head" + w <- lift (getRefChanHeadHash @UNIX puk) hx <- ContT $ maybe1 w (pure nil) case what of "parsed" -> do - - lbz <- runExceptT (readFromMerkle sto (SimpleKey (coerce hx))) - <&> either (const Nothing) Just - - lbs <- ContT $ maybe1 lbz (pure nil) - - (_, hdblk) <- unboxSignedBox @(RefChanHeadBlock L4Proto) @'HBS2Basic lbs - & orThrowUser "can't unbox signed box" + hdblk <- lift (Client.getRefChanHead @UNIX puk) exit $ mkStr (show $ pretty hdblk) diff --git a/hbs2-core/lib/HBS2/OrDie.hs b/hbs2-core/lib/HBS2/OrDie.hs index 183c0c28..43f229a5 100644 --- a/hbs2-core/lib/HBS2/OrDie.hs +++ b/hbs2-core/lib/HBS2/OrDie.hs @@ -74,4 +74,9 @@ orThrowUser :: (OrThrow a1, MonadIO m) orThrowUser p = orThrow (userError (show p)) +orThrowPassIO :: (MonadIO m, Exception e) => Either e a -> m a +orThrowPassIO = \case + Left e -> throwIO e + Right x -> pure x + diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 877efece..2373b4b3 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -164,6 +164,9 @@ library HBS2.Peer.Proto.BrowserPlugin HBS2.Peer.RPC.Client + HBS2.Peer.RPC.Client.Internal + HBS2.Peer.RPC.Client.RefChan + HBS2.Peer.RPC.Class HBS2.Peer.RPC.API.Peer HBS2.Peer.RPC.API.RefLog diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client.hs index b52f5fe6..da9f334a 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Client.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client.hs @@ -1,11 +1,11 @@ -module HBS2.Peer.RPC.Client where +module HBS2.Peer.RPC.Client + ( module HBS2.Peer.RPC.Client + , module Exported + ) where + +import HBS2.Net.Proto.Service as Exported +import HBS2.Peer.RPC.Client.Internal as Exported -import HBS2.Net.Proto.Service - -import Data.Kind - -class Monad m => HasClientAPI (api :: [Type]) proto m where - getClientAPI :: m (ServiceCaller api proto) diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/Internal.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/Internal.hs new file mode 100644 index 00000000..3cb41159 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client/Internal.hs @@ -0,0 +1,25 @@ +module HBS2.Peer.RPC.Client.Internal + ( module HBS2.Peer.RPC.Client.Internal + , module Exported + ) where + +import HBS2.Peer.Prelude + +import HBS2.Hash as Exported +import HBS2.Data.Types.Refs as Exported + +import HBS2.Net.Proto.Service as Exported + +import Data.Kind +import Control.Exception + +data RpcClientError = + RpcNotConnectedError + | RpcTimeoutError + deriving (Eq,Typeable,Show) + +instance Exception RpcClientError + +class Monad m => HasClientAPI (api :: [Type]) proto m where + getClientAPI :: m (ServiceCaller api proto) + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs new file mode 100644 index 00000000..a97b630c --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs @@ -0,0 +1,57 @@ +{-# Language AllowAmbiguousTypes #-} +module HBS2.Peer.RPC.Client.RefChan where + +import HBS2.OrDie +import HBS2.Storage +import HBS2.Storage.Operations.ByteString +import HBS2.Data.Types.SignedBox + +import HBS2.Peer.Proto.RefChan +import HBS2.Peer.Prelude +import HBS2.Peer.RPC.API.RefChan +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client.Internal +import HBS2.Peer.RPC.Client.StorageClient + +import Data.Coerce +import Control.Monad.Except +import Control.Monad.Trans.Maybe +import UnliftIO + + +getRefChanHeadHash :: forall proto m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + ) + => PubKey 'Sign 'HBS2Basic + -> m (Maybe HashRef) +getRefChanHeadHash puk = do + api <- getClientAPI @RefChanAPI @proto + callRpcWaitMay @RpcRefChanHeadGet (TimeoutSec 1) api puk >>= \case + Nothing -> throwIO RpcTimeoutError + Just e -> pure e + + +getRefChanHead :: forall proto m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI proto m + , HasClientAPI StorageAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + , HasProtocol proto (ServiceProto StorageAPI proto) + ) + => PubKey 'Sign 'HBS2Basic + -> m (Maybe (RefChanHeadBlock L4Proto)) +getRefChanHead puk = do + + sto <- getClientAPI @StorageAPI @proto <&> AnyStorage . StorageClient + + runMaybeT do + hx <- lift (getRefChanHeadHash @proto puk) >>= toMPlus + lbs <- runExceptT (readFromMerkle sto (SimpleKey (coerce hx))) + >>= orThrowPassIO + + -- FIXME: error-on-bad-signature + (_, hdblk) <- unboxSignedBox @(RefChanHeadBlock L4Proto) @'HBS2Basic lbs + & toMPlus + + pure hdblk + diff --git a/hbs2-sync/app/Main.hs b/hbs2-sync/app/Main.hs index 33a20fff..45c94e10 100644 --- a/hbs2-sync/app/Main.hs +++ b/hbs2-sync/app/Main.hs @@ -71,5 +71,5 @@ main = do _ -> do die "command not specified; run hbs2-sync help for details" - void $ runSyncApp $ run dict cli + void $ runSyncApp $ recover $ run dict cli diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs index fad925bb..f243fb68 100644 --- a/hbs2-sync/src/HBS2/Sync/Prelude.hs +++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs @@ -8,11 +8,17 @@ import HBS2.Prelude.Plated as Exported import HBS2.Base58 import HBS2.OrDie as Exported import HBS2.Data.Types.Refs as Exported +import HBS2.Net.Auth.GroupKeySymm qualified as Symm import HBS2.Clock as Exported import HBS2.Net.Proto.Service +import HBS2.Storage +import HBS2.Storage.Operations.Class +import HBS2.Peer.Proto.RefChan import HBS2.Peer.CLI.Detect import HBS2.Peer.RPC.Client import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.Client.RefChan as Client +import HBS2.Peer.RPC.Client.StorageClient import HBS2.Peer.RPC.API.Peer import HBS2.Peer.RPC.API.RefChan import HBS2.Peer.RPC.API.RefLog @@ -21,6 +27,7 @@ import HBS2.System.Logger.Simple.ANSI as Exported import HBS2.Misc.PrettyStuff as Exported import HBS2.CLI.Run hiding (PeerException(..)) +import HBS2.CLI.Run.MetaData import Data.Config.Suckless as Exported import Data.Config.Suckless.Script as Exported @@ -30,26 +37,34 @@ import Codec.Serialise as Exported import Control.Concurrent.STM (flushTQueue) import Control.Monad.Reader as Exported import Control.Monad.Trans.Cont as Exported +import Data.ByteString.Lazy qualified as LBS import Data.Either import Data.HashMap.Strict qualified as HM import Data.HashSet qualified as HS import Data.List qualified as L import Data.List (stripPrefix) +import Data.Map (Map) +import Data.Map qualified as Map import Data.Maybe +import Data.Set qualified as Set +import Data.Set (Set) import Data.Time.Clock.POSIX import Data.Time.Clock (UTCTime) import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Time.LocalTime (utcToLocalTime, getCurrentTimeZone, utc) import Data.Word +import Lens.Micro.Platform +import Streaming.Prelude qualified as S import System.Directory (getModificationTime) import System.FilePath.Posix import UnliftIO {- HLINT ignore "Functor law" -} +{- HLINT ignore "Eta reduce" -} data SyncEnv = SyncEnv - { rechanAPI :: ServiceCaller RefChanAPI UNIX + { refchanAPI :: ServiceCaller RefChanAPI UNIX , storageAPI :: ServiceCaller StorageAPI UNIX , peerAPI :: ServiceCaller PeerAPI UNIX } @@ -66,6 +81,18 @@ newtype SyncApp m a = type SyncAppPerks m = MonadUnliftIO m +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 + withSyncApp :: SyncAppPerks m => Maybe SyncEnv -> SyncApp m a -> m a withSyncApp env action = runReaderT (fromSyncApp action) env @@ -113,7 +140,9 @@ data PeerException = instance Exception PeerException data RunDirectoryException = - RefChanNotSetException + RefChanNotSetException + | RefChanHeadNotFoundException + | EncryptionKeysNotDefined deriving stock (Show,Typeable) instance Exception RunDirectoryException @@ -143,12 +172,42 @@ data EntryDesc = data DirEntry = DirEntry EntryDesc FilePath deriving stock (Eq,Ord,Show,Data,Generic) -entriesFromLocalFile :: MonadUnliftIO m => FilePath -> FilePath -> m [DirEntry] -entriesFromLocalFile prefix fn = do - pure mempty +getEntryTimestamp :: DirEntry -> Word64 +getEntryTimestamp (DirEntry d _) = entryTimestamp d + +isFile :: DirEntry -> Bool +isFile = \case + DirEntry (EntryDesc { entryType = File}) _ -> True + _ -> False + +entriesFromLocalFile :: MonadUnliftIO m => FilePath -> FilePath -> m (Map FilePath DirEntry) +entriesFromLocalFile prefix fn' = do + + let fn0 = removePrefix prefix fn + ts <- getFileTimestamp fn + + let dirs = splitDirectories (dropFileName fn0) + & dropWhile (== ".") + + debug $ red "SOURCE" <+> pretty fn0 <+> pretty fn <+> pretty dirs + + let es = flip L.unfoldr ("",dirs) $ \case + (_,[]) -> Nothing + (p,d:ds) -> Just (dirEntry ts (p d), (p d, ds) ) + + pure $ Map.fromList [ (p, e) + | e@(DirEntry _ p) <- fileEntry ts fn0 : es + ] + + where + fn = normalise fn' + dirEntry ts p = DirEntry (EntryDesc Dir ts) p + fileEntry ts p = DirEntry (EntryDesc File ts) p runDirectory :: ( IsContext c , SyncAppPerks m + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m , Exception (BadFormException c) ) => FilePath -> RunM c m () runDirectory path = do @@ -159,13 +218,25 @@ runDirectory path = do runDir `catch` \case RefChanNotSetException -> do - warn $ "no refchan set for" <+> pretty path + err $ "no refchan set for" <+> pretty path + RefChanHeadNotFoundException -> do + err $ "no refchan head found for" <+> pretty path + EncryptionKeysNotDefined -> do + err $ "no readers defined in the refchan for " <+> pretty path + + `catch` \case + (e :: OperationError) -> do + err $ viaShow e + `finally` do warn "exiting" atomically (writeTVar t d0) where + merge :: DirEntry -> DirEntry -> DirEntry + merge a b = if getEntryTimestamp a > getEntryTimestamp b then a else b + runDir = do notice $ yellow "run directory" <+> pretty path @@ -204,11 +275,17 @@ runDirectory path = do evalTop ins - i <- atomically (flushTQueue tincl) <&> HS.fromList <&> HS.toList - e <- atomically (flushTQueue texcl) <&> HS.fromList <&> HS.toList + incl <- atomically (flushTQueue tincl) <&> HS.fromList <&> HS.toList + excl <- atomically (flushTQueue texcl) <&> HS.fromList <&> HS.toList - rc <- readTVarIO trc - >>= orThrow RefChanNotSetException + refchan <- readTVarIO trc + >>= orThrow RefChanNotSetException + + rch <- Client.getRefChanHead @UNIX refchan + >>= orThrow RefChanHeadNotFoundException + + sto <- getClientAPI @StorageAPI @UNIX + <&> AnyStorage . StorageClient debug $ "step 1" <+> "load state from refchan" debug $ "step 1.1" <+> "initial state is empty" @@ -222,14 +299,59 @@ runDirectory path = do let p0 = normalise path - glob i e path $ \fn -> do - let fn0 = removePrefix path fn - ts <- getFileTimestamp fn - debug $ yellow "file" <+> viaShow ts <+> pretty fn0 - pure True + es' <- S.toList_ $ do + glob incl excl path $ \fn -> do + let fn0 = removePrefix path fn + es <- liftIO (entriesFromLocalFile path fn) + -- debug $ yellow "file" <+> viaShow ts <+> pretty fn0 + S.each es + pure True + + debug "FUCKING GOT REFCHAN HEAD" + + let local = Map.fromList [ (p,e) | e@(DirEntry _ p) <- es' ] + let remote = Map.empty + + let merged = Map.unionWith merge local remote + + for_ (Map.toList merged) $ \(p,e) -> do + debug $ yellow "entry" <+> pretty p <+> viaShow e + + when (not (Map.member p remote) && isFile e) do + + -- FIXME: dangerous! + lbs <- liftIO (LBS.readFile (path p)) + + let (dir,file) = splitFileName p + + let meta = HM.fromList [ ("file-name", fromString file) + ] + <> case dir of + "./" -> mempty + d -> HM.singleton "location" (fromString d) + + let members = view refChanHeadReaders rch & HS.toList + + -- FIXME: support-unencrypted? + when (L.null members) do + throwIO EncryptionKeysNotDefined + + gk <- Symm.generateGroupKey @'HBS2Basic Nothing members + + -- FIXME: survive-this-error? + href <- createTreeWithMetadata sto (Just gk) meta lbs + >>= orThrowPassIO + + notice $ red "POST NEW REMOTE ENTRY" <+> pretty p <+> pretty href + + pure () + + unless (Map.member p local) do + notice $ red "WRITE NEW LOCAL ENTRY" <+> pretty p debug $ pretty ins + syncEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m () syncEntries = do