summaryrefslogtreecommitdiff
path: root/src/Erebos
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos')
-rw-r--r--src/Erebos/Attach.hs2
-rw-r--r--src/Erebos/Channel.hs2
-rw-r--r--src/Erebos/Chatroom.hs41
-rw-r--r--src/Erebos/Contact.hs2
-rw-r--r--src/Erebos/Conversation.hs4
-rw-r--r--src/Erebos/Discovery.hs2
-rw-r--r--src/Erebos/ICE.chs2
-rw-r--r--src/Erebos/ICE/pjproject.c6
-rw-r--r--src/Erebos/Identity.hs10
-rw-r--r--src/Erebos/Message.hs2
-rw-r--r--src/Erebos/Network.hs2
-rw-r--r--src/Erebos/Network.hs-boot2
-rw-r--r--src/Erebos/Network/Protocol.hs87
-rw-r--r--src/Erebos/Network/ifaddrs.c6
-rw-r--r--src/Erebos/Object/Internal.hs (renamed from src/Erebos/Storage.hs)182
-rw-r--r--src/Erebos/Pairing.hs2
-rw-r--r--src/Erebos/PubKey.hs2
-rw-r--r--src/Erebos/Service.hs2
-rw-r--r--src/Erebos/Set.hs2
-rw-r--r--src/Erebos/State.hs29
-rw-r--r--src/Erebos/Storage/Key.hs2
-rw-r--r--src/Erebos/Storage/Merge.hs2
-rw-r--r--src/Erebos/Sync.hs2
23 files changed, 271 insertions, 124 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 c8b5805..25c8c17 100644
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -13,6 +13,7 @@ module Erebos.Chatroom (
chatroomSetSubscribe,
chatroomMembers,
joinChatroom, joinChatroomByStateData,
+ joinChatroomAs, joinChatroomAsByStateData,
leaveChatroom, leaveChatroomByStateData,
getMessagesSinceState,
@@ -48,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
@@ -185,15 +186,18 @@ sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStat
sendChatroomMessageByStateData
:: (MonadStorage m, MonadHead LocalState m, MonadError String m)
=> Stored ChatroomStateData -> Text -> m ()
-sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing (Just msg) False
+sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing Nothing (Just msg) False
sendRawChatroomMessageByStateData
:: (MonadStorage m, MonadHead LocalState m, MonadError String m)
- => Stored ChatroomStateData -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m ()
-sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do
+ => 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
- mdFrom <- finalOwner . localIdentity . fromStored <$> getLocalHead
+ 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
@@ -205,7 +209,8 @@ sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ f
mergeSorted . (:[]) <$> mstore ChatroomStateData
{ rsdPrev = roomStateData cstate
, rsdRoom = []
- , rsdSubscribe = Just True
+ , rsdSubscribe = Just (not mdLeave)
+ , rsdIdentity = mbIdentity
, rsdMessages = [ mdata ]
}
@@ -214,6 +219,7 @@ data ChatroomStateData = ChatroomStateData
{ rsdPrev :: [Stored ChatroomStateData]
, rsdRoom :: [Stored (Signed ChatroomData)]
, rsdSubscribe :: Maybe Bool
+ , rsdIdentity :: Maybe UnifiedIdentity
, rsdMessages :: [Stored (Signed ChatMessageData)]
}
@@ -222,6 +228,7 @@ data ChatroomState = ChatroomState
, roomStateRoom :: Maybe Chatroom
, roomStateMessageData :: [Stored (Signed ChatMessageData)]
, roomStateSubscribe :: Bool
+ , roomStateIdentity :: Maybe UnifiedIdentity
, roomStateMessages :: [ChatMessage]
}
@@ -230,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 {..}
@@ -249,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 {..}
@@ -266,6 +276,7 @@ createChatroom rdName rdDescription = do
{ rsdPrev = []
, rsdRoom = [ rdata ]
, rsdSubscribe = Just True
+ , rsdIdentity = Nothing
, rsdMessages = []
}
@@ -313,6 +324,7 @@ updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomStat
{ rsdPrev = roomStateData cstate
, rsdRoom = [ rdata ]
, rsdSubscribe = Just True
+ , rsdIdentity = Nothing
, rsdMessages = []
}
@@ -343,6 +355,7 @@ chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $
{ rsdPrev = roomStateData cstate
, rsdRoom = []
, rsdSubscribe = Just subscribe
+ , rsdIdentity = Nothing
, rsdMessages = []
}
@@ -364,7 +377,17 @@ joinChatroom rstate = joinChatroomByStateData (head $ roomStateData rstate)
joinChatroomByStateData
:: (MonadStorage m, MonadHead LocalState m, MonadError String m)
=> Stored ChatroomStateData -> m ()
-joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing False
+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)
@@ -374,7 +397,7 @@ leaveChatroom rstate = leaveChatroomByStateData (head $ roomStateData rstate)
leaveChatroomByStateData
:: (MonadStorage m, MonadHead LocalState m, MonadError String m)
=> Stored ChatroomStateData -> m ()
-leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing True
+leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing True
getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage]
getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur)
@@ -498,6 +521,7 @@ instance Service ChatroomService where
{ rsdPrev = prev
, rsdRoom = room
, rsdSubscribe = Nothing
+ , rsdIdentity = Nothing
, rsdMessages = []
}
storeSetAddComponent sdata set
@@ -542,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 f2094f6..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,
@@ -40,8 +40,8 @@ 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
@@ -282,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
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 2064d1c..358bb7c 100644
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -63,10 +63,10 @@ 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
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 ded0b05..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
diff --git a/src/Erebos/Network/ifaddrs.c b/src/Erebos/Network/ifaddrs.c
index 70685bc..637716e 100644
--- a/src/Erebos/Network/ifaddrs.c
+++ b/src/Erebos/Network/ifaddrs.c
@@ -36,8 +36,10 @@ uint32_t * join_multicast(int fd, size_t * count)
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)) {
+ 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;
diff --git a/src/Erebos/Storage.hs b/src/Erebos/Object/Internal.hs
index 2e6653a..312c3af 100644
--- a/src/Erebos/Storage.hs
+++ b/src/Erebos/Object/Internal.hs
@@ -1,4 +1,4 @@
-module Erebos.Storage (
+module Erebos.Object.Internal (
Storage, PartialStorage, StorageCompleteness,
openStorage, memoryStorage,
deriveEphemeralStorage, derivePartialStorage,
@@ -38,6 +38,7 @@ module Erebos.Storage (
storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef,
storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef,
storeZRef,
+ storeRecItems,
Load, LoadRec,
evalLoad,
@@ -121,24 +122,31 @@ 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
+ 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"
@@ -210,24 +218,30 @@ copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> retu
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 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' 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'
@@ -242,6 +256,7 @@ data Object' c
= Blob ByteString
| Rec [(ByteString, RecItem' c)]
| ZeroObject
+ | UnknownObject ByteString ByteString
deriving (Show)
type Object = Object' Complete
@@ -256,6 +271,7 @@ data RecItem' c
| RecDate ZonedTime
| RecUUID UUID
| RecRef (Ref' c)
+ | RecUnknown ByteString ByteString
deriving (Show)
type RecItem = RecItem' Complete
@@ -266,6 +282,7 @@ serializeObject = \case
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.
@@ -292,6 +309,7 @@ serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex x, BC.single
serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pack (formatTime defaultTimeLocale "%s %z" x), BC.singleton '\n']
serializeRecItem name (RecUUID x) = [name, BC.pack ":u", BC.singleton ' ', U.toASCIIBytes x, BC.singleton '\n']
serializeRecItem name (RecRef x) = [name, BC.pack ":r ", showRef x, BC.singleton '\n']
+serializeRecItem name (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
@@ -324,7 +342,7 @@ unsafeDeserializeObject st bytes =
_ | 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"
+ | otherwise -> return $ UnknownObject otype content
_ -> throwError $ "Malformed object"
where splitObjPrefix line = do
[otype, tlen] <- return $ BLC.words line
@@ -344,7 +362,8 @@ unsafeDeserializeObject st bytes =
itype = B.take (space-colon-1) $ B.drop (colon+1) line
content = B.drop (space+1) line
- val <- case BC.unpack itype of
+ 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
@@ -605,6 +624,7 @@ class Storable a => ZeroStorable a where
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
@@ -613,6 +633,7 @@ 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)
@@ -647,6 +668,7 @@ instance Storable Object where
Rec xs' <- copyObject st (Rec xs)
return xs'
store' ZeroObject = StoreZero
+ store' (UnknownObject otype content) = StoreUnknown otype content
load' = loadCurrentObject
@@ -790,6 +812,12 @@ storeZRef name x = StoreRecM $ do
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
@@ -813,91 +841,97 @@ 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++"'"
+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 = (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++"'"
+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 = (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++"'"
+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 = (lookup (BC.pack name) <$> loadRecItems) >>= \case
- Nothing -> return Nothing
- Just (RecText x) -> Just <$> fromText x
- Just _ -> throwError $ "Expecting type text of record item '"++name++"'"
+loadMbText name = listToMaybe <$> loadTexts 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++"'"
+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 = (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++"'"
+loadMbBinary name = listToMaybe <$> loadBinaries 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++"'"
+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 = (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++"'"
+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 = (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++"'"
+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 = (lookup (BC.pack name) <$> loadRecItems) >>= \case
- Nothing -> return Nothing
- Just (RecRef x) -> return (Just x)
- Just _ -> throwError $ "Expecting type ref of record item '"++name++"'"
+loadMbRawRef name = listToMaybe <$> loadRawRefs 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++"'"
+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
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/Storage/Key.hs b/src/Erebos/Storage/Key.hs
index 5da79e3..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
diff --git a/src/Erebos/Storage/Merge.hs b/src/Erebos/Storage/Merge.hs
index a3b0fd7..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
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 23:49:22 +0000