From e5931ae1108a29829745392c42abfe5cc9cf4c0b Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Wed, 7 Aug 2024 07:16:06 +0300
Subject: [PATCH] wip, nicer code

---
 .../lib/HBS2/Storage/Compact.hs               | 32 ++++++++++++++++
 hbs2-sync/src/HBS2/Sync/Prelude.hs            | 38 +++++++------------
 2 files changed, 46 insertions(+), 24 deletions(-)

diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs b/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs
index 3bcd6137..049308f2 100644
--- a/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs
+++ b/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs
@@ -6,6 +6,7 @@ module HBS2.Storage.Compact
   , CompactStorageOpenError(..)
   , CompactStorage
   , CompactStorageOpenOpt(..)
+  , CompactStorageError(..)
   , readonly
   , compactStorageOpen
   , compactStorageClose
@@ -19,7 +20,9 @@ module HBS2.Storage.Compact
   , HBS2.Storage.Compact.keys
   , HBS2.Storage.Compact.member
   , HBS2.Storage.Compact.put
+  , HBS2.Storage.Compact.putVal
   , HBS2.Storage.Compact.get
+  , HBS2.Storage.Compact.getValEither
   , HBS2.Storage.Compact.del
   , HBS2.Storage.Compact.commit
   ) where
@@ -620,6 +623,14 @@ put :: ForCompactStorage m
 
 put = compactStoragePut
 
+putVal :: forall k v m h . (ForCompactStorage m, Serialise k, Serialise v)
+       => CompactStorage h
+       -> k
+       -> v
+       -> m ()
+putVal sto k v = do
+  put sto (LBS.toStrict $ serialise k) (LBS.toStrict $ serialise v)
+
 get  :: ForCompactStorage m
      => CompactStorage k
      -> ByteString
@@ -627,6 +638,27 @@ get  :: ForCompactStorage m
 
 get = compactStorageGet
 
+data CompactStorageError =
+  DeserealiseError
+  deriving (Typeable,Show)
+
+instance Exception CompactStorageError
+
+getValEither :: forall v k m h . ( ForCompactStorage m
+                                 , Serialise k, Serialise v
+                                 )
+              => CompactStorage h
+              -> k
+              -> m (Either CompactStorageError (Maybe v))
+
+getValEither sto k = do
+  bs <- get sto (LBS.toStrict (serialise k))
+  let v = fmap (deserialiseOrFail @v . LBS.fromStrict) bs
+  case v of
+    Just (Left _)  -> pure $ Left DeserealiseError
+    Just (Right x) -> pure $ Right (Just x)
+    Nothing -> pure (Right Nothing)
+
 del :: ForCompactStorage m
      => CompactStorage k
      -> ByteString
diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs
index a15511d4..e18a5e72 100644
--- a/hbs2-sync/src/HBS2/Sync/Prelude.hs
+++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs
@@ -446,13 +446,10 @@ runDirectory = do
 
         liftIO $ setModificationTime (path </> p) timestamp
 
-        lift $ Compact.put tombs (fromString p) (LBS.toStrict (serialise (0 :: Integer)))
-
+        lift $ Compact.putVal tombs p (0 :: Integer)
 
     runDir = do
 
-      now <- liftIO $ getPOSIXTime <&> round
-
       path <- getRunDir
 
       env <- getRunDirEnv path >>= orThrow DirNotSet
@@ -479,19 +476,17 @@ runDirectory = do
           N (p,TombEntry e) -> do
             notice $ green "removed entry" <+> pretty p
 
-          D (p,e) n -> do
+          D (p,e) _ -> do
             notice $ "locally deleted file" <+> pretty p
 
-            -- FIXME: fix-copypaste
             tombs <- getTombs
-            n <- Compact.get tombs (fromString p)
-                   <&> fmap (deserialiseOrFail @Integer . LBS.fromStrict)
-                   <&> fmap (either (const Nothing) Just)
-                   <&> join
+
+            n <- Compact.getValEither @Integer tombs p
+                   <&> fromRight (Just 0)
 
             when (n < Just 2) do
               postEntryTx refchan path e
-              Compact.put tombs (fromString p) (LBS.toStrict $ serialise $ maybe 0 succ n)
+              Compact.putVal tombs p (maybe 0 succ n)
 
           N (_,_) -> none
 
@@ -532,13 +527,10 @@ runDirectory = do
               tombs <- getTombs
               postEntryTx refchan path e
 
-              -- FIXME: fix-copypaste
-              n <- Compact.get tombs (fromString p)
-                     <&> fmap (deserialiseOrFail @Integer . LBS.fromStrict)
-                     <&> fmap (either (const Nothing) Just)
-                     <&> join
+              n <- Compact.getValEither @Integer tombs p
+                    <&> fromRight (Just 0)
 
-              Compact.put tombs (fromString p) (LBS.toStrict $ serialise $ maybe 0 succ n)
+              Compact.putVal tombs p (maybe 0 succ n)
 
               notice $ red "tomb entry" <+> pretty (path </> p)
               rm fullPath
@@ -556,6 +548,7 @@ findDeleted = do
 
   tombs <- getTombs
   -- TODO: check-if-non-latin-filenames-work
+  --   resolved: ok
   seen <- Compact.keys tombs
             <&> fmap BS8.unpack
 
@@ -566,10 +559,8 @@ findDeleted = do
 
       here <- liftIO $ doesFileExist path
 
-      n <- Compact.get tombs (fromString f0)
-             <&> fmap (deserialiseOrFail @Integer . LBS.fromStrict)
-             <&> fmap (either (const Nothing) Just)
-             <&> join
+      n <- Compact.getValEither @Integer tombs f0
+            <&> fromRight (Just 0)
 
       when (not here && isJust n) do
         S.yield (D (f0, makeTomb now f0 Nothing) n)
@@ -602,10 +593,9 @@ postEntryTx refchan path entry = do
     guard (isFile entry || isTomb entry)
 
     let p = entryPath entry
-    -- FIXME: dangerous!
-    lbs <- if isTomb entry then do
-             pure ""
+    lbs <- if isTomb entry then do pure mempty
            else
+             -- FIXME: dangerous!
              liftIO (LBS.readFile (path </> p))
 
     let (dir,file) = splitFileName p