28 files changed, 1515 insertions, 1138 deletions
diff --git a/src/Erebos/Attach.hs b/src/Erebos/Attach.hs
index bd2f521..e0a240e 100644
--- a/src/Erebos/Attach.hs
+++ b/src/Erebos/Attach.hs
@@ -16,11 +16,11 @@ import qualified Data.Text as T
 
 import Erebos.Identity
 import Erebos.Network
+import Erebos.Object.Internal
 import Erebos.Pairing
 import Erebos.PubKey
 import Erebos.Service
 import Erebos.State
-import Erebos.Storage
 import Erebos.Storage.Key
 
 type AttachService = PairingService AttachIdentity
diff --git a/src/Erebos/Channel.hs b/src/Erebos/Channel.hs
index 5f66637..c17c9ab 100644
--- a/src/Erebos/Channel.hs
+++ b/src/Erebos/Channel.hs
@@ -26,8 +26,8 @@ import Data.ByteString.Lazy qualified as BL
 import Data.List
 
 import Erebos.Identity
+import Erebos.Object.Internal
 import Erebos.PubKey
-import Erebos.Storage
 
 data Channel = Channel
     { chPeers :: [Stored (Signed IdentityData)]
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
index ae373b6..25c8c17 100644
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -11,6 +11,10 @@ module Erebos.Chatroom (
     findChatroomByRoomData,
     findChatroomByStateData,
     chatroomSetSubscribe,
+    chatroomMembers,
+    joinChatroom, joinChatroomByStateData,
+    joinChatroomAs, joinChatroomAsByStateData,
+    leaveChatroom, leaveChatroomByStateData,
     getMessagesSinceState,
 
     ChatroomSetChange(..),
@@ -33,6 +37,8 @@ import Control.Monad.IO.Class
 
 import Data.Bool
 import Data.Either
+import Data.Foldable
+import Data.Function
 import Data.IORef
 import Data.List
 import Data.Maybe
@@ -43,11 +49,11 @@ import Data.Text (Text)
 import Data.Time
 
 import Erebos.Identity
+import Erebos.Object.Internal
 import Erebos.PubKey
 import Erebos.Service
 import Erebos.Set
 import Erebos.State
-import Erebos.Storage
 import Erebos.Storage.Merge
 import Erebos.Util
 
@@ -180,27 +186,31 @@ sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStat
 sendChatroomMessageByStateData
     :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
     => Stored ChatroomStateData -> Text -> m ()
-sendChatroomMessageByStateData lookupData msg = void $ findAndUpdateChatroomState $ \cstate -> do
+sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing Nothing (Just msg) False
+
+sendRawChatroomMessageByStateData
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => Stored ChatroomStateData -> Maybe UnifiedIdentity -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m ()
+sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do
     guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
     Just $ do
-        self <- finalOwner . localIdentity . fromStored <$> getLocalHead
-        secret <- loadKey $ idKeyMessage self
-        time <- liftIO getZonedTime
-        mdata <- mstore =<< sign secret =<< mstore ChatMessageData
-            { mdPrev = roomStateMessageData cstate
-            , mdRoom = if null (roomStateMessageData cstate)
-                          then maybe [] roomData (roomStateRoom cstate)
-                          else []
-            , mdFrom = self
-            , mdReplyTo = Nothing
-            , mdTime = time
-            , mdText = Just msg
-            , mdLeave = False
-            }
+        mdFrom <- finalOwner <$> if
+            | Just identity <- mbIdentity -> return identity
+            | Just identity <- roomStateIdentity cstate -> return identity
+            | otherwise -> localIdentity . fromStored <$> getLocalHead
+        secret <- loadKey $ idKeyMessage mdFrom
+        mdTime <- liftIO getZonedTime
+        let mdPrev = roomStateMessageData cstate
+            mdRoom = if null (roomStateMessageData cstate)
+                        then maybe [] roomData (roomStateRoom cstate)
+                        else []
+
+        mdata <- mstore =<< sign secret =<< mstore ChatMessageData {..}
         mergeSorted . (:[]) <$> mstore ChatroomStateData
             { rsdPrev = roomStateData cstate
             , rsdRoom = []
-            , rsdSubscribe = Just True
+            , rsdSubscribe = Just (not mdLeave)
+            , rsdIdentity = mbIdentity
             , rsdMessages = [ mdata ]
             }
 
@@ -209,6 +219,7 @@ data ChatroomStateData = ChatroomStateData
     { rsdPrev :: [Stored ChatroomStateData]
     , rsdRoom :: [Stored (Signed ChatroomData)]
     , rsdSubscribe :: Maybe Bool
+    , rsdIdentity :: Maybe UnifiedIdentity
     , rsdMessages :: [Stored (Signed ChatMessageData)]
     }
 
@@ -217,6 +228,7 @@ data ChatroomState = ChatroomState
     , roomStateRoom :: Maybe Chatroom
     , roomStateMessageData :: [Stored (Signed ChatMessageData)]
     , roomStateSubscribe :: Bool
+    , roomStateIdentity :: Maybe UnifiedIdentity
     , roomStateMessages :: [ChatMessage]
     }
 
@@ -225,12 +237,14 @@ instance Storable ChatroomStateData where
         forM_ rsdPrev $ storeRef "PREV"
         forM_ rsdRoom $ storeRef "room"
         forM_ rsdSubscribe $ storeInt "subscribe" . bool @Int 0 1
+        forM_ rsdIdentity $ storeRef "id" . idExtData
         forM_ rsdMessages $ storeRef "msg"
 
     load' = loadRec $ do
         rsdPrev <- loadRefs "PREV"
         rsdRoom <- loadRefs "room"
         rsdSubscribe <- fmap ((/=) @Int 0) <$> loadMbInt "subscribe"
+        rsdIdentity <- loadMbUnifiedIdentity "id"
         rsdMessages <- loadRefs "msg"
         return ChatroomStateData {..}
 
@@ -244,6 +258,7 @@ instance Mergeable ChatroomState where
                 ChatroomStateData {..} | null rsdMessages -> Nothing
                                        | otherwise        -> Just rsdMessages
             roomStateSubscribe = fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData
+            roomStateIdentity = findPropertyFirst rsdIdentity roomStateData
             roomStateMessages = threadToListSince [] $ concatMap (rsdMessages . fromStored) roomStateData
          in ChatroomState {..}
 
@@ -261,6 +276,7 @@ createChatroom rdName rdDescription = do
         { rsdPrev = []
         , rsdRoom = [ rdata ]
         , rsdSubscribe = Just True
+        , rsdIdentity = Nothing
         , rsdMessages = []
         }
 
@@ -308,6 +324,7 @@ updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomStat
             { rsdPrev = roomStateData cstate
             , rsdRoom = [ rdata ]
             , rsdSubscribe = Just True
+            , rsdIdentity = Nothing
             , rsdMessages = []
             }
 
@@ -338,9 +355,50 @@ chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $
             { rsdPrev = roomStateData cstate
             , rsdRoom = []
             , rsdSubscribe = Just subscribe
+            , rsdIdentity = Nothing
             , rsdMessages = []
             }
 
+chatroomMembers :: ChatroomState -> [ ComposedIdentity ]
+chatroomMembers ChatroomState {..} =
+    map (mdFrom . fromSigned . head) $
+    filter (any $ not . mdLeave . fromSigned) $ -- keep only users that hasn't left
+    map (filterAncestors . map snd) $ -- gather message data per each identity and filter ancestors
+    groupBy ((==) `on` fst) $ -- group on identity root
+    sortBy (comparing fst) $ -- sort by first root of identity data
+    map (\x -> ( head . filterAncestors . concatMap storedRoots . idDataF . mdFrom . fromSigned $ x, x )) $
+    toList $ ancestors $ roomStateMessageData
+
+joinChatroom
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => ChatroomState -> m ()
+joinChatroom rstate = joinChatroomByStateData (head $ roomStateData rstate)
+
+joinChatroomByStateData
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => Stored ChatroomStateData -> m ()
+joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing False
+
+joinChatroomAs
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => UnifiedIdentity -> ChatroomState -> m ()
+joinChatroomAs identity rstate = joinChatroomAsByStateData identity (head $ roomStateData rstate)
+
+joinChatroomAsByStateData
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => UnifiedIdentity -> Stored ChatroomStateData -> m ()
+joinChatroomAsByStateData identity lookupData = sendRawChatroomMessageByStateData lookupData (Just identity) Nothing Nothing False
+
+leaveChatroom
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => ChatroomState -> m ()
+leaveChatroom rstate = leaveChatroomByStateData (head $ roomStateData rstate)
+
+leaveChatroomByStateData
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => Stored ChatroomStateData -> m ()
+leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing True
+
 getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage]
 getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur)
 
@@ -463,6 +521,7 @@ instance Service ChatroomService where
                                 { rsdPrev = prev
                                 , rsdRoom = room
                                 , rsdSubscribe = Nothing
+                                , rsdIdentity = Nothing
                                 , rsdMessages = []
                                 }
                             storeSetAddComponent sdata set
@@ -507,6 +566,7 @@ instance Service ChatroomService where
                                     { rsdPrev = prevData
                                     , rsdRoom = []
                                     , rsdSubscribe = Nothing
+                                    , rsdIdentity = Nothing
                                     , rsdMessages = messages
                                     }
                                 storeSetAddComponent sdata set
diff --git a/src/Erebos/Contact.hs b/src/Erebos/Contact.hs
index d90aa50..0af434f 100644
--- a/src/Erebos/Contact.hs
+++ b/src/Erebos/Contact.hs
@@ -23,12 +23,12 @@ import qualified Data.Text as T
 
 import Erebos.Identity
 import Erebos.Network
+import Erebos.Object.Internal
 import Erebos.Pairing
 import Erebos.PubKey
 import Erebos.Service
 import Erebos.Set
 import Erebos.State
-import Erebos.Storage
 import Erebos.Storage.Merge
 
 data Contact = Contact
diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs
index 63475bd..4c68830 100644
--- a/src/Erebos/Conversation.hs
+++ b/src/Erebos/Conversation.hs
@@ -29,11 +29,11 @@ import Data.Text qualified as T
 import Data.Time.Format
 import Data.Time.LocalTime
 
-import Erebos.Identity
 import Erebos.Chatroom
+import Erebos.Identity
 import Erebos.Message hiding (formatMessage)
+import Erebos.Object.Internal
 import Erebos.State
-import Erebos.Storage
 
 
 data Message = DirectMessageMessage DirectMessage Bool
diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs
index 48df9c3..d89a7fa 100644
--- a/src/Erebos/Discovery.hs
+++ b/src/Erebos/Discovery.hs
@@ -19,8 +19,8 @@ import Network.Socket
 import Erebos.ICE
 import Erebos.Identity
 import Erebos.Network
+import Erebos.Object.Internal
 import Erebos.Service
-import Erebos.Storage
 
 
 keepaliveSeconds :: Int
diff --git a/src/Erebos/ICE.chs b/src/Erebos/ICE.chs
index 096ee0d..787ce51 100644
--- a/src/Erebos/ICE.chs
+++ b/src/Erebos/ICE.chs
@@ -40,7 +40,7 @@ import Foreign.Ptr
 import Foreign.StablePtr
 
 import Erebos.Flow
-import Erebos.Storage
+import Erebos.Object.Internal
 
 #include "pjproject.h"
 
