git.iko.soy/typeable/uuid
on a5fdff1 help sign in
typeable/uuid/Data/UUID/V1.hs
108 lines 2.6 kB history raw
1{-# OPTIONS_GHC -fno-cse #-}
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.
15module Data.UUID.V1(nextUUID)
16where
18import Data.Time
20import Data.Bits
21import Data.Word
22import Data.Binary
24import Data.IORef
25import System.IO
26import System.IO.Unsafe
28import System.Info.MAC
29import Data.MAC
31import 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
36-- RFC 4122.
37--
38-- Returns nothing if the hardware MAC address could not
39-- be discovered.
40nextUUID :: IO (Maybe UUID)
41nextUUID = 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
53-- |The bit layout and version number here used are described in clause 13 of
54-- ITU X.667, from September 2004.
55word64ToTimePieces :: Word64 -> (Word32, Word16, Word16)
56word64ToTimePieces w = (lo, mi, hi)
57 where
58 lo = fromIntegral $ (w `shiftL` 32) `shiftR` 32
59 mi = fromIntegral $ (w `shiftL` 16) `shiftR` 48
60 hi = (fromIntegral $ w `shiftR` 48) `setBit` 15
63stepTime = 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
81{-# NOINLINE state #-}
82state = unsafePerformIO $ do
83 h0 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
84 newIORef $ State 0 h0
87data State = State
88 {-# UNPACK #-} !Word16
89 {-# UNPACK #-} !Word64
90 deriving (Show)
94hundredsOfNanosSinceGregorianReform :: UTCTime -> Word64
95hundredsOfNanosSinceGregorianReform t = floor $ 10000000 * dt
96 where
97 gregorianReform = UTCTime (fromGregorian 1582 10 15) 0
98 dt = t `diffUTCTime` gregorianReform
101-- |Per clause 13 of ITU X.667, from September 2004.
102word16ToClockSeqPieces :: Word16 -> (Word8, Word8)
103word16ToClockSeqPieces w = (lo, hi)
104 where
105 lo = fromIntegral $ (w `shiftL` 8) `shiftR` 8
106 hi = (fromIntegral $ w `shiftR` 8) `setBit` 7