@@ -0,0 +1,170 @@
1+{-# INCLUDE "cbits.h" #-}
2+{-# LANGUAGE ForeignFunctionInterface, CPP #-}
3+
4+module Data.UUID(UUID
5+ ,fromString
6+ ,toString
7+ ,toStringUpper
8+ ,toStringLower
9+ ,generate
10+ ,generateRandom
11+ ,generateTime
12+ ,null
13+ )
14+where
15+
16+import Foreign.C.String
17+import Foreign.C
18+import Foreign
19+
20+import Data.Char
21+
22+import Prelude hiding (null)
23+
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+
32+instance Eq UUID where
33+ (U a) == (U b) = c_compare a b == 0
34+
35+instance Ord UUID where
36+ compare (U p1) (U p2) =
37+ case c_compare p1 p2 of
38+ 0 -> EQ
39+ n|n<0 -> LT
40+ |n>0 -> GT
41+
42+instance Show UUID where
43+ show = toString
44+
45+generate :: IO UUID
46+generate = do
47+ p <- mallocBytes 16
48+ c_generate p
49+ return $ U p
50+
51+generateRandom :: IO UUID
52+generateRandom = do
53+ p <- mallocBytes 16
54+ c_generate_random p
55+ return $ U p
56+
57+generateTime :: IO UUID
58+generateTime = do
59+ p <- mallocBytes 16
60+ c_generate_time p
61+ return $ U p
62+
63+null :: UUID -> Bool
64+null (U p) = c_null p /= 0
65+
66+fromString :: String -> Maybe UUID
67+fromString s = unsafePerformIO $ do
68+ p <- mallocBytes 16
69+ chars <- mallocBytes 37
70+ pack 0 s chars
71+ res <- c_read p (castPtr chars)
72+ case res of
73+ 0 -> return . Just $ U p
74+ _ -> return Nothing
75+
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+
93+toString :: UUID -> String
94+toString (U p) = unsafePerformIO $ do
95+ chars <- mallocBytes 37
96+ c_show p chars
97+ unpack (castPtr chars) 0
98+
99+toStringLower :: UUID -> String
100+toStringLower (U p) = unsafePerformIO $ do
101+ chars <- mallocBytes 37
102+ c_show_lower p chars
103+ unpack (castPtr chars) 0
104+
105+toStringUpper :: UUID -> String
106+toStringUpper (U p) = unsafePerformIO $ do
107+ 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 #-}
128+
129+-- comparing UUIDs
130+foreign import ccall unsafe "c_compare"
131+ c_compare :: C_UUID -> C_UUID -> CInt
132+
133+-- making random UUIDs
134+foreign import ccall unsafe "c_generate"
135+ c_generate :: C_UUID -> IO ()
136+
137+foreign import ccall unsafe "c_generate_time"
138+ c_generate_time :: C_UUID -> IO ()
139+
140+foreign import ccall unsafe "c_generate_random"
141+ c_generate_random :: C_UUID -> IO ()
142+
143+-- Null check
144+foreign import ccall unsafe "c_null"
145+ c_null :: C_UUID -> CInt
146+
147+
148+-- Parsing
149+foreign import ccall unsafe "c_read"
150+ c_read :: C_UUID -> CString ->IO CInt
151+
152+-- Showing
153+
154+foreign import ccall unsafe "c_show"
155+ c_show :: C_UUID -> CString -> IO ()
156+
157+foreign import ccall unsafe "c_show_lower"
158+ c_show_lower :: C_UUID -> CString -> IO ()
159+
160+foreign import ccall unsafe "c_show_upper"
161+ c_show_upper :: C_UUID -> CString -> IO ()
162+
163+
164+-- Queries
165+
166+foreign import ccall unsafe "c_type"
167+ c_type :: C_UUID -> CInt
168+
169+foreign import ccall unsafe "c_variant"
170+ c_variant :: C_UUID -> CInt