Replace uuid package with custom module

Avoids transitive denpednecies not buildable with wasm backend.

8 files changed, 121 insertions, 34 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/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..ffe11e5 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
@@ -205,26 +204,6 @@ 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..353cc0e
--- /dev/null
+++ b/src/Erebos/UUID.hs
@@ -0,0 +1,78 @@
+module Erebos.UUID (
+    UUID,
+    toString, fromString,
+    toText, fromText,
+    toASCIIBytes, fromASCIIBytes,
+    nextRandom,
+) where
+
+import Control.Monad
+
+import Crypto.Random.Entropy
+
+import Data.Bits
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BSC
+import Data.Text (Text)
+import Data.Text.Encoding
+
+import Erebos.Util
+
+
+newtype UUID = UUID ByteString
+    deriving (Eq, Ord)
+
+instance Show UUID where
+    show = toString
+
+
+toString :: UUID -> String
+toString = BSC.unpack . toASCIIBytes
+
+fromString :: String -> Maybe UUID
+fromString = fromASCIIBytes . BSC.pack
+
+toText :: UUID -> Text
+toText = decodeUtf8 . toASCIIBytes
+
+fromText :: Text -> Maybe UUID
+fromText = fromASCIIBytes . encodeUtf8
+
+toASCIIBytes :: UUID -> ByteString
+toASCIIBytes (UUID uuid) = BS.concat
+    [ showHex $ BS.take 4 $            uuid
+    , BSC.singleton '-'
+    , showHex $ BS.take 2 $ BS.drop  4 uuid
+    , BSC.singleton '-'
+    , showHex $ BS.take 2 $ BS.drop  6 uuid
+    , BSC.singleton '-'
+    , showHex $ BS.take 2 $ BS.drop  8 uuid
+    , BSC.singleton '-'
+    , showHex             $ BS.drop 10 uuid
+    ]
+
+fromASCIIBytes :: ByteString -> Maybe UUID
+fromASCIIBytes bs = do
+    guard $ BS.length bs == 36
+    guard $ BSC.index bs 8 == '-'
+    guard $ BSC.index bs 13 == '-'
+    guard $ BSC.index bs 18 == '-'
+    guard $ BSC.index bs 23 == '-'
+    UUID . BS.concat <$> sequence
+        [ readHex $ BS.take 8 $            bs
+        , readHex $ BS.take 4 $ BS.drop 9  bs
+        , readHex $ BS.take 4 $ BS.drop 14 bs
+        , readHex $ BS.take 4 $ BS.drop 19 bs
+        , readHex             $ BS.drop 24 bs
+        ]
+
+
+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 $ UUID $ BS.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