1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
{-# OPTIONS_GHC -fno-cse #-}
{-# LANGUAGE TypeFamilies #-}
{- |
Module : Data.UUID.V1
Copyright : (c) 2008 Jason Dusek
(c) 2009 Mark Lentczner
(c) 2009-2010,2012 Antoine Latter
License : BSD-style
Maintainer : aslatter@gmail.com
Stability : experimental
Portability : portable
RFC 4122 Version 1 UUID state machine.
The generated UUID is based on the hardware MAC
address and the system clock.
If we cannot lookup the MAC address we seed the
generator with a psuedo-random number.
-}
module Data.UUID.V1(nextUUID)
where
import Data.Bits
import Data.Maybe
import Data.Time
import Data.Word
import Control.Applicative ((<$>),(<*>))
import Control.Concurrent.MVar
import System.IO.Unsafe
import qualified System.Random as R
import Network.Info
import Data.UUID.Builder
import Data.UUID.Internal
-- | Returns a new UUID derived from the local hardware MAC
-- address and the current system time.
-- Is generated according to the Version 1 UUID sepcified in
-- RFC 4122.
--
-- Returns 'Nothing' if you request UUIDs too quickly.
nextUUID :: IO (Maybe UUID)
nextUUID = do
res <- stepTime
case res of
Just (mac', c, t) -> return $ Just $ makeUUID t c mac'
_ -> return Nothing
makeUUID :: Word64 -> Word16 -> MAC -> UUID
makeUUID time clock mac' =
buildFromBytes 1 /-/ tLow /-/ tMid /-/ tHigh /-/ clock /-/ (MACSource mac')
where tLow = (fromIntegral time) :: Word32
tMid = (fromIntegral (time `shiftR` 32)) :: Word16
tHigh = (fromIntegral (time `shiftR` 48)) :: Word16
newtype MACSource = MACSource MAC
instance ByteSource MACSource where
z /-/ (MACSource (MAC a b c d e f)) = z a b c d e f
type instance ByteSink MACSource g = Takes3Bytes (Takes3Bytes g)
-- |Approximates the clock algorithm in RFC 4122, section 4.2
-- Isn't system wide or thread safe, nor does it properly randomize
-- the clock value on initialization.
stepTime :: IO (Maybe (MAC, Word16, Word64))
stepTime = do
h1 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
modifyMVar state $ \s@(State mac' c0 h0) ->
if h1 > h0
then
return (State mac' c0 h1, Just (mac', c0, h1))
else
let
c1 = succ c0
in if c1 <= 0x3fff -- when clock is initially randomized,
-- then this test will need to change
then
return (State mac' c1 h1, Just (mac', c1, h1))
else
return (s, Nothing)
{-# NOINLINE state #-}
state :: MVar State
state = unsafePerformIO $ do
h0 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
mac' <- getMac
newMVar $ State mac' 0 h0 -- the 0 should be a random number
-- SysMAC.mac can fail on some machines.
-- In those cases we fake it with a random
-- 6 bytes seed.
getMac :: IO MAC
getMac =
getNetworkInterfaces >>=
return . listToMaybe . filter (minBound /=) . map mac >>=
\macM -> case macM of
Just m -> return m
Nothing -> randomMac
randomMac :: IO MAC
randomMac =
-- I'm too lazy to thread through
-- the random state ...
MAC
<$> (R.randomIO >>= return . (1 .|.)) -- We must set the multicast bit to True. See section 4.5 of the RFC.
<*> R.randomIO
<*> R.randomIO
<*> R.randomIO
<*> R.randomIO
<*> R.randomIO
data State = State
{-# UNPACK #-} !MAC
{-# UNPACK #-} !Word16
{-# UNPACK #-} !Word64
deriving (Show)
hundredsOfNanosSinceGregorianReform :: UTCTime -> Word64
hundredsOfNanosSinceGregorianReform t = floor $ 10000000 * dt
where
gregorianReform = UTCTime (fromGregorian 1582 10 15) 0
dt = t `diffUTCTime` gregorianReform
|
