git.iko.soy/typeable/uuid
on 473e034 help sign in
typeable/uuid/Data/UUID/V1.hs
105 lines 2.7 kB history raw
1{-# OPTIONS_GHC -fno-cse #-}
2{-# LANGUAGE TypeFamilies #-}
4-- |
5-- Module : Data.UUID.V1
6-- Copyright : (c) 2008 Jason Dusek
7--
8-- License : BSD-style
9--
10-- Maintainer : aslatter@gmail.com
11-- Stability : experimental
12-- Portability : portable
13--
14-- RFC 4122 Version 1 UUID state machine.
16module Data.UUID.V1(nextUUID)
17where
19import Data.Time
21import Data.Bits
22import Data.Word
24import Control.Concurrent.MVar
25import System.IO
26import System.IO.Unsafe
28import qualified System.Info.MAC as SysMAC
29import Data.MAC
31import Data.UUID.Builder
32import Data.UUID.Internal
34-- | Returns a new UUID derived from the local hardware MAC
35-- address and the current system time.
36-- Is generated according to the Version 1 UUID sepcified in
37-- RFC 4122.
38--
39-- Returns nothing if the hardware MAC address could not
40-- be discovered.
41nextUUID :: IO (Maybe UUID)
42nextUUID = do
43 res <- stepTime
44 mac <- SysMAC.mac
45 case (res, mac) of
46 (Just (c, t), Just m) -> return $ Just $ makeUUID t c m
47 _ -> return Nothing
50makeUUID :: Word64 -> Word16 -> MAC -> UUID
51makeUUID time clock mac =
52 buildFromBytes 1 /-/ tLow /-/ tMid /-/ tHigh /-/ clock /-/ (MACSource mac)
53 where tLow = (fromIntegral time) :: Word32
54 tMid = (fromIntegral (time `shiftR` 32)) :: Word16
55 tHigh = (fromIntegral (time `shiftR` 48)) :: Word16
57newtype MACSource = MACSource MAC
58instance ByteSource MACSource where
59 z /-/ (MACSource (MAC a b c d e f)) = z a b c d e f
60type instance ByteSink MACSource g = Takes3Bytes (Takes3Bytes g)
63-- |Approximates the clock algorithm in RFC 4122, section 4.2
64-- Isn't system wide or thread safe, nor does it properly randomize
65-- the clock value on initialization.
66stepTime :: IO (Maybe (Word16, Word64))
67stepTime = do
68 h1 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
69 modifyMVar state $ \s@(State c0 h0) ->
70 if h1 > h0
71 then
72 return (State c0 h1, Just (c0, h1))
73 else
74 let
75 c1 = succ c0
76 in if c1 <= 0x3fff -- when clock is initially randomized,
77 -- then this test will need to change
78 then
79 return (State c1 h1, Just (c1, h1))
80 else
81 return (s, Nothing)
84{-# NOINLINE state #-}
85state :: MVar State
86state = unsafePerformIO $ do
87 h0 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
88 newMVar $ State 0 h0 -- the 0 should be a random number
91data State = State
92 {-# UNPACK #-} !Word16
93 {-# UNPACK #-} !Word64
94 deriving (Show)
98hundredsOfNanosSinceGregorianReform :: UTCTime -> Word64
99hundredsOfNanosSinceGregorianReform t = floor $ 10000000 * dt
100 where
101 gregorianReform = UTCTime (fromGregorian 1582 10 15) 0
102 dt = t `diffUTCTime` gregorianReform