module Data.UUID.V1(nextUUID)
where
import Data.Time
import Data.Bits
import Data.Word
import Data.Binary
import Data.IORef
import System.IO
import System.IO.Unsafe
import System.Info.MAC
import Data.MAC
import Data.UUID.Internal
nextUUID :: IO (Maybe UUID)
nextUUID = do
res <- stepTime
mac <- mac
case (res, mac) of
(Just (c, t), Just (MAC a' b' c' d' e' f')) -> do
let
(tL, tM, tH) = word64ToTimePieces t
(cL, cH) = word16ToClockSeqPieces c
return $ Just $ UUID tL tM tH cH cL $ Node a' b' c' d' e' f'
_ -> return Nothing
word64ToTimePieces :: Word64 -> (Word32, Word16, Word16)
word64ToTimePieces w = (lo, mi, hi)
where
lo = fromIntegral $ (w `shiftL` 32) `shiftR` 32
mi = fromIntegral $ (w `shiftL` 16) `shiftR` 48
hi = (fromIntegral $ w `shiftR` 48) `setBit` 15
stepTime = do
State c0 h0 <- readIORef state
h1 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
if h1 > h0
then do
writeIORef state $ State 0 h1
return $ Just (0, h1)
else do
let
c1 = succ c0
if c1 < 2^14
then do
writeIORef state $ State c1 h0
return $ Just (c1, h0)
else do
return Nothing
state = unsafePerformIO $ do
h0 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
newIORef $ State 0 h0
data State = State
!Word16
!Word64
deriving (Show)
hundredsOfNanosSinceGregorianReform :: UTCTime -> Word64
hundredsOfNanosSinceGregorianReform t = floor $ 10000000 * dt
where
gregorianReform = UTCTime (fromGregorian 1582 10 15) 0
dt = t `diffUTCTime` gregorianReform
word16ToClockSeqPieces :: Word16 -> (Word8, Word8)
word16ToClockSeqPieces w = (lo, hi)
where
lo = fromIntegral $ (w `shiftL` 8) `shiftR` 8
hi = (fromIntegral $ w `shiftR` 8) `setBit` 7