diff --git a/src/Erebos/ICE/pjproject.c b/src/Erebos/ICE/pjproject.c
index bb06b1f..d3037bf 100644
--- a/src/Erebos/ICE/pjproject.c
+++ b/src/Erebos/ICE/pjproject.c
@@ -172,7 +172,7 @@ pj_ice_strans * ice_create(pj_ice_sess_role role, HsStablePtr sptr, HsStablePtr
 
 	pj_ice_strans * res;
 
-	struct user_data * udata = malloc(sizeof(struct user_data));
+	struct user_data * udata = calloc( 1, sizeof( struct user_data ));
 	udata->role = role;
 	udata->sptr = sptr;
 	udata->cb_init = cb;
@@ -213,7 +213,9 @@ ssize_t ice_encode_session(pj_ice_strans * strans, char * ufrag, char * pass,
 	pj_str_t local_ufrag, local_pwd;
 	pj_status_t status;
 
-	pj_ice_strans_get_ufrag_pwd(strans, &local_ufrag, &local_pwd, NULL, NULL);
+	status = pj_ice_strans_get_ufrag_pwd( strans, &local_ufrag, &local_pwd, NULL, NULL );
+	if( status != PJ_SUCCESS )
+		return -status;
 
 	n = snprintf(ufrag, maxlen, "%.*s", (int) local_ufrag.slen, local_ufrag.ptr);
 	if (n < 0 || n == maxlen)
diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs
index 8761fde..fdfacfc 100644
--- a/src/Erebos/Identity.hs
+++ b/src/Erebos/Identity.hs
@@ -13,7 +13,7 @@ module Erebos.Identity (
     createIdentity,
     validateIdentity, validateIdentityF, validateIdentityFE,
     validateExtendedIdentity, validateExtendedIdentityF, validateExtendedIdentityFE,
-    loadIdentity, loadUnifiedIdentity,
+    loadIdentity, loadMbIdentity, loadUnifiedIdentity, loadMbUnifiedIdentity,
 
     mergeIdentity, toUnifiedIdentity, toComposedIdentity,
     updateIdentity, updateOwners,
@@ -35,14 +35,13 @@ import Data.Foldable
 import Data.Function
 import Data.List
 import Data.Maybe
-import Data.Ord
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
 
+import Erebos.Object.Internal
 import Erebos.PubKey
-import Erebos.Storage
 import Erebos.Storage.Merge
 import Erebos.Util
 
@@ -283,9 +282,15 @@ validateExtendedIdentityFE mdata = do
 loadIdentity :: String -> LoadRec ComposedIdentity
 loadIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name
 
+loadMbIdentity :: String -> LoadRec (Maybe ComposedIdentity)
+loadMbIdentity name = return . validateExtendedIdentityF =<< loadRefs name
+
 loadUnifiedIdentity :: String -> LoadRec UnifiedIdentity
 loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentity =<< loadRef name
 
+loadMbUnifiedIdentity :: String -> LoadRec (Maybe UnifiedIdentity)
+loadMbUnifiedIdentity name = return . (validateExtendedIdentity =<<) =<< loadMbRef name
+
 
 gatherPrevious :: Set (Stored (Signed ExtendedIdentityData)) -> [Stored (Signed ExtendedIdentityData)] -> Set (Stored (Signed ExtendedIdentityData))
 gatherPrevious res (n:ns) | n `S.member` res = gatherPrevious res ns
@@ -304,25 +309,18 @@ verifySignatures sidd = do
         throwError "signature verification failed"
 
 lookupProperty :: forall a m. Foldable m => (ExtendedIdentityData -> Maybe a) -> m (Stored (Signed ExtendedIdentityData)) -> Maybe a
-lookupProperty sel topHeads = findResult filteredLayers
-    where findPropHeads :: Stored (Signed ExtendedIdentityData) -> [(Stored (Signed ExtendedIdentityData), a)]
-          findPropHeads sobj | Just x <- sel $ fromSigned sobj = [(sobj, x)]
-                             | otherwise = findPropHeads =<< (eiddPrev $ fromSigned sobj)
-
-          propHeads :: [(Stored (Signed ExtendedIdentityData), a)]
-          propHeads = findPropHeads =<< toList topHeads
-
-          historyLayers :: [Set (Stored (Signed ExtendedIdentityData))]
-          historyLayers = generations $ map fst propHeads
+lookupProperty sel topHeads = findResult propHeads
+  where
+    findPropHeads :: Stored (Signed ExtendedIdentityData) -> [ Stored (Signed ExtendedIdentityData) ]
+    findPropHeads sobj | Just _ <- sel $ fromSigned sobj = [ sobj ]
+                       | otherwise = findPropHeads =<< (eiddPrev $ fromSigned sobj)
 
-          filteredLayers :: [[(Stored (Signed ExtendedIdentityData), a)]]
-          filteredLayers = scanl (\cur obsolete -> filter ((`S.notMember` obsolete) . fst) cur) propHeads historyLayers
+    propHeads :: [ Stored (Signed ExtendedIdentityData) ]
+    propHeads = filterAncestors $ findPropHeads =<< toList topHeads
 
-          findResult ([(_, x)] : _) = Just x
-          findResult ([] : _) = Nothing
-          findResult [] = Nothing
-          findResult [xs] = Just $ snd $ minimumBy (comparing fst) xs
-          findResult (_:rest) = findResult rest
+    findResult :: [ Stored (Signed ExtendedIdentityData) ] -> Maybe a
+    findResult [] = Nothing
+    findResult xs = sel $ fromSigned $ minimum xs
 
 mergeIdentity :: (MonadStorage m, MonadError String m, MonadIO m) => Identity f -> m UnifiedIdentity
 mergeIdentity idt | Just idt' <- toUnifiedIdentity idt = return idt'
@@ -385,8 +383,9 @@ updateOwners updates orig@Identity { idOwner_ = Just owner, idUpdates_ = cupdate
 updateOwners _ orig@Identity { idOwner_ = Nothing } = orig
 
 sameIdentity :: (Foldable m, Foldable m') => Identity m -> Identity m' -> Bool
-sameIdentity x y = not $ S.null $ S.intersection (refset x) (refset y)
-    where refset idt = foldr S.insert (ancestors $ toList $ idDataF idt) (idDataF idt)
+sameIdentity x y = intersectsSorted (roots x) (roots y)
+  where
+    roots idt = uniq $ sort $ concatMap storedRoots $ toList $ idDataF idt
 
 
 unfoldOwners :: (Foldable m) => Identity m -> [ComposedIdentity]
diff --git a/src/Erebos/Message.hs b/src/Erebos/Message.hs
index 5ef27f3..a558d1a 100644
--- a/src/Erebos/Message.hs
+++ b/src/Erebos/Message.hs
@@ -31,9 +31,9 @@ import Data.Time.LocalTime
 
 import Erebos.Identity
 import Erebos.Network
+import Erebos.Object.Internal
 import Erebos.Service
 import Erebos.State
-import Erebos.Storage
 import Erebos.Storage.Merge
 
 data DirectMessage = DirectMessage
diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs
index 402e163..358bb7c 100644
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -54,16 +54,19 @@ import GHC.Conc.Sync (unsafeIOToSTM)
 import Network.Socket hiding (ControlMessage)
 import qualified Network.Socket.ByteString as S
 
+import Foreign.C.Types
+import Foreign.Marshal.Alloc
+
 import Erebos.Channel
 #ifdef ENABLE_ICE_SUPPORT
 import Erebos.ICE
 #endif
 import Erebos.Identity
 import Erebos.Network.Protocol
+import Erebos.Object.Internal
 import Erebos.PubKey
 import Erebos.Service
 import Erebos.State
-import Erebos.Storage
 import Erebos.Storage.Key
 import Erebos.Storage.Merge
 
@@ -71,6 +74,9 @@ import Erebos.Storage.Merge
 discoveryPort :: PortNumber
 discoveryPort = 29665
 
+discoveryMulticastGroup :: HostAddress6
+discoveryMulticastGroup = tupleToHostAddress6 (0xff12, 0xb6a4, 0x6b1f, 0x0969, 0xcaee, 0xacc2, 0x5c93, 0x73e1) -- ff12:b6a4:6b1f:969:caee:acc2:5c93:73e1
+
 announceIntervalSeconds :: Int
 announceIntervalSeconds = 60
 
@@ -249,8 +255,6 @@ startServer opt serverOrigHead logd' serverServices = do
         either (atomically . logd) return =<< runExceptT =<<
             atomically (readTQueue serverIOActions)
 
-    broadcastAddreses <- getBroadcastAddresses discoveryPort
-
     let open addr = do
             sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
             putMVar serverSocket sock
@@ -261,9 +265,14 @@ startServer opt serverOrigHead logd' serverServices = do
             return sock
 
         loop sock = do
-            when (serverLocalDiscovery opt) $ forkServerThread server $ forever $ do
-                atomically $ writeFlowBulk serverControlFlow $ map (SendAnnounce . DatagramAddress) broadcastAddreses
-                threadDelay $ announceIntervalSeconds * 1000 * 1000
+            when (serverLocalDiscovery opt) $ forkServerThread server $ do
+                announceAddreses <- fmap concat $ sequence $
+                    [ map (SockAddrInet6 discoveryPort 0 discoveryMulticastGroup) <$> joinMulticast sock
+                    , getBroadcastAddresses discoveryPort
+                    ]
+                forever $ do
+                    atomically $ writeFlowBulk serverControlFlow $ map (SendAnnounce . DatagramAddress) announceAddreses
+                    threadDelay $ announceIntervalSeconds * 1000 * 1000
 
             let announceUpdate identity = do
                     st <- derivePartialStorage serverStorage
@@ -535,8 +544,12 @@ handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs =
                         liftSTM $ finalizedChannel peer ch identity
                     _ -> return ()
 
-            Rejected dgst -> do
-                logd $ "rejected by peer: " ++ show dgst
+            Rejected dgst
+                | peerRequest : _ <- mapMaybe (\case TrChannelRequest d -> Just d; _ -> Nothing) headers
+                , peerRequest < dgst
+                -> return () -- Our request was rejected due to lower priority
+
+                | otherwise -> logd $ "rejected by peer: " ++ show dgst
 
             DataRequest dgst
                 | secure || dgst `elem` plaintextRefs -> do
@@ -607,9 +620,15 @@ handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs =
                     ChannelCookieWait {} -> return ()
                     ChannelCookieReceived {} -> process
                     ChannelCookieConfirmed {} -> process
-                    ChannelOurRequest our | dgst < refDigest (storedRef our) -> process
-                                          | otherwise -> reject
-                    ChannelPeerRequest {} -> process
+                    ChannelOurRequest our
+                        | dgst < refDigest (storedRef our) -> process
+                        | otherwise -> do
+                            -- Reject peer channel request with lower priority
+                            addHeader $ TrChannelRequest $ refDigest $ storedRef our
+                            reject
+                    ChannelPeerRequest prev
+                        | dgst == wrDigest prev -> addHeader $ Acknowledged dgst
+                        | otherwise -> process
                     ChannelOurAccept {} -> reject
                     ChannelEstablished {} -> process
                     ChannelClosed {} -> return ()
@@ -661,12 +680,14 @@ setupChannel identity peer upid = do
             [ TrChannelRequest reqref
             , AnnounceSelf $ refDigest $ storedRef $ idData identity
             ]
+    let sendChannelRequest = do
+            sendToPeerPlain peer [ Acknowledged reqref, Rejected reqref ] $
+                TransportPacket (TransportHeader hitems) [storedRef req]
+            setPeerChannel peer $ ChannelOurRequest req
     liftIO $ atomically $ do
         getPeerChannel peer >>= \case
-            ChannelCookieConfirmed -> do
-                sendToPeerPlain peer [ Acknowledged reqref, Rejected reqref ] $
-                    TransportPacket (TransportHeader hitems) [storedRef req]
-                setPeerChannel peer $ ChannelOurRequest req
+            ChannelCookieReceived -> sendChannelRequest
+            ChannelCookieConfirmed -> sendChannelRequest
             _ -> return ()
 
 handleChannelRequest :: Peer -> UnifiedIdentity -> Ref -> WaitingRefCallback
@@ -932,9 +953,19 @@ runPeerServiceOn mbservice peer handler = liftIO $ do
             logd $ "unhandled service '" ++ show (toUUID svc) ++ "'"
 
 
+foreign import ccall unsafe "Network/ifaddrs.h join_multicast" cJoinMulticast :: CInt -> Ptr CSize -> IO (Ptr Word32)
 foreign import ccall unsafe "Network/ifaddrs.h broadcast_addresses" cBroadcastAddresses :: IO (Ptr Word32)
 foreign import ccall unsafe "stdlib.h free" cFree :: Ptr Word32 -> IO ()
 
+joinMulticast :: Socket -> IO [ Word32 ]
+joinMulticast sock =
+    withFdSocket sock $ \fd ->
+    alloca $ \pcount -> do
+        ptr <- cJoinMulticast fd pcount
+        count <- fromIntegral <$> peek pcount
+        forM [ 0 .. count - 1 ] $ \i ->
+            peekElemOff ptr i
+
 getBroadcastAddresses :: PortNumber -> IO [SockAddr]
 getBroadcastAddresses port = do
     ptr <- cBroadcastAddresses
diff --git a/src/Erebos/Network.hs-boot b/src/Erebos/Network.hs-boot
index 849bfc1..af77581 100644
--- a/src/Erebos/Network.hs-boot
+++ b/src/Erebos/Network.hs-boot
@@ -1,6 +1,6 @@
 module Erebos.Network where
 
-import Erebos.Storage
+import Erebos.Object.Internal
 
 data Server
 data Peer
diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs
index d759994..bceb355 100644
--- a/src/Erebos/Network/Protocol.hs
+++ b/src/Erebos/Network/Protocol.hs
@@ -40,7 +40,17 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Trans
 
+import Crypto.Cipher.ChaChaPoly1305 qualified as C
+import Crypto.MAC.Poly1305 qualified as C (Auth(..), authTag)
+import Crypto.Error
+import Crypto.Random
+
+import Data.Binary
+import Data.Binary.Get
+import Data.Binary.Put
 import Data.Bits
+import Data.ByteArray (Bytes, ScrubbedBytes)
+import Data.ByteArray qualified as BA
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as B
 import Data.ByteString.Char8 qualified as BC
@@ -51,15 +61,14 @@ import Data.Maybe
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Void
-import Data.Word
 
 import System.Clock
 
 import Erebos.Channel
 import Erebos.Flow
 import Erebos.Identity
+import Erebos.Object.Internal
 import Erebos.Service
-import Erebos.Storage
 
 
 protocolVersion :: Text
@@ -104,6 +113,35 @@ data SecurityRequirement = PlaintextOnly
                          | EncryptedOnly
     deriving (Eq, Ord)
 
+data ParsedCookie = ParsedCookie
+    { cookieNonce :: C.Nonce
+    , cookieValidity :: Word32
+    , cookieContent :: ByteString
+    , cookieMac :: C.Auth
+    }
+
+instance Eq ParsedCookie where
+    (==) = (==) `on` (\c -> ( BA.convert (cookieNonce c) :: ByteString, cookieValidity c, cookieContent c, cookieMac c ))
+
+instance Show ParsedCookie where
+    show ParsedCookie {..} = show (nonce, cookieValidity, cookieContent, mac)
+      where C.Auth mac = cookieMac
+            nonce = BA.convert cookieNonce :: ByteString
+
+instance Binary ParsedCookie where
+    put ParsedCookie {..} = do
+        putByteString $ BA.convert cookieNonce
+        putWord32be cookieValidity
+        putByteString $ BA.convert cookieMac
+        putByteString cookieContent
+
+    get = do
+        Just cookieNonce <- maybeCryptoError . C.nonce12 <$> getByteString 12
+        cookieValidity <- getWord32be
+        Just cookieMac <- maybeCryptoError . C.authTag <$> getByteString 16
+        cookieContent <- BL.toStrict <$> getRemainingLazyByteString
+        return ParsedCookie {..}
+
 isHeaderItemAcknowledged :: TransportHeaderItem -> Bool
 isHeaderItemAcknowledged = \case
     Acknowledged {} -> False
@@ -168,9 +206,12 @@ data GlobalState addr = (Eq addr, Show addr) => GlobalState
     , gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
     , gLog :: String -> STM ()
     , gStorage :: PartialStorage
+    , gStartTime :: TimeSpec
     , gNowVar :: TVar TimeSpec
     , gNextTimeout :: TVar TimeSpec
     , gInitConfig :: Ref
+    , gCookieKey :: ScrubbedBytes
+    , gCookieStartTime :: Word32
     }
 
 data Connection addr = Connection
@@ -444,11 +485,14 @@ erebosNetworkProtocol initialIdentity gLog gDataFlow gControlFlow = do
     mStorage <- memoryStorage
     gStorage <- derivePartialStorage mStorage
 
-    startTime <- getTime Monotonic
-    gNowVar <- newTVarIO startTime
-    gNextTimeout <- newTVarIO startTime
+    gStartTime <- getTime Monotonic
+    gNowVar <- newTVarIO gStartTime
+    gNextTimeout <- newTVarIO gStartTime
     gInitConfig <- store mStorage $ (Rec [] :: Object)
 
+    gCookieKey <- getRandomBytes 32
+    gCookieStartTime <- runGet getWord32host . BL.pack . BA.unpack @ScrubbedBytes <$> getRandomBytes 4
+
     let gs = GlobalState {..}
 
     let signalTimeouts = forever $ do
@@ -702,11 +746,38 @@ generateCookieHeaders Connection {..} ch = catMaybes <$> sequence [ echoHeader,
         _ -> return Nothing
 
 createCookie :: GlobalState addr -> addr -> IO Cookie
-createCookie GlobalState {} addr = return (Cookie $ BC.pack $ show addr)
+createCookie GlobalState {..} addr = do
+    (nonceBytes :: Bytes) <- getRandomBytes 12
+    validUntil <- (fromNanoSecs (60 * 10^(9 :: Int)) +) <$> getTime Monotonic
+    let validSecondsFromStart = fromIntegral $ toNanoSecs (validUntil - gStartTime) `div` (10^(9 :: Int))
+        cookieValidity = validSecondsFromStart - gCookieStartTime
+        plainContent = BC.pack (show addr)
+    throwCryptoErrorIO $ do
+        cookieNonce <- C.nonce12 nonceBytes
+        st1 <- C.initialize gCookieKey cookieNonce
+        let st2 = C.finalizeAAD $ C.appendAAD (BL.toStrict $ runPut $ putWord32be cookieValidity) st1
+            (cookieContent, st3) = C.encrypt plainContent st2
+            cookieMac = C.finalize st3
+        return $ Cookie $ BL.toStrict $ encode $ ParsedCookie {..}
 
 verifyCookie :: GlobalState addr -> addr -> Cookie -> IO Bool
-verifyCookie GlobalState {} addr (Cookie cookie) = return $ show addr == BC.unpack cookie
-
+verifyCookie GlobalState {..} addr (Cookie cookie) = do
+    ctime <- getTime Monotonic
+    return $ fromMaybe False $ do
+        ( _, _, ParsedCookie {..} ) <- either (const Nothing) Just $ decodeOrFail $ BL.fromStrict cookie
+        maybeCryptoError $ do
+            st1 <- C.initialize gCookieKey cookieNonce
+            let st2 = C.finalizeAAD $ C.appendAAD (BL.toStrict $ runPut $ putWord32be cookieValidity) st1
+                (plainContent, st3) = C.decrypt cookieContent st2
+                mac = C.finalize st3
+
+                validSecondsFromStart = fromIntegral $ cookieValidity + gCookieStartTime
+                validUntil = gStartTime + fromNanoSecs (validSecondsFromStart * (10^(9 :: Int)))
+            return $ and
+                [ mac == cookieMac
+                , ctime <= validUntil
+                , show addr == BC.unpack plainContent
+                ]
 
 reservePacket :: Connection addr -> STM ReservedToSend
 reservePacket conn@Connection {..} = do
@@ -891,6 +962,7 @@ processOutgoing gs@GlobalState {..} = do
                     now <- readTVar gNowVar
                     if next <= now
                       then do
+                        writeTVar cNextKeepAlive Nothing
                         identity <- fst <$> readTVar gIdentity
                         let header = TransportHeader [ AnnounceSelf $ refDigest $ storedRef $ idData identity ]
                         writeTQueue cSecureOutQueue (EncryptedOnly, TransportPacket header [], [])
diff --git a/src/Erebos/Network/ifaddrs.c b/src/Erebos/Network/ifaddrs.c
index efeca18..637716e 100644
--- a/src/Erebos/Network/ifaddrs.c
+++ b/src/Erebos/Network/ifaddrs.c
@@ -1,13 +1,91 @@
 #include "ifaddrs.h"
 
-#ifndef _WIN32
+#include <errno.h>
+#include <stdbool.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
 
+#ifndef _WIN32
 #include <arpa/inet.h>
-#include <ifaddrs.h>
 #include <net/if.h>
-#include <stdlib.h>
-#include <sys/types.h>
+#include <ifaddrs.h>
 #include <endian.h>
+#include <sys/types.h>
+#include <sys/socket.h>
+#else
+#include <winsock2.h>
+#include <ws2ipdef.h>
+#include <ws2tcpip.h>
+#endif
+
+#define DISCOVERY_MULTICAST_GROUP "ff12:b6a4:6b1f:969:caee:acc2:5c93:73e1"
+
+uint32_t * join_multicast(int fd, size_t * count)
+{
+	size_t capacity = 16;
+	*count = 0;
+	uint32_t * interfaces = malloc(sizeof(uint32_t) * capacity);
+
+#ifdef _WIN32
+	interfaces[0] = 0;
+	*count = 1;
+#else
+	struct ifaddrs * addrs;
+	if (getifaddrs(&addrs) < 0)
+		return 0;
+
+	for (struct ifaddrs * ifa = addrs; ifa; ifa = ifa->ifa_next) {
+		if( ifa->ifa_addr && ifa->ifa_addr->sa_family == AF_INET6 &&
+				! (ifa->ifa_flags & IFF_LOOPBACK) &&
+				(ifa->ifa_flags & IFF_MULTICAST) &&
+				! IN6_IS_ADDR_LINKLOCAL( & ((struct sockaddr_in6 *) ifa->ifa_addr)->sin6_addr ) ){
+			int idx = if_nametoindex(ifa->ifa_name);
+
+			bool seen = false;
+			for (size_t i = 0; i < *count; i++) {
+				if (interfaces[i] == idx) {
+					seen = true;
+					break;
+				}
+			}
+			if (seen)
+				continue;
+
+			if (*count + 1 >= capacity) {
+				capacity *= 2;
+				uint32_t * nret = realloc(interfaces, sizeof(uint32_t) * capacity);
+				if (nret) {
+					interfaces = nret;
+				} else {
+					free(interfaces);
+					*count = 0;
+					return NULL;
+				}
+			}
+
+			interfaces[*count] = idx;
+			(*count)++;
+		}
+	}
+
+	freeifaddrs(addrs);
+#endif
+
+	for (size_t i = 0; i < *count; i++) {
+		struct ipv6_mreq group;
+		group.ipv6mr_interface = interfaces[i];
+		inet_pton(AF_INET6, DISCOVERY_MULTICAST_GROUP, &group.ipv6mr_multiaddr);
+		int ret = setsockopt(fd, IPPROTO_IPV6, IPV6_ADD_MEMBERSHIP,
+				(const void *) &group, sizeof(group));
+		if (ret < 0)
+			fprintf(stderr, "IPV6_ADD_MEMBERSHIP failed: %s\n", strerror(errno));
+	}
+
+	return interfaces;
+}
+
+#ifndef _WIN32
 
 uint32_t * broadcast_addresses(void)
 {
diff --git a/src/Erebos/Network/ifaddrs.h b/src/Erebos/Network/ifaddrs.h
index 06d26ec..8852ec6 100644
--- a/src/Erebos/Network/ifaddrs.h
+++ b/src/Erebos/Network/ifaddrs.h
@@ -1,3 +1,5 @@
+#include <stddef.h>
 #include <stdint.h>
 
+uint32_t * join_multicast(int fd, size_t * count);
 uint32_t * broadcast_addresses(void);
diff --git a/src/Erebos/Object.hs b/src/Erebos/Object.hs
new file mode 100644
index 0000000..26ca09f
--- /dev/null
+++ b/src/Erebos/Object.hs
@@ -0,0 +1,22 @@
+{-|
+Description: Core Erebos objects and references
+
+Data types and functions for working with "raw" Erebos objects and references.
+-}
+
+module Erebos.Object (
+    Object, PartialObject, Object'(..),
+    serializeObject, deserializeObject, deserializeObjects,
+    ioLoadObject, ioLoadBytes,
+    storeRawBytes, lazyLoadBytes,
+
+    RecItem, RecItem'(..),
+
+    Ref, PartialRef, RefDigest,
+    refDigest,
+    readRef, showRef, showRefDigest,
+    refDigestFromByteString, hashToRefDigest,
+    copyRef, partialRef, partialRefFromDigest,
+) where
+
+import Erebos.Object.Internal
diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs
new file mode 100644
index 0000000..312c3af
--- /dev/null
+++ b/src/Erebos/Object/Internal.hs
@@ -0,0 +1,1087 @@
+module Erebos.Object.Internal (
+    Storage, PartialStorage, StorageCompleteness,
+    openStorage, memoryStorage,
+    deriveEphemeralStorage, derivePartialStorage,
+
+    Ref, PartialRef, RefDigest,
+    refDigest,
+    readRef, showRef, showRefDigest,
+    refDigestFromByteString, hashToRefDigest,
+    copyRef, partialRef, partialRefFromDigest,
+
+    Object, PartialObject, Object'(..), RecItem, RecItem'(..),
+    serializeObject, deserializeObject, deserializeObjects,
+    ioLoadObject, ioLoadBytes,
+    storeRawBytes, lazyLoadBytes,
+    storeObject,
+    collectObjects, collectStoredObjects,
+
+    Head, HeadType(..),
+    HeadTypeID, mkHeadTypeID,
+    headId, headStorage, headRef, headObject, headStoredObject,
+    loadHeads, loadHead, reloadHead,
+    storeHead, replaceHead, updateHead, updateHead_,
+    loadHeadRaw, storeHeadRaw, replaceHeadRaw,
+
+    WatchedHead,
+    watchHead, watchHeadWith, unwatchHead,
+    watchHeadRaw,
+
+    MonadStorage(..),
+
+    Storable(..), ZeroStorable(..),
+    StorableText(..), StorableDate(..), StorableUUID(..),
+
+    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,
+    storeRecItems,
+
+    Load, LoadRec,
+    evalLoad,
+    loadCurrentRef, loadCurrentObject,
+    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,
+    loadZRef,
+
+    Stored,
+    fromStored, storedRef,
+    wrappedStore, wrappedLoad,
+    copyStored,
+    unsafeMapStored,
+
+    StoreInfo(..), makeStoreInfo,
+
+    StoredHistory,
+    fromHistory, fromHistoryAt, storedFromHistory, storedHistoryList,
+    beginHistory, modifyHistory,
+) where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.Writer
+
+import Crypto.Hash
+
+import Data.Bifunctor
+import Data.ByteString (ByteString)
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Lazy.Char8 as BLC
+import Data.Char
+import Data.Function
+import qualified Data.HashTable.IO as HT
+import Data.List
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Ratio
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding
+import Data.Text.Encoding.Error
+import Data.Time.Calendar
+import Data.Time.Clock
+import Data.Time.Format
+import Data.Time.LocalTime
+import Data.Typeable
+import Data.UUID (UUID)
+import qualified Data.UUID as U
+import qualified Data.UUID.V4 as U
+
+import System.Directory
+import System.FSNotify
+import System.FilePath
+import System.IO.Error
+import System.IO.Unsafe
+
+import Erebos.Storage.Internal
+
+
+type Storage = Storage' Complete
+type PartialStorage = Storage' Partial
+
+storageVersion :: String
+storageVersion = "0.1"
+
+openStorage :: FilePath -> IO Storage
+openStorage path = modifyIOError annotate $ do
+    let versionFileName = "erebos-storage"
+    let versionPath = path </> versionFileName
+    let writeVersionFile = writeFileOnce versionPath $ BLC.pack $ storageVersion <> "\n"
+
+    maybeVersion <- handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
+        Just <$> readFile versionPath
+    version <- case maybeVersion of
+        Just versionContent -> do
+            return $ takeWhile (/= '\n') versionContent
+
+        Nothing -> do
+            files <- handleJust (guard . isDoesNotExistError) (const $ return []) $
+                listDirectory path
+            when (not $ or
+                    [ null files
+                    , versionFileName `elem` files
+                    , (versionFileName ++ ".lock") `elem` files
+                    , "objects" `elem` files && "heads" `elem` files
+                    ]) $ do
+                fail "directory is neither empty, nor an existing erebos storage"
+
+            createDirectoryIfMissing True $ path
+            writeVersionFile
+            takeWhile (/= '\n') <$> readFile versionPath
+
+    when (version /= storageVersion) $ do
+        fail $ "unsupported storage version " <> version
+
+    createDirectoryIfMissing True $ path </> "objects"
+    createDirectoryIfMissing True $ path </> "heads"
+    watchers <- newMVar (Nothing, [], WatchList 1 [])
+    refgen <- newMVar =<< HT.new
+    refroots <- newMVar =<< HT.new
+    return $ Storage
+        { stBacking = StorageDir path watchers
+        , stParent = Nothing
+        , stRefGeneration = refgen
+        , stRefRoots = refroots
+        }
+  where
+    annotate e = annotateIOError e "failed to open storage" Nothing (Just path)
+
+memoryStorage' :: IO (Storage' c')
+memoryStorage' = do
+    backing <- StorageMemory <$> newMVar [] <*> newMVar M.empty <*> newMVar M.empty <*> newMVar (WatchList 1 [])
+    refgen <- newMVar =<< HT.new
+    refroots <- newMVar =<< HT.new
+    return $ Storage
+        { stBacking = backing
+        , stParent = Nothing
+        , stRefGeneration = refgen
+        , stRefRoots = refroots
+        }
+
+memoryStorage :: IO Storage
+memoryStorage = memoryStorage'
+
+deriveEphemeralStorage :: Storage -> IO Storage
+deriveEphemeralStorage parent = do
+    st <- memoryStorage
+    return $ st { stParent = Just parent }
+
+derivePartialStorage :: Storage -> IO PartialStorage
+derivePartialStorage parent = do
+    st <- memoryStorage'
+    return $ st { stParent = Just parent }
+
+type Ref = Ref' Complete
+type PartialRef = Ref' Partial
+
+zeroRef :: Storage' c -> Ref' c
+zeroRef s = Ref s (RefDigest h)
+    where h = case digestFromByteString $ B.replicate (hashDigestSize $ digestAlgo h) 0 of
+                   Nothing -> error $ "Failed to create zero hash"
+                   Just h' -> h'
+          digestAlgo :: Digest a -> a
+          digestAlgo = undefined
+
+isZeroRef :: Ref' c -> Bool
+isZeroRef (Ref _ h) = all (==0) $ BA.unpack h
+
+
+refFromDigest :: Storage' c -> RefDigest -> IO (Maybe (Ref' c))
+refFromDigest st dgst = fmap (const $ Ref st dgst) <$> ioLoadBytesFromStorage st dgst
+
+readRef :: Storage -> ByteString -> IO (Maybe Ref)
+readRef s b =
+    case readRefDigest b of
+         Nothing -> return Nothing
+         Just dgst -> refFromDigest s dgst
+
+copyRef' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (c (Ref' c'))
+copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> return $ return ref
+                                                                Nothing  -> doCopy
+    where doCopy = do mbobj' <- ioLoadObject ref'
+                      mbobj <- sequence $ copyObject' st <$> mbobj'
+                      sequence $ unsafeStoreObject st <$> join mbobj
+
+copyRecItem' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> RecItem' c -> IO (c (RecItem' c'))
+copyRecItem' st = \case
+    RecEmpty -> return $ return $ RecEmpty
+    RecInt x -> return $ return $ RecInt x
+    RecNum x -> return $ return $ RecNum x
+    RecText x -> return $ return $ RecText x
+    RecBinary x -> return $ return $ RecBinary x
+    RecDate x -> return $ return $ RecDate x
+    RecUUID x -> return $ return $ RecUUID x
+    RecRef x -> fmap RecRef <$> copyRef' st 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'))
+copyObject' _ (Blob bs) = return $ return $ Blob bs
+copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM (\( n, item ) -> fmap ( n, ) <$> copyRecItem' st item) rs
+copyObject' _ ZeroObject = return $ return ZeroObject
+copyObject' _ (UnknownObject otype content) = return $ return $ UnknownObject otype content
+
+copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c'))
+copyRef st ref' = liftIO $ returnLoadResult <$> copyRef' st ref'
+
+copyRecItem :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> RecItem' c -> m (LoadResult c (RecItem' c'))
+copyRecItem st item' = liftIO $ returnLoadResult <$> copyRecItem' st item'
+
+copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c'))
+copyObject st obj' = returnLoadResult <$> copyObject' st obj'
+
+partialRef :: PartialStorage -> Ref -> PartialRef
+partialRef st (Ref _ dgst) = Ref st dgst
+
+partialRefFromDigest :: PartialStorage -> RefDigest -> PartialRef
+partialRefFromDigest st dgst = Ref st dgst
+
+
+data Object' c
+    = Blob ByteString
+    | Rec [(ByteString, RecItem' c)]
+    | ZeroObject
+    | UnknownObject ByteString ByteString
+    deriving (Show)
+
+type Object = Object' Complete
+type PartialObject = Object' Partial
+
+data RecItem' c
+    = RecEmpty
+    | RecInt Integer
+    | RecNum Rational
+    | RecText Text
+    | RecBinary ByteString
+    | RecDate ZonedTime
+    | RecUUID UUID
+    | RecRef (Ref' c)
+    | RecUnknown ByteString ByteString
+    deriving (Show)
+
+type RecItem = RecItem' Complete
+
+serializeObject :: Object' c -> BL.ByteString
+serializeObject = \case
+    Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]
+    Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec
+                in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt
+    ZeroObject -> BL.empty
+    UnknownObject otype cnt -> BL.fromChunks [ otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ]
+
+-- |Serializes and stores object data without ony dependencies, so is safe only
+-- if all the referenced objects are already stored or reference is partial.
+unsafeStoreObject :: Storage' c -> Object' c -> IO (Ref' c)
+unsafeStoreObject storage = \case
+    ZeroObject -> return $ zeroRef storage
+    obj -> unsafeStoreRawBytes storage $ serializeObject obj
+
+storeObject :: PartialStorage -> PartialObject -> IO PartialRef
+storeObject = unsafeStoreObject
+
+storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef
+storeRawBytes = unsafeStoreRawBytes
+
+serializeRecItem :: ByteString -> RecItem' c -> [ByteString]
+serializeRecItem name (RecEmpty) = [name, BC.pack ":e", BC.singleton ' ', BC.singleton '\n']
+serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n']
+serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n']
+serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n']
+    where escaped = BC.concatMap escape $ encodeUtf8 x
+          escape '\n' = BC.pack "\n\t"
+          escape c    = BC.singleton c
+serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex x, BC.singleton '\n']
+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 (RecUnknown t x) = [ name, BC.singleton ':', t, BC.singleton ' ', x, BC.singleton '\n' ]
+
+lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c)
+lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject
+
+ioLoadObject :: forall c. StorageCompleteness c => Ref' c -> IO (c (Object' c))
+ioLoadObject ref | isZeroRef ref = return $ return ZeroObject
+ioLoadObject ref@(Ref st rhash) = do
+    file' <- ioLoadBytes ref
+    return $ do
+        file <- file'
+        let chash = hashToRefDigest file
+        when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -}
+        return $ case runExcept $ unsafeDeserializeObject st file of
+                      Left err -> error $ err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -}
+                      Right (x, rest) | BL.null rest -> x
+                                      | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -}
+
+lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.ByteString
+lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString)
+lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref
+
+unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except String (Object' c, BL.ByteString)
+unsafeDeserializeObject _  bytes | BL.null bytes = return (ZeroObject, bytes)
+unsafeDeserializeObject st bytes =
+    case BLC.break (=='\n') bytes of
+        (line, rest) | Just (otype, len) <- splitObjPrefix line -> do
+            let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest
+            guard $ B.length content == len
+            (,next) <$> case otype of
+                 _ | otype == BC.pack "blob" -> return $ Blob content
+                   | otype == BC.pack "rec" -> maybe (throwError $ "Malformed record item ")
+                                                   (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content
+                   | otherwise -> return $ UnknownObject otype content
+        _ -> throwError $ "Malformed object"
+    where splitObjPrefix line = do
+              [otype, tlen] <- return $ BLC.words line
+              (len, rest) <- BLC.readInt tlen
+              guard $ BL.null rest
+              return (BL.toStrict otype, len)
+
+          mergeCont cs (a:b:rest) | Just ('\t', b') <- BC.uncons b = mergeCont (b':BC.pack "\n":cs) (a:rest)
+          mergeCont cs (a:rest) = B.concat (a : reverse cs) : mergeCont [] rest
+          mergeCont _ [] = []
+
+          parseRecLine line = do
+              colon <- BC.elemIndex ':' line
+              space <- BC.elemIndex ' ' line
+              guard $ colon < space
+              let name = B.take colon line
+                  itype = B.take (space-colon-1) $ B.drop (colon+1) line
+                  content = B.drop (space+1) line
+
+              let val = fromMaybe (RecUnknown itype content) $
+                      case BC.unpack itype of
+                          "e" -> do guard $ B.null content
+                                    return RecEmpty
+                          "i" -> do (num, rest) <- BC.readInteger content
+                                    guard $ B.null rest
+                                    return $ RecInt num
+                          "n" -> RecNum <$> parseRatio content
+                          "t" -> return $ RecText $ decodeUtf8With lenientDecode content
+                          "b" -> RecBinary <$> readHex content
+                          "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content)
+                          "u" -> RecUUID <$> U.fromASCIIBytes content
+                          "r" -> RecRef . Ref st <$> readRefDigest content
+                          _   -> Nothing
+              return (name, val)
+
+deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString)
+deserializeObject = unsafeDeserializeObject
+
+deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject]
+deserializeObjects _  bytes | BL.null bytes = return []
+deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes
+                                 (obj:) <$> deserializeObjects st rest
+
+
+collectObjects :: Object -> [Object]
+collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj)
+
+collectStoredObjects :: Stored Object -> [Stored Object]
+collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj)
+
+collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest)
+collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items
+    where helper (RecRef ref) (xs, s) | r <- refDigest ref
+                                      , r `S.notMember` s
+                                      = let o = wrappedLoad ref
+                                            (xs', s') = collectOtherStored (S.insert r s) $ fromStored o
+                                         in ((o : xs') ++ xs, s')
+          helper _          (xs, s) = (xs, s)
+collectOtherStored seen _ = ([], seen)
+
+
+type Head = Head' Complete
+
+headId :: Head a -> HeadID
+headId (Head uuid _) = uuid
+
+headStorage :: Head a -> Storage
+headStorage = refStorage . headRef
+
+headRef :: Head a -> Ref
+headRef (Head _ sx) = storedRef sx
+
+headObject :: Head a -> a
+headObject (Head _ sx) = fromStored sx
+
+headStoredObject :: Head a -> Stored a
+headStoredObject (Head _ sx) = sx
+
+deriving instance StorableUUID HeadID
+deriving instance StorableUUID HeadTypeID
+
+mkHeadTypeID :: String -> HeadTypeID
+mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString
+
+class Storable a => HeadType a where
+    headTypeID :: proxy a -> HeadTypeID
+
+
+headTypePath :: FilePath -> HeadTypeID -> FilePath
+headTypePath spath (HeadTypeID tid) = spath </> "heads" </> U.toString tid
+
+headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath
+headPath spath tid (HeadID hid) = headTypePath spath tid </> U.toString hid
+
+loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a]
+loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = liftIO $ do
+    let hpath = headTypePath spath $ headTypeID @a Proxy
+
+    files <- filterM (doesFileExist . (hpath </>)) =<<
+        handleJust (\e -> guard (isDoesNotExistError e)) (const $ return [])
+        (getDirectoryContents hpath)
+    fmap catMaybes $ forM files $ \hname -> do
+        case U.fromString hname of
+             Just hid -> do
+                 (h:_) <- BC.lines <$> B.readFile (hpath </> hname)
+                 Just ref <- readRef s h
+                 return $ Just $ Head (HeadID hid) $ wrappedLoad ref
+             Nothing -> return Nothing
+loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = liftIO $ do
+    let toHead ((tid, hid), ref) | tid == headTypeID @a Proxy = Just $ Head hid $ wrappedLoad ref
+                                 | otherwise                  = Nothing
+    catMaybes . map toHead <$> readMVar theads
+
+loadHead :: forall a m. (HeadType a, MonadIO m) => Storage -> HeadID -> m (Maybe (Head a))
+loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid
+
+loadHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> m (Maybe Ref)
+loadHeadRaw s@(Storage { stBacking = StorageDir { dirPath = spath }}) tid hid = liftIO $ do
+    handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do
+        (h:_) <- BC.lines <$> B.readFile (headPath spath tid hid)
+        Just ref <- readRef s h
+        return $ Just ref
+loadHeadRaw Storage { stBacking = StorageMemory { memHeads = theads } } tid hid = liftIO $ do
+    lookup (tid, hid) <$> readMVar theads
+
+reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a))
+reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid
+
+storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a)
+storeHead st obj = do
+    let tid = headTypeID @a Proxy
+    stored <- wrappedStore st obj
+    hid <- storeHeadRaw st tid (storedRef stored)
+    return $ Head hid stored
+
+storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID
+storeHeadRaw st tid ref = liftIO $ do
+    hid <- HeadID <$> U.nextRandom
+    case stBacking st of
+         StorageDir { dirPath = spath } -> do
+             Right () <- writeFileChecked (headPath spath tid hid) Nothing $
+                 showRef ref `B.append` BC.singleton '\n'
+             return ()
+         StorageMemory { memHeads = theads } -> do
+             modifyMVar_ theads $ return . (((tid, hid), ref) :)
+    return hid
+
+replaceHead :: forall a m. (HeadType a, MonadIO m) => Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a))
+replaceHead prev@(Head hid pobj) stored' = liftIO $ do
+    let st = headStorage prev
+        tid = headTypeID @a Proxy
+    stored <- copyStored st stored'
+    bimap (fmap $ Head hid . wrappedLoad) (const $ Head hid stored) <$>
+        replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored)
+
+replaceHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> Ref -> Ref -> m (Either (Maybe Ref) Ref)
+replaceHeadRaw st tid hid prev new = liftIO $ do
+    case stBacking st of
+         StorageDir { dirPath = spath } -> do
+             let filename = headPath spath tid hid
+                 showRefL r = showRef r `B.append` BC.singleton '\n'
+
+             writeFileChecked filename (Just $ showRefL prev) (showRefL new) >>= \case
+                 Left Nothing -> return $ Left Nothing
+                 Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs
+                                      return $ Left $ Just oref
+                 Right () -> return $ Right new
+
+         StorageMemory { memHeads = theads, memWatchers = twatch } -> do
+             res <- modifyMVar theads $ \hs -> do
+                 ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar twatch
+                 return $ case partition ((==(tid, hid)) . fst) hs of
+                     ([] , _  ) -> (hs, Left Nothing)
+                     ((_, r):_, hs') | r == prev -> (((tid, hid), new) : hs',
+                                                                  Right (new, ws))
+                                     | otherwise -> (hs, Left $ Just r)
+             case res of
+                  Right (r, ws) -> mapM_ ($ r) ws >> return (Right r)
+                  Left x -> return $ Left x
+
+updateHead :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b)
+updateHead h f = do
+    (o, x) <- f $ headStoredObject h
+    replaceHead h o >>= \case
+        Right h' -> return (Just h', x)
+        Left Nothing -> return (Nothing, x)
+        Left (Just h') -> updateHead h' f
+
+updateHead_ :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a)) -> m (Maybe (Head a))
+updateHead_ h = fmap fst . updateHead h . (fmap (,()) .)
+
+
+data WatchedHead = forall a. WatchedHead Storage WatchID (MVar a)
+
+watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHead
+watchHead h = watchHeadWith h id
+
+watchHeadWith :: forall a b. (HeadType a, Eq b) => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead
+watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do
+    watchHeadRaw st (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb
+
+watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead
+watchHeadRaw st tid hid sel cb = do
+    memo <- newEmptyMVar
+    let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo)
+            where wl' = wl { wlNext = wlNext wl + 1
+                           , wlList = WatchListItem
+                               { wlID = wlNext wl
+                               , wlHead = (tid, hid)
+                               , wlFun = \r -> do
+                                   let x = sel r
+                                   modifyMVar_ memo $ \prev -> do
+                                       when (Just x /= prev) $ cb x
+                                       return $ Just x
+                               } : wlList wl
+                           }
+
+    watched <- case stBacking st of
+         StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do
+             manager <- maybe startManager return mbmanager
+             ilist' <- case tid `elem` ilist of
+                 True -> return ilist
+                 False -> do
+                     void $ watchDir manager (headTypePath spath tid) (const True) $ \case
+                         Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do
+                             loadHeadRaw st tid ihid >>= \case
+                                 Just ref -> do
+                                     (_, _, iwl) <- readMVar mvar
+                                     mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl
+                                 Nothing -> return ()
+                         _ -> return ()
+                     return $ tid : ilist
+             return $ first ( Just manager, ilist', ) $ addWatcher wl
+
+         StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher
+
+    cur <- fmap sel <$> loadHeadRaw st tid hid
+    maybe (return ()) cb cur
+    putMVar memo cur
+
+    return watched
+
+unwatchHead :: WatchedHead -> IO ()
+unwatchHead (WatchedHead st wid _) = do
+    let delWatcher wl = wl { wlList = filter ((/=wid) . wlID) $ wlList wl }
+    case stBacking st of
+        StorageDir { dirWatchers = mvar } -> modifyMVar_ mvar $ return . second delWatcher
+        StorageMemory { memWatchers = mvar } -> modifyMVar_ mvar $ return . delWatcher
+
+
+class Monad m => MonadStorage m where
+    getStorage :: m Storage
+    mstore :: Storable a => a -> m (Stored a)
+
+    default mstore :: MonadIO m => Storable a => a -> m (Stored a)
+    mstore x = do
+        st <- getStorage
+        wrappedStore st x
+
+instance MonadIO m => MonadStorage (ReaderT Storage m) where
+    getStorage = ask
+
+instance MonadIO m => MonadStorage (ReaderT (Head a) m) where
+    getStorage = asks $ headStorage
+
+
+class Storable a where
+    store' :: a -> Store
+    load' :: Load a
+
+    store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c)
+    store st = evalStore st . store'
+    load :: Ref -> a
+    load = evalLoad load'
+
+class Storable a => ZeroStorable a where
+    fromZero :: Storage -> a
+
+data Store = StoreBlob ByteString
+           | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]])
+           | StoreZero
+           | StoreUnknown ByteString ByteString
+
+evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c)
+evalStore st = unsafeStoreObject st <=< evalStoreObject st
+
+evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c)
+evalStoreObject _ (StoreBlob x) = return $ Blob x
+evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s)
+evalStoreObject _ StoreZero = return ZeroObject
+evalStoreObject _ (StoreUnknown otype content) = return $ UnknownObject otype content
+
+newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a)
+    deriving (Functor, Applicative, Monad)
+
+type StoreRec c = StoreRecM c ()
+
+newtype Load a = Load (ReaderT (Ref, Object) (Except String) a)
+    deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String)
+
+evalLoad :: Load a -> Ref -> a
+evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ")++)) id $ runExcept $ runReaderT f (ref, lazyLoadObject ref)
+
+loadCurrentRef :: Load Ref
+loadCurrentRef = Load $ asks fst
+
+loadCurrentObject :: Load Object
+loadCurrentObject = Load $ asks snd
+
+newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a)
+    deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String)
+
+loadRecCurrentRef :: LoadRec Ref
+loadRecCurrentRef = LoadRec $ asks fst
+
+loadRecItems :: LoadRec [(ByteString, RecItem)]
+loadRecItems = LoadRec $ asks snd
+
+
+instance Storable Object where
+    store' (Blob bs) = StoreBlob bs
+    store' (Rec xs) = StoreRec $ \st -> return $ do
+        Rec xs' <- copyObject st (Rec xs)
+        return xs'
+    store' ZeroObject = StoreZero
+    store' (UnknownObject otype content) = StoreUnknown otype content
+
+    load' = loadCurrentObject
+
+    store st = unsafeStoreObject st <=< copyObject st
+    load = lazyLoadObject
+
+instance Storable ByteString where
+    store' = storeBlob
+    load' = loadBlob id
+
+instance Storable a => Storable [a] where
+    store' []     = storeZero
+    store' (x:xs) = storeRec $ do
+        storeRef "i" x
+        storeRef "n" xs
+
+    load' = loadCurrentObject >>= \case
+                ZeroObject -> return []
+                _          -> loadRec $ (:)
+                                  <$> loadRef "i"
+                                  <*> loadRef "n"
+
+instance Storable a => ZeroStorable [a] where
+    fromZero _ = []
+
+
+storeBlob :: ByteString -> Store
+storeBlob = StoreBlob
+
+storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store
+storeRec sr = StoreRec $ do
+    let StoreRecM r = sr
+    execWriter . runReaderT r
+
+storeZero :: Store
+storeZero = StoreZero
+
+
+class StorableText a where
+    toText :: a -> Text
+    fromText :: MonadError String m => Text -> m a
+
+instance StorableText Text where
+    toText = id; fromText = return
+
+instance StorableText [Char] where
+    toText = T.pack; fromText = return . T.unpack
+
+
+class StorableDate a where
+    toDate :: a -> ZonedTime
+    fromDate :: ZonedTime -> a
+
+instance StorableDate ZonedTime where
+    toDate = id; fromDate = id
+
+instance StorableDate UTCTime where
+    toDate = utcToZonedTime utc
+    fromDate = zonedTimeToUTC
+
+instance StorableDate Day where
+    toDate day = toDate $ UTCTime day 0
+    fromDate = utctDay . fromDate
+
+
+class StorableUUID a where
+    toUUID :: a -> UUID
+    fromUUID :: UUID -> a
+
+instance StorableUUID UUID where
+    toUUID = id; fromUUID = id
+
+
+storeEmpty :: String -> StoreRec c
+storeEmpty name = StoreRecM $ tell [return [(BC.pack name, RecEmpty)]]
+
+storeMbEmpty :: String -> Maybe () -> StoreRec c
+storeMbEmpty name = maybe (return ()) (const $ storeEmpty name)
+
+storeInt :: Integral a => String -> a -> StoreRec c
+storeInt name x = StoreRecM $ tell [return [(BC.pack name, RecInt $ toInteger x)]]
+
+storeMbInt :: Integral a => String -> Maybe a -> StoreRec c
+storeMbInt name = maybe (return ()) (storeInt name)
+
+storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c
+storeNum name x = StoreRecM $ tell [return [(BC.pack name, RecNum $ toRational x)]]
+
+storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c
+storeMbNum name = maybe (return ()) (storeNum name)
+
+storeText :: StorableText a => String -> a -> StoreRec c
+storeText name x = StoreRecM $ tell [return [(BC.pack name, RecText $ toText x)]]
+
+storeMbText :: StorableText a => String -> Maybe a -> StoreRec c
+storeMbText name = maybe (return ()) (storeText name)
+
+storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c
+storeBinary name x = StoreRecM $ tell [return [(BC.pack name, RecBinary $ BA.convert x)]]
+
+storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c
+storeMbBinary name = maybe (return ()) (storeBinary name)
+
+storeDate :: StorableDate a => String -> a -> StoreRec c
+storeDate name x = StoreRecM $ tell [return [(BC.pack name, RecDate $ toDate x)]]
+
+storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c
+storeMbDate name = maybe (return ()) (storeDate name)
+
+storeUUID :: StorableUUID a => String -> a -> StoreRec c
+storeUUID name x = StoreRecM $ tell [return [(BC.pack name, RecUUID $ toUUID x)]]
+
+storeMbUUID :: StorableUUID a => String -> Maybe a -> StoreRec c
+storeMbUUID name = maybe (return ()) (storeUUID name)
+
+storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c
+storeRef name x = StoreRecM $ do
+    s <- ask
+    tell $ (:[]) $ do
+        ref <- store s x
+        return [(BC.pack name, RecRef ref)]
+
+storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c
+storeMbRef name = maybe (return ()) (storeRef name)
+
+storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c
+storeRawRef name ref = StoreRecM $ do
+    st <- ask
+    tell $ (:[]) $ do
+        ref' <- copyRef st ref
+        return [(BC.pack name, RecRef ref')]
+
+storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c
+storeMbRawRef name = maybe (return ()) (storeRawRef name)
+
+storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c
+storeZRef name x = StoreRecM $ do
+    s <- ask
+    tell $ (:[]) $ do
+        ref <- store s x
+        return $ if isZeroRef ref then []
+                                  else [(BC.pack name, RecRef ref)]
+
+storeRecItems :: StorageCompleteness c => [ ( ByteString, RecItem ) ] -> StoreRec c
+storeRecItems items = StoreRecM $ do
+    st <- ask
+    tell $ flip map items $ \( name, value ) -> do
+        value' <- copyRecItem st value
+        return [ ( name, value' ) ]
+
+loadBlob :: (ByteString -> a) -> Load a
+loadBlob f = loadCurrentObject >>= \case
+    Blob x -> return $ f x
+    _      -> throwError "Expecting blob"
+
+loadRec :: LoadRec a -> Load a
+loadRec (LoadRec lrec) = loadCurrentObject >>= \case
+    Rec rs -> do
+        ref <- loadCurrentRef
+        either throwError return $ runExcept $ runReaderT lrec (ref, rs)
+    _ -> throwError "Expecting record"
+
+loadZero :: a -> Load a
+loadZero x = loadCurrentObject >>= \case
+    ZeroObject -> return x
+    _          -> throwError "Expecting zero"
+
+
+loadEmpty :: String -> LoadRec ()
+loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name
+
+loadMbEmpty :: String -> LoadRec (Maybe ())
+loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems
+  where
+    bname = BC.pack name
+    p ( name', RecEmpty ) | name' == bname
+        = Just ()
+    p _ = Nothing
+
+loadInt :: Num a => String -> LoadRec a
+loadInt name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbInt name
+
+loadMbInt :: Num a => String -> LoadRec (Maybe a)
+loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems
+  where
+    bname = BC.pack name
+    p ( name', RecInt x ) | name' == bname
+        = Just (fromInteger x)
+    p _ = Nothing
+
+loadNum :: (Real a, Fractional a) => String -> LoadRec a
+loadNum name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbNum name
+
+loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a)
+loadMbNum name = listToMaybe . mapMaybe p <$> loadRecItems
+  where
+    bname = BC.pack name
+    p ( name', RecNum x ) | name' == bname
+        = Just (fromRational x)
+    p _ = Nothing
+
+loadText :: StorableText a => String -> LoadRec a
+loadText name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbText name
+
+loadMbText :: StorableText a => String -> LoadRec (Maybe a)
+loadMbText name = listToMaybe <$> loadTexts name
+
+loadTexts :: StorableText a => String -> LoadRec [a]
+loadTexts name = sequence . mapMaybe p =<< loadRecItems
+  where
+    bname = BC.pack name
+    p ( name', RecText x ) | name' == bname
+        = Just (fromText x)
+    p _ = Nothing
+
+loadBinary :: BA.ByteArray a => String -> LoadRec a
+loadBinary name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbBinary name
+
+loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a)
+loadMbBinary name = listToMaybe <$> loadBinaries name
+
+loadBinaries :: BA.ByteArray a => String -> LoadRec [a]
+loadBinaries name = mapMaybe p <$> loadRecItems
+  where
+    bname = BC.pack name
+    p ( name', RecBinary x ) | name' == bname
+        = Just (BA.convert x)
+    p _ = Nothing
+
+loadDate :: StorableDate a => String -> LoadRec a
+loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name
+
+loadMbDate :: StorableDate a => String -> LoadRec (Maybe a)
+loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems
+  where
+    bname = BC.pack name
+    p ( name', RecDate x ) | name' == bname
+        = Just (fromDate x)
+    p _ = Nothing
+
+loadUUID :: StorableUUID a => String -> LoadRec a
+loadUUID name = maybe (throwError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name
+
+loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a)
+loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems
+  where
+    bname = BC.pack name
+    p ( name', RecUUID x ) | name' == bname
+        = Just (fromUUID x)
+    p _ = Nothing
+
+loadRawRef :: String -> LoadRec Ref
+loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name
+
+loadMbRawRef :: String -> LoadRec (Maybe Ref)
+loadMbRawRef name = listToMaybe <$> loadRawRefs name
+
+loadRawRefs :: String -> LoadRec [Ref]
+loadRawRefs name = mapMaybe p <$> loadRecItems
+  where
+    bname = BC.pack name
+    p ( name', RecRef x ) | name' == bname = Just x
+    p _                                    = Nothing
+
+loadRef :: Storable a => String -> LoadRec a
+loadRef name = load <$> loadRawRef name
+
+loadMbRef :: Storable a => String -> LoadRec (Maybe a)
+loadMbRef name = fmap load <$> loadMbRawRef name
+
+loadRefs :: Storable a => String -> LoadRec [a]
+loadRefs name = map load <$> loadRawRefs name
+
+loadZRef :: ZeroStorable a => String -> LoadRec a
+loadZRef name = loadMbRef name >>= \case
+                    Nothing -> do Ref st _ <- loadRecCurrentRef
+                                  return $ fromZero st
+                    Just x  -> return x
+
+
+type Stored a = Stored' Complete a
+
+instance Storable a => Storable (Stored a) where
+    store st = copyRef st . storedRef
+    store' (Stored _ x) = store' x
+    load' = Stored <$> loadCurrentRef <*> load'
+
+instance ZeroStorable a => ZeroStorable (Stored a) where
+    fromZero st = Stored (zeroRef st) $ fromZero st
+
+fromStored :: Stored a -> a
+fromStored (Stored _ x) = x
+
+storedRef :: Stored a -> Ref
+storedRef (Stored ref _) = ref
+
+wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a)
+wrappedStore st x = do ref <- liftIO $ store st x
+                       return $ Stored ref 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'
+
+-- |Passed function needs to preserve the object representation to be safe
+unsafeMapStored :: (a -> b) -> Stored a -> Stored b
+unsafeMapStored f (Stored ref x) = Stored ref (f x)
+
+
+data StoreInfo = StoreInfo
+    { infoDate :: ZonedTime
+    , infoNote :: Maybe Text
+    }
+    deriving (Show)
+
+makeStoreInfo :: IO StoreInfo
+makeStoreInfo = StoreInfo
+    <$> getZonedTime
+    <*> pure Nothing
+
+storeInfoRec :: StoreInfo -> StoreRec c
+storeInfoRec info = do
+    storeDate "date" $ infoDate info
+    storeMbText "note" $ infoNote info
+
+loadInfoRec :: LoadRec StoreInfo
+loadInfoRec = StoreInfo
+    <$> loadDate "date"
+    <*> loadMbText "note"
+
+
+data History a = History StoreInfo (Stored a) (Maybe (StoredHistory a))
+    deriving (Show)
+
+type StoredHistory a = Stored (History a)
+
+instance Storable a => Storable (History a) where
+    store' (History si x prev) = storeRec $ do
+        storeInfoRec si
+        storeMbRef "prev" prev
+        storeRef "item" x
+
+    load' = loadRec $ History
+        <$> loadInfoRec
+        <*> loadRef "item"
+        <*> loadMbRef "prev"
+
+fromHistory :: StoredHistory a -> a
+fromHistory = fromStored . storedFromHistory
+
+fromHistoryAt :: ZonedTime -> StoredHistory a -> Maybe a
+fromHistoryAt zat = fmap (fromStored . snd) . listToMaybe . dropWhile ((at<) . zonedTimeToUTC . fst) . storedHistoryTimedList
+    where at = zonedTimeToUTC zat
+
+storedFromHistory :: StoredHistory a -> Stored a
+storedFromHistory sh = let History _ item _ = fromStored sh
+                        in item
+
+storedHistoryList :: StoredHistory a -> [Stored a]
+storedHistoryList = map snd . storedHistoryTimedList
+
+storedHistoryTimedList :: StoredHistory a -> [(ZonedTime, Stored a)]
+storedHistoryTimedList sh = let History hinfo item prev = fromStored sh
+                             in (infoDate hinfo, item) : maybe [] storedHistoryTimedList prev
+
+beginHistory :: Storable a => Storage -> StoreInfo -> a -> IO (StoredHistory a)
+beginHistory st si x = do sx <- wrappedStore st x
+                          wrappedStore st $ History si sx Nothing
+
+modifyHistory :: Storable a => StoreInfo -> (a -> a) -> StoredHistory a -> IO (StoredHistory a)
+modifyHistory si f prev@(Stored (Ref st _) _) = do
+    sx <- wrappedStore st $ f $ fromHistory prev
+    wrappedStore st $ History si sx (Just prev)
+
+
+showRatio :: Rational -> String
+showRatio r = case decimalRatio r of
+                   Just (n, 1) -> show n
+                   Just (n', d) -> let n = abs n'
+                                    in (if n' < 0 then "-" else "") ++ show (n `div` d) ++ "." ++
+                                       (concatMap (show.(`mod` 10).snd) $ reverse $ takeWhile ((>1).fst) $ zip (iterate (`div` 10) d) (iterate (`div` 10) (n `mod` d)))
+                   Nothing -> show (numerator r) ++ "/" ++ show (denominator r)
+
+decimalRatio :: Rational -> Maybe (Integer, Integer)
+decimalRatio r = do
+    let n = numerator r
+        d = denominator r
+        (c2, d') = takeFactors 2 d
+        (c5, d'') = takeFactors 5 d'
+    guard $ d'' == 1
+    let m = if c2 > c5 then 5 ^ (c2 - c5)
+                       else 2 ^ (c5 - c2)
+    return (n * m, d * m)
+
+takeFactors :: Integer -> Integer -> (Integer, Integer)
+takeFactors f n | n `mod` f == 0 = let (c, n') = takeFactors f (n `div` f)
+                                    in (c+1, n')
+                | otherwise = (0, n)
+
+parseRatio :: ByteString -> Maybe Rational
+parseRatio bs = case BC.groupBy ((==) `on` isNumber) bs of
+                     (m:xs) | m == BC.pack "-" -> negate <$> positive xs
+                     xs                        -> positive xs
+    where positive = \case
+              [bx] -> fromInteger . fst <$> BC.readInteger bx
+              [bx, op, by] -> do
+                  (x, _) <- BC.readInteger bx
+                  (y, _) <- BC.readInteger by
+                  case BC.unpack op of
+                       "." -> return $ (x % 1) + (y % (10 ^ BC.length by))
+                       "/" -> return $ x % y
+                       _   -> Nothing
+              _ -> Nothing
diff --git a/src/Erebos/Pairing.hs b/src/Erebos/Pairing.hs
index 2166e71..772eda0 100644
--- a/src/Erebos/Pairing.hs
+++ b/src/Erebos/Pairing.hs
@@ -27,10 +27,10 @@ import Data.Word
 
 import Erebos.Identity
 import Erebos.Network
+import Erebos.Object.Internal
 import Erebos.PubKey
 import Erebos.Service
 import Erebos.State
-import Erebos.Storage
 
 data PairingService a = PairingRequest (Stored (Signed IdentityData)) (Stored (Signed IdentityData)) RefDigest
                       | PairingResponse Bytes
diff --git a/src/Erebos/PubKey.hs b/src/Erebos/PubKey.hs
index 09a8e02..5d0cf62 100644
--- a/src/Erebos/PubKey.hs
+++ b/src/Erebos/PubKey.hs
@@ -21,7 +21,7 @@ import Data.ByteArray
 import Data.ByteString (ByteString)
 import qualified Data.Text as T
 
-import Erebos.Storage
+import Erebos.Object.Internal
 import Erebos.Storage.Key
 
 data PublicKey = PublicKey ED.PublicKey
diff --git a/src/Erebos/Service.hs b/src/Erebos/Service.hs
index f8428d1..5341c52 100644
--- a/src/Erebos/Service.hs
+++ b/src/Erebos/Service.hs
@@ -34,8 +34,8 @@ import qualified Data.UUID as U
 
 import Erebos.Identity
 import {-# SOURCE #-} Erebos.Network
+import Erebos.Object.Internal
 import Erebos.State
-import Erebos.Storage
 
 class (Typeable s, Storable s, Typeable (ServiceState s), Typeable (ServiceGlobalState s)) => Service s where
     serviceID :: proxy s -> ServiceID
diff --git a/src/Erebos/Set.hs b/src/Erebos/Set.hs
index c5edd56..1dc96ee 100644
--- a/src/Erebos/Set.hs
+++ b/src/Erebos/Set.hs
@@ -19,7 +19,7 @@ import Data.Map qualified as M
 import Data.Maybe
 import Data.Ord
 
-import Erebos.Storage
+import Erebos.Object.Internal
 import Erebos.Storage.Merge
 import Erebos.Util
 
diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs
index 324127a..40896f7 100644
--- a/src/Erebos/State.hs
+++ b/src/Erebos/State.hs
@@ -22,24 +22,27 @@ module Erebos.State (
 import Control.Monad.Except
 import Control.Monad.Reader
 
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BC
 import Data.Foldable
 import Data.Maybe
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
 import Data.Typeable
 import Data.UUID (UUID)
-import qualified Data.UUID as U
+import Data.UUID qualified as U
 
 import System.IO
 
 import Erebos.Identity
+import Erebos.Object.Internal
 import Erebos.PubKey
-import Erebos.Storage
 import Erebos.Storage.Merge
 
 data LocalState = LocalState
     { lsIdentity :: Stored (Signed ExtendedIdentityData)
     , lsShared :: [Stored SharedState]
+    , lsOther :: [ ( ByteString, RecItem ) ]
     }
 
 data SharedState = SharedState
@@ -58,13 +61,16 @@ class Mergeable a => SharedType a where
     sharedTypeID :: proxy a -> SharedTypeID
 
 instance Storable LocalState where
-    store' st = storeRec $ do
-        storeRef "id" $ lsIdentity st
-        mapM_ (storeRef "shared") $ lsShared st
+    store' LocalState {..} = storeRec $ do
+        storeRef "id" lsIdentity
+        mapM_ (storeRef "shared") lsShared
+        storeRecItems lsOther
 
-    load' = loadRec $ LocalState
-        <$> loadRef "id"
-        <*> loadRefs "shared"
+    load' = loadRec $ do
+        lsIdentity <- loadRef "id"
+        lsShared <- loadRefs "shared"
+        lsOther <- filter ((`notElem` [ BC.pack "id", BC.pack "shared" ]) . fst) <$> loadRecItems
+        return LocalState {..}
 
 instance HeadType LocalState where
     headTypeID _ = mkHeadTypeID "1d7491a9-7bcb-4eaa-8f13-c8c4c4087e4e"
@@ -123,7 +129,8 @@ loadLocalStateHead st = loadHeads st >>= \case
             }
         storeHead st $ LocalState
             { lsIdentity = idExtData identity
-            , lsShared = [shared]
+            , lsShared = [ shared ]
+            , lsOther = []
             }
 
 localIdentity :: LocalState -> UnifiedIdentity
diff --git a/src/Erebos/Storable.hs b/src/Erebos/Storable.hs
new file mode 100644
index 0000000..15f43b3
--- /dev/null
+++ b/src/Erebos/Storable.hs
@@ -0,0 +1,39 @@
+{-|
+Description: Encoding custom types into Erebos objects
+
+Module provides the 'Storable' class for types that can be serialized to/from
+Erebos objects, along with various helpers, mostly for encoding using records.
+
+The 'Stored' wrapper for objects actually encoded and stored in some storage is
+defined here as well.
+-}
+
+module Erebos.Storable (
+    Storable(..), ZeroStorable(..),
+    StorableText(..), StorableDate(..), StorableUUID(..),
+
+    Store, StoreRec,
+    storeBlob, storeRec, storeZero,
+    storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef,
+    storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef,
+    storeZRef,
+    storeRecItems,
+
+    Load, LoadRec,
+    loadCurrentRef, loadCurrentObject,
+    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,
+    loadZRef,
+
+    Stored,
+    fromStored, storedRef,
+    wrappedStore, wrappedLoad,
+    copyStored,
+    unsafeMapStored,
+) where
+
+import Erebos.Object.Internal
diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs
index 2e6653a..3b2ce4a 100644
--- a/src/Erebos/Storage.hs
+++ b/src/Erebos/Storage.hs
@@ -1,21 +1,15 @@
+{-|
+Description: Working with storage and heads
+
+Provides functions for opening 'Storage' backed either by disk or memory. For
+conveniance also function for working with 'Head's are reexported here.
+-}
+
 module Erebos.Storage (
-    Storage, PartialStorage, StorageCompleteness,
+    Storage, PartialStorage,
     openStorage, memoryStorage,
     deriveEphemeralStorage, derivePartialStorage,
 
-    Ref, PartialRef, RefDigest,
-    refDigest,
-    readRef, showRef, showRefDigest,
-    refDigestFromByteString, hashToRefDigest,
-    copyRef, partialRef, partialRefFromDigest,
-
-    Object, PartialObject, Object'(..), RecItem, RecItem'(..),
-    serializeObject, deserializeObject, deserializeObjects,
-    ioLoadObject, ioLoadBytes,
-    storeRawBytes, lazyLoadBytes,
-    storeObject,
-    collectObjects, collectStoredObjects,
-
     Head, HeadType(..),
     HeadTypeID, mkHeadTypeID,
     headId, headStorage, headRef, headObject, headStoredObject,
@@ -28,1026 +22,6 @@ module Erebos.Storage (
     watchHeadRaw,
 
     MonadStorage(..),
-
-    Storable(..), ZeroStorable(..),
-    StorableText(..), StorableDate(..), StorableUUID(..),
-
-    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,
-
-    Load, LoadRec,
-    evalLoad,
-    loadCurrentRef, loadCurrentObject,
-    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,
-    loadZRef,
-
-    Stored,
-    fromStored, storedRef,
-    wrappedStore, wrappedLoad,
-    copyStored,
-    unsafeMapStored,
-
-    StoreInfo(..), makeStoreInfo,
-
-    StoredHistory,
-    fromHistory, fromHistoryAt, storedFromHistory, storedHistoryList,
-    beginHistory, modifyHistory,
 ) where
 
-import Control.Applicative
-import Control.Concurrent
-import Control.Exception
-import Control.Monad
-import Control.Monad.Except
-import Control.Monad.Reader
-import Control.Monad.Writer
-
-import Crypto.Hash
-
-import Data.Bifunctor
-import Data.ByteString (ByteString)
-import qualified Data.ByteArray as BA
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as BC
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString.Lazy.Char8 as BLC
-import Data.Char
-import Data.Function
-import qualified Data.HashTable.IO as HT
-import Data.List
-import qualified Data.Map as M
-import Data.Maybe
-import Data.Ratio
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Text.Encoding
-import Data.Text.Encoding.Error
-import Data.Time.Calendar
-import Data.Time.Clock
-import Data.Time.Format
-import Data.Time.LocalTime
-import Data.Typeable
-import Data.UUID (UUID)
-import qualified Data.UUID as U
-import qualified Data.UUID.V4 as U
-
-import System.Directory
-import System.FSNotify
-import System.FilePath
-import System.IO.Error
-import System.IO.Unsafe
-
-import Erebos.Storage.Internal
-
-
-type Storage = Storage' Complete
-type PartialStorage = Storage' Partial
-
-storageVersion :: String
-storageVersion = "0.1"
-
-openStorage :: FilePath -> IO Storage
-openStorage path = modifyIOError annotate $ do
-    let versionFileName = "erebos-storage"
-    let versionPath = path </> versionFileName
-    let writeVersionFile = writeFile versionPath $ storageVersion <> "\n"
-
-    doesDirectoryExist path >>= \case
-        True -> do
-            listDirectory path >>= \case
-                files@(_:_)
-                    | versionFileName `elem` files -> do
-                        readFile versionPath >>= \case
-                            content | (ver:_) <- lines content, ver == storageVersion -> return ()
-                                    | otherwise -> fail "unsupported storage version"
-
-                    | "objects" `notElem` files || "heads" `notElem` files -> do
-                        fail "directory is neither empty, nor an existing erebos storage"
-
-                _ -> writeVersionFile
-        False -> do
-            createDirectoryIfMissing True $ path
-            writeVersionFile
-
-    createDirectoryIfMissing True $ path </> "objects"
-    createDirectoryIfMissing True $ path </> "heads"
-    watchers <- newMVar (Nothing, [], WatchList 1 [])
-    refgen <- newMVar =<< HT.new
-    refroots <- newMVar =<< HT.new
-    return $ Storage
-        { stBacking = StorageDir path watchers
-        , stParent = Nothing
-        , stRefGeneration = refgen
-        , stRefRoots = refroots
-        }
-  where
-    annotate e = annotateIOError e "failed to open storage" Nothing (Just path)
-
-memoryStorage' :: IO (Storage' c')
-memoryStorage' = do
-    backing <- StorageMemory <$> newMVar [] <*> newMVar M.empty <*> newMVar M.empty <*> newMVar (WatchList 1 [])
-    refgen <- newMVar =<< HT.new
-    refroots <- newMVar =<< HT.new
-    return $ Storage
-        { stBacking = backing
-        , stParent = Nothing
-        , stRefGeneration = refgen
-        , stRefRoots = refroots
-        }
-
-memoryStorage :: IO Storage
-memoryStorage = memoryStorage'
-
-deriveEphemeralStorage :: Storage -> IO Storage
-deriveEphemeralStorage parent = do
-    st <- memoryStorage
-    return $ st { stParent = Just parent }
-
-derivePartialStorage :: Storage -> IO PartialStorage
-derivePartialStorage parent = do
-    st <- memoryStorage'
-    return $ st { stParent = Just parent }
-
-type Ref = Ref' Complete
-type PartialRef = Ref' Partial
-
-zeroRef :: Storage' c -> Ref' c
-zeroRef s = Ref s (RefDigest h)
-    where h = case digestFromByteString $ B.replicate (hashDigestSize $ digestAlgo h) 0 of
-                   Nothing -> error $ "Failed to create zero hash"
-                   Just h' -> h'
-          digestAlgo :: Digest a -> a
-          digestAlgo = undefined
-
-isZeroRef :: Ref' c -> Bool
-isZeroRef (Ref _ h) = all (==0) $ BA.unpack h
-
-
-refFromDigest :: Storage' c -> RefDigest -> IO (Maybe (Ref' c))
-refFromDigest st dgst = fmap (const $ Ref st dgst) <$> ioLoadBytesFromStorage st dgst
-
-readRef :: Storage -> ByteString -> IO (Maybe Ref)
-readRef s b =
-    case readRefDigest b of
-         Nothing -> return Nothing
-         Just dgst -> refFromDigest s dgst
-
-copyRef' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (c (Ref' c'))
-copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> return $ return ref
-                                                                Nothing  -> doCopy
-    where doCopy = do mbobj' <- ioLoadObject ref'
-                      mbobj <- sequence $ copyObject' st <$> mbobj'
-                      sequence $ unsafeStoreObject st <$> join mbobj
-
-copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c'))
-copyObject' _ (Blob bs) = return $ return $ Blob bs
-copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM copyItem rs
-    where copyItem :: (ByteString, RecItem' c) -> IO (c (ByteString, RecItem' c'))
-          copyItem (n, item) = fmap (n,) <$> case item of
-              RecEmpty -> return $ return $ RecEmpty
-              RecInt x -> return $ return $ RecInt x
-              RecNum x -> return $ return $ RecNum x
-              RecText x -> return $ return $ RecText x
-              RecBinary x -> return $ return $ RecBinary x
-              RecDate x -> return $ return $ RecDate x
-              RecUUID x -> return $ return $ RecUUID x
-              RecRef x -> fmap RecRef <$> copyRef' st x
-copyObject' _ ZeroObject = return $ return ZeroObject
-
-copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c'))
-copyRef st ref' = liftIO $ returnLoadResult <$> copyRef' st ref'
-
-copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c'))
-copyObject st obj' = returnLoadResult <$> copyObject' st obj'
-
-partialRef :: PartialStorage -> Ref -> PartialRef
-partialRef st (Ref _ dgst) = Ref st dgst
-
-partialRefFromDigest :: PartialStorage -> RefDigest -> PartialRef
-partialRefFromDigest st dgst = Ref st dgst
-
-
-data Object' c
-    = Blob ByteString
-    | Rec [(ByteString, RecItem' c)]
-    | ZeroObject
-    deriving (Show)
-
-type Object = Object' Complete
-type PartialObject = Object' Partial
-
-data RecItem' c
-    = RecEmpty
-    | RecInt Integer
-    | RecNum Rational
-    | RecText Text
-    | RecBinary ByteString
-    | RecDate ZonedTime
-    | RecUUID UUID
-    | RecRef (Ref' c)
-    deriving (Show)
-
-type RecItem = RecItem' Complete
-
-serializeObject :: Object' c -> BL.ByteString
-serializeObject = \case
-    Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]
-    Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec
-                in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt
-    ZeroObject -> BL.empty
-
--- |Serializes and stores object data without ony dependencies, so is safe only
--- if all the referenced objects are already stored or reference is partial.
-unsafeStoreObject :: Storage' c -> Object' c -> IO (Ref' c)
-unsafeStoreObject storage = \case
-    ZeroObject -> return $ zeroRef storage
-    obj -> unsafeStoreRawBytes storage $ serializeObject obj
-
-storeObject :: PartialStorage -> PartialObject -> IO PartialRef
-storeObject = unsafeStoreObject
-
-storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef
-storeRawBytes = unsafeStoreRawBytes
-
-serializeRecItem :: ByteString -> RecItem' c -> [ByteString]
-serializeRecItem name (RecEmpty) = [name, BC.pack ":e", BC.singleton ' ', BC.singleton '\n']
-serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n']
-serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n']
-serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n']
-    where escaped = BC.concatMap escape $ encodeUtf8 x
-          escape '\n' = BC.pack "\n\t"
-          escape c    = BC.singleton c
-serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex x, BC.singleton '\n']
-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']
-
-lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c)
-lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject
-
-ioLoadObject :: forall c. StorageCompleteness c => Ref' c -> IO (c (Object' c))
-ioLoadObject ref | isZeroRef ref = return $ return ZeroObject
-ioLoadObject ref@(Ref st rhash) = do
-    file' <- ioLoadBytes ref
-    return $ do
-        file <- file'
-        let chash = hashToRefDigest file
-        when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -}
-        return $ case runExcept $ unsafeDeserializeObject st file of
-                      Left err -> error $ err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -}
-                      Right (x, rest) | BL.null rest -> x
-                                      | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -}
-
-lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.ByteString
-lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString)
-lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref
-
-unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except String (Object' c, BL.ByteString)
-unsafeDeserializeObject _  bytes | BL.null bytes = return (ZeroObject, bytes)
-unsafeDeserializeObject st bytes =
-    case BLC.break (=='\n') bytes of
-        (line, rest) | Just (otype, len) <- splitObjPrefix line -> do
-            let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest
-            guard $ B.length content == len
-            (,next) <$> case otype of
-                 _ | otype == BC.pack "blob" -> return $ Blob content
-                   | otype == BC.pack "rec" -> maybe (throwError $ "Malformed record item ")
-                                                   (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content
-                   | otherwise -> throwError $ "Unknown object type"
-        _ -> throwError $ "Malformed object"
-    where splitObjPrefix line = do
-              [otype, tlen] <- return $ BLC.words line
-              (len, rest) <- BLC.readInt tlen
-              guard $ BL.null rest
-              return (BL.toStrict otype, len)
-
-          mergeCont cs (a:b:rest) | Just ('\t', b') <- BC.uncons b = mergeCont (b':BC.pack "\n":cs) (a:rest)
-          mergeCont cs (a:rest) = B.concat (a : reverse cs) : mergeCont [] rest
-          mergeCont _ [] = []
-
-          parseRecLine line = do
-              colon <- BC.elemIndex ':' line
-              space <- BC.elemIndex ' ' line
-              guard $ colon < space
-              let name = B.take colon line
-                  itype = B.take (space-colon-1) $ B.drop (colon+1) line
-                  content = B.drop (space+1) line
-
-              val <- case BC.unpack itype of
-                          "e" -> do guard $ B.null content
-                                    return RecEmpty
-                          "i" -> do (num, rest) <- BC.readInteger content
-                                    guard $ B.null rest
-                                    return $ RecInt num
-                          "n" -> RecNum <$> parseRatio content
-                          "t" -> return $ RecText $ decodeUtf8With lenientDecode content
-                          "b" -> RecBinary <$> readHex content
-                          "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content)
-                          "u" -> RecUUID <$> U.fromASCIIBytes content
-                          "r" -> RecRef . Ref st <$> readRefDigest content
-                          _   -> Nothing
-              return (name, val)
-
-deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString)
-deserializeObject = unsafeDeserializeObject
-
-deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject]
-deserializeObjects _  bytes | BL.null bytes = return []
-deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes
-                                 (obj:) <$> deserializeObjects st rest
-
-
-collectObjects :: Object -> [Object]
-collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj)
-
-collectStoredObjects :: Stored Object -> [Stored Object]
-collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj)
-
-collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest)
-collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items
-    where helper (RecRef ref) (xs, s) | r <- refDigest ref
-                                      , r `S.notMember` s
-                                      = let o = wrappedLoad ref
-                                            (xs', s') = collectOtherStored (S.insert r s) $ fromStored o
-                                         in ((o : xs') ++ xs, s')
-          helper _          (xs, s) = (xs, s)
-collectOtherStored seen _ = ([], seen)
-
-
-type Head = Head' Complete
-
-headId :: Head a -> HeadID
-headId (Head uuid _) = uuid
-
-headStorage :: Head a -> Storage
-headStorage = refStorage . headRef
-
-headRef :: Head a -> Ref
-headRef (Head _ sx) = storedRef sx
-
-headObject :: Head a -> a
-headObject (Head _ sx) = fromStored sx
-
-headStoredObject :: Head a -> Stored a
-headStoredObject (Head _ sx) = sx
-
-deriving instance StorableUUID HeadID
-deriving instance StorableUUID HeadTypeID
-
-mkHeadTypeID :: String -> HeadTypeID
-mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString
-
-class Storable a => HeadType a where
-    headTypeID :: proxy a -> HeadTypeID
-
-
-headTypePath :: FilePath -> HeadTypeID -> FilePath
-headTypePath spath (HeadTypeID tid) = spath </> "heads" </> U.toString tid
-
-headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath
-headPath spath tid (HeadID hid) = headTypePath spath tid </> U.toString hid
-
-loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a]
-loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = liftIO $ do
-    let hpath = headTypePath spath $ headTypeID @a Proxy
-
-    files <- filterM (doesFileExist . (hpath </>)) =<<
-        handleJust (\e -> guard (isDoesNotExistError e)) (const $ return [])
-        (getDirectoryContents hpath)
-    fmap catMaybes $ forM files $ \hname -> do
-        case U.fromString hname of
-             Just hid -> do
-                 (h:_) <- BC.lines <$> B.readFile (hpath </> hname)
-                 Just ref <- readRef s h
-                 return $ Just $ Head (HeadID hid) $ wrappedLoad ref
-             Nothing -> return Nothing
-loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = liftIO $ do
-    let toHead ((tid, hid), ref) | tid == headTypeID @a Proxy = Just $ Head hid $ wrappedLoad ref
-                                 | otherwise                  = Nothing
-    catMaybes . map toHead <$> readMVar theads
-
-loadHead :: forall a m. (HeadType a, MonadIO m) => Storage -> HeadID -> m (Maybe (Head a))
-loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid
-
-loadHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> m (Maybe Ref)
-loadHeadRaw s@(Storage { stBacking = StorageDir { dirPath = spath }}) tid hid = liftIO $ do
-    handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do
-        (h:_) <- BC.lines <$> B.readFile (headPath spath tid hid)
-        Just ref <- readRef s h
-        return $ Just ref
-loadHeadRaw Storage { stBacking = StorageMemory { memHeads = theads } } tid hid = liftIO $ do
-    lookup (tid, hid) <$> readMVar theads
-
-reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a))
-reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid
-
-storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a)
-storeHead st obj = do
-    let tid = headTypeID @a Proxy
-    stored <- wrappedStore st obj
-    hid <- storeHeadRaw st tid (storedRef stored)
-    return $ Head hid stored
-
-storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID
-storeHeadRaw st tid ref = liftIO $ do
-    hid <- HeadID <$> U.nextRandom
-    case stBacking st of
-         StorageDir { dirPath = spath } -> do
-             Right () <- writeFileChecked (headPath spath tid hid) Nothing $
-                 showRef ref `B.append` BC.singleton '\n'
-             return ()
-         StorageMemory { memHeads = theads } -> do
-             modifyMVar_ theads $ return . (((tid, hid), ref) :)
-    return hid
-
-replaceHead :: forall a m. (HeadType a, MonadIO m) => Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a))
-replaceHead prev@(Head hid pobj) stored' = liftIO $ do
-    let st = headStorage prev
-        tid = headTypeID @a Proxy
-    stored <- copyStored st stored'
-    bimap (fmap $ Head hid . wrappedLoad) (const $ Head hid stored) <$>
-        replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored)
-
-replaceHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> Ref -> Ref -> m (Either (Maybe Ref) Ref)
-replaceHeadRaw st tid hid prev new = liftIO $ do
-    case stBacking st of
-         StorageDir { dirPath = spath } -> do
-             let filename = headPath spath tid hid
-                 showRefL r = showRef r `B.append` BC.singleton '\n'
-
-             writeFileChecked filename (Just $ showRefL prev) (showRefL new) >>= \case
-                 Left Nothing -> return $ Left Nothing
-                 Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs
-                                      return $ Left $ Just oref
-                 Right () -> return $ Right new
-
-         StorageMemory { memHeads = theads, memWatchers = twatch } -> do
-             res <- modifyMVar theads $ \hs -> do
-                 ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar twatch
-                 return $ case partition ((==(tid, hid)) . fst) hs of
-                     ([] , _  ) -> (hs, Left Nothing)
-                     ((_, r):_, hs') | r == prev -> (((tid, hid), new) : hs',
-                                                                  Right (new, ws))
-                                     | otherwise -> (hs, Left $ Just r)
-             case res of
-                  Right (r, ws) -> mapM_ ($ r) ws >> return (Right r)
-                  Left x -> return $ Left x
-
-updateHead :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b)
-updateHead h f = do
-    (o, x) <- f $ headStoredObject h
-    replaceHead h o >>= \case
-        Right h' -> return (Just h', x)
-        Left Nothing -> return (Nothing, x)
-        Left (Just h') -> updateHead h' f
-
-updateHead_ :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a)) -> m (Maybe (Head a))
-updateHead_ h = fmap fst . updateHead h . (fmap (,()) .)
-
-
-data WatchedHead = forall a. WatchedHead Storage WatchID (MVar a)
-
-watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHead
-watchHead h = watchHeadWith h id
-
-watchHeadWith :: forall a b. (HeadType a, Eq b) => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead
-watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do
-    watchHeadRaw st (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb
-
-watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead
-watchHeadRaw st tid hid sel cb = do
-    memo <- newEmptyMVar
-    let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo)
-            where wl' = wl { wlNext = wlNext wl + 1
-                           , wlList = WatchListItem
-                               { wlID = wlNext wl
-                               , wlHead = (tid, hid)
-                               , wlFun = \r -> do
-                                   let x = sel r
-                                   modifyMVar_ memo $ \prev -> do
-                                       when (Just x /= prev) $ cb x
-                                       return $ Just x
-                               } : wlList wl
-                           }
-
-    watched <- case stBacking st of
-         StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do
-             manager <- maybe startManager return mbmanager
-             ilist' <- case tid `elem` ilist of
-                 True -> return ilist
-                 False -> do
-                     void $ watchDir manager (headTypePath spath tid) (const True) $ \case
-                         Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do
-                             loadHeadRaw st tid ihid >>= \case
-                                 Just ref -> do
-                                     (_, _, iwl) <- readMVar mvar
-                                     mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl
-                                 Nothing -> return ()
-                         _ -> return ()
-                     return $ tid : ilist
-             return $ first ( Just manager, ilist', ) $ addWatcher wl
-
-         StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher
-
-    cur <- fmap sel <$> loadHeadRaw st tid hid
-    maybe (return ()) cb cur
-    putMVar memo cur
-
-    return watched
-
-unwatchHead :: WatchedHead -> IO ()
-unwatchHead (WatchedHead st wid _) = do
-    let delWatcher wl = wl { wlList = filter ((/=wid) . wlID) $ wlList wl }
-    case stBacking st of
-        StorageDir { dirWatchers = mvar } -> modifyMVar_ mvar $ return . second delWatcher
-        StorageMemory { memWatchers = mvar } -> modifyMVar_ mvar $ return . delWatcher
-
-
-class Monad m => MonadStorage m where
-    getStorage :: m Storage
-    mstore :: Storable a => a -> m (Stored a)
-
-    default mstore :: MonadIO m => Storable a => a -> m (Stored a)
-    mstore x = do
-        st <- getStorage
-        wrappedStore st x
-
-instance MonadIO m => MonadStorage (ReaderT Storage m) where
-    getStorage = ask
-
-instance MonadIO m => MonadStorage (ReaderT (Head a) m) where
-    getStorage = asks $ headStorage
-
-
-class Storable a where
-    store' :: a -> Store
-    load' :: Load a
-
-    store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c)
-    store st = evalStore st . store'
-    load :: Ref -> a
-    load = evalLoad load'
-
-class Storable a => ZeroStorable a where
-    fromZero :: Storage -> a
-
-data Store = StoreBlob ByteString
-           | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]])
-           | StoreZero
-
-evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c)
-evalStore st = unsafeStoreObject st <=< evalStoreObject st
-
-evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c)
-evalStoreObject _ (StoreBlob x) = return $ Blob x
-evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s)
-evalStoreObject _ StoreZero = return ZeroObject
-
-newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a)
-    deriving (Functor, Applicative, Monad)
-
-type StoreRec c = StoreRecM c ()
-
-newtype Load a = Load (ReaderT (Ref, Object) (Except String) a)
-    deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String)
-
-evalLoad :: Load a -> Ref -> a
-evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ")++)) id $ runExcept $ runReaderT f (ref, lazyLoadObject ref)
-
-loadCurrentRef :: Load Ref
-loadCurrentRef = Load $ asks fst
-
-loadCurrentObject :: Load Object
-loadCurrentObject = Load $ asks snd
-
-newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a)
-    deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String)
-
-loadRecCurrentRef :: LoadRec Ref
-loadRecCurrentRef = LoadRec $ asks fst
-
-loadRecItems :: LoadRec [(ByteString, RecItem)]
-loadRecItems = LoadRec $ asks snd
-
-
-instance Storable Object where
-    store' (Blob bs) = StoreBlob bs
-    store' (Rec xs) = StoreRec $ \st -> return $ do
-        Rec xs' <- copyObject st (Rec xs)
-        return xs'
-    store' ZeroObject = StoreZero
-
-    load' = loadCurrentObject
-
-    store st = unsafeStoreObject st <=< copyObject st
-    load = lazyLoadObject
-
-instance Storable ByteString where
-    store' = storeBlob
-    load' = loadBlob id
-
-instance Storable a => Storable [a] where
-    store' []     = storeZero
-    store' (x:xs) = storeRec $ do
-        storeRef "i" x
-        storeRef "n" xs
-
-    load' = loadCurrentObject >>= \case
-                ZeroObject -> return []
-                _          -> loadRec $ (:)
-                                  <$> loadRef "i"
-                                  <*> loadRef "n"
-
-instance Storable a => ZeroStorable [a] where
-    fromZero _ = []
-
-
-storeBlob :: ByteString -> Store
-storeBlob = StoreBlob
-
-storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store
-storeRec sr = StoreRec $ do
-    let StoreRecM r = sr
-    execWriter . runReaderT r
-
-storeZero :: Store
-storeZero = StoreZero
-
-
-class StorableText a where
-    toText :: a -> Text
-    fromText :: MonadError String m => Text -> m a
-
-instance StorableText Text where
-    toText = id; fromText = return
-
-instance StorableText [Char] where
-    toText = T.pack; fromText = return . T.unpack
-
-
-class StorableDate a where
-    toDate :: a -> ZonedTime
-    fromDate :: ZonedTime -> a
-
-instance StorableDate ZonedTime where
-    toDate = id; fromDate = id
-
-instance StorableDate UTCTime where
-    toDate = utcToZonedTime utc
-    fromDate = zonedTimeToUTC
-
-instance StorableDate Day where
-    toDate day = toDate $ UTCTime day 0
-    fromDate = utctDay . fromDate
-
-
-class StorableUUID a where
-    toUUID :: a -> UUID
-    fromUUID :: UUID -> a
-
-instance StorableUUID UUID where
-    toUUID = id; fromUUID = id
-
-
-storeEmpty :: String -> StoreRec c
-storeEmpty name = StoreRecM $ tell [return [(BC.pack name, RecEmpty)]]
-
-storeMbEmpty :: String -> Maybe () -> StoreRec c
-storeMbEmpty name = maybe (return ()) (const $ storeEmpty name)
-
-storeInt :: Integral a => String -> a -> StoreRec c
-storeInt name x = StoreRecM $ tell [return [(BC.pack name, RecInt $ toInteger x)]]
-
-storeMbInt :: Integral a => String -> Maybe a -> StoreRec c
-storeMbInt name = maybe (return ()) (storeInt name)
-
-storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c
-storeNum name x = StoreRecM $ tell [return [(BC.pack name, RecNum $ toRational x)]]
-
-storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c
-storeMbNum name = maybe (return ()) (storeNum name)
-
-storeText :: StorableText a => String -> a -> StoreRec c
-storeText name x = StoreRecM $ tell [return [(BC.pack name, RecText $ toText x)]]
-
-storeMbText :: StorableText a => String -> Maybe a -> StoreRec c
-storeMbText name = maybe (return ()) (storeText name)
-
-storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c
-storeBinary name x = StoreRecM $ tell [return [(BC.pack name, RecBinary $ BA.convert x)]]
-
-storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c
-storeMbBinary name = maybe (return ()) (storeBinary name)
-
-storeDate :: StorableDate a => String -> a -> StoreRec c
-storeDate name x = StoreRecM $ tell [return [(BC.pack name, RecDate $ toDate x)]]
-
-storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c
-storeMbDate name = maybe (return ()) (storeDate name)
-
-storeUUID :: StorableUUID a => String -> a -> StoreRec c
-storeUUID name x = StoreRecM $ tell [return [(BC.pack name, RecUUID $ toUUID x)]]
-
-storeMbUUID :: StorableUUID a => String -> Maybe a -> StoreRec c
-storeMbUUID name = maybe (return ()) (storeUUID name)
-
-storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c
-storeRef name x = StoreRecM $ do
-    s <- ask
-    tell $ (:[]) $ do
-        ref <- store s x
-        return [(BC.pack name, RecRef ref)]
-
-storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c
-storeMbRef name = maybe (return ()) (storeRef name)
-
-storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c
-storeRawRef name ref = StoreRecM $ do
-    st <- ask
-    tell $ (:[]) $ do
-        ref' <- copyRef st ref
-        return [(BC.pack name, RecRef ref')]
-
-storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c
-storeMbRawRef name = maybe (return ()) (storeRawRef name)
-
-storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c
-storeZRef name x = StoreRecM $ do
-    s <- ask
-    tell $ (:[]) $ do
-        ref <- store s x
-        return $ if isZeroRef ref then []
-                                  else [(BC.pack name, RecRef ref)]
-
-
-loadBlob :: (ByteString -> a) -> Load a
-loadBlob f = loadCurrentObject >>= \case
-    Blob x -> return $ f x
-    _      -> throwError "Expecting blob"
-
-loadRec :: LoadRec a -> Load a
-loadRec (LoadRec lrec) = loadCurrentObject >>= \case
-    Rec rs -> do
-        ref <- loadCurrentRef
-        either throwError return $ runExcept $ runReaderT lrec (ref, rs)
-    _ -> throwError "Expecting record"
-
-loadZero :: a -> Load a
-loadZero x = loadCurrentObject >>= \case
-    ZeroObject -> return x
-    _          -> throwError "Expecting zero"
-
-
-loadEmpty :: String -> LoadRec ()
-loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name
-
-loadMbEmpty :: String -> LoadRec (Maybe ())
-loadMbEmpty name = (lookup (BC.pack name) <$> loadRecItems) >>= \case
-    Nothing -> return Nothing
-    Just (RecEmpty) -> return (Just ())
-    Just _ -> throwError $ "Expecting type int of record item '"++name++"'"
-
-loadInt :: Num a => String -> LoadRec a
-loadInt name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbInt name
-
-loadMbInt :: Num a => String -> LoadRec (Maybe a)
-loadMbInt name = (lookup (BC.pack name) <$> loadRecItems) >>= \case
-    Nothing -> return Nothing
-    Just (RecInt x) -> return (Just $ fromInteger x)
-    Just _ -> throwError $ "Expecting type int of record item '"++name++"'"
-
-loadNum :: (Real a, Fractional a) => String -> LoadRec a
-loadNum name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbNum name
-
-loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a)
-loadMbNum name = (lookup (BC.pack name) <$> loadRecItems) >>= \case
-    Nothing -> return Nothing
-    Just (RecNum x) -> return (Just $ fromRational x)
-    Just _ -> throwError $ "Expecting type number of record item '"++name++"'"
-
-loadText :: StorableText a => String -> LoadRec a
-loadText name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbText name
-
-loadMbText :: StorableText a => String -> LoadRec (Maybe a)
-loadMbText name = (lookup (BC.pack name) <$> loadRecItems) >>= \case
-    Nothing -> return Nothing
-    Just (RecText x) -> Just <$> fromText x
-    Just _ -> throwError $ "Expecting type text of record item '"++name++"'"
-
-loadTexts :: StorableText a => String -> LoadRec [a]
-loadTexts name = do
-    items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems
-    forM items $ \case RecText x -> fromText x
-                       _ -> throwError $ "Expecting type text of record item '"++name++"'"
-
-loadBinary :: BA.ByteArray a => String -> LoadRec a
-loadBinary name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbBinary name
-
-loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a)
-loadMbBinary name = (lookup (BC.pack name) <$> loadRecItems) >>= \case
-    Nothing -> return Nothing
-    Just (RecBinary x) -> return $ Just $ BA.convert x
-    Just _ -> throwError $ "Expecting type binary of record item '"++name++"'"
-
-loadBinaries :: BA.ByteArray a => String -> LoadRec [a]
-loadBinaries name = do
-    items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems
-    forM items $ \case RecBinary x -> return $ BA.convert x
-                       _ -> throwError $ "Expecting type binary of record item '"++name++"'"
-
-loadDate :: StorableDate a => String -> LoadRec a
-loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name
-
-loadMbDate :: StorableDate a => String -> LoadRec (Maybe a)
-loadMbDate name = (lookup (BC.pack name) <$> loadRecItems) >>= \case
-    Nothing -> return Nothing
-    Just (RecDate x) -> return $ Just $ fromDate x
-    Just _ -> throwError $ "Expecting type date of record item '"++name++"'"
-
-loadUUID :: StorableUUID a => String -> LoadRec a
-loadUUID name = maybe (throwError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name
-
-loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a)
-loadMbUUID name = (lookup (BC.pack name) <$> loadRecItems) >>= \case
-    Nothing -> return Nothing
-    Just (RecUUID x) -> return $ Just $ fromUUID x
-    Just _ -> throwError $ "Expecting type UUID of record item '"++name++"'"
-
-loadRawRef :: String -> LoadRec Ref
-loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name
-
-loadMbRawRef :: String -> LoadRec (Maybe Ref)
-loadMbRawRef name = (lookup (BC.pack name) <$> loadRecItems) >>= \case
-    Nothing -> return Nothing
-    Just (RecRef x) -> return (Just x)
-    Just _ -> throwError $ "Expecting type ref of record item '"++name++"'"
-
-loadRawRefs :: String -> LoadRec [Ref]
-loadRawRefs name = do
-    items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems
-    forM items $ \case RecRef x -> return x
-                       _ -> throwError $ "Expecting type ref of record item '"++name++"'"
-
-loadRef :: Storable a => String -> LoadRec a
-loadRef name = load <$> loadRawRef name
-
-loadMbRef :: Storable a => String -> LoadRec (Maybe a)
-loadMbRef name = fmap load <$> loadMbRawRef name
-
-loadRefs :: Storable a => String -> LoadRec [a]
-loadRefs name = map load <$> loadRawRefs name
-
-loadZRef :: ZeroStorable a => String -> LoadRec a
-loadZRef name = loadMbRef name >>= \case
-                    Nothing -> do Ref st _ <- loadRecCurrentRef
-                                  return $ fromZero st
-                    Just x  -> return x
-
-
-type Stored a = Stored' Complete a
-
-instance Storable a => Storable (Stored a) where
-    store st = copyRef st . storedRef
-    store' (Stored _ x) = store' x
-    load' = Stored <$> loadCurrentRef <*> load'
-
-instance ZeroStorable a => ZeroStorable (Stored a) where
-    fromZero st = Stored (zeroRef st) $ fromZero st
-
-fromStored :: Stored a -> a
-fromStored (Stored _ x) = x
-
-storedRef :: Stored a -> Ref
-storedRef (Stored ref _) = ref
-
-wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a)
-wrappedStore st x = do ref <- liftIO $ store st x
-                       return $ Stored ref 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'
-
--- |Passed function needs to preserve the object representation to be safe
-unsafeMapStored :: (a -> b) -> Stored a -> Stored b
-unsafeMapStored f (Stored ref x) = Stored ref (f x)
-
-
-data StoreInfo = StoreInfo
-    { infoDate :: ZonedTime
-    , infoNote :: Maybe Text
-    }
-    deriving (Show)
-
-makeStoreInfo :: IO StoreInfo
-makeStoreInfo = StoreInfo
-    <$> getZonedTime
-    <*> pure Nothing
-
-storeInfoRec :: StoreInfo -> StoreRec c
-storeInfoRec info = do
-    storeDate "date" $ infoDate info
-    storeMbText "note" $ infoNote info
-
-loadInfoRec :: LoadRec StoreInfo
-loadInfoRec = StoreInfo
-    <$> loadDate "date"
-    <*> loadMbText "note"
-
-
-data History a = History StoreInfo (Stored a) (Maybe (StoredHistory a))
-    deriving (Show)
-
-type StoredHistory a = Stored (History a)
-
-instance Storable a => Storable (History a) where
-    store' (History si x prev) = storeRec $ do
-        storeInfoRec si
-        storeMbRef "prev" prev
-        storeRef "item" x
-
-    load' = loadRec $ History
-        <$> loadInfoRec
-        <*> loadRef "item"
-        <*> loadMbRef "prev"
-
-fromHistory :: StoredHistory a -> a
-fromHistory = fromStored . storedFromHistory
-
-fromHistoryAt :: ZonedTime -> StoredHistory a -> Maybe a
-fromHistoryAt zat = fmap (fromStored . snd) . listToMaybe . dropWhile ((at<) . zonedTimeToUTC . fst) . storedHistoryTimedList
-    where at = zonedTimeToUTC zat
-
-storedFromHistory :: StoredHistory a -> Stored a
-storedFromHistory sh = let History _ item _ = fromStored sh
-                        in item
-
-storedHistoryList :: StoredHistory a -> [Stored a]
-storedHistoryList = map snd . storedHistoryTimedList
-
-storedHistoryTimedList :: StoredHistory a -> [(ZonedTime, Stored a)]
-storedHistoryTimedList sh = let History hinfo item prev = fromStored sh
-                             in (infoDate hinfo, item) : maybe [] storedHistoryTimedList prev
-
-beginHistory :: Storable a => Storage -> StoreInfo -> a -> IO (StoredHistory a)
-beginHistory st si x = do sx <- wrappedStore st x
-                          wrappedStore st $ History si sx Nothing
-
-modifyHistory :: Storable a => StoreInfo -> (a -> a) -> StoredHistory a -> IO (StoredHistory a)
-modifyHistory si f prev@(Stored (Ref st _) _) = do
-    sx <- wrappedStore st $ f $ fromHistory prev
-    wrappedStore st $ History si sx (Just prev)
-
-
-showRatio :: Rational -> String
-showRatio r = case decimalRatio r of
-                   Just (n, 1) -> show n
-                   Just (n', d) -> let n = abs n'
-                                    in (if n' < 0 then "-" else "") ++ show (n `div` d) ++ "." ++
-                                       (concatMap (show.(`mod` 10).snd) $ reverse $ takeWhile ((>1).fst) $ zip (iterate (`div` 10) d) (iterate (`div` 10) (n `mod` d)))
-                   Nothing -> show (numerator r) ++ "/" ++ show (denominator r)
-
-decimalRatio :: Rational -> Maybe (Integer, Integer)
-decimalRatio r = do
-    let n = numerator r
-        d = denominator r
-        (c2, d') = takeFactors 2 d
-        (c5, d'') = takeFactors 5 d'
-    guard $ d'' == 1
-    let m = if c2 > c5 then 5 ^ (c2 - c5)
-                       else 2 ^ (c5 - c2)
-    return (n * m, d * m)
-
-takeFactors :: Integer -> Integer -> (Integer, Integer)
-takeFactors f n | n `mod` f == 0 = let (c, n') = takeFactors f (n `div` f)
-                                    in (c+1, n')
-                | otherwise = (0, n)
-
-parseRatio :: ByteString -> Maybe Rational
-parseRatio bs = case BC.groupBy ((==) `on` isNumber) bs of
-                     (m:xs) | m == BC.pack "-" -> negate <$> positive xs
-                     xs                        -> positive xs
-    where positive = \case
-              [bx] -> fromInteger . fst <$> BC.readInteger bx
-              [bx, op, by] -> do
-                  (x, _) <- BC.readInteger bx
-                  (y, _) <- BC.readInteger by
-                  case BC.unpack op of
-                       "." -> return $ (x % 1) + (y % (10 ^ BC.length by))
-                       "/" -> return $ x % y
-                       _   -> Nothing
-              _ -> Nothing
+import Erebos.Object.Internal
diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs
index d419a5e..8b794d8 100644
--- a/src/Erebos/Storage/Internal.hs
+++ b/src/Erebos/Storage/Internal.hs
@@ -241,7 +241,7 @@ writeFileOnce file content = bracket (openLockFile locked)
         doesFileExist file >>= \case
             True  -> removeFile locked
             False -> do BL.hPut h content
-                        hFlush h
+                        hClose h
                         renameFile locked file
     where locked = file ++ ".lock"
 
@@ -254,13 +254,13 @@ writeFileChecked file prev content = bracket (openLockFile locked)
                 removeFile locked
                 return $ Left $ Just current
             (Nothing, False) -> do B.hPut h content
-                                   hFlush h
+                                   hClose h
                                    renameFile locked file
                                    return $ Right ()
             (Just expected, True) -> do
                 current <- B.readFile file
                 if current == expected then do B.hPut h content
-                                               hFlush h
+                                               hClose h
                                                renameFile locked file
                                                return $ return ()
                                        else do removeFile locked
diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs
index b6afc20..9e52397 100644
--- a/src/Erebos/Storage/Key.hs
+++ b/src/Erebos/Storage/Key.hs
@@ -18,7 +18,7 @@ import System.Directory
 import System.FilePath
 import System.IO.Error
 
-import Erebos.Storage
+import Erebos.Object.Internal
 import Erebos.Storage.Internal
 
 class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where
@@ -80,6 +80,7 @@ moveKeys from to = liftIO $ do
                 return M.empty
 
         (StorageMemory { memKeys = fromKeys }, StorageMemory { memKeys = toKeys }) -> do
-            modifyMVar_ fromKeys $ \fkeys -> do
-                modifyMVar_ toKeys $ return . M.union fkeys
-                return M.empty
+            when (fromKeys /= toKeys) $ do
+                modifyMVar_ fromKeys $ \fkeys -> do
+                    modifyMVar_ toKeys $ return . M.union fkeys
+                    return M.empty
diff --git a/src/Erebos/Storage/Merge.hs b/src/Erebos/Storage/Merge.hs
index 9d9db13..d5d184e 100644
--- a/src/Erebos/Storage/Merge.hs
+++ b/src/Erebos/Storage/Merge.hs
@@ -31,7 +31,7 @@ import Data.Set qualified as S
 
 import System.IO.Unsafe (unsafePerformIO)
 
-import Erebos.Storage
+import Erebos.Object.Internal
 import Erebos.Storage.Internal
 import Erebos.Util
 
@@ -97,13 +97,16 @@ storedGeneration x =
         doLookup x
 
 
+-- |Returns list of sets starting with the set of given objects and
+-- intcrementally adding parents.
 generations :: Storable a => [Stored a] -> [Set (Stored a)]
 generations = unfoldr gen . (,S.empty)
-    where gen (hs, cur) = case filter (`S.notMember` cur) $ previous =<< hs of
+    where gen (hs, cur) = case filter (`S.notMember` cur) hs of
               []    -> Nothing
               added -> let next = foldr S.insert cur added
-                        in Just (next, (added, next))
+                        in Just (next, (previous =<< added, next))
 
+-- |Returns set containing all given objects and their ancestors
 ancestors :: Storable a => [Stored a] -> Set (Stored a)
 ancestors = last . (S.empty:) . generations
 
diff --git a/src/Erebos/Sync.hs b/src/Erebos/Sync.hs
index 04b5f11..71122f7 100644
--- a/src/Erebos/Sync.hs
+++ b/src/Erebos/Sync.hs
@@ -8,9 +8,9 @@ import Control.Monad.Reader
 import Data.List
 
 import Erebos.Identity
+import Erebos.Object.Internal
 import Erebos.Service
 import Erebos.State
-import Erebos.Storage
 import Erebos.Storage.Merge
 
 data SyncService = SyncPacket (Stored SharedState)