{-# 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.Types.Internal.Builder
import Data.UUID.Types.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 specified in
-- RFC 4122.
--
-- Returns 'Nothing' if you request UUIDs too quickly.
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) -> Maybe UUID -> IO (Maybe UUID)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UUID -> IO (Maybe UUID)) -> Maybe UUID -> IO (Maybe UUID)
forall a b. (a -> b) -> a -> b
$ UUID -> Maybe UUID
forall a. a -> Maybe a
Just (UUID -> Maybe UUID) -> UUID -> Maybe UUID
forall a b. (a -> b) -> a -> b
$ Word64 -> Word16 -> MAC -> UUID
makeUUID Word64
t Word16
c MAC
mac'
    Maybe (MAC, Word16, Word64)
_ -> Maybe UUID -> IO (Maybe UUID)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UUID
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
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> UUID
buildFromBytes Word8
1 ByteSink
  Word32
  (Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> UUID)
-> Word32
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> UUID
forall w g. ByteSource w => ByteSink w g -> w -> g
/-/ Word32
tLow ByteSink
  Word16
  (Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> UUID)
-> Word16
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> UUID
forall w g. ByteSource w => ByteSink w g -> w -> g
/-/ Word16
tMid ByteSink
  Word16
  (Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> UUID)
-> Word16
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> UUID
forall w g. ByteSource w => ByteSink w g -> w -> g
/-/ Word16
tHigh ByteSink
  Word16 (Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> UUID)
-> Word16
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> UUID
forall w g. ByteSource w => ByteSink w g -> w -> g
/-/ Word16
clock ByteSink MACSource UUID -> MACSource -> UUID
forall w g. ByteSource w => ByteSink w g -> w -> g
/-/ (MAC -> MACSource
MACSource MAC
mac')
    where tLow :: Word32
tLow = (Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
time) :: Word32
          tMid :: Word16
tMid = (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
time Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32)) :: Word16
          tHigh :: Word16
tHigh = (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
time Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
48)) :: Word16

newtype MACSource = MACSource MAC
instance ByteSource MACSource where
    ByteSink MACSource g
z /-/ :: ByteSink MACSource g -> MACSource -> g
/-/ (MACSource (MAC Word8
a Word8
b Word8
c Word8
d Word8
e Word8
f)) = ByteSink MACSource g
Takes3Bytes (Takes3Bytes g)
z Word8
a Word8
b Word8
c Word8
d Word8
e Word8
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 :: IO (Maybe (MAC, Word16, Word64))
stepTime = do
  Word64
h1 <- (UTCTime -> Word64) -> IO UTCTime -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UTCTime -> Word64
hundredsOfNanosSinceGregorianReform IO UTCTime
getCurrentTime
  MVar State
-> (State -> IO (State, Maybe (MAC, Word16, Word64)))
-> IO (Maybe (MAC, Word16, Word64))
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar State
state ((State -> IO (State, Maybe (MAC, Word16, Word64)))
 -> IO (Maybe (MAC, Word16, Word64)))
-> (State -> IO (State, Maybe (MAC, Word16, Word64)))
-> IO (Maybe (MAC, Word16, Word64))
forall a b. (a -> b) -> a -> b
$ \s :: State
s@(State MAC
mac' Word16
c0 Word64
h0) ->
   if Word64
h1 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
h0
    then
      (State, Maybe (MAC, Word16, Word64))
-> IO (State, Maybe (MAC, Word16, Word64))
forall (m :: * -> *) a. Monad m => a -> m a
return (MAC -> Word16 -> Word64 -> State
State MAC
mac' Word16
c0 Word64
h1, (MAC, Word16, Word64) -> Maybe (MAC, Word16, Word64)
forall a. a -> Maybe a
Just (MAC
mac', Word16
c0, Word64
h1))
    else
      let
        c1 :: Word16
c1 = Word16 -> Word16
forall a. Enum a => a -> a
succ Word16
c0
      in if Word16
c1 Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16
0x3fff -- when clock is initially randomized,
                      -- then this test will need to change
         then
          (State, Maybe (MAC, Word16, Word64))
-> IO (State, Maybe (MAC, Word16, Word64))
forall (m :: * -> *) a. Monad m => a -> m a
return (MAC -> Word16 -> Word64 -> State
State MAC
mac' Word16
c1 Word64
h1, (MAC, Word16, Word64) -> Maybe (MAC, Word16, Word64)
forall a. a -> Maybe a
Just (MAC
mac', Word16
c1, Word64
h1))
        else
          (State, Maybe (MAC, Word16, Word64))
