{-# OPTIONS_GHC -fno-cse #-}
{-# LANGUAGE TypeFamilies #-}
module Data.UUID.V1(nextUUID)
where
import Data.Time
import Data.Bits
import Data.Word
import Control.Applicative ((<$>),(<*>))
import Control.Concurrent.MVar
import System.IO.Unsafe
import qualified System.Random as R
import qualified System.Info.MAC as SysMAC
import Data.MAC
import Data.UUID.Builder
import Data.UUID.Internal
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)
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
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
getMac :: IO MAC
getMac =
SysMAC.mac >>= \macM ->
case macM of
Just m -> return m
Nothing -> randomMac
randomMac :: IO MAC
randomMac =
MAC
<$> R.randomIO
<*> 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