@@ -0,0 +1,108 @@
1+{-# OPTIONS_GHC -fno-cse #-}
2+
3+-- |
4+-- Module : Data.UUID.V1
5+-- Copyright : (c) 2008 Jason Dusek
6+--
7+-- License : BSD-style
8+--
9+-- Maintainer : aslatter@gmail.com
10+-- Stability : experimental
11+-- Portability : portable
12+--
13+-- RFC 4122 Version 1 UUID state machine.
14+
15+module Data.UUID.V1(nextUUID)
16+where
17+
18+import Data.Time
19+
20+import Data.Bits
21+import Data.Word
22+import Data.Binary
23+
24+import Data.IORef
25+import System.IO
26+import System.IO.Unsafe
27+
28+import System.Info.MAC
29+import Data.MAC
30+
31+import Data.UUID.Internal
32+
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
36+-- RFC 4122.
37+--
38+-- Returns nothing if the hardware MAC address could not
39+-- be discovered.
40+nextUUID :: IO (Maybe UUID)
41+nextUUID = do
42+ res <- stepTime
43+ mac <- mac
44+ case (res, mac) of
45+ (Just (c, t), Just (MAC a' b' c' d' e' f')) -> do
46+ let
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'
50+ _ -> return Nothing
51+
52+
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)
57+ where
58+ lo = fromIntegral $ (w `shiftL` 32) `shiftR` 32
59+ mi = fromIntegral $ (w `shiftL` 16) `shiftR` 32
60+ hi = (fromIntegral $ w `shiftR` 48) `setBit` 15
61+
62+
63+stepTime = do
64+ State c0 h0 <- readIORef state
65+ h1 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
66+ if h1 > h0
67+ then do
68+ writeIORef state $ State 0 h1
69+ return $ Just (0, h1)
70+ else do
71+ let
72+ c1 = succ c0
73+ if c1 < 2^14
74+ then do
75+ writeIORef state $ State c1 h0
76+ return $ Just (c1, h0)
77+ else do
78+ return Nothing
79+
80+
81+{-# NOINLINE state #-}
82+state = unsafePerformIO $ do
83+ h0 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
84+ newIORef $ State 0 h0
85+
86+
87+data State = State
88+ {-# UNPACK #-} !Word16
89+ {-# UNPACK #-} !Word64
90+ deriving (Show)
91+
92+
93+
94+hundredsOfNanosSinceGregorianReform :: UTCTime -> Word64
95+hundredsOfNanosSinceGregorianReform t = floor $ 10000000 * dt
96+ where
97+ gregorianReform = UTCTime (fromGregorian 1582 10 15) 0
98+ dt = t `diffUTCTime` gregorianReform
99+
100+
101+-- |Per clause 13 of ITU X.667, from September 2004.
102+word16ToClockSeqPieces :: Word16 -> (Word8, Word8)
103+word16ToClockSeqPieces w = (lo, hi)
104+ where
105+ lo = fromIntegral $ (w `shiftL` 8) `shiftR` 8
106+ hi = (fromIntegral $ w `shiftR` 8) `setBit` 7
107+
108+