    {-# 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 sepcified 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
    mac', c :: Word16
    c, t :: 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 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 time :: Word64
    time clock :: Word16
    clock mac' :: MAC
    mac' =
        Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> Word8
    -> UUID
    buildFromBytes 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` 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` 48)) :: Word16

    newtype MACSource = MACSource MAC
    instance ByteSource MACSource where
        z :: ByteSink MACSource g
    z /-/ :: ByteSink MACSource g -> MACSource -> g
    /-/ (MACSource (MAC a :: Word8
    a b :: Word8
    b c :: Word8
    c d :: Word8
    d e :: Word8
    e f :: 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
    mac' c0 :: Word16
    c0 h0 :: 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
    <= 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' 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
    >>=
        \macM :: Maybe MAC
    macM -> case Maybe MAC
    macM of
          Just m :: MAC
    m -> MAC -> IO MAC
    forall (m :: * -> *) a. Monad m => a -> m a
    return MAC
    m
          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. Random a => IO 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
    . (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. Random a => IO 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. Random a => IO 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. Random a => IO 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. Random a => IO 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. Random a => IO 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 t :: 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
    $ 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 1582 10 15) 0
      dt :: NominalDiffTime
    dt = UTCTime
    t UTCTime -> UTCTime -> NominalDiffTime
    `diffUTCTime` UTCTime
    gregorianReform