mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
2d91362466
commit
c1b3470949
|
|
@ -59,6 +59,7 @@ import Control.Monad.Trans.Cont as Exported
|
|||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Except
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Ord
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Coerce
|
||||
import Data.Either
|
||||
|
|
@ -79,8 +80,9 @@ import Data.Time.LocalTime (utcToLocalTime, getCurrentTimeZone, utc)
|
|||
import Data.Word
|
||||
import Lens.Micro.Platform
|
||||
import Streaming.Prelude qualified as S
|
||||
import System.Directory (getModificationTime,setModificationTime,doesFileExist)
|
||||
import System.Directory (getModificationTime,setModificationTime,doesFileExist,listDirectory)
|
||||
import System.FilePath.Posix
|
||||
import System.FilePattern
|
||||
import System.Exit qualified as Exit
|
||||
import UnliftIO
|
||||
|
||||
|
|
@ -255,6 +257,18 @@ data EntryDesc =
|
|||
|
||||
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
|
||||
|
||||
pattern TombEntry :: Entry -> Entry
|
||||
pattern TombEntry e <- e@(DirEntry (EntryDesc { entryType = Tomb }) _)
|
||||
|
||||
|
|
@ -291,8 +305,8 @@ instance IsContext c => ToSexp c Entry where
|
|||
toSexp (DirEntry w p) = mkForm @c "entry" [toSexp w, mkStr p]
|
||||
|
||||
|
||||
makeTomb :: Word64 -> FilePath -> Entry
|
||||
makeTomb t n = DirEntry (EntryDesc Tomb t Nothing) n
|
||||
makeTomb :: Word64 -> FilePath -> Maybe HashRef -> Entry
|
||||
makeTomb t n h = DirEntry (EntryDesc Tomb t h) n
|
||||
|
||||
entryPath :: Entry -> FilePath
|
||||
entryPath (DirEntry _ p) = p
|
||||
|
|
@ -308,6 +322,11 @@ isFile = \case
|
|||
DirEntry (EntryDesc { entryType = File}) _ -> True
|
||||
_ -> False
|
||||
|
||||
isTomb :: Entry -> Bool
|
||||
isTomb = \case
|
||||
DirEntry (EntryDesc { entryType = Tomb}) _ -> True
|
||||
_ -> False
|
||||
|
||||
isDir :: Entry -> Bool
|
||||
isDir = \case
|
||||
DirEntry (EntryDesc { entryType = Dir}) _ -> True
|
||||
|
|
@ -370,50 +389,6 @@ runDirectory = do
|
|||
|
||||
where
|
||||
|
||||
postEntryTx refchan path entry = do
|
||||
|
||||
sto <- getStorage
|
||||
|
||||
env <- getRunDirEnv path >>= orThrow DirNotSet
|
||||
|
||||
creds <- view dirSyncCreds env & orThrow DirNotSet
|
||||
|
||||
rch <- Client.getRefChanHead @UNIX refchan
|
||||
>>= orThrow RefChanHeadNotFoundException
|
||||
|
||||
let p = entryPath entry
|
||||
-- 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 <- lift $ createTreeWithMetadata sto (Just gk) meta lbs
|
||||
>>= orThrowPassIO
|
||||
|
||||
let tx = AnnotatedHashRef Nothing href
|
||||
let spk = view peerSignPk creds
|
||||
let ssk = view peerSignSk creds
|
||||
|
||||
let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx)
|
||||
|
||||
notice $ red "POST NEW REMOTE ENTRY" <+> pretty p <+> pretty href
|
||||
|
||||
postRefChanTx @UNIX refchan box
|
||||
|
||||
writeEntry path e = do
|
||||
|
||||
|
|
@ -497,10 +472,82 @@ runDirectory = do
|
|||
when (not here || older) do
|
||||
writeEntry path e
|
||||
|
||||
E (p,TombEntry e) -> do
|
||||
let fullPath = path </> p
|
||||
here <- liftIO $ doesFileExist fullPath
|
||||
when here do
|
||||
notice $ red "tomb entry" <+> pretty (path </> p)
|
||||
rm fullPath
|
||||
|
||||
E (p,_) -> do
|
||||
notice $ "skip entry" <+> pretty (path </> p)
|
||||
|
||||
|
||||
postEntryTx :: ( MonadUnliftIO m
|
||||
, HasStorage m
|
||||
, HasRunDir m
|
||||
, HasClientAPI StorageAPI UNIX m
|
||||
, HasClientAPI RefChanAPI UNIX m
|
||||
)
|
||||
=> MyRefChan
|
||||
-> FilePath
|
||||
-> Entry
|
||||
-> m ()
|
||||
postEntryTx refchan path entry = do
|
||||
|
||||
sto <- getStorage
|
||||
|
||||
env <- getRunDirEnv path >>= orThrow DirNotSet
|
||||
|
||||
creds <- view dirSyncCreds env & orThrow DirNotSet
|
||||
|
||||
rch <- Client.getRefChanHead @UNIX refchan
|
||||
>>= orThrow RefChanHeadNotFoundException
|
||||
|
||||
void $ runMaybeT do
|
||||
|
||||
guard (isFile entry || isTomb entry)
|
||||
|
||||
let p = entryPath entry
|
||||
-- FIXME: dangerous!
|
||||
lbs <- if isTomb entry then do
|
||||
pure ""
|
||||
else
|
||||
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)
|
||||
<> if not (isTomb entry) then HM.empty
|
||||
else HM.singleton "tomb" "#t"
|
||||
|
||||
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 <- lift $ createTreeWithMetadata sto (Just gk) meta lbs
|
||||
>>= orThrowPassIO
|
||||
|
||||
let tx = AnnotatedHashRef Nothing href
|
||||
let spk = view peerSignPk creds
|
||||
let ssk = view peerSignSk creds
|
||||
|
||||
let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx)
|
||||
|
||||
notice $ red "POST NEW REMOTE ENTRY" <+> pretty p <+> pretty href
|
||||
|
||||
lift $ postRefChanTx @UNIX refchan box
|
||||
|
||||
|
||||
merge :: Entry -> Entry -> Entry
|
||||
merge a b = do
|
||||
if | getEntryTimestamp a > getEntryTimestamp b -> a
|
||||
|
|
@ -549,17 +596,29 @@ mergeState orig = do
|
|||
|
||||
let files = [ (p,e) | (p,e) <- orig, isFile e ] & Map.fromListWith merge
|
||||
|
||||
let tombs = [ (p,e) | (p,e) <- orig, isTomb e ] & Map.fromListWith merge
|
||||
|
||||
let names = Map.keysSet (dirs <> files)
|
||||
|
||||
now <- liftIO $ getPOSIXTime <&> round
|
||||
|
||||
S.toList_ do
|
||||
for_ (Map.toList files) $ \(p,e@(DirEntry d _)) -> do
|
||||
if Map.member p dirs then do
|
||||
if
|
||||
| Map.member p dirs -> do
|
||||
let new = uniqName names p
|
||||
S.yield $ M (p, new, DirEntry d new)
|
||||
S.yield $ N (p, makeTomb now p)
|
||||
else
|
||||
S.yield $ N (p, makeTomb now p Nothing)
|
||||
|
||||
| Map.member p tombs -> do
|
||||
let tomb = Map.lookup p tombs
|
||||
case tomb of
|
||||
Just t | getEntryTimestamp t >= getEntryTimestamp e -> do
|
||||
S.yield $ E (p,t)
|
||||
|
||||
_ -> S.yield $ E (p,e)
|
||||
|
||||
| otherwise -> do
|
||||
S.yield $ E (p,e)
|
||||
|
||||
where
|
||||
|
|
@ -698,7 +757,16 @@ getStateFromRefChan rchan = do
|
|||
void $ runMaybeT do
|
||||
fn <- toMPlus $ headMay [ l | ListVal [StringLike "file-name:", StringLike l] <- what ]
|
||||
ts <- toMPlus $ HM.lookup txh tsmap
|
||||
let r = entriesFromFile (Just tree) ts (loc </> fn)
|
||||
let tomb = or [ True | TombLikeOpt <- what ]
|
||||
let fullPath = loc </> fn
|
||||
|
||||
debug $ red $ "META" <+> pretty what
|
||||
|
||||
if tomb then do
|
||||
lift $ S.yield $
|
||||
Map.singleton fullPath (makeTomb ts fullPath (Just tree))
|
||||
else do
|
||||
let r = entriesFromFile (Just tree) ts fullPath
|
||||
lift $ S.yield r
|
||||
|
||||
pure $ Map.toList $ Map.unionsWith merge ess0
|
||||
|
|
@ -909,6 +977,63 @@ syncEntries = do
|
|||
_ -> runDirectory
|
||||
|
||||
|
||||
entry $ bindMatch "prune" $ nil_ \case
|
||||
[] -> do
|
||||
|
||||
|
||||
path <- getRunDir
|
||||
|
||||
env <- getRunDirEnv path >>= orThrow DirNotSet
|
||||
|
||||
let excl = view dirSyncExclude env
|
||||
|
||||
let skip p = or [ i ?== p | i <- excl ]
|
||||
|
||||
dirs <- S.toList_ do
|
||||
flip fix [path] $ \next -> \case
|
||||
(d:ds) -> do
|
||||
dirs <- liftIO (listDirectory d)
|
||||
let es = [ path </> d </> x | x <- dirs, not (skip x) ]
|
||||
dd <- liftIO $ filterM doesDirectoryExist es
|
||||
S.each dd
|
||||
next (ds <> dd)
|
||||
|
||||
[] -> pure ()
|
||||
|
||||
for_ (L.sortBy (comparing Down) dirs) $ \d -> do
|
||||
pu <- liftIO (listDirectory d) <&> L.null
|
||||
when pu do
|
||||
notice $ red "prune" <+> pretty d
|
||||
rm d
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
|
||||
entry $ bindMatch "tomb" $ nil_ \case
|
||||
[StringLike p] -> do
|
||||
|
||||
path <- getRunDir
|
||||
env <- getRunDirEnv path >>= orThrow DirNotSet
|
||||
|
||||
void $ runMaybeT do
|
||||
|
||||
let fullPath = path </> p
|
||||
|
||||
rchan <- view dirSyncRefChan env
|
||||
& toMPlus
|
||||
|
||||
|
||||
here <- liftIO (doesFileExist fullPath)
|
||||
guard here
|
||||
|
||||
now <- liftIO getPOSIXTime <&> round
|
||||
|
||||
notice $ red "ABOUT TO POST TOMB TX" <+> pretty p
|
||||
lift $ postEntryTx rchan path (makeTomb now p mzero)
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
|
||||
-- debugPrefix :: LoggerEntry -> LoggerEntry
|
||||
debugPrefix = toStderr . logPrefix "[debug] "
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue