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