module Data.UUID.Internal
(UUID(..)
,null
,nil
,fromByteString
,toByteString
,fromString
,toString
,fromWords
,toWords
,toList
,buildFromBytes
,buildFromWords
,fromASCIIBytes
,toASCIIBytes
,fromLazyASCIIBytes
,toLazyASCIIBytes
,UnpackedUUID(..)
,pack
,unpack
) where
import Prelude hiding (null)
import Control.Applicative ((<*>))
import Control.DeepSeq (NFData(..))
import Control.Monad (liftM4, guard)
import Data.Functor ((<$>))
import Data.Char
import Data.Bits
import Data.Hashable
import Data.List (elemIndices)
import Foreign.Ptr (Ptr)
#if MIN_VERSION_base(4,0,0)
import Data.Data
#else
import Data.Generics.Basics
#endif
import Foreign.Storable
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Unsafe as BU
import Data.UUID.Builder
import Data.Word.Util
import System.Random
data UUID
= UUID
!Word32
!Word32
!Word32
!Word32
deriving (Eq, Ord, Typeable)
toWords :: UUID -> (Word32, Word32, Word32, Word32)
toWords (UUID w1 w2 w3 w4) = (w1, w2, w3, w4)
fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
fromWords = UUID
data UnpackedUUID =
UnpackedUUID {
time_low :: Word32
, time_mid :: Word16
, time_hi_and_version :: Word16
, clock_seq_hi_res :: Word8
, clock_seq_low :: Word8
, node_0 :: Word8
, node_1 :: Word8
, node_2 :: Word8
, node_3 :: Word8
, node_4 :: Word8
, node_5 :: Word8
}
deriving (Read, Show, Eq, Ord)
unpack :: UUID -> UnpackedUUID
unpack (UUID w0 w1 w2 w3) =
build /-/ w0 /-/ w1 /-/ w2 /-/ w3
where
build x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC xD xE xF =
UnpackedUUID {
time_low = word x0 x1 x2 x3
, time_mid = w8to16 x4 x5
, time_hi_and_version = w8to16 x6 x7
, clock_seq_hi_res = x8
, clock_seq_low = x9
, node_0 = xA
, node_1 = xB
, node_2 = xC
, node_3 = xD
, node_4 = xE
, node_5 = xF
}
pack :: UnpackedUUID -> UUID
pack unpacked =
makeFromBytes /-/ (time_low unpacked)
/-/ (time_mid unpacked)
/-/ (time_hi_and_version unpacked)
/-/ (clock_seq_hi_res unpacked)
/-/ (clock_seq_low unpacked)
/-/ (node_0 unpacked) /-/ (node_1 unpacked)
/-/ (node_2 unpacked) /-/ (node_3 unpacked)
/-/ (node_4 unpacked) /-/ (node_5 unpacked)
word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
word a b c d = (fromIntegral a `shiftL` 24)
.|. (fromIntegral b `shiftL` 16)
.|. (fromIntegral c `shiftL` 8)
.|. (fromIntegral d )
byte :: Int -> Word32 -> Word8
byte i w = fromIntegral (w `shiftR` (i * 8))
makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8
-> Word8 -> Word8 -> Word8 -> Word8
-> Word8 -> Word8 -> Word8 -> Word8
-> Word8 -> Word8 -> Word8 -> Word8
-> UUID
makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
= UUID w0 w1 w2 w3
where w0 = word b0 b1 b2 b3
w1 = word b4 b5 b6 b7
w2 = word b8 b9 ba bb
w3 = word bc bd be bf
makeFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
makeFromWords = UUID
buildFromBytes :: Word8
-> Word8 -> Word8 -> Word8 -> Word8
-> Word8 -> Word8 -> Word8 -> Word8
-> Word8 -> Word8 -> Word8 -> Word8
-> Word8 -> Word8 -> Word8 -> Word8
-> UUID
buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =
makeFromBytes b0 b1 b2 b3 b4 b5 b6' b7 b8' b9 ba bb bc bd be bf
where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
b8' = b8 .&. 0x3f .|. 0x80
buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
buildFromWords v w0 w1 w2 w3 = makeFromWords w0 w1' w2' w3
where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
w2' = w2 .&. 0x3fffffff .|. 0x80000000
toList :: UUID -> [Word8]
toList (UUID w0 w1 w2 w3) =
[byte 3 w0, byte 2 w0, byte 1 w0, byte 0 w0,
byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1,
byte 3 w2, byte 2 w2, byte 1 w2, byte 0 w2,
byte 3 w3, byte 2 w3, byte 1 w3, byte 0 w3]
fromList :: [Word8] -> Maybe UUID
fromList [b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf] =
Just $ makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
fromList _ = Nothing
null :: UUID -> Bool
null = (== nil)
nil :: UUID
nil = UUID 0 0 0 0
fromByteString :: BL.ByteString -> Maybe UUID
fromByteString = fromList . BL.unpack
toByteString :: UUID -> BL.ByteString
toByteString = BL.pack . toList
fromString :: String -> Maybe UUID
fromString xs | validFmt = fromString' xs
| otherwise = Nothing
where validFmt = elemIndices '-' xs == [8,13,18,23]
fromString' :: String -> Maybe UUID
fromString' s0 = do
(w0, s1) <- hexWord s0
(w1, s2) <- hexWord s1
(w2, s3) <- hexWord s2
(w3, s4) <- hexWord s3
if s4 /= "" then Nothing
else Just $ UUID w0 w1 w2 w3
where hexWord :: String -> Maybe (Word32, String)
hexWord s = Just (0, s) >>= hexByte >>= hexByte
>>= hexByte >>= hexByte
hexByte :: (Word32, String) -> Maybe (Word32, String)
hexByte (w, '-':ds) = hexByte (w, ds)
hexByte (w, hi:lo:ds)
| bothHex = Just ((w `shiftL` 8) .|. octet, ds)
| otherwise = Nothing
where bothHex = isHexDigit hi && isHexDigit lo
octet = fromIntegral (16 * digitToInt hi + digitToInt lo)
hexByte _ = Nothing
toString :: UUID -> String
toString (UUID w0 w1 w2 w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""
where hexw :: Word32 -> String -> String
hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
: hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
hexw' :: Word32 -> String -> String
hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
: '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
hexn :: Word32 -> Int -> Char
hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
toASCIIBytes :: UUID -> B.ByteString
toASCIIBytes uuid = BI.unsafeCreate 36 (pokeASCII uuid)
pokeASCII :: UUID -> Ptr Word8 -> IO ()
pokeASCII uuid ptr = do
pokeDash 8
pokeDash 13
pokeDash 18
pokeDash 23
pokeSingle 0 w0
pokeDouble 9 w1
pokeDouble 19 w2
pokeSingle 28 w3
where
(w0, w1, w2, w3) = toWords uuid
pokeDash ix = pokeElemOff ptr ix 45
pokeSingle ix w = do
pokeWord ix w 28
pokeWord (ix + 1) w 24
pokeWord (ix + 2) w 20
pokeWord (ix + 3) w 16
pokeWord (ix + 4) w 12
pokeWord (ix + 5) w 8
pokeWord (ix + 6) w 4
pokeWord (ix + 7) w 0
pokeDouble ix w = do
pokeWord ix w 28
pokeWord (ix + 1) w 24
pokeWord (ix + 2) w 20
pokeWord (ix + 3) w 16
pokeWord (ix + 5) w 12
pokeWord (ix + 6) w 8
pokeWord (ix + 7) w 4
pokeWord (ix + 8) w 0
pokeWord ix w r =
pokeElemOff ptr ix (fromIntegral (toDigit ((w `shiftR` r) .&. 0xf)))
toDigit :: Word32 -> Word32
toDigit w = if w < 10 then 48 + w else 97 + w 10
fromASCIIBytes :: B.ByteString -> Maybe UUID
fromASCIIBytes bs = do
guard wellFormed
fromWords <$> single 0 <*> double 9 14 <*> double 19 24 <*> single 28
where
dashIx bs' ix = BU.unsafeIndex bs' ix == 45
wellFormed =
B.length bs == 36 && dashIx bs 8 && dashIx bs 13 &&
dashIx bs 18 && dashIx bs 23
single ix = combine <$> octet ix <*> octet (ix + 2)
<*> octet (ix + 4) <*> octet (ix + 6)
double ix0 ix1 = combine <$> octet ix0 <*> octet (ix0 + 2)
<*> octet ix1 <*> octet (ix1 + 2)
combine o0 o1 o2 o3 = shiftL o0 24 .|. shiftL o1 16 .|. shiftL o2 8 .|. o3
octet ix = do
hi <- fromIntegral <$> toDigit (BU.unsafeIndex bs ix)
lo <- fromIntegral <$> toDigit (BU.unsafeIndex bs (ix + 1))
return (16 * hi + lo)
toDigit :: Word8 -> Maybe Word8
toDigit w
| w >= 48 && w <= 57 = Just (w 48)
| w >= 65 && w <= 70 = Just (10 + w 65)
| w >= 97 && w <= 102 = Just (10 + w 97)
| otherwise = Nothing
toLazyASCIIBytes :: UUID -> BL.ByteString
toLazyASCIIBytes =
#if MIN_VERSION_bytestring(0,10,0)
BL.fromStrict
#else
BL.fromChunks . return
#endif
. toASCIIBytes
fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
fromLazyASCIIBytes bs =
if BL.length bs == 36 then fromASCIIBytes (
#if MIN_VERSION_bytestring(0,10,0)
BL.toStrict bs
#else
B.concat $ BL.toChunks bs
#endif
) else Nothing
instance Random UUID where
random g = (fromGenNext w0 w1 w2 w3 w4, g4)
where (w0, g0) = next g
(w1, g1) = next g0
(w2, g2) = next g1
(w3, g3) = next g2
(w4, g4) = next g3
randomR _ = random
fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID
fromGenNext w0 w1 w2 w3 w4 =
buildFromBytes 4 /-/ (ThreeByte w0)
/-/ (ThreeByte w1)
/-/ w2
/-/ (ThreeByte w3)
/-/ (ThreeByte w4)
type instance ByteSink ThreeByte g = Takes3Bytes g
newtype ThreeByte = ThreeByte Int
instance ByteSource ThreeByte where
f /-/ (ThreeByte w) = f b1 b2 b3
where b1 = fromIntegral (w `shiftR` 16)
b2 = fromIntegral (w `shiftR` 8)
b3 = fromIntegral w
instance NFData UUID where
rnf = rnf . toWords
instance Hashable UUID where
hash (UUID w0 w1 w2 w3) =
hash w0 `hashWithSalt` w1
`hashWithSalt` w2
`hashWithSalt` w3
hashWithSalt s (UUID w0 w1 w2 w3) =
s `hashWithSalt` w0
`hashWithSalt` w1
`hashWithSalt` w2
`hashWithSalt` w3
instance Show UUID where
show = toString
instance Read UUID where
readsPrec _ str =
let noSpaces = dropWhile isSpace str
in case fromString (take 36 noSpaces) of
Nothing -> []
Just u -> [(u,drop 36 noSpaces)]
instance Storable UUID where
sizeOf _ = 16
alignment _ = 4
peekByteOff p off =
pack <$>
(UnpackedUUID
<$> peekByteOff p off
<*> peekByteOff p (off+4)
<*> peekByteOff p (off+6)
<*> peekByteOff p (off+8)
<*> peekByteOff p (off+9)
<*> peekByteOff p (off+10)
<*> peekByteOff p (off+11)
<*> peekByteOff p (off+12)
<*> peekByteOff p (off+13)
<*> peekByteOff p (off+14)
<*> peekByteOff p (off+15)
)
pokeByteOff p off u =
case unpack u of
(UnpackedUUID x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) ->
do
pokeByteOff p off x0
pokeByteOff p (off+4) x1
pokeByteOff p (off+6) x2
pokeByteOff p (off+8) x3
pokeByteOff p (off+9) x4
pokeByteOff p (off+10) x5
pokeByteOff p (off+11) x6
pokeByteOff p (off+12) x7
pokeByteOff p (off+13) x8
pokeByteOff p (off+14) x9
pokeByteOff p (off+15) x10
instance Binary UUID where
put (UUID w0 w1 w2 w3) =
putWord32be w0 >> putWord32be w1 >> putWord32be w2 >> putWord32be w3
get = liftM4 UUID getWord32be getWord32be getWord32be getWord32be
instance Data UUID where
toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
gunfold _ _ = error "gunfold"
dataTypeOf _ = uuidType
uuidType :: DataType
uuidType = mkNoRepType "Data.UUID.UUID"
#if !(MIN_VERSION_base(4,2,0))
mkNoRepType :: String -> DataType
mkNoRepType = mkNorepType
#endif