@@ -0,0 +1,108 @@
1+{-# OPTIONS_GHC -fno-cse #-}
4+-- Module : Data.UUID.V1
5+-- Copyright : (c) 2008 Jason Dusek
9+-- Maintainer : aslatter@gmail.com
10+-- Stability : experimental
11+-- Portability : portable
13+-- RFC 4122 Version 1 UUID state machine.
15+module Data.UUID.V1(nextUUID)
26+import System.IO.Unsafe
28+import System.Info.MAC
31+import Data.UUID.Internal
33+-- | Returns a new UUID derived from the local hardware MAC
34+-- address and the current system time.
35+-- Is generated according to the Version 1 UUID sepcified in
38+-- Returns nothing if the hardware MAC address could not
40+nextUUID :: IO (Maybe UUID)
45+ (Just (c, t), Just (MAC a' b' c' d' e' f')) -> do
47+ (tL, tM, tH) = word64ToTimePieces t
48+ (cL, cH) = word16ToClockSeqPieces c
49+ return $ Just $ UUID tL tM tH cH cL $ Node a' b' c' d' e' f'
53+-- |The bit layout and version number here used are described in clause 13 of
54+-- ITU X.667, from September 2004.
55+word64ToTimePieces :: Word64 -> (Word32, Word16, Word16)
56+word64ToTimePieces w = (lo, mi, hi)
58+ lo = fromIntegral $ (w `shiftL` 32) `shiftR` 32
59+ mi = fromIntegral $ (w `shiftL` 16) `shiftR` 32
60+ hi = (fromIntegral $ w `shiftR` 48) `setBit` 15
64+ State c0 h0 <- readIORef state
65+ h1 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
68+ writeIORef state $ State 0 h1
69+ return $ Just (0, h1)
75+ writeIORef state $ State c1 h0
76+ return $ Just (c1, h0)
81+{-# NOINLINE state #-}
82+state = unsafePerformIO $ do
83+ h0 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
84+ newIORef $ State 0 h0
88+ {-# UNPACK #-} !Word16
89+ {-# UNPACK #-} !Word64
94+hundredsOfNanosSinceGregorianReform :: UTCTime -> Word64
95+hundredsOfNanosSinceGregorianReform t = floor $ 10000000 * dt
97+ gregorianReform = UTCTime (fromGregorian 1582 10 15) 0
98+ dt = t `diffUTCTime` gregorianReform
101+-- |Per clause 13 of ITU X.667, from September 2004.
102+word16ToClockSeqPieces :: Word16 -> (Word8, Word8)
103+word16ToClockSeqPieces w = (lo, hi)
105+ lo = fromIntegral $ (w `shiftL` 8) `shiftR` 8
106+ hi = (fromIntegral $ w `shiftR` 8) `setBit` 7