{-# LANGUAGE DeriveDataTypeable, CPP #-} -- | -- Module : Data.UUID -- Copyright : (c) 2008 Antoine Latter -- -- License : BSD-style -- -- Maintainer : aslatter@gmail.com -- Stability : experimental -- Portability : portable 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 -- |The UUID type. A 'Random' instance is provided which produces -- version 3 UUIDs as specified in RFC 4122. The 'Storable' and -- 'Binary' instances are compatable with RFC 4122. The 'Binary' -- instance serializes to network byte order. data UUID = UUID {uuid_timeLow :: SLOT(Word32) ,uuid_timeMid :: SLOT(Word16) ,uuid_timeHigh :: SLOT(Word16) -- includes version number ,uuid_clockSeqHi :: SLOT(Word8) -- includes reserved field ,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 -- range is ignored versionMask :: Word16 -- 0000 1111 1111 1111 versionMask = 0x0FFF versionRandom :: Word16 versionRandom = 4 `shiftL` 12 reservedMask :: Word8 -- 0011 1111 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 -- neglect range 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 -- not sure what to put here 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 -- Binary instance in network byte-order 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 -- My goal with this instance was to make it work just enough to do what -- I want when used with the HStringTemplate library. instance Data UUID where toConstr uu = mkConstr uuidType (show uu) [] (error "fixity") gunfold _ _ = error "gunfold" dataTypeOf _ = uuidType uuidType = mkNorepType "Data.UUID.UUID" -- |If the passed in 'String' can be parsed as a 'UUID', it will be. -- The hyphens may not be omitted. -- Example: -- -- @ -- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\" -- @ -- -- Hex digits may be upper or lower-case. 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) -- | Convert a string to a hex value, assuming the string is already validated. hexVal :: Num a => String -> a hexVal = fromInteger . foldl' (\n c -> 16*n + digitToInteger c) 0 digitToInteger :: Char -> Integer digitToInteger = fromIntegral . digitToInt -- | Convert a UUID into a hypenated string using lower-case letters. -- Example: -- -- @ -- toString $ fromString \"550e8400-e29b-41d4-a716-446655440000\" -- @ 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 -- remove all occurances of the input element in the inpt list. -- none of the sub-lists are empty. 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 -- the passed-in predicate signals when to stop unfolding 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 -- no random intance for Data.Word types :-( -- this will work, though 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)