{-# LANGUAGE ScopedTypeVariables #-} {- | uuid256.hs — reference implementation of README.md (UUID256, random layout) in Haskell (GHC ≥ 9, base + bytestring + containers). ghc -O2 -outputdir /tmp/uuid256-hs-build -o /tmp/uuid256-hs uuid256.hs && /tmp/uuid256-hs /tmp/uuid256-hs -n 200000 -i 3 -- 2e5 ids with 3 planted duplicates (proves detection) /tmp/uuid256-hs -g [count] -- just print one (or count) new ids, nothing else (runghc uuid256.hs -g also works, interpreted) import Uuid256 (from this file's top section) id <- generate -- Uuid256 (32 strict bytes), §5.1: /dev/urandom (OS CSPRNG), ver=4 / var=10 applied let txt = toCanonical id -- §3.1: "0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1f" parse True txt :: Either ParseError Uuid256 -- §6: strict; parse False is lenient Randomness (§5.2): /dev/urandom — base has no CSPRNG (System.Random is not one; use the `entropy` package if you prefer a portable dependency). Bulk check: one urandom read for all ids, §4 applied to each, then a Data.Set of the 32-byte ids (exact). -} module Main (main) where import qualified Data.ByteString as B import qualified Data.Set as Set import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.Char (isHexDigit, digitToInt, toLower, toUpper) import Data.List (foldl') import Data.Word (Word8) import System.Environment (getArgs) import System.Exit (exitWith, ExitCode(..)) import System.IO (withBinaryFile, IOMode(..)) import Text.Printf (printf) import Data.Time.Clock (getCurrentTime, diffUTCTime) import Control.Monad (forM_, when, replicateM_) -- ============================================================================ -- Spec §3–§6: the Uuid256 type -- ============================================================================ newtype Uuid256 = Uuid256 B.ByteString deriving (Eq, Ord) -- 32 bytes, big-endian: byte 0 most significant (§7.1: Ord == text order) instance Show Uuid256 where show = toCanonical data ParseError = ErrLength | ErrHyphen | ErrChar | ErrVersion deriving (Eq, Show) versionNumber :: Word8 versionNumber = 4 -- | §5.2 — n bytes from the OS CSPRNG. osRandom :: Int -> IO B.ByteString osRandom n = withBinaryFile "/dev/urandom" ReadMode $ \h -> B.hGet h n -- | §4 — force version nibble (byte 12) and variant bits (byte 16) in a raw 32-byte string. setVerVar :: B.ByteString -> B.ByteString setVerVar b = B.pack [ f i x | (i, x) <- zip [0 :: Int ..] (B.unpack b) ] where f 12 x = (x .&. 0x0F) .|. (versionNumber `shiftL` 4) -- hex digit 24 = '4' f 16 x = (x .&. 0x3F) .|. 0x80 -- hex digit 32 in [89ab] f _ x = x -- | §5.1 — a new id straight from the OS CSPRNG. generate :: IO Uuid256 generate = Uuid256 . setVerVar <$> osRandom 32 fromBytes :: B.ByteString -> Maybe Uuid256 fromBytes b | B.length b == 32 = Just (Uuid256 b) | otherwise = Nothing toBytes :: Uuid256 -> B.ByteString toBytes (Uuid256 b) = b -- | §6 — ver == 4 && var == 10. isStrict :: Uuid256 -> Bool isStrict (Uuid256 b) = (B.index b 12 `shiftR` 4) == versionNumber && (B.index b 16 `shiftR` 6) == 2 -- | §3.1 — canonical text: 16-8-8-8-24, lowercase, 68 chars. toCanonical :: Uuid256 -> String toCanonical (Uuid256 b) = concat [ hex2 x ++ (if i `elem` [7, 11, 15, 19] then "-" else "") | (i, x) <- zip [0 :: Int ..] (B.unpack b) ] where hex2 x = [hexDigit (x `shiftR` 4), hexDigit (x .&. 0x0F)] hexDigit d = "0123456789abcdef" !! fromIntegral d toCompact :: Uuid256 -> String toCompact = filter (/= '-') . toCanonical -- | §6 — canonical (68) or compact (64) form, any case; strict checks ver/var. parse :: Bool -> String -> Either ParseError Uuid256 parse strict s0 = do let s = map toLower s0 hexs <- case length s of 68 | all (\i -> s !! i == '-') [16, 25, 34, 43] -> Right (filter (/= '-') s) | otherwise -> Left ErrHyphen 64 -> Right s _ -> Left ErrLength if length hexs /= 64 || not (all isHexDigit hexs) then Left ErrChar else do -- a stray '-' outside the 4 slots leaves < 64 hex digits let bytes = B.pack (pairs hexs) u = Uuid256 bytes if strict && not (isStrict u) then Left ErrVersion else Right u where pairs (a:b:rest) = fromIntegral (digitToInt a * 16 + digitToInt b) : pairs rest pairs _ = [] nilId, maxId :: Uuid256 nilId = Uuid256 (B.replicate 32 0x00) -- §8 maxId = Uuid256 (B.replicate 32 0xFF) -- ============================================================================ -- Self-tests (spec §11 vectors, §3.2/§6 parser rules, live generation) -- ============================================================================ unhex :: String -> B.ByteString unhex s = either (const B.empty) toBytes (parse False s) selfTest :: IO Int selfTest = do let vectors = [ ("000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f", "0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1f") , ("fffefdfcfbfaf9f8f7f6f5f4f3f2f1f0efeeedecebeae9e8e7e6e5e4e3e2e1e0", "fffefdfcfbfaf9f8-f7f6f5f4-43f2f1f0-afeeedec-ebeae9e8e7e6e5e4e3e2e1e0") ] f1 <- fmap sum $ mapM (\(i, (raw, expected)) -> do let u = Uuid256 (setVerVar (unhex raw)); txt = toCanonical u ok = txt == expected && isStrict u && parse True txt == Right u && parse True (map toUpper txt) == Right u && either (const False) (const True) (parse False raw) && parse True raw == Left ErrVersion -- raw compact: lenient ok, strict rejects && toCompact u == filter (/= '-') txt printf " spec §11 vector %d: %s %s\n" (i :: Int) (if ok then "PASS" else "FAIL") txt return (if ok then 0 else 1)) (zip [1 ..] vectors) let nilTxt = toCanonical nilId ok2 = parse True "0001020304050607_08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1f" == Left ErrHyphen && parse True "0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1" == Left ErrLength && parse True "0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1g" == Left ErrChar && parse True nilTxt == Left ErrVersion && parse False nilTxt == Right nilId && nilId < maxId && toCanonical maxId == concat [replicate 16 'f', "-", replicate 8 'f', "-", replicate 8 'f', "-", replicate 8 'f', "-", replicate 24 'f'] printf " parser rules (§3.2/§6): %s\n" (if ok2 then "PASS" else "FAIL") f3 <- fmap sum $ mapM (\_ -> do u <- generate let txt = toCanonical u ok = isStrict u && length txt == 68 && txt !! 26 == '4' && (txt !! 35) `elem` "89ab" && parse True txt == Right u printf " generate: %s %s\n" txt (if ok then "ok" else "BAD" :: String) return (if ok then 0 else 1)) [1 .. 3 :: Int] return (f1 + (if ok2 then 0 else 1) + f3) -- ============================================================================ -- Bulk exact duplicate check -- ============================================================================ commas :: Int -> String commas = reverse . go . reverse . show where go (a:b:c:d:rest) = a : b : c : ',' : go (d : rest) go xs = xs idAt :: B.ByteString -> Int -> B.ByteString idAt buf i = B.take 32 (B.drop (i * 32) buf) main :: IO () main = do args <- getArgs let num v = case reads v :: [(Int, String)] of { [(x, "")] -> Just x; _ -> Nothing } go acc ("-n":v:rest) | Just x <- num v = go (acc >>= \(_, p) -> Just (x, p)) rest go acc ("-i":v:rest) | Just x <- num v = go (acc >>= \(n, _) -> Just (n, x)) rest go acc [] = acc go _ _ = Nothing -- unknown flag, dangling flag or bad number → usage case args of (flag:txt:_) | flag `elem` ["-p", "-P"] -> do -- parse mode: -p strict, -P lenient case parse (flag == "-p") txt of Right u -> putStrLn ("ok " ++ toCompact u) Left e -> putStrLn ("error " ++ case e of { ErrLength -> "length"; ErrHyphen -> "hyphen"; ErrChar -> "char"; ErrVersion -> "version" }) >> exitWith (ExitFailure 1) ("-g":rest) -> do let count = case rest of (c:_) | all (`elem` "0123456789") c && not (null c) -> read c; _ -> 1 -- -g N: exactly N (0 allowed); junk → 1 replicateM_ count (generate >>= putStrLn . toCanonical) _ -> do (n, planted) <- case go (Just (1000000 :: Int, 0 :: Int)) args of Just np -> return np Nothing -> putStrLn "usage: uuid256-hs [-g [count]] [-n count] [-i planted_dups] | -p|-P " >> exitWith (ExitFailure 2) when (n < 2 || planted < 0 || planted > n `div` 2) $ putStrLn "-n must be >= 2 and -i at most n/2" >> exitWith (ExitFailure 2) putStrLn "UUID256 reference implementation (Haskell) — README.md (256-bit random, 16-8-8-8-24 text)\n" putStrLn "Self-tests:" fails <- selfTest when (fails > 0) $ putStrLn " self-test FAILED — aborting" >> exitWith (ExitFailure 1) let k = 20000 :: Int t0 <- getCurrentTime replicateM_ k (generate >>= \u -> u `seq` return ()) t1 <- getCurrentTime let perCall = realToFrac (diffUTCTime t1 t0) / fromIntegral k :: Double printf "\ngenerate per-call cost: %.2f µs → %.3f M ids/s single-threaded (1e9 ids would take ~%.0f min just to generate; opening /dev/urandom per call dominates)\n" (perCall * 1e6) (1 / perCall / 1e6) (1e9 * perCall / 60) printf "\nBulk exact duplicate check: n=%s ids, planted duplicates=%d\n" (commas n) planted tA <- getCurrentTime raw <- osRandom (n * 32) -- §5.2, one read let buf0 = B.concat [ setVerVar (idAt raw i) | i <- [0 .. n - 1] ] -- §4 on every id plants = [ (src, n - 1 - src) | kk <- [0 .. planted - 1], let src = kk * ((n `div` 2) `div` planted) ] -- stride: distinct pairs for every k < planted <= n/2 buf = foldl' (\b (src, dst) -> B.concat [B.take (dst * 32) b, idAt b src, B.drop ((dst + 1) * 32) b]) buf0 plants -- id[dst] := id[src] forM_ plants $ \(src, dst) -> printf " planted: id[%s] := id[%s]\n" (commas dst) (commas src) B.length buf `seq` return () tB <- getCurrentTime let ids = [ idAt buf i | i <- [0 .. n - 1] ] bad = length [ () | b <- ids, (B.index b 12 `shiftR` 4) /= versionNumber || (B.index b 16 `shiftR` 6) /= 2 ] -- exact: first-occurrence set; a repeat is a duplicate (index of first occurrence looked up afterwards) (_, dupsRev) = foldl' (\(seen, ds) (i, b) -> if Set.member b seen then (seen, (i, b) : ds) else (Set.insert b seen, ds)) (Set.empty, []) (zip [0 ..] ids) firstIdx b = case [ j | (j, b') <- zip [0 :: Int ..] ids, b' == b ] of { (j:_) -> j; [] -> -1 } dups = [ (firstIdx b, i, b) | (i, b) <- reverse dupsRev ] length dups `seq` bad `seq` return () tC <- getCurrentTime forM_ dups $ \(i, j, b) -> printf " DUPLICATE id[%s] == id[%s] %s\n" (commas i) (commas j) (toCanonical (Uuid256 b)) let step = max 1 (n `div` 1000) rtOk = length [ () | i <- [0, step .. n - 1], let u = Uuid256 (idAt buf i), parse True (toCanonical u) == Right u ] putStrLn "\n==== RESULT ====" printf "ids generated: %s (/dev/urandom + §4 in %.1fs; Set-based dedup in %.1fs)\n" (commas n) (realToFrac (diffUTCTime tB tA) :: Double) (realToFrac (diffUTCTime tC tB) :: Double) printf "version/variant violations: %s\n" (commas bad) printf "text round-trips (sampled): %s ok\n" (commas rtOk) printf "FULL 256-bit DUPLICATES: %s%s\n" (commas (length dups)) (if planted > 0 then printf " (planted: %d — %s)" planted (if length dups == planted then "all detected" else "COUNT MISMATCH" :: String) else "" :: String) when (null dups) $ printf " → no duplicates among %s ids\n" (commas n) let log2p = 2 * logBase 2 (fromIntegral n) - 251 :: Double printf "expected P(any collision) §5.3: n²/2²⁵¹ ≈ 2^%.1f ≈ %.1e\n" log2p (2 ** log2p) exitWith (if length dups == planted then ExitSuccess else ExitFailure 1)