Internal.hs

{-# LANGUAGE DeriveDataTypeable, CPP #-}

-- |
-- Module      : Data.UUID
-- Copyright   : (c) 2008 Antoine Latter
--
-- License     : BSD-style
--
-- Maintainer  : aslatter@gmail.com
-- Stability   : experimental
-- Portability : portable

module Data.UUID.Internal
    (UUID(..)
    ,Node(..)
    ,nodeToList
    ,listToNode
    ,fromString
    ,toString
    ,versionMask
    ,reservedMask
    ,reserved
    ) where

import Data.Word
import Data.Char
import Data.Maybe
import Data.Bits
import Data.List (splitAt, foldl', unfoldr)

import Data.Typeable
import Data.Generics.Basics

import Foreign.Ptr
import Foreign.Storable

import Data.Binary
import Data.Binary.Put
import Data.Binary.Get

import System.Random

import Text.Printf

#ifndef STRICT
#define SLOT(x) x
#else
#define SLOT(x) {-# UNPACK #-} !x
#endif

-- |The UUID type.  A 'Random' instance is provided which produces
-- version 3 UUIDs as specified in RFC 4122.  The 'Storable' and 
-- 'Binary' instances are compatable with RFC 4122.  The 'Binary'
-- instance serializes to network byte order.
data UUID = UUID
    {uuid_timeLow  :: SLOT(Word32)
    ,uuid_timeMid  :: SLOT(Word16)
    ,uuid_timeHigh :: SLOT(Word16) -- includes version number
    ,uuid_clockSeqHi :: SLOT(Word8) -- includes reserved field
    ,uuid_clokcSeqLow :: SLOT(Word8)
    ,uuid_node :: SLOT(Node)
    } deriving (Eq, Ord, Typeable)

instance Random UUID where
    random g = let (timeLow, g1)  = randomBoundedIntegral g
                   (timeMid, g2)  = randomBoundedIntegral g1
                   (timeHigh, g3) = randomBoundedIntegral g2
                   (seqHigh, g4)  = randomBoundedIntegral g3
                   (seqLow, g5)   = randomBoundedIntegral g4
                   (node, g6)     = random g5
                   seqHighReserved = (seqHigh .&. reservedMask) .|. reserved
                   timeHighVersion = (timeHigh .&. versionMask) .|. versionRandom
               in (UUID timeLow timeMid timeHighVersion seqHighReserved seqLow node, g6)

    randomR _ = random -- range is ignored

versionMask :: Word16 -- 0000 1111 1111 1111
versionMask = 0x0FFF

versionRandom :: Word16
versionRandom = 4 `shiftL` 12

reservedMask :: Word8 -- 0011 1111
reservedMask = 0x3F

reserved :: Word8
reserved = bit 7

data Node = Node
    SLOT(Word8)
    SLOT(Word8)
    SLOT(Word8)
    SLOT(Word8)
    SLOT(Word8)
    SLOT(Word8)
 deriving (Eq, Ord, Typeable)

instance Random Node where
    random g = let (w1, g1) = randomBoundedIntegral g
                   (w2, g2) = randomBoundedIntegral g1
                   (w3, g3) = randomBoundedIntegral g2
                   (w4, g4) = randomBoundedIntegral g3
                   (w5, g5) = randomBoundedIntegral g4
                   (w6, g6) = randomBoundedIntegral g5
               in (Node w1 w2 w3 w4 w5 w6, g6)
    randomR _ = random -- neglect range


nodeToList :: Node -> [Word8]
nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]

listToNode :: [Word8] -> Maybe Node
listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
listToNode _ = Nothing

instance Show UUID where
    show = toString

instance Read UUID where
    readsPrec _ str = case fromString (take 36 str) of
      Nothing -> []
      Just u  -> [(u,drop 36 str)]


instance Storable UUID where
    sizeOf _ = 16
    alignment _ = 4 -- not sure what to put here

    peek p = do
      tl   <- peek $ castPtr p
      tm   <- peekByteOff p 4
      th   <- peekByteOff p 6
      ch   <- peekByteOff p 8
      cl   <- peekByteOff p 9
      node <- peekByteOff p 10
      return $ UUID tl tm th ch cl node

    poke p (UUID tl tm th ch cl node) = do
      poke (castPtr p) tl
      pokeByteOff p 4 tm
      pokeByteOff p 6 th
      pokeByteOff p 8 ch
      pokeByteOff p 9 cl
      pokeByteOff p 10 node

instance Storable Node where
    sizeOf _ = 6
    alignment _ = 1 -- ???

    peek p = do
      w1 <- peek $ castPtr p
      w2 <- peekByteOff p 1
      w3 <- peekByteOff p 2
      w4 <- peekByteOff p 3
      w5 <- peekByteOff p 4
      w6 <- peekByteOff p 5
      return $ Node w1 w2 w3 w4 w5 w6

    poke p (Node w1 w2 w3 w4 w5 w6) = do
      poke (castPtr p) w1
      pokeByteOff p 1 w2
      pokeByteOff p 2 w3
      pokeByteOff p 3 w4
      pokeByteOff p 4 w5
      pokeByteOff p 5 w6

-- Binary instance in network byte-order
instance Binary UUID where
    put (UUID tl tm th ch cl n) = do
                       putWord32be tl
                       putWord16be tm
                       putWord16be th
                       putWord8 ch
                       putWord8 cl
                       put n

    get = do
      tl <- getWord32be
      tm <- getWord16be
      th <- getWord16be
      ch <- getWord8
      cl <- getWord8
      node <- get
      return $ UUID tl tm th ch cl node

instance Binary Node where
    put (Node w1 w2 w3 w4 w5 w6) = do
                       putWord8 w1
                       putWord8 w2
                       putWord8 w3
                       putWord8 w4
                       putWord8 w5
                       putWord8 w6

    get = do
      w1 <- getWord8
      w2 <- getWord8
      w3 <- getWord8
      w4 <- getWord8
      w5 <- getWord8
      w6 <- getWord8
      return $ Node w1 w2 w3 w4 w5 w6


-- My goal with this instance was to make it work just enough to do what
-- I want when used with the HStringTemplate library.
instance Data UUID where
    toConstr uu  = mkConstr uuidType (show uu) [] (error "fixity")
    gunfold _ _  = error "gunfold"
    dataTypeOf _ = uuidType

uuidType =  mkNorepType "Data.UUID.UUID"




-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
-- The hyphens may not be omitted.
-- Example:
--
-- @
--  fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
-- @
--
-- Hex digits may be upper or lower-case.
fromString :: String -> Maybe UUID
fromString xs | validFmt  = Just uuid
              | otherwise = Nothing
  where validFmt = length ws == 5 &&
                   map length ws == [8,4,4,4,12] &&
                   all isHexDigit (concat ws) &&
                   isJust node
        ws = splitList '-' xs
        [tl, tm, th, c, n] = ws
        ns = unfoldUntil Prelude.null (splitAt 2) n :: [String]
        node = listToNode $ map hexVal ns :: Maybe Node
        uuid = UUID (hexVal tl) (hexVal tm) (hexVal th) (hexVal $ take 2 c) (hexVal $ drop 2 c) (fromJust $ node)

-- | Convert a string to a hex value, assuming the string is already validated.
hexVal :: Num a => String -> a
hexVal = fromInteger . foldl' (\n c -> 16*n + digitToInteger c) 0

digitToInteger :: Char -> Integer
digitToInteger = fromIntegral . digitToInt


-- | Convert a UUID into a hypenated string using lower-case letters.
-- Example:
--
-- @
--  toString $ fromString \"550e8400-e29b-41d4-a716-446655440000\"
-- @
toString :: UUID -> String
toString (UUID tl tm th ch cl n) = printf "%08x-%04x-%04x-%02x%02x-%s" tl tm th ch cl ns
    where ns = concatMap hexb $ nodeToList n
          hexb x = printf "%02x" x :: String


-- remove all occurances of the input element in the inpt list.
-- none of the sub-lists are empty.
splitList :: Eq a => a -> [a] -> [[a]]
splitList c xs = let ys = dropWhile (== c) xs
                 in case span (/= c) ys of
                      ([],_) -> []
                      (sub,rest) -> sub : splitList c rest

-- the passed-in predicate signals when to stop unfolding
unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
unfoldUntil p f n = unfoldr g n
 where g m | p m       = Nothing
           | otherwise = Just $ f m


-- no random intance for Data.Word types :-(
-- this will work, though

randomBoundedIntegral :: (RandomGen g, Bounded a, Integral a) => g -> (a, g)
randomBoundedIntegral g =
    let (n, g1) = randomR (fromIntegral l, fromIntegral u) g
        _ = n :: Integer
        retVal = fromIntegral n `asTypeOf` (l `asTypeOf` u)
        u = maxBound
        l = minBound
    in (retVal, g1)