@@ -1,6 +1,4 @@
1−{-# INCLUDE <uuid/uuid.h> #-}
2−{-# INCLUDE <string.h> #-}
3−{-# LANGUAGE ForeignFunctionInterface #-}
1+{-# LANGUAGE DeriveDataTypeable #-}
42
53-- |
64-- Module : Data.UUID
@@ -12,10 +10,7 @@
1210-- Stability : experimental
1311-- Portability : portable
1412--
15−-- Haskell bindings to /libuuid/.
16−-- The library /libuuid/ is available as a part of e2fsprogs:
17−-- <http://e2fsprogs.sourceforge.net/>.
18−--
13+--
1914-- This library is useful for creating, comparing, parsing and
2015-- printing Universally Unique Identifiers.
2116-- See <http://en.wikipedia.org/wiki/UUID> for the general idea.
@@ -32,29 +27,87 @@ module Data.UUID(UUID
3227 )
3328where
3429
35−import Foreign.C.String
36−import Foreign.C
37−import Foreign.ForeignPtr
38−import Foreign
30+import Data.Word
31+import System.Random
32+import Data.Maybe
33+
34+import Data.Char
3935
4036import Data.Typeable
4137import Data.Generics.Basics
4238
43−import Prelude hiding (null)
44−
45−import Data.UUID.Internal
39+import Data.Bits
4640
47−instance Eq UUID where
48− a == b = compare a b == EQ
41+import Text.Printf
4942
50−instance Ord UUID where
51− compare (U fp1) (U fp2) = unsafePerformIO $
52− withForeignPtr fp1 $ \p1 ->
53− withForeignPtr fp2 $ \p2 ->
54− case c_compare p1 p2 of
55− 0 -> return EQ
56− n|n<0 -> return LT
57− |n>0 -> return GT
43+import Prelude hiding (null)
44+import qualified Prelude
45+
46+import Data.List (splitAt, foldl', unfoldr)
47+
48+import Foreign.Ptr
49+import Foreign.Storable
50+
51+
52+data UUID = UUID
53+ {uuid_timeLow :: {-# UNPACK #-} !Word32
54+ ,uuid_timeMid :: {-# UNPACK #-} !Word16
55+ ,uuid_timeHigh :: {-# UNPACK #-} !Word16 -- includes version number
56+ ,uuid_clockSeqHi :: {-# UNPACK #-} !Word8 -- includes reserved field
57+ ,uuid_clokcSeqLow :: {-# UNPACK #-} !Word8
58+ ,uuid_node :: {-# UNPACK #-} !Node
59+ } deriving (Eq, Ord, Typeable)
60+
61+instance Random UUID where
62+ random g = let (timeLow, g1) = random g
63+ (timeMid, g2) = random g1
64+ (timeHigh, g3) = random g2
65+ (seqHigh, g4) = random g3
66+ (seqLow, g5) = random g4
67+ (node, g6) = random g5
68+ seqHighReserved = (seqHigh .&. reservedMask) .|. reserved
69+ timeHighVersion = (timeHigh .&. versionMask) .|. versionRandom
70+ in (UUID timeLow timeMid timeHighVersion seqHighReserved seqLow node, g6)
71+
72+ randomR _ = random -- range is ignored
73+
74+versionMask :: Word16 -- 0000 1111 1111 1111
75+versionMask = 0x0FFF
76+
77+versionRandom :: Word16
78+versionRandom = shiftL 12 4
79+
80+reservedMask :: Word8 -- 0011 1111
81+reservedMask = 0x3F
82+
83+reserved :: Word8
84+reserved = bit 7
85+
86+data Node = Node
87+ {-# UNPACK #-} !Word8
88+ {-# UNPACK #-} !Word8
89+ {-# UNPACK #-} !Word8
90+ {-# UNPACK #-} !Word8
91+ {-# UNPACK #-} !Word8
92+ {-# UNPACK #-} !Word8
93+ deriving (Eq, Ord, Typeable)
94+
95+instance Random Node where
96+ random g = let (w1, g1) = random g
97+ (w2, g2) = random g1
98+ (w3, g3) = random g2
99+ (w4, g4) = random g3
100+ (w5, g5) = random g4
101+ (w6, g6) = random g5
102+ in (Node w1 w2 w3 w4 w5 w6, g6)
103+ randomR _ = random -- neglect range
104+
105+nodeToList :: Node -> [Word8]
106+nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
107+
108+listToNode :: [Word8] -> Maybe Node
109+listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
110+listToNode _ = Nothing
58111
59112instance Show UUID where
60113 show = toString
@@ -64,22 +117,48 @@ instance Read UUID where
64117 Nothing -> []
65118 Just u -> [(u,drop 36 str)]
66119
67−instance Typeable UUID where
68− typeOf _ = mkTyConApp (mkTyCon "Data.UUID.UUID") []
69120
70121instance Storable UUID where
71− sizeOf _ = (16 *) $ sizeOf (undefined :: CChar)
72− alignment _ = alignment (undefined :: CChar)
73−
74− peek psource = do
75− fp <- mallocForeignPtrArray $ sizeOf (undefined :: UUID)
76− withForeignPtr fp $ \pdest ->
77− memcpy pdest psource $ fromIntegral $ sizeOf (undefined :: UUID)
78− return $ U fp
79−
80− poke pdest (U fp) = withForeignPtr fp $ \psource ->
81− memcpy pdest psource $ fromIntegral $ sizeOf (undefined :: UUID)
82−
122+ sizeOf _ = 16
123+ alignment _ = 4 -- not sure what to put here
124+
125+ peek p = do
126+ tl <- peek $ castPtr p
127+ tm <- peekByteOff (castPtr p) 4
128+ th <- peekByteOff (castPtr p) 6
129+ ch <- peekByteOff (castPtr p) 8
130+ cl <- peekByteOff (castPtr p) 9
131+ node <- peekByteOff (castPtr p) 10
132+ return $ UUID tl tm th ch cl node
133+
134+ poke p (UUID tl tm th ch cl node) = do
135+ poke (castPtr p) tl
136+ pokeByteOff (castPtr p) 4 tm
137+ pokeByteOff (castPtr p) 6 th
138+ pokeByteOff (castPtr p) 8 ch
139+ pokeByteOff (castPtr p) 9 cl
140+ pokeByteOff (castPtr p) 10 node
141+
142+instance Storable Node where
143+ sizeOf _ = 6
144+ alignment _ = 1 -- ???
145+
146+ peek p = do
147+ w1 <- peek $ castPtr p
148+ w2 <- peekByteOff (castPtr p) 1
149+ w3 <- peekByteOff (castPtr p) 2
150+ w4 <- peekByteOff (castPtr p) 3
151+ w5 <- peekByteOff (castPtr p) 4
152+ w6 <- peekByteOff (castPtr p) 5
153+ return $ Node w1 w2 w3 w4 w5 w6
154+
155+ poke p (Node w1 w2 w3 w4 w5 w6) = do
156+ poke (castPtr p) w1
157+ pokeByteOff (castPtr p) 1 w2
158+ pokeByteOff (castPtr p) 2 w3
159+ pokeByteOff (castPtr p) 3 w4
160+ pokeByteOff (castPtr p) 4 w5
161+ pokeByteOff (castPtr p) 5 w6
83162
84163-- My goal with this instance was to make it work just enough to do what
85164-- I want when used with the HStringTemplate library.
@@ -95,29 +174,23 @@ uuidType = mkNorepType "Data.UUID.UUID"
95174-- Otherwise a UUID will be generated based on the current time and the
96175-- hardware MAC address, if available.
97176generate :: IO UUID
98−generate = generateWrap c_generate
177+generate = generateRandom
99178
100179-- |Create a new 'UUID'. If \/dev\/urandom is available, it will be used.
101180-- Otherwise a psuedorandom generator will be used.
102181generateRandom :: IO UUID
103−generateRandom = generateWrap c_generate_random
182+generateRandom = randomIO -- not a good solution, as someone could have changed the global generator
104183
105184-- |Create a new 'UUID'. The UUID will be generated based on the
106185-- current time and the hardware MAC address, if available.
107186generateTime :: IO UUID
108−generateTime = generateWrap c_generate_time
109−
110−generateWrap :: (C_UUID -> IO ()) -> IO UUID
111−generateWrap gen = do
112− fp <- mallocForeignPtrArray 16
113− withForeignPtr fp $ \p -> gen p
114− return $ U fp
187+generateTime = error "Data.UUID.generateTime: not yet implemented"
115188
116189-- |Returns 'True' if the passed-in 'UUID' is the null UUID.
117190null :: UUID -> Bool
118−null (U fp) = unsafePerformIO $
119− withForeignPtr fp $ \p ->
120− return $ c_null p == 1
191+null = (== nullUuid)
192+ where nullUuid = UUID 0 0 0 0 0 $ Node 0 0 0 0 0 0
193+
121194
122195-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
123196-- The hyphens may not be omitted.
@@ -129,88 +202,83 @@ null (U fp) = unsafePerformIO $
129202--
130203-- Hex digits may be upper or lower-case.
131204fromString :: String -> Maybe UUID
132−fromString s = unsafePerformIO $ do
133− fp <- mallocForeignPtrArray 16
134− res <- withCAString s $ \chars ->
135− withForeignPtr fp $ \p ->
136− c_read chars p
137− case res of
138− 0 -> return . Just $ U fp
139− _ -> return Nothing
205+fromString xs | validFmt = Just uuid
206+ | otherwise = Nothing
207+ where validFmt = length ws == 5 &&
208+ map length ws == [8,4,4,4,12] &&
209+ all isHexDigit (concat ws) &&
210+ isJust node
211+ ws = splitList '-' xs
212+ [tl, tm, th, c, n] = ws
213+ ns = unfoldUntil Prelude.null (splitAt 2) n :: [String]
214+ node = listToNode $ map hexVal ns :: Maybe Node
215+ uuid = UUID (hexVal tl) (hexVal tm) (hexVal th) (hexVal $ take 2 c) (hexVal $ drop 2 c) (fromJust $ node)
216+
217+-- | Convert a string to a hex value, assuming the string is already validated.
218+hexVal :: Num a => String -> a
219+hexVal = fromInteger . foldl' (\n c -> 16*n + digitToInteger c) 0
220+
221+digitToInteger :: Char -> Integer
222+digitToInteger = fromIntegral . digitToInt
140223
141224-- |Returns a 'String' representation of the passed in 'UUID'.
142225-- Hex digits occuring in the output will be either upper or
143226-- lower-case depending on system defaults and locale.
144227toString :: UUID -> String
145−toString = toStringWrap c_show
146−
147−-- |Returns a 'String' representation of the passed in 'UUID'.
148−-- Hex digits occuring in the output will be lower-case.
149−toStringLower :: UUID -> String
150−toStringLower = toStringWrap c_show_lower
151−
152−-- |Returns a 'String' representation of the passed in 'UUID'.
153−-- Hex digits occuring in the output will be upper-case.
154−toStringUpper :: UUID -> String
155−toStringUpper = toStringWrap c_show_upper
156−
157−-- |The passed in function /f/ is given a the raw UUID data
158−-- and a 37-byte buffer to fill with the textual representation
159−-- of the UUID. The buffer is expected to contain a null-terminator
160−-- after /f/ is finished.
161−toStringWrap :: (C_UUID -> CString -> IO ()) -> UUID -> String
162−toStringWrap f (U fp) = unsafePerformIO $
163− allocaBytes 37 $ \chars -> do
164− withForeignPtr fp $ \p -> f p chars
165− peekCAString chars
228+toString = toStringLower
166229
167−-- FFI calls to do the work
168230
169−type C_UUID = Ptr CChar
170−
171−-- comparing UUIDs
172−foreign import ccall unsafe "uuid_compare"
173− c_compare :: C_UUID -> C_UUID -> CInt
174−
175−-- making random UUIDs
176−foreign import ccall unsafe "uuid_generate"
177− c_generate :: C_UUID -> IO ()
178−
179−foreign import ccall unsafe "uuid_generate_time"
180− c_generate_time :: C_UUID -> IO ()
181−
182−foreign import ccall unsafe "uuid_generate_random"
183− c_generate_random :: C_UUID -> IO ()
184−
185−-- Null check
186−foreign import ccall unsafe "uuid_is_null"
187− c_null :: C_UUID -> CInt
188−
189−-- Parsing
190−foreign import ccall unsafe "uuid_parse"
191− c_read :: CString -> C_UUID ->IO CInt
192−
193−-- Showing
194−
195−foreign import ccall unsafe "uuid_unparse"
196− c_show :: C_UUID -> CString -> IO ()
197−
198−foreign import ccall unsafe "uuid_unparse_lower"
199− c_show_lower :: C_UUID -> CString -> IO ()
200−
201−foreign import ccall unsafe "uuid_unparse_upper"
202− c_show_upper :: C_UUID -> CString -> IO ()
203−
204−
205−-- Queries
206−
207−foreign import ccall unsafe "uuid_type"
208− c_type :: C_UUID -> CInt
209−
210−foreign import ccall unsafe "uuid_variant"
211− c_variant :: C_UUID -> CInt
212−
213−-- Other
231+-- | Convert a UUID into a hypenated string using upper-case letters.
232+-- example: toStringUpper $ fromString "550e8400-e29b-41d4-a716-446655440000"
233+toStringUpper :: UUID -> String
234+toStringUpper (UUID tl tm th ch cl n) = printf "%08X-%04X-%04X-%02X%02X-%s" tl tm th ch cl ns
235+ where ns = concatMap hexb $ nodeToList n
236+ hexb x = printf "%02X" x :: String
214237
215−foreign import ccall unsafe "memcpy"
216− memcpy :: Ptr a -> Ptr b -> CSize -> IO ()
238+-- | Convert a UUID into a hypenated string using lower-case letters.
239+-- example: toStringLower $ fromString "550e8400-e29b-41d4-a716-446655440000"
240+toStringLower :: UUID -> String
241+toStringLower (UUID tl tm th ch cl n) = printf "%08x-%04x-%04x-%02x%02x-%s" tl tm th ch cl ns
242+ where ns = concatMap hexb $ nodeToList n
243+ hexb x = printf "%02x" x :: String
244+
245+-- remove all occurances of the input element in the inpt list.
246+-- non of the sub-lists are empty.
247+splitList :: Eq a => a -> [a] -> [[a]]
248+splitList c xs = let ys = dropWhile (== c) xs
249+ in case span (/= c) ys of
250+ ([],_) -> []
251+ (sub,rest) -> sub : splitList c rest
252+
253+unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
254+unfoldUntil p f n = unfoldr g n
255+ where g m = case p m of
256+ True -> Nothing
257+ False -> Just $ f m
258+
259+-- I'm not sure how fast these instances are, but they'll do for now.
260+
261+instance Random Word8 where
262+ random g = randomBoundedIntegral g
263+ randomR r g = randomRIntegral r g
264+
265+instance Random Word16 where
266+ random g = randomBoundedIntegral g
267+ randomR r g = randomRIntegral r g
268+
269+instance Random Word32 where
270+ random g = randomBoundedIntegral g
271+ randomR r g = randomRIntegral r g
272+
273+randomBoundedIntegral :: (RandomGen g, Bounded a, Integral a) => g -> (a, g)
274+randomBoundedIntegral g = let (n, g1) = randomR (fromIntegral l, fromIntegral u) g
275+ _ = n :: Integer
276+ retVal = fromIntegral n `asTypeOf` (l `asTypeOf` u)
277+ u = maxBound
278+ l = minBound
279+ in (retVal, g1)
280+
281+randomRIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g)
282+randomRIntegral (l, u) g = let (val, g1) = randomR (fromIntegral l, fromIntegral u) g
283+ _ = val :: Integer
284+ in (fromIntegral val, g1)