1 files changed, 61 insertions, 16 deletions
diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs
index 4bca49c..fdb587a 100644
--- a/src/Erebos/Object/Internal.hs
+++ b/src/Erebos/Object/Internal.hs
@@ -2,8 +2,9 @@ module Erebos.Object.Internal (
     Storage, PartialStorage, StorageCompleteness,
 
     Ref, PartialRef, RefDigest,
-    refDigest,
-    readRef, showRef, showRefDigest,
+    refDigest, refFromDigest,
+    readRef, showRef,
+    readRefDigest, showRefDigest,
     refDigestFromByteString, hashToRefDigest,
     copyRef, partialRef, partialRefFromDigest,
 
@@ -22,9 +23,9 @@ module Erebos.Object.Internal (
     Store, StoreRec,
     evalStore, evalStoreObject,
     storeBlob, storeRec, storeZero,
-    storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef,
-    storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef,
-    storeZRef,
+    storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef, storeWeak, storeRawWeak,
+    storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef, storeMbWeak, storeMbRawWeak,
+    storeZRef, storeZWeak,
     storeRecItems,
 
     Load, LoadRec,
@@ -33,9 +34,9 @@ module Erebos.Object.Internal (
     loadRecCurrentRef, loadRecItems,
 
     loadBlob, loadRec, loadZero,
-    loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef,
-    loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef,
-    loadTexts, loadBinaries, loadRefs, loadRawRefs,
+    loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef, loadRawWeak,
+    loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, loadMbRawWeak,
+    loadTexts, loadBinaries, loadRefs, loadRawRefs, loadRawWeaks,
     loadZRef,
 
     Stored,
@@ -74,13 +75,14 @@ import Data.Time.Calendar
 import Data.Time.Clock
 import Data.Time.Format
 import Data.Time.LocalTime
-import Data.UUID (UUID)
-import qualified Data.UUID as U
 
 import System.IO.Unsafe
 
 import Erebos.Error
 import Erebos.Storage.Internal
+import Erebos.UUID (UUID)
+import Erebos.UUID qualified as U
+import Erebos.Util
 
 
 zeroRef :: Storage' c -> Ref' c
@@ -121,6 +123,7 @@ copyRecItem' st = \case
     RecDate x -> return $ return $ RecDate x
     RecUUID x -> return $ return $ RecUUID x
     RecRef x -> fmap RecRef <$> copyRef' st x
+    RecWeak x -> return $ return $ RecWeak x
     RecUnknown t x -> return $ return $ RecUnknown t x
 
 copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c'))
@@ -164,6 +167,7 @@ data RecItem' c
     | RecDate ZonedTime
     | RecUUID UUID
     | RecRef (Ref' c)
+    | RecWeak RefDigest
     | RecUnknown ByteString ByteString
     deriving (Show)
 
@@ -202,6 +206,7 @@ serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex x, BC.single
 serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pack (formatTime defaultTimeLocale "%s %z" x), BC.singleton '\n']
 serializeRecItem name (RecUUID x) = [name, BC.pack ":u", BC.singleton ' ', U.toASCIIBytes x, BC.singleton '\n']
 serializeRecItem name (RecRef x) = [name, BC.pack ":r ", showRef x, BC.singleton '\n']
+serializeRecItem name (RecWeak x) = [name, BC.pack ":w ", showRefDigest x, BC.singleton '\n']
 serializeRecItem name (RecUnknown t x) = [ name, BC.singleton ':', t, BC.singleton ' ', x, BC.singleton '\n' ]
 
 lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c)
@@ -268,6 +273,7 @@ unsafeDeserializeObject st bytes =
                           "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content)
                           "u" -> RecUUID <$> U.fromASCIIBytes content
                           "r" -> RecRef . Ref st <$> readRefDigest content
+                          "w" -> RecWeak <$> readRefDigest content
                           _   -> Nothing
               return (name, val)
 
@@ -518,6 +524,33 @@ storeZRef name x = StoreRecM $ do
         return $ if isZeroRef ref then []
                                   else [(BC.pack name, RecRef ref)]
 
+storeWeak :: Storable a => StorageCompleteness c => String -> a -> StoreRec c
+storeWeak name x = StoreRecM $ do
+    s <- ask
+    tell $ (:[]) $ do
+        ref <- store s x
+        return [ ( BC.pack name, RecWeak $ refDigest ref ) ]
+
+storeMbWeak :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c
+storeMbWeak name = maybe (return ()) (storeWeak name)
+
+storeRawWeak :: StorageCompleteness c => String -> RefDigest -> StoreRec c
+storeRawWeak name dgst = StoreRecM $ do
+    tell $ (:[]) $ do
+        return [ ( BC.pack name, RecWeak dgst ) ]
+
+storeMbRawWeak :: StorageCompleteness c => String -> Maybe RefDigest -> StoreRec c
+storeMbRawWeak name = maybe (return ()) (storeRawWeak name)
+
+storeZWeak :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c
+storeZWeak name x = StoreRecM $ do
+    s <- ask
+    tell $ (:[]) $ do
+        ref <- store s x
+        return $ if isZeroRef ref then []
+                                  else [ ( BC.pack name, RecWeak $ refDigest ref ) ]
+
+
 storeRecItems :: StorageCompleteness c => [ ( ByteString, RecItem ) ] -> StoreRec c
 storeRecItems items = StoreRecM $ do
     st <- ask
@@ -654,8 +687,21 @@ loadZRef name = loadMbRef name >>= \case
                                   return $ fromZero st
                     Just x  -> return x
 
+loadRawWeak :: String -> LoadRec RefDigest
+loadRawWeak name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbRawWeak name
+
+loadMbRawWeak :: String -> LoadRec (Maybe RefDigest)
+loadMbRawWeak name = listToMaybe <$> loadRawWeaks name
+
+loadRawWeaks :: String -> LoadRec [ RefDigest ]
+loadRawWeaks name = mapMaybe p <$> loadRecItems
+  where
+    bname = BC.pack name
+    p ( name', RecRef x )  | name' == bname = Just (refDigest x)
+    p ( name', RecWeak x ) | name' == bname = Just x
+    p _                                     = Nothing
+
 
-type Stored a = Stored' Complete a
 
 instance Storable a => Storable (Stored a) where
     store st = copyRef st . storedRef
@@ -666,10 +712,10 @@ instance ZeroStorable a => ZeroStorable (Stored a) where
     fromZero st = Stored (zeroRef st) $ fromZero st
 
 fromStored :: Stored a -> a
-fromStored (Stored _ x) = x
+fromStored = storedObject'
 
 storedRef :: Stored a -> Ref
-storedRef (Stored ref _) = ref
+storedRef = storedRef'
 
 wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a)
 wrappedStore st x = do ref <- liftIO $ store st x
@@ -678,9 +724,8 @@ wrappedStore st x = do ref <- liftIO $ store st x
 wrappedLoad :: Storable a => Ref -> Stored a
 wrappedLoad ref = Stored ref (load ref)
 
-copyStored :: forall c c' m a. (StorageCompleteness c, StorageCompleteness c', MonadIO m) =>
-    Storage' c' -> Stored' c a -> m (LoadResult c (Stored' c' a))
-copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (flip Stored x) <$> copyRef' st ref'
+copyStored :: forall m a. MonadIO m => Storage -> Stored a -> m (Stored a)
+copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (\r -> Stored r x) <$> copyRef' st ref'
 
 -- |Passed function needs to preserve the object representation to be safe
 unsafeMapStored :: (a -> b) -> Stored a -> Stored b