@@ -1,6 +1,4 @@
1−{-# INCLUDE <uuid/uuid.h> #-}
1+{-# LANGUAGE DeriveDataTypeable #-}
2−{-# INCLUDE <string.h> #-}
3−{-# LANGUAGE ForeignFunctionInterface #-}
6-- Module : Data.UUID
4-- Module : Data.UUID
@@ -12,10 +10,7 @@
12-- Stability : experimental
10-- Stability : experimental
13-- Portability : portable
11-- Portability : portable
15−-- Haskell bindings to /libuuid/.
13+--
16−-- The library /libuuid/ is available as a part of e2fsprogs:
17−-- <http://e2fsprogs.sourceforge.net/>.
19-- This library is useful for creating, comparing, parsing and
14-- This library is useful for creating, comparing, parsing and
20-- printing Universally Unique Identifiers.
15-- printing Universally Unique Identifiers.
21-- See <http://en.wikipedia.org/wiki/UUID> for the general idea.
16-- See <http://en.wikipedia.org/wiki/UUID> for the general idea.
@@ -32,29 +27,87 @@ module Data.UUID(UUID
35−import Foreign.C.String
30+import Data.Word
36−import Foreign.C
31+import System.Random
37−import Foreign.ForeignPtr
32+import Data.Maybe
38−import Foreign
34+import Data.Char
40import Data.Typeable
36import Data.Typeable
41import Data.Generics.Basics
37import Data.Generics.Basics
43−import Prelude hiding (null)
39+import Data.Bits
45−import Data.UUID.Internal
47−instance Eq UUID where
41+import Text.Printf
48− a == b = compare a b == EQ
43+import Prelude hiding (null)
44+import qualified Prelude
46+import Data.List (splitAt, foldl', unfoldr)
49+import Foreign.Storable
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)
50−instance Ord UUID where
61+instance Random UUID where
51− compare (U fp1) (U fp2) = unsafePerformIO $
62+ random g = let (timeLow, g1) = random g
52− withForeignPtr fp1 $ \p1 ->
63+ (timeMid, g2) = random g1
53− withForeignPtr fp2 $ \p2 ->
64+ (timeHigh, g3) = random g2
54− case c_compare p1 p2 of
65+ (seqHigh, g4) = random g3
55− 0 -> return EQ
66+ (seqLow, g5) = random g4
56− n|n<0 -> return LT
67+ (node, g6) = random g5
57− |n>0 -> return GT
68+ seqHighReserved = (seqHigh .&. reservedMask) .|. reserved
69+ timeHighVersion = (timeHigh .&. versionMask) .|. versionRandom
70+ in (UUID timeLow timeMid timeHighVersion seqHighReserved seqLow node, g6)
72+ randomR _ = random -- range is ignored
74+versionMask :: Word16 -- 0000 1111 1111 1111
77+versionRandom :: Word16
78+versionRandom = shiftL 12 4
80+reservedMask :: Word8 -- 0011 1111
87+ {-# UNPACK #-} !Word8
88+ {-# UNPACK #-} !Word8
89+ {-# UNPACK #-} !Word8
90+ {-# UNPACK #-} !Word8
91+ {-# UNPACK #-} !Word8
92+ {-# UNPACK #-} !Word8
93+ deriving (Eq, Ord, Typeable)
95+instance Random Node where
96+ random g = let (w1, g1) = random g
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
105+nodeToList :: Node -> [Word8]
106+nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
108+listToNode :: [Word8] -> Maybe Node
109+listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
110+listToNode _ = Nothing
59instance Show UUID where
112instance Show UUID where
60 show = toString
113 show = toString
@@ -64,22 +117,48 @@ instance Read UUID where
64 Nothing -> []
117 Nothing -> []
65 Just u -> [(u,drop 36 str)]
118 Just u -> [(u,drop 36 str)]
67−instance Typeable UUID where
68− typeOf _ = mkTyConApp (mkTyCon "Data.UUID.UUID") []
70instance Storable UUID where
121instance Storable UUID where
71− sizeOf _ = (16 *) $ sizeOf (undefined :: CChar)
122+ sizeOf _ = 16
123+ alignment _ = 4 -- not sure what to put here
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
134+ poke p (UUID tl tm th ch cl node) = do
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
142+instance Storable Node where
72− alignment _ = alignment (undefined :: CChar)
144+ alignment _ = 1 -- ???
74− peek psource = do
146+ peek p = do
75− fp <- mallocForeignPtrArray $ sizeOf (undefined :: UUID)
147+ w1 <- peek $ castPtr p
76− withForeignPtr fp $ \pdest ->
148+ w2 <- peekByteOff (castPtr p) 1
77− memcpy pdest psource $ fromIntegral $ sizeOf (undefined :: UUID)
149+ w3 <- peekByteOff (castPtr p) 2
78− return $ U fp
150+ w4 <- peekByteOff (castPtr p) 3
79−
151+ w5 <- peekByteOff (castPtr p) 4
80− poke pdest (U fp) = withForeignPtr fp $ \psource ->
152+ w6 <- peekByteOff (castPtr p) 5
81− memcpy pdest psource $ fromIntegral $ sizeOf (undefined :: UUID)
153+ return $ Node w1 w2 w3 w4 w5 w6
155+ poke p (Node w1 w2 w3 w4 w5 w6) = do
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
84-- My goal with this instance was to make it work just enough to do what
163-- My goal with this instance was to make it work just enough to do what
85-- I want when used with the HStringTemplate library.
164-- I want when used with the HStringTemplate library.
@@ -95,29 +174,23 @@ uuidType = mkNorepType "Data.UUID.UUID"
95-- Otherwise a UUID will be generated based on the current time and the
174-- Otherwise a UUID will be generated based on the current time and the
96-- hardware MAC address, if available.
175-- hardware MAC address, if available.
97generate :: IO UUID
176generate :: IO UUID
98−generate = generateWrap c_generate
177+generate = generateRandom
100-- |Create a new 'UUID'. If \/dev\/urandom is available, it will be used.
179-- |Create a new 'UUID'. If \/dev\/urandom is available, it will be used.
101-- Otherwise a psuedorandom generator will be used.
180-- Otherwise a psuedorandom generator will be used.
102generateRandom :: IO UUID
181generateRandom :: IO UUID
103−generateRandom = generateWrap c_generate_random
182+generateRandom = randomIO -- not a good solution, as someone could have changed the global generator
105-- |Create a new 'UUID'. The UUID will be generated based on the
184-- |Create a new 'UUID'. The UUID will be generated based on the
106-- current time and the hardware MAC address, if available.
185-- current time and the hardware MAC address, if available.
107generateTime :: IO UUID
186generateTime :: IO UUID
108−generateTime = generateWrap c_generate_time
187+generateTime = error "Data.UUID.generateTime: not yet implemented"
110−generateWrap :: (C_UUID -> IO ()) -> IO UUID
111−generateWrap gen = do
112− fp <- mallocForeignPtrArray 16
113− withForeignPtr fp $ \p -> gen p
116-- |Returns 'True' if the passed-in 'UUID' is the null UUID.
189-- |Returns 'True' if the passed-in 'UUID' is the null UUID.
117null :: UUID -> Bool
190null :: UUID -> Bool
118−null (U fp) = unsafePerformIO $
191+null = (== nullUuid)
119− withForeignPtr fp $ \p ->
192+ where nullUuid = UUID 0 0 0 0 0 $ Node 0 0 0 0 0 0
120− return $ c_null p == 1
193+
122-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
195-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
123-- The hyphens may not be omitted.
196-- The hyphens may not be omitted.
@@ -129,88 +202,83 @@ null (U fp) = unsafePerformIO $
130-- Hex digits may be upper or lower-case.
203-- Hex digits may be upper or lower-case.
131fromString :: String -> Maybe UUID
204fromString :: String -> Maybe UUID
132−fromString s = unsafePerformIO $ do
205+fromString xs | validFmt = Just uuid
133− fp <- mallocForeignPtrArray 16
206+ | otherwise = Nothing
134− res <- withCAString s $ \chars ->
207+ where validFmt = length ws == 5 &&
135− withForeignPtr fp $ \p ->
208+ map length ws == [8,4,4,4,12] &&
136− c_read chars p
209+ all isHexDigit (concat ws) &&
137− case res of
210+ isJust node
138− 0 -> return . Just $ U fp
211+ ws = splitList '-' xs
139− _ -> return Nothing
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)
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
221+digitToInteger :: Char -> Integer
222+digitToInteger = fromIntegral . digitToInt
141-- |Returns a 'String' representation of the passed in 'UUID'.
224-- |Returns a 'String' representation of the passed in 'UUID'.
142-- Hex digits occuring in the output will be either upper or
225-- Hex digits occuring in the output will be either upper or
143-- lower-case depending on system defaults and locale.
226-- lower-case depending on system defaults and locale.
144toString :: UUID -> String
227toString :: UUID -> String
145−toString = toStringWrap c_show
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
228+toString = toStringLower
150−toStringLower = toStringWrap c_show_lower
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
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
167−-- FFI calls to do the work
169−type C_UUID = Ptr CChar
231+-- | Convert a UUID into a hypenated string using upper-case letters.
170−
232+-- example: toStringUpper $ fromString "550e8400-e29b-41d4-a716-446655440000"
171−-- comparing UUIDs
233+toStringUpper :: UUID -> String
172−foreign import ccall unsafe "uuid_compare"
234+toStringUpper (UUID tl tm th ch cl n) = printf "%08X-%04X-%04X-%02X%02X-%s" tl tm th ch cl ns
173− c_compare :: C_UUID -> C_UUID -> CInt
235+ where ns = concatMap hexb $ nodeToList n
174−
236+ hexb x = printf "%02X" x :: String
175−-- making random UUIDs
176−foreign import ccall unsafe "uuid_generate"
177− c_generate :: C_UUID -> IO ()
179−foreign import ccall unsafe "uuid_generate_time"
180− c_generate_time :: C_UUID -> IO ()
182−foreign import ccall unsafe "uuid_generate_random"
183− c_generate_random :: C_UUID -> IO ()
186−foreign import ccall unsafe "uuid_is_null"
187− c_null :: C_UUID -> CInt
190−foreign import ccall unsafe "uuid_parse"
191− c_read :: CString -> C_UUID ->IO CInt
195−foreign import ccall unsafe "uuid_unparse"
196− c_show :: C_UUID -> CString -> IO ()
198−foreign import ccall unsafe "uuid_unparse_lower"
199− c_show_lower :: C_UUID -> CString -> IO ()
201−foreign import ccall unsafe "uuid_unparse_upper"
202− c_show_upper :: C_UUID -> CString -> IO ()
207−foreign import ccall unsafe "uuid_type"
208− c_type :: C_UUID -> CInt
210−foreign import ccall unsafe "uuid_variant"
211− c_variant :: C_UUID -> CInt
215−foreign import ccall unsafe "memcpy"
238+-- | Convert a UUID into a hypenated string using lower-case letters.
216− memcpy :: Ptr a -> Ptr b -> CSize -> IO ()
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
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
251+ (sub,rest) -> sub : splitList c rest
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
259+-- I'm not sure how fast these instances are, but they'll do for now.
261+instance Random Word8 where
262+ random g = randomBoundedIntegral g
263+ randomR r g = randomRIntegral r g
265+instance Random Word16 where
266+ random g = randomBoundedIntegral g
267+ randomR r g = randomRIntegral r g
269+instance Random Word32 where
270+ random g = randomBoundedIntegral g
271+ randomR r g = randomRIntegral r g
273+randomBoundedIntegral :: (RandomGen g, Bounded a, Integral a) => g -> (a, g)
274+randomBoundedIntegral g = let (n, g1) = randomR (fromIntegral l, fromIntegral u) g
276+ retVal = fromIntegral n `asTypeOf` (l `asTypeOf` u)
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
284+ in (fromIntegral val, g1)