@@ -1,5 +1,13 @@
1−{-# INCLUDE "cbits.h" #-}
2−{-# LANGUAGE ForeignFunctionInterface, CPP #-}
1+{-# INCLUDE <uuid/uuid.h> #-}
2+{-# LANGUAGE ForeignFunctionInterface #-}
3+
4+-- |Haskell bindings to /libuuid/.
5+-- The library /libuuid/ is available as a part of e2fsprogs:
6+-- <http://e2fsprogs.sourceforge.net/>.
7+--
8+-- This library is useful for creating, comparing, parsing and
9+-- printing Universally Unique Identifiers.
10+-- See <http://en.wikipedia.org/wiki/UUID> for the general idea.
311
412module Data.UUID(UUID
513 ,fromString
@@ -15,156 +23,157 @@ where
1523
1624import Foreign.C.String
1725import Foreign.C
26+import Foreign.ForeignPtr
1827import Foreign
1928
20−import Data.Char
21−
2229import Prelude hiding (null)
2330
24−#if defined(__GLASGOW_HASKELL__)
25−import GHC.Base (unsafeChr)
26−#endif
27−
28−newtype UUID = U C_UUID
29−
30−type C_UUID = Ptr ()
31+import Data.UUID.Internal
3132
3233instance Eq UUID where
33− (U a) == (U b) = c_compare a b == 0
34+ a == b = compare a b == EQ
3435
3536instance Ord UUID where
36− compare (U p1) (U p2) =
37+ compare (U fp1) (U fp2) = unsafePerformIO $
38+ withForeignPtr fp1 $ \p1 ->
39+ withForeignPtr fp2 $ \p2 ->
3740 case c_compare p1 p2 of
38− 0 -> EQ
39− n|n<0 -> LT
40− |n>0 -> GT
41+ 0 -> return EQ
42+ n|n<0 -> return LT
43+ |n>0 -> return GT
4144
4245instance Show UUID where
4346 show = toString
4447
48+instance Read UUID where
49+ readsPrec _ str = case fromString (take 36 str) of
50+ Nothing -> []
51+ Just u -> [(u,drop 36 str)]
52+
53+-- |Creates a new 'UUID'. If \/dev\/urandom is available, it will be used.
54+-- Otherwise a UUID will be generated based on the current time and the
55+-- hardware MAC address, if available.
4556generate :: IO UUID
4657generate = do
47− p <- mallocBytes 16
48− c_generate p
49− return $ U p
58+ fp <- mallocForeignPtrArray 16
59+ withForeignPtr fp $ \p -> c_generate p
60+ return $ U fp
5061
62+-- |Create a new 'UUID'. If \/dev\/urandom is available, it will be used.
63+-- Otherwise a psuedorandom generator will be used.
5164generateRandom :: IO UUID
5265generateRandom = do
53− p <- mallocBytes 16
54− c_generate_random p
55− return $ U p
66+ fp <- mallocForeignPtrArray 16
67+ withForeignPtr fp $ \p -> c_generate_random p
68+ return $ U fp
5669
70+-- |Create a new 'UUID'. The UUID will be generated based on the
71+-- current time and the hardware MAC address, if available.
5772generateTime :: IO UUID
5873generateTime = do
59− p <- mallocBytes 16
60− c_generate_time p
61− return $ U p
74+ fp <- mallocForeignPtrArray 16
75+ withForeignPtr fp $ \p -> c_generate_time p
76+ return $ U fp
6277
78+-- |Returns 'True' if the passed-in 'UUID' is the null UUID.
6379null :: UUID -> Bool
64−null (U p) = c_null p /= 0
65−
80+null (U fp) = unsafePerformIO $
81+ withForeignPtr fp $ \p ->
82+ return $ c_null p == 1
83+
84+-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
85+-- The hyphens may not be ommited.
86+-- Example:
87+--
88+-- @
89+-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
90+-- @
91+--
92+-- Hex digits may be upper or lower-case.
6693fromString :: String -> Maybe UUID
6794fromString s = unsafePerformIO $ do
68− p <- mallocBytes 16
69− chars <- mallocBytes 37
70− pack 0 s chars
71− res <- c_read p (castPtr chars)
95+ fp <- mallocForeignPtrArray 16
96+ res <- withCString s $ \chars ->
97+ withForeignPtr fp $ \p ->
98+ c_read (castPtr chars) p
7299 case res of
73− 0 -> return . Just $ U p
100+ 0 -> return . Just $ U fp
74101 _ -> return Nothing
75102
76−pack :: Int -> String -> Ptr Word8 -> IO ()
77−pack 37 _ p = pokeByteOff p 37 (0 :: Word8)
78−pack n (c:cs) p = do
79− pokeByteOff p n (c2w c)
80− pack (n+1) cs p
81−pack n [] p = pokeByteOff p n (0 :: Word8)
82−
83−unpack :: Ptr Word8 -> Int -> IO String
84−unpack p 37 = return []
85−unpack p n = do
86− c <- peekByteOff p n
87− case c of
88− 0 -> return []
89− _ -> do
90− cs <- unpack p (n+1)
91− return $ (w2c c) : cs
92−
103+-- |Returns a 'String' representation of the passed in UUID.
104+-- Hex digits occuring in the output will be either upper or
105+-- lower-case depending on system defaults and locale.
93106toString :: UUID -> String
94−toString (U p) = unsafePerformIO $ do
107+toString (U fp) = unsafePerformIO $ do
95108 chars <- mallocBytes 37
96− c_show p chars
97− unpack (castPtr chars) 0
109+ withForeignPtr fp $ \p -> c_show p chars
110+ st <- peekCString chars
111+ free chars
112+ return st
98113
114+-- |Returns a 'String' representation of the passed in UUID.
115+-- Hex digits occuring in the output will be lower-case.
99116toStringLower :: UUID -> String
100−toStringLower (U p) = unsafePerformIO $ do
117+toStringLower (U fp) = unsafePerformIO $ do
101118 chars <- mallocBytes 37
102− c_show_lower p chars
103− unpack (castPtr chars) 0
104−
119+ withForeignPtr fp $ \p -> c_show_lower p chars
120+ st <- peekCString chars
121+ free chars
122+ return st
123+
124+-- |Returns a 'String' representation of the passed in UUID.
125+-- Hex digits occuring in the output will be upper-case.
105126toStringUpper :: UUID -> String
106−toStringUpper (U p) = unsafePerformIO $ do
127+toStringUpper (U fp) = unsafePerformIO $ do
107128 chars <- mallocBytes 37
108− c_show_upper p chars
109− unpack (castPtr chars) 0
110−
111−-- | Conversion between 'Word8' and 'Char'. Should compile to a no-op.
112−-- Shamelessly stolen from the 'bytestring' package.
113−w2c :: Word8 -> Char
114−#if !defined(__GLASGOW_HASKELL__)
115−w2c = chr . fromIntegral
116−#else
117−w2c = unsafeChr . fromIntegral
118−#endif
119−{-# INLINE w2c #-}
120−
121−-- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and
122−-- silently truncates to 8 bits Chars > '\255'. It is provided as
123−-- convenience for ByteString construction.
124−-- Shamelessly stolen from the 'bytestring' package.
125−c2w :: Char -> Word8
126−c2w = fromIntegral . ord
127−{-# INLINE c2w #-}
129+ withForeignPtr fp $ \p -> c_show_upper p chars
130+ st <- peekCString chars
131+ free chars
132+ return st
133+
134+
135+-- FFI calls to do the work
136+
137+type C_UUID = Ptr CChar
128138
129139-- comparing UUIDs
130−foreign import ccall unsafe "c_compare"
140+foreign import ccall unsafe "uuid_compare"
131141 c_compare :: C_UUID -> C_UUID -> CInt
132142
133143-- making random UUIDs
134−foreign import ccall unsafe "c_generate"
144+foreign import ccall unsafe "uuid_generate"
135145 c_generate :: C_UUID -> IO ()
136146
137−foreign import ccall unsafe "c_generate_time"
147+foreign import ccall unsafe "uuid_generate_time"
138148 c_generate_time :: C_UUID -> IO ()
139149
140−foreign import ccall unsafe "c_generate_random"
150+foreign import ccall unsafe "uuid_generate_random"
141151 c_generate_random :: C_UUID -> IO ()
142152
143153-- Null check
144−foreign import ccall unsafe "c_null"
154+foreign import ccall unsafe "uuid_is_null"
145155 c_null :: C_UUID -> CInt
146156
147−
148157-- Parsing
149−foreign import ccall unsafe "c_read"
150− c_read :: C_UUID -> CString ->IO CInt
158+foreign import ccall unsafe "uuid_parse"
159+ c_read :: CString -> C_UUID ->IO CInt
151160
152161-- Showing
153162
154−foreign import ccall unsafe "c_show"
163+foreign import ccall unsafe "uuid_unparse"
155164 c_show :: C_UUID -> CString -> IO ()
156165
157−foreign import ccall unsafe "c_show_lower"
166+foreign import ccall unsafe "uuid_unparse_lower"
158167 c_show_lower :: C_UUID -> CString -> IO ()
159168
160−foreign import ccall unsafe "c_show_upper"
169+foreign import ccall unsafe "uuid_unparse_upper"
161170 c_show_upper :: C_UUID -> CString -> IO ()
162171
163172
164173-- Queries
165174
166−foreign import ccall unsafe "c_type"
175+foreign import ccall unsafe "uuid_type"
167176 c_type :: C_UUID -> CInt
168177
169−foreign import ccall unsafe "c_variant"
178+foreign import ccall unsafe "uuid_variant"
170179 c_variant :: C_UUID -> CInt