diff --git a/Data/UUID.hs b/Data/UUID.hs new file mode 100644 --- /dev/null +++ b/Data/UUID.hs @@ -0,0 +1,225 @@ +{-# INCLUDE #-} +{-# INCLUDE #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | +-- Module : Data.UUID +-- Copyright : (c) 2008 Antoine Latter +-- +-- License : BSD-style +-- +-- Maintainer : aslatter@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Haskell bindings to /libuuid/. +-- The library /libuuid/ is available as a part of e2fsprogs: +-- . +-- +-- This library is useful for creating, comparing, parsing and +-- printing Universally Unique Identifiers. +-- See for the general idea. + +module Data.UUID(UUID + ,fromString + ,toString + ,toStringUpper + ,toStringLower + ,generate + ,generateRandom + ,generateTime + ,null + ) +where + +import Foreign.C.String +import Foreign.C +import Foreign.ForeignPtr +import Foreign + +import Data.Typeable +import Data.Generics.Basics + +import Prelude hiding (null) + +import Data.UUID.Internal + +instance Eq UUID where + a == b = compare a b == EQ + +instance Ord UUID where + compare (U fp1) (U fp2) = unsafePerformIO $ + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + case c_compare p1 p2 of + 0 -> return EQ + n|n<0 -> return LT + |n>0 -> return GT + +instance Show UUID where + show = toString + +instance Read UUID where + readsPrec _ str = case fromString (take 36 str) of + Nothing -> [] + Just u -> [(u,drop 36 str)] + +instance Typeable UUID where + typeOf _ = mkTyConApp (mkTyCon "Data.UUID.UUID") [] + +instance Storable UUID where + sizeOf _ = (16 *) $ alignment (undefined :: CChar) + alignment _ = alignment (undefined :: CChar) + + peek psource = do + fp <- mallocForeignPtrArray 16 + withForeignPtr fp $ \pdest -> + memcpy pdest psource $ fromIntegral $ sizeOf (undefined :: UUID) + return $ U fp + + poke pdest (U fp) = withForeignPtr fp $ \psource -> + memcpy pdest psource $ fromIntegral $ sizeOf (undefined :: UUID) + + +-- My goal with this instance was to make it work just enough to do what +-- I want when used with the HStringTemplate library. +instance Data UUID where + toConstr uu = mkConstr uuidType (show uu) [] (error "fixity") + gunfold _ _ = error "gunfold" + dataTypeOf _ = uuidType + +uuidType = mkNorepType "Data.UUID.UUID" + + +-- |Creates a new 'UUID'. If \/dev\/urandom is available, it will be used. +-- Otherwise a UUID will be generated based on the current time and the +-- hardware MAC address, if available. +generate :: IO UUID +generate = do + fp <- mallocForeignPtrArray 16 + withForeignPtr fp $ \p -> c_generate p + return $ U fp + +-- |Create a new 'UUID'. If \/dev\/urandom is available, it will be used. +-- Otherwise a psuedorandom generator will be used. +generateRandom :: IO UUID +generateRandom = do + fp <- mallocForeignPtrArray 16 + withForeignPtr fp $ \p -> c_generate_random p + return $ U fp + +-- |Create a new 'UUID'. The UUID will be generated based on the +-- current time and the hardware MAC address, if available. +generateTime :: IO UUID +generateTime = do + fp <- mallocForeignPtrArray 16 + withForeignPtr fp $ \p -> c_generate_time p + return $ U fp + +-- |Returns 'True' if the passed-in 'UUID' is the null UUID. +null :: UUID -> Bool +null (U fp) = unsafePerformIO $ + withForeignPtr fp $ \p -> + return $ c_null p == 1 + +-- |If the passed in 'String' can be parsed as a 'UUID', it will be. +-- The hyphens may not be omitted. +-- Example: +-- +-- @ +-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\" +-- @ +-- +-- Hex digits may be upper or lower-case. +fromString :: String -> Maybe UUID +fromString s = unsafePerformIO $ do + fp <- mallocForeignPtrArray 16 + res <- withCAString s $ \chars -> + withForeignPtr fp $ \p -> + c_read (castPtr chars) p + case res of + 0 -> return . Just $ U fp + _ -> return Nothing + +-- |Returns a 'String' representation of the passed in 'UUID'. +-- Hex digits occuring in the output will be either upper or +-- lower-case depending on system defaults and locale. +toString :: UUID -> String +toString (U fp) = unsafePerformIO $ do + chars <- mallocBytes 37 + withForeignPtr fp $ \p -> c_show p chars + st <- peekCAString chars + free chars + return st + +-- |Returns a 'String' representation of the passed in 'UUID'. +-- Hex digits occuring in the output will be lower-case. +toStringLower :: UUID -> String +toStringLower (U fp) = unsafePerformIO $ do + chars <- mallocBytes 37 + withForeignPtr fp $ \p -> c_show_lower p chars + st <- peekCAString chars + free chars + return st + +-- |Returns a 'String' representation of the passed in 'UUID'. +-- Hex digits occuring in the output will be upper-case. +toStringUpper :: UUID -> String +toStringUpper (U fp) = unsafePerformIO $ do + chars <- mallocBytes 37 + withForeignPtr fp $ \p -> c_show_upper p chars + st <- peekCAString chars + free chars + return st + + +-- FFI calls to do the work + +type C_UUID = Ptr CChar + +-- comparing UUIDs +foreign import ccall unsafe "uuid_compare" + c_compare :: C_UUID -> C_UUID -> CInt + +-- making random UUIDs +foreign import ccall unsafe "uuid_generate" + c_generate :: C_UUID -> IO () + +foreign import ccall unsafe "uuid_generate_time" + c_generate_time :: C_UUID -> IO () + +foreign import ccall unsafe "uuid_generate_random" + c_generate_random :: C_UUID -> IO () + +-- Null check +foreign import ccall unsafe "uuid_is_null" + c_null :: C_UUID -> CInt + +-- Parsing +foreign import ccall unsafe "uuid_parse" + c_read :: CString -> C_UUID ->IO CInt + +-- Showing + +foreign import ccall unsafe "uuid_unparse" + c_show :: C_UUID -> CString -> IO () + +foreign import ccall unsafe "uuid_unparse_lower" + c_show_lower :: C_UUID -> CString -> IO () + +foreign import ccall unsafe "uuid_unparse_upper" + c_show_upper :: C_UUID -> CString -> IO () + + +-- Queries + +foreign import ccall unsafe "uuid_type" + c_type :: C_UUID -> CInt + +foreign import ccall unsafe "uuid_variant" + c_variant :: C_UUID -> CInt + +-- Other + +foreign import ccall unsafe "memcpy" + memcpy :: Ptr a -> Ptr b -> CSize -> IO () diff --git a/Data/UUID/Internal.hs b/Data/UUID/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/UUID/Internal.hs @@ -0,0 +1,59 @@ +-- | +-- Module : Data.UUID.Internal +-- Copyright : (c) 2008 Antoine Latter +-- +-- License : BSD-style +-- +-- Maintainer : aslatter@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- If the public interface in "Data.UUID" doesn't give you +-- the flexibility you need, you should be able to find +-- something here. + +module Data.UUID.Internal(UUID(..) + ,toBytes + ,fromBytes + ,unsafeFromBytes + ,toForeignPtr + ,fromForeignPtr + ) where + +import Foreign.ForeignPtr +import Foreign.C +import Foreign + +-- |The UUID type. Represents 128-bits of identification. +newtype UUID = U (ForeignPtr CChar) + +-- |Returns the passed in UUID as a list of 16 bytes. +toBytes :: UUID -> [Word8] +toBytes (U fp) = unsafePerformIO $ withForeignPtr fp $ \p -> + peekArray 16 (castPtr p) + +-- |Creates a UUID out of a list of bytes. +-- Will throw an error if the list is not of length 16. +fromBytes :: [Word8] -> UUID +fromBytes xs = if length xs == 16 + then unsafeFromBytes xs + else error "Data.UUID.Internal.fromBytes: passed in list of bytes must be of length 16." + +-- |Creates a UUID out of a list of bytes. +-- Does not perform a length check. +-- Behavior is undefined for lists not of length 16. +unsafeFromBytes :: [Word8] -> UUID +unsafeFromBytes xs = U $ castForeignPtr $ unsafePerformIO $ do + p <- mallocForeignPtrBytes 16 + withForeignPtr p $ flip pokeArray xs + return p + +-- |Given a UUID, returns a pointer to the 16 bytes +-- of memory that make up the UUID. +toForeignPtr :: UUID -> ForeignPtr CChar +toForeignPtr (U p) = p + +-- |The passed in pointer is treated as if it were a pointer +-- to 16 bytes of memory. You're in trouble if it isn't. +fromForeignPtr :: ForeignPtr CChar -> UUID +fromForeignPtr = U diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2008, Antoine Latter + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + * The names of the authors may not be used to endorse or promote +products derived from this software without specific prior written +permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED +TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple +main :: IO () +main = defaultMain + diff --git a/uuid.cabal b/uuid.cabal new file mode 100644 --- /dev/null +++ b/uuid.cabal @@ -0,0 +1,32 @@ +Name: uuid +Version: 0.1.0 +Copyright: 2008, Antoine Latter +Author: Antoine Latter +Maintainer: aslatter@gmail.com +License: BSD3 +License-file: LICENSE + +Category: Data +Build-Type: Simple +Cabal-Version: >= 1.2 + +Description: + Haskell bindings to libuuid. + The library libuuid is available as a part of e2fsprogs: + . + + + This library is useful for creating, comparing, parsing and + printing Universally Unique Identifiers. + See for the general idea. + +Library + Build-Depends: base + + Exposed-Modules: + Data.UUID, + Data.UUID.Internal + + Extensions: ForeignFunctionInterface + + Extra-Libraries: uuid