-> IO (State, Maybe (MAC, Word16, Word64))
forall (m :: * -> *) a. Monad m => a -> m a
return (State
s, Maybe (MAC, Word16, Word64)
forall a. Maybe a
Nothing)


{-# NOINLINE state #-}
state :: MVar State
state :: MVar State
state = IO (MVar State) -> MVar State
forall a. IO a -> a
unsafePerformIO (IO (MVar State) -> MVar State) -> IO (MVar State) -> MVar State
forall a b. (a -> b) -> a -> b
$ do
  Word64
h0 <- (UTCTime -> Word64) -> IO UTCTime -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UTCTime -> Word64
hundredsOfNanosSinceGregorianReform IO UTCTime
getCurrentTime
  MAC
mac' <- IO MAC
getMac
  State -> IO (MVar State)
forall a. a -> IO (MVar a)
newMVar (State -> IO (MVar State)) -> State -> IO (MVar State)
forall a b. (a -> b) -> a -> b
$ MAC -> Word16 -> Word64 -> State
State MAC
mac' Word16
0 Word64
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 :: IO MAC
getMac =
    IO [NetworkInterface]
getNetworkInterfaces IO [NetworkInterface]
-> ([NetworkInterface] -> IO (Maybe MAC)) -> IO (Maybe MAC)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    Maybe MAC -> IO (Maybe MAC)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MAC -> IO (Maybe MAC))
-> ([NetworkInterface] -> Maybe MAC)
-> [NetworkInterface]
-> IO (Maybe MAC)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MAC] -> Maybe MAC
forall a. [a] -> Maybe a
listToMaybe ([MAC] -> Maybe MAC)
-> ([NetworkInterface] -> [MAC]) -> [NetworkInterface] -> Maybe MAC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MAC -> Bool) -> [MAC] -> [MAC]
forall a. (a -> Bool) -> [a] -> [a]
filter (MAC
forall a. Bounded a => a
minBound MAC -> MAC -> Bool
forall a. Eq a => a -> a -> Bool
/=) ([MAC] -> [MAC])
-> ([NetworkInterface] -> [MAC]) -> [NetworkInterface] -> [MAC]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NetworkInterface -> MAC) -> [NetworkInterface] -> [MAC]
forall a b. (a -> b) -> [a] -> [b]
map NetworkInterface -> MAC
mac IO (Maybe MAC) -> (Maybe MAC -> IO MAC) -> IO 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 -> MAC -> IO MAC
forall (m :: * -> *) a. Monad m => a -> m a
return MAC
m
      Maybe MAC
Nothing -> IO MAC
randomMac

randomMac :: IO MAC
randomMac :: IO MAC
randomMac =
    -- I'm too lazy to thread through
    -- the random state ...
    Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> MAC
MAC
     (Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> MAC)
-> IO Word8
-> IO (Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> MAC)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO Word8
forall a (m :: * -> *). (Random a, MonadIO m) => m a
R.randomIO IO Word8 -> (Word8 -> IO Word8) -> IO Word8
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> IO Word8
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> IO Word8) -> (Word8 -> Word8) -> Word8 -> IO Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8
1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.)) -- We must set the multicast bit to True. See section 4.5 of the RFC.
     IO (Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> MAC)
-> IO Word8 -> IO (Word8 -> Word8 -> Word8 -> Word8 -> MAC)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Word8
forall a (m :: * -> *). (Random a, MonadIO m) => m a
R.randomIO
     IO (Word8 -> Word8 -> Word8 -> Word8 -> MAC)
-> IO Word8 -> IO (Word8 -> Word8 -> Word8 -> MAC)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Word8
forall a (m :: * -> *). (Random a, MonadIO m) => m a
R.randomIO
     IO (Word8 -> Word8 -> Word8 -> MAC)
-> IO Word8 -> IO (Word8 -> Word8 -> MAC)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Word8
forall a (m :: * -> *). (Random a, MonadIO m) => m a
R.randomIO
     IO (Word8 -> Word8 -> MAC) -> IO Word8 -> IO (Word8 -> MAC)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Word8
forall a (m :: * -> *). (Random a, MonadIO m) => m a
R.randomIO
     IO (Word8 -> MAC) -> IO Word8 -> IO MAC
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Word8
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
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
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 = NominalDiffTime -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
floor (NominalDiffTime -> Word64) -> NominalDiffTime -> Word64
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
10000000 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
dt
 where
  gregorianReform :: UTCTime
gregorianReform = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
1582 Int
10 Int
15) DiffTime
0
  dt :: NominalDiffTime
dt = UTCTime
t UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
gregorianReform