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
#if __GLASGOW_HASKELL__ >= 610
import Data.Data
#else
import Data.Generics.Basics
#endif
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)