summaryrefslogtreecommitdiff
path: root/src/Erebos
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos')
-rw-r--r--src/Erebos/Object/Internal.hs5
-rw-r--r--src/Erebos/Pairing.hs27
-rw-r--r--src/Erebos/Service.hs4
-rw-r--r--src/Erebos/State.hs4
-rw-r--r--src/Erebos/Storage/Disk.hs2
-rw-r--r--src/Erebos/Storage/Head.hs3
-rw-r--r--src/Erebos/Storage/Internal.hs33
-rw-r--r--src/Erebos/UUID.hs24
-rw-r--r--src/Erebos/Util.hs30
9 files changed, 83 insertions, 49 deletions
diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs
index 6111d2a..1e87040 100644
--- a/src/Erebos/Object/Internal.hs
+++ b/src/Erebos/Object/Internal.hs
@@ -74,13 +74,14 @@ import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Format
import Data.Time.LocalTime
-import Data.UUID (UUID)
-import qualified Data.UUID as U
import System.IO.Unsafe
import Erebos.Error
import Erebos.Storage.Internal
+import Erebos.UUID (UUID)
+import Erebos.UUID qualified as U
+import Erebos.Util
zeroRef :: Storage' c -> Ref' c
diff --git a/src/Erebos/Pairing.hs b/src/Erebos/Pairing.hs
index 703afcd..e3ebf2b 100644
--- a/src/Erebos/Pairing.hs
+++ b/src/Erebos/Pairing.hs
@@ -17,9 +17,10 @@ import Control.Monad.Reader
import Crypto.Random
import Data.Bits
-import Data.ByteArray (Bytes, convert)
-import qualified Data.ByteArray as BA
-import qualified Data.ByteString.Char8 as BC
+import Data.ByteArray qualified as BA
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BC
import Data.Kind
import Data.Maybe
import Data.Typeable
@@ -34,16 +35,16 @@ import Erebos.State
import Erebos.Storable
data PairingService a = PairingRequest (Stored (Signed IdentityData)) (Stored (Signed IdentityData)) RefDigest
- | PairingResponse Bytes
- | PairingRequestNonce Bytes
+ | PairingResponse ByteString
+ | PairingRequestNonce ByteString
| PairingAccept a
| PairingReject
data PairingState a = NoPairing
- | OurRequest UnifiedIdentity UnifiedIdentity Bytes
+ | OurRequest UnifiedIdentity UnifiedIdentity ByteString
| OurRequestConfirm (Maybe (PairingVerifiedResult a))
| OurRequestReady
- | PeerRequest UnifiedIdentity UnifiedIdentity Bytes RefDigest
+ | PeerRequest UnifiedIdentity UnifiedIdentity ByteString RefDigest
| PeerRequestConfirm
| PairingDone
@@ -88,7 +89,7 @@ instance Storable a => Storable (PairingService a) where
load' = do
res <- loadRec $ do
- (req :: Maybe Bytes) <- loadMbBinary "request"
+ (req :: Maybe ByteString) <- loadMbBinary "request"
idReq <- loadMbRef "id-req"
idRsp <- loadMbRef "id-rsp"
rsp <- loadMbBinary "response"
@@ -171,7 +172,7 @@ instance PairingResult a => Service (PairingService a) where
x@(OurRequestReady, _) -> reject $ uncurry PairingUnexpectedMessage x
(PeerRequest peer self nonce dgst, PairingRequestNonce pnonce) -> do
- if dgst == nonceDigest peer self pnonce BA.empty
+ if dgst == nonceDigest peer self pnonce BS.empty
then do hook <- asks $ pairingHookRequestNonce . svcAttributes
hook $ confirmationNumber $ nonceDigest peer self pnonce nonce
svcSet PeerRequestConfirm
@@ -188,12 +189,12 @@ reject reason = do
replyPacket PairingReject
-nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest
+nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> ByteString -> ByteString -> RefDigest
nonceDigest idReq idRsp nonceReq nonceRsp = hashToRefDigest $ serializeObject $ Rec
[ (BC.pack "id-req", RecRef $ storedRef $ idData idReq)
, (BC.pack "id-rsp", RecRef $ storedRef $ idData idRsp)
- , (BC.pack "nonce-req", RecBinary $ convert nonceReq)
- , (BC.pack "nonce-rsp", RecBinary $ convert nonceRsp)
+ , (BC.pack "nonce-req", RecBinary nonceReq)
+ , (BC.pack "nonce-rsp", RecBinary nonceRsp)
]
confirmationNumber :: RefDigest -> String
@@ -212,7 +213,7 @@ pairingRequest _ peer = do
PeerIdentityFull pid -> return pid
_ -> throwOtherError "incomplete peer identity"
sendToPeerWith @(PairingService a) peer $ \case
- NoPairing -> return (Just $ PairingRequest (idData self) (idData pid) (nonceDigest self pid nonce BA.empty), OurRequest self pid nonce)
+ NoPairing -> return (Just $ PairingRequest (idData self) (idData pid) (nonceDigest self pid nonce BS.empty), OurRequest self pid nonce)
_ -> throwOtherError "already in progress"
pairingAccept :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m ()
diff --git a/src/Erebos/Service.hs b/src/Erebos/Service.hs
index e95e700..753f58e 100644
--- a/src/Erebos/Service.hs
+++ b/src/Erebos/Service.hs
@@ -29,14 +29,14 @@ import Control.Monad.Writer
import Data.Kind
import Data.Typeable
-import Data.UUID (UUID)
-import qualified Data.UUID as U
import Erebos.Identity
import {-# SOURCE #-} Erebos.Network
import Erebos.State
import Erebos.Storable
import Erebos.Storage.Head
+import Erebos.UUID (UUID)
+import Erebos.UUID qualified as U
class (
Typeable s, Storable s,
diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs
index 5ce9952..076a8c0 100644
--- a/src/Erebos/State.hs
+++ b/src/Erebos/State.hs
@@ -23,8 +23,6 @@ import Control.Monad.Reader
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BC
import Data.Typeable
-import Data.UUID (UUID)
-import Data.UUID qualified as U
import Erebos.Identity
import Erebos.Object
@@ -32,6 +30,8 @@ import Erebos.PubKey
import Erebos.Storable
import Erebos.Storage.Head
import Erebos.Storage.Merge
+import Erebos.UUID (UUID)
+import Erebos.UUID qualified as U
data LocalState = LocalState
{ lsPrev :: Maybe RefDigest
diff --git a/src/Erebos/Storage/Disk.hs b/src/Erebos/Storage/Disk.hs
index 370c584..8e35940 100644
--- a/src/Erebos/Storage/Disk.hs
+++ b/src/Erebos/Storage/Disk.hs
@@ -18,7 +18,6 @@ import Data.ByteString.Lazy.Char8 qualified as BLC
import Data.Function
import Data.List
import Data.Maybe
-import Data.UUID qualified as U
import System.Directory
import System.FSNotify
@@ -31,6 +30,7 @@ import Erebos.Storage.Backend
import Erebos.Storage.Head
import Erebos.Storage.Internal
import Erebos.Storage.Platform
+import Erebos.UUID qualified as U
data DiskStorage = StorageDir
diff --git a/src/Erebos/Storage/Head.hs b/src/Erebos/Storage/Head.hs
index 8f8e009..3239fe0 100644
--- a/src/Erebos/Storage/Head.hs
+++ b/src/Erebos/Storage/Head.hs
@@ -28,13 +28,12 @@ import Control.Monad.Reader
import Data.Bifunctor
import Data.Typeable
-import Data.UUID qualified as U
-import Data.UUID.V4 qualified as U
import Erebos.Object
import Erebos.Storable
import Erebos.Storage.Backend
import Erebos.Storage.Internal
+import Erebos.UUID qualified as U
-- | Represents loaded Erebos storage head, along with the object it pointed to
diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs
index 6df1410..73bdc55 100644
--- a/src/Erebos/Storage/Internal.hs
+++ b/src/Erebos/Storage/Internal.hs
@@ -4,29 +4,28 @@ import Control.Arrow
import Control.Concurrent
import Control.DeepSeq
import Control.Exception
-import Control.Monad
import Control.Monad.Identity
import Crypto.Hash
import Data.Bits
-import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes)
+import Data.ByteArray (ByteArrayAccess, ScrubbedBytes)
import Data.ByteArray qualified as BA
import Data.ByteString (ByteString)
-import Data.ByteString qualified as B
import Data.ByteString.Char8 qualified as BC
import Data.ByteString.Lazy qualified as BL
-import Data.Char
import Data.HashTable.IO qualified as HT
import Data.Hashable
import Data.Kind
import Data.Typeable
-import Data.UUID (UUID)
import Foreign.Storable (peek)
import System.IO.Unsafe (unsafePerformIO)
+import Erebos.UUID (UUID)
+import Erebos.Util
+
data Storage' c = forall bck. (StorageBackend bck, BackendCompleteness bck ~ c) => Storage
{ stBackend :: bck
@@ -196,35 +195,15 @@ showRefDigest = showRefDigestParts >>> \(alg, hex) -> alg <> BC.pack "#" <> hex
readRefDigest :: ByteString -> Maybe RefDigest
readRefDigest x = case BC.split '#' x of
[alg, dgst] | BA.convert alg == BC.pack "blake2" ->
- refDigestFromByteString =<< readHex @ByteString dgst
+ refDigestFromByteString =<< readHex dgst
_ -> Nothing
-refDigestFromByteString :: ByteArrayAccess ba => ba -> Maybe RefDigest
+refDigestFromByteString :: ByteString -> Maybe RefDigest
refDigestFromByteString = fmap RefDigest . digestFromByteString
hashToRefDigest :: BL.ByteString -> RefDigest
hashToRefDigest = RefDigest . hashFinalize . hashUpdates hashInit . BL.toChunks
-showHex :: ByteArrayAccess ba => ba -> ByteString
-showHex = B.concat . map showHexByte . BA.unpack
- where showHexChar x | x < 10 = x + o '0'
- | otherwise = x + o 'a' - 10
- showHexByte x = B.pack [ showHexChar (x `div` 16), showHexChar (x `mod` 16) ]
- o = fromIntegral . ord
-
-readHex :: ByteArray ba => ByteString -> Maybe ba
-readHex = return . BA.concat <=< readHex'
- where readHex' bs | B.null bs = Just []
- readHex' bs = do (bx, bs') <- B.uncons bs
- (by, bs'') <- B.uncons bs'
- x <- hexDigit bx
- y <- hexDigit by
- (B.singleton (x * 16 + y) :) <$> readHex' bs''
- hexDigit x | x >= o '0' && x <= o '9' = Just $ x - o '0'
- | x >= o 'a' && x <= o 'z' = Just $ x - o 'a' + 10
- | otherwise = Nothing
- o = fromIntegral . ord
-
newtype Generation = Generation Int
deriving (Eq, Show)
diff --git a/src/Erebos/UUID.hs b/src/Erebos/UUID.hs
new file mode 100644
index 0000000..128d450
--- /dev/null
+++ b/src/Erebos/UUID.hs
@@ -0,0 +1,24 @@
+module Erebos.UUID (
+ UUID,
+ toString, fromString,
+ toText, fromText,
+ toASCIIBytes, fromASCIIBytes,
+ nextRandom,
+) where
+
+import Crypto.Random.Entropy
+
+import Data.Bits
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BSL
+import Data.Maybe
+import Data.UUID.Types
+
+nextRandom :: IO UUID
+nextRandom = do
+ [ b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf ]
+ <- BS.unpack <$> getEntropy 16
+ let version = 4
+ b6' = b6 .&. 0x0f .|. (version `shiftL` 4)
+ b8' = b8 .&. 0x3f .|. 0x80
+ return $ fromJust $ fromByteString $ BSL.pack [ b0, b1, b2, b3, b4, b5, b6', b7, b8', b9, ba, bb, bc, bd, be, bf ]
diff --git a/src/Erebos/Util.hs b/src/Erebos/Util.hs
index ffca9c7..0381c3e 100644
--- a/src/Erebos/Util.hs
+++ b/src/Erebos/Util.hs
@@ -1,5 +1,14 @@
module Erebos.Util where
+import Control.Monad
+
+import Data.ByteArray (ByteArray, ByteArrayAccess)
+import Data.ByteArray qualified as BA
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as B
+import Data.Char
+
+
uniq :: Eq a => [a] -> [a]
uniq (x:y:xs) | x == y = uniq (x:xs)
| otherwise = x : uniq (y:xs)
@@ -35,3 +44,24 @@ intersectsSorted (x:xs) (y:ys) | x < y = intersectsSorted xs (y:ys)
| x > y = intersectsSorted (x:xs) ys
| otherwise = True
intersectsSorted _ _ = False
+
+
+showHex :: ByteArrayAccess ba => ba -> ByteString
+showHex = B.concat . map showHexByte . BA.unpack
+ where showHexChar x | x < 10 = x + o '0'
+ | otherwise = x + o 'a' - 10
+ showHexByte x = B.pack [ showHexChar (x `div` 16), showHexChar (x `mod` 16) ]
+ o = fromIntegral . ord
+
+readHex :: ByteArray ba => ByteString -> Maybe ba
+readHex = return . BA.concat <=< readHex'
+ where readHex' bs | B.null bs = Just []
+ readHex' bs = do (bx, bs') <- B.uncons bs
+ (by, bs'') <- B.uncons bs'
+ x <- hexDigit bx
+ y <- hexDigit by
+ (B.singleton (x * 16 + y) :) <$> readHex' bs''
+ hexDigit x | x >= o '0' && x <= o '9' = Just $ x - o '0'
+ | x >= o 'a' && x <= o 'z' = Just $ x - o 'a' + 10
+ | otherwise = Nothing
+ o = fromIntegral . ord
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-21 05:33:39 +0000