module Data.UUID.Internal
(UUID(..)
,Node(..)
,nodeToList
,listToNode
,fromString
,toString
,versionMask
,reservedMask
,reserved
) where
import Data.Word
import Data.Char
import Data.Maybe
import Data.Bits
import Data.List (splitAt, foldl', unfoldr)
import Data.Typeable
import Data.Generics.Basics
import Foreign.Ptr
import Foreign.Storable
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import System.Random
import Text.Printf
#ifndef STRICT
#define SLOT(x) x
#else
#define SLOT(x) {-# UNPACK #-} !x
#endif
data UUID = UUID
{uuid_timeLow :: SLOT(Word32)
,uuid_timeMid :: SLOT(Word16)
,uuid_timeHigh :: SLOT(Word16)
,uuid_clockSeqHi :: SLOT(Word8)
,uuid_clokcSeqLow :: SLOT(Word8)
,uuid_node :: SLOT(Node)
} deriving (Eq, Ord, Typeable)
instance Random UUID where
random g = let (timeLow, g1) = randomBoundedIntegral g
(timeMid, g2) = randomBoundedIntegral g1
(timeHigh, g3) = randomBoundedIntegral g2
(seqHigh, g4) = randomBoundedIntegral g3
(seqLow, g5) = randomBoundedIntegral g4
(node, g6) = random g5
seqHighReserved = (seqHigh .&. reservedMask) .|. reserved
timeHighVersion = (timeHigh .&. versionMask) .|. versionRandom
in (UUID timeLow timeMid timeHighVersion seqHighReserved seqLow node, g6)
randomR _ = random
versionMask :: Word16
versionMask = 0x0FFF
versionRandom :: Word16
versionRandom = 4 `shiftL` 12
reservedMask :: Word8
reservedMask = 0x3F
reserved :: Word8
reserved = bit 7
data Node = Node
SLOT(Word8)
SLOT(Word8)
SLOT(Word8)
SLOT(Word8)
SLOT(Word8)
SLOT(Word8)
deriving (Eq, Ord, Typeable)
instance Random Node where
random g = let (w1, g1) = randomBoundedIntegral g
(w2, g2) = randomBoundedIntegral g1
(w3, g3) = randomBoundedIntegral g2
(w4, g4) = randomBoundedIntegral g3
(w5, g5) = randomBoundedIntegral g4
(w6, g6) = randomBoundedIntegral g5
in (Node w1 w2 w3 w4 w5 w6, g6)
randomR _ = random
nodeToList :: Node -> [Word8]
nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
listToNode :: [Word8] -> Maybe Node
listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
listToNode _ = Nothing
instance Show UUID where
show = toString
instance Read UUID where
readsPrec _ str = case fromString (take 36 str) of
Nothing -> []
Just u -> [(u,drop 36 str)]
instance Storable UUID where
sizeOf _ = 16
alignment _ = 4
peek p = do
tl <- peek $ castPtr p
tm <- peekByteOff p 4
th <- peekByteOff p 6
ch <- peekByteOff p 8
cl <- peekByteOff p 9
node <- peekByteOff p 10
return $ UUID tl tm th ch cl node
poke p (UUID tl tm th ch cl node) = do
poke (castPtr p) tl
pokeByteOff p 4 tm
pokeByteOff p 6 th
pokeByteOff p 8 ch
pokeByteOff p 9 cl
pokeByteOff p 10 node
instance Storable Node where
sizeOf _ = 6
alignment _ = 1
peek p = do
w1 <- peek $ castPtr p
w2 <- peekByteOff p 1
w3 <- peekByteOff p 2
w4 <- peekByteOff p 3
w5 <- peekByteOff p 4
w6 <- peekByteOff p 5
return $ Node w1 w2 w3 w4 w5 w6
poke p (Node w1 w2 w3 w4 w5 w6) = do
poke (castPtr p) w1
pokeByteOff p 1 w2
pokeByteOff p 2 w3
pokeByteOff p 3 w4
pokeByteOff p 4 w5
pokeByteOff p 5 w6
instance Binary UUID where
put (UUID tl tm th ch cl n) = do
putWord32be tl
putWord16be tm
putWord16be th
putWord8 ch
putWord8 cl
put n
get = do
tl <- getWord32be
tm <- getWord16be
th <- getWord16be
ch <- getWord8
cl <- getWord8
node <- get
return $ UUID tl tm th ch cl node
instance Binary Node where
put (Node w1 w2 w3 w4 w5 w6) = do
putWord8 w1
putWord8 w2
putWord8 w3
putWord8 w4
putWord8 w5
putWord8 w6
get = do
w1 <- getWord8
w2 <- getWord8
w3 <- getWord8
w4 <- getWord8
w5 <- getWord8
w6 <- getWord8
return $ Node w1 w2 w3 w4 w5 w6
instance Data UUID where
toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
gunfold _ _ = error "gunfold"
dataTypeOf _ = uuidType
uuidType = mkNorepType "Data.UUID.UUID"
fromString :: String -> Maybe UUID
fromString xs | validFmt = Just uuid
| otherwise = Nothing
where validFmt = length ws == 5 &&
map length ws == [8,4,4,4,12] &&
all isHexDigit (concat ws) &&
isJust node
ws = splitList '-' xs
[tl, tm, th, c, n] = ws
ns = unfoldUntil Prelude.null (splitAt 2) n :: [String]
node = listToNode $ map hexVal ns :: Maybe Node
uuid = UUID (hexVal tl) (hexVal tm) (hexVal th) (hexVal $ take 2 c) (hexVal $ drop 2 c) (fromJust $ node)
hexVal :: Num a => String -> a
hexVal = fromInteger . foldl' (\n c -> 16*n + digitToInteger c) 0
digitToInteger :: Char -> Integer
digitToInteger = fromIntegral . digitToInt
toString :: UUID -> String
toString (UUID tl tm th ch cl n) = printf "%08x-%04x-%04x-%02x%02x-%s" tl tm th ch cl ns
where ns = concatMap hexb $ nodeToList n
hexb x = printf "%02x" x :: String
splitList :: Eq a => a -> [a] -> [[a]]
splitList c xs = let ys = dropWhile (== c) xs
in case span (/= c) ys of
([],_) -> []
(sub,rest) -> sub : splitList c rest
unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
unfoldUntil p f n = unfoldr g n
where g m | p m = Nothing
| otherwise = Just $ f m
randomBoundedIntegral :: (RandomGen g, Bounded a, Integral a) => g -> (a, g)
randomBoundedIntegral g =
let (n, g1) = randomR (fromIntegral l, fromIntegral u) g
_ = n :: Integer
retVal = fromIntegral n `asTypeOf` (l `asTypeOf` u)
u = maxBound
l = minBound
in (retVal, g1)