{-# OPTIONS_GHC -fno-cse #-}
{-# LANGUAGE TypeFamilies #-}
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.Types.Internal.Builder
import Data.UUID.Types.Internal
nextUUID :: IO (Maybe UUID)
nextUUID :: IO (Maybe UUID)
nextUUID = do
Maybe (MAC, Word16, Word64)
res <- IO (Maybe (MAC, Word16, Word64))
stepTime
case Maybe (MAC, Word16, Word64)
res of
Just (MAC
mac', Word16
c, Word64
t) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Word64 -> Word16 -> MAC -> UUID
makeUUID Word64
t Word16
c MAC
mac'
Maybe (MAC, Word16, Word64)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
makeUUID :: Word64 -> Word16 -> MAC -> UUID
makeUUID :: Word64 -> Word16 -> MAC -> UUID
makeUUID Word64
time Word16
clock MAC
mac' =
Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Takes2Bytes
(Takes2Bytes (Takes2Bytes (Takes3Bytes (Takes3Bytes UUID))))
buildFromBytes Word8
1 forall w g. ByteSource w => ByteSink w g -> w -> g
/-/ Word32
tLow forall w g. ByteSource w => ByteSink w g -> w -> g
/-/ Word16
tMid forall w g. ByteSource w => ByteSink w g -> w -> g
/-/ Word16
tHigh forall w g. ByteSource w => ByteSink w g -> w -> g
/-/ Word16
clock forall w g. ByteSource w => ByteSink w g -> w -> g
/-/ (MAC -> MACSource
MACSource MAC
mac')
where tLow :: Word32
tLow = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
time) :: Word32
tMid :: Word16
tMid = (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
time forall a. Bits a => a -> Int -> a
`shiftR` Int
32)) :: Word16
tHigh :: Word16
tHigh = (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
time forall a. Bits a => a -> Int -> a
`shiftR` Int
48)) :: Word16
newtype MACSource = MACSource MAC
instance ByteSource MACSource where
ByteSink MACSource g
z /-/ :: forall g. ByteSink MACSource g -> MACSource -> g
/-/ (MACSource (MAC Word8
a Word8
b Word8
c Word8
d Word8
e Word8
f)) = ByteSink MACSource g
z Word8
a Word8
b Word8
c Word8
d Word8
e Word8
f
type instance ByteSink MACSource g = Takes3Bytes (Takes3Bytes g)
stepTime :: IO (Maybe (MAC, Word16, Word64))
stepTime :: IO (Maybe (MAC, Word16, Word64))
stepTime = do
Word64
h1 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UTCTime -> Word64
hundredsOfNanosSinceGregorianReform IO UTCTime
getCurrentTime
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar State
state forall a b. (a -> b) -> a -> b
$ \s :: State
s@(State MAC
mac' Word16
c0 Word64
h0) ->
if Word64
h1 forall a. Ord a => a -> a -> Bool
> Word64
h0
then
forall (m :: * -> *) a. Monad m => a -> m a
return (MAC -> Word16 -> Word64 -> State
State MAC
mac' Word16
c0 Word64
h1, forall a. a -> Maybe a
Just (MAC
mac', Word16
c0, Word64
h1))
else
let
c1 :: Word16
c1 = forall a. Enum a => a -> a
succ Word16
c0
in if Word16
c1 forall a. Ord a => a -> a -> Bool
<= Word16
0x3fff
then
forall (m :: * -> *) a. Monad m => a -> m a
return (MAC -> Word16 -> Word64 -> State
State MAC
mac' Word16
c1 Word64
h1, forall a. a -> Maybe a
Just (MAC
mac', Word16
c1, Word64
h1))
else
forall (m :: * -> *) a. Monad m => a -> m a
return (State
s, forall a. Maybe a
Nothing)
{-# NOINLINE state #-}
state :: MVar State
state :: MVar State
state = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
Word64
h0 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UTCTime -> Word64
hundredsOfNanosSinceGregorianReform IO UTCTime
getCurrentTime
MAC
mac' <- IO MAC
getMac
forall a. a -> IO (MVar a)
newMVar forall a b. (a -> b) -> a -> b
$ MAC -> Word16 -> Word64 -> State
State MAC
mac' Word16
0 Word64
h0
getMac :: IO MAC
getMac :: IO MAC
getMac =
IO [NetworkInterface]
getNetworkInterfaces forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Bounded a => a
minBound forall a. Eq a => a -> a -> Bool
/=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map NetworkInterface -> MAC
mac forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
\Maybe MAC
macM -> case Maybe MAC
macM of
Just MAC
m -> forall (m :: * -> *) a. Monad m => a -> m a
return MAC
m
Maybe MAC
Nothing -> IO MAC
randomMac
randomMac :: IO MAC
randomMac :: IO MAC
randomMac =
Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> MAC
MAC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a (m :: * -> *). (Random a, MonadIO m) => m a
R.randomIO forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8
1 forall a. Bits a => a -> a -> a
.|.))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *). (Random a, MonadIO m) => m a
R.randomIO
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *). (Random a, MonadIO m) => m a
R.randomIO
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *). (Random a, MonadIO m) => m a
R.randomIO
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *). (Random a, MonadIO m) => m a
R.randomIO
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *). (Random a, MonadIO m) => m a
R.randomIO
data State = State
{-# UNPACK #-} !MAC
{-# UNPACK #-} !Word16
{-# UNPACK #-} !Word64
deriving (Int -> State -> ShowS
[State] -> ShowS
State -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show)
hundredsOfNanosSinceGregorianReform :: UTCTime -> Word64
hundredsOfNanosSinceGregorianReform :: UTCTime -> Word64
hundredsOfNanosSinceGregorianReform UTCTime
t = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ NominalDiffTime
10000000 forall a. Num a => a -> a -> a
* NominalDiffTime
dt
where
gregorianReform :: UTCTime
gregorianReform = Day -> DiffTime -> UTCTime
UTCTime (Year -> Int -> Int -> Day
fromGregorian Year
1582 Int
10 Int
15) DiffTime
0
dt :: NominalDiffTime
dt = UTCTime
t UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
gregorianReform