diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,2 @@ + Jason Dusek + diff --git a/Data/UUID/Bytes.hs b/Data/UUID/Bytes.hs new file mode 100644 --- /dev/null +++ b/Data/UUID/Bytes.hs @@ -0,0 +1,55 @@ + +{-| A 'UUID' as plain old bytes. + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} + +module Data.UUID.Bytes + ( UUID(..) + , listOfBytes + ) where + + +import Data.Word +import Data.Char +import Control.Monad +import Numeric +import Text.ParserCombinators.ReadPrec (lift) +import Text.ParserCombinators.ReadP +import Text.Read hiding (pfail) +import Data.List +import Text.Printf + + +data UUID = UUID + !Word8 !Word8 !Word8 !Word8 !Word8 !Word8 !Word8 !Word8 + !Word8 !Word8 !Word8 !Word8 !Word8 !Word8 !Word8 !Word8 +instance Show UUID where + show (UUID x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC xD xE xF) + = printf formatUUID x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC xD xE xF + where + formatUUID = intercalate "-" $ map b [ 2, 1, 1, 1, 3 ] + b = concat . (`replicate` "%02.2x%02.2x") +instance Read UUID where + readPrec = lift $ do + [x0,x1,x2,x3] <- count 4 byte + char '-' + [x4,x5] <- count 2 byte + char '-' + [x6,x7] <- count 2 byte + char '-' + [x8,x9] <- count 2 byte + char '-' + [xA,xB,xC,xD,xE,xF] <- count 6 byte + return $ UUID x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC xD xE xF + where + byte = do + s <- sequence $ replicate 2 $ satisfy isHexDigit + case readHex s of + [(b, _)] -> return b + _ -> pfail +instance Eq UUID +instance Ord UUID + + +listOfBytes (UUID x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC xD xE xF) + = [ x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, xA, xB, xC, xD, xE, xF ] + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ + + © 1970-2038, persons listed in the CONTRIBUTORS file (hereafter + "contributors"). The list of contributors shall be understood as an integral + component of this copyright notice. + + 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, the list of contributors and the following + disclaimer. + + . Redistributions in binary form must reproduce the above copyright notice, + this list of conditions, the list of contributors and the following + disclaimer in the documentation and/or other materials provided with the + distribution. + + . Names of the contributors may not be used to endorse or promote products + derived from this software without specific prior written permission. + + This software is provided by the 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 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/Macros.hs b/Macros.hs new file mode 100644 --- /dev/null +++ b/Macros.hs @@ -0,0 +1,54 @@ + +{-| Macros of general use. + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} + +{-# LANGUAGE TemplateHaskell + #-} + + +module Macros where + + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Data.List +import Text.Regex + + +{-| Just a macro to pull in a file. + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} +pullFile f = lift =<< runIO (readFile f) + + +{-| Extract the usage from the module we're in and put it here. + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} +usage = lift =<< do + mod <- currentModule + runIO $ do + s <- readFile $ fileName mod + return $ extractUsage s + where + fileName mod = map replace mod ++ ".hs" + replace '.' = '/' + replace c = c + + +{-| Pulls the usage out of the comments in a file, digging through the file + - to find a comment with no text before the @SYNOPSIS@ or @USAGE@, and then + - treating all the text of the comment as the usage statement. + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} +extractUsage s = + case regex s of + Just [_, a, _, b] -> ('\n':) . normalizeEmptyLines'' $ a ++ b + _ -> "" + where + r s = matchRegex (mkRegexWithOpts r False True) s + regex = ".*\\{-([\t -]*\n)+([ \t]+(SYNOPSIS|USAGE))(.+)\n[-\t ]*-\\}" + + -- normalizeLeadingEmptyLines +normalizeLeadingEmpties = ('\n':) . dropWhile (`elem` "\n \t") +normalizeEmptyLines'' = reverse . normalizeLeadingEmpties . reverse + + + + diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,118 @@ +{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + SYNOPSIS + hooty (-1|-4)? (-n )? + + DESCRIPTION + + The `hooty` program generates any number of UUIDs (one by default), using + either the version 1 (time and MAC) or version 4 (random) algorithm + (version 1 is the default). On all platforms, `hooty` uses the native + implementation. + + OPTIONS + + -n, --number + Create such-and-such many UUIDs in one go. + + -1, --sequential + Create UUIDs using the version 1 (time and MAC) algorithm. + + -4, --random + Create UUIDs using the version 4 (random) algorithm. + + -h, -?, --help + Print this help and exit. + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} + +{-# LANGUAGE TemplateHaskell + , PatternGuards + #-} + +import qualified System.UUID.V1 as V1 +import qualified System.UUID.V4 as V4 +import Options +import Messages +import qualified Macros as Macros +import System.Environment +import System.Exit +import Control.Monad +import Control.Applicative +import Data.Maybe +import Data.Word +import qualified Data.Map as Map + +main = do + m <- opts + let + lk = (`Map.lookup` m) + when (isJust $ lk "h") $ do + stdout << usage + exitWith ExitSuccess + when (all (isJust . lk) ["1","4"]) $ do + bail "Please specify either version 1 or version 4." + let + n :: Word + n = fromMaybe 1 $ maybeRead =<< lk "n" + gen = + if isJust $ lk "4" + then V4.uuid + else V1.uuid + mapM_ (const $ print =<< gen) [1..n] + + +bail :: String -> IO a +bail s = do + stderr << s + stderr << usage + exitFailure + + +usage = $(Macros.usage) + + +opts = do + args <- getArgs + case runParser options () "command line arguments" args of + Right list -> return $ foldr ($) Map.empty list + Left e -> bail $ show e + + +options = do + res <- choice + [ eof >> return [] + , many1 options' + ] + eof + return res + + +options' = do + o <- choice opts + opt o + where + opt o@[c] + | c `elem` "h14" = return $ Map.insert o "" + | c == 'n' = choice + [ eof >> fail "Option requires an argument." + , try $ do + s <- initialChar '-' + fail $ "Option requiring argument followed by:\n " ++ s + , fmap (Map.insert o) anyString + ] + | otherwise = prb $ "unimplemented option '" ++ o ++ "'" + opt o = prb $ "unimplemented option '" ++ o ++ "'" + prb s = fail $ "Please report a bug -- " ++ s ++ "." + opts = map try + [ option "h?" ["help"] + , option "1" ["sequential"] + , option "4" ["random"] + , option "n" ["number"] + ] ++ [ fail "Invalid option." ] + + +maybeRead s + | [(a, _)] <- reads s = Just a + | otherwise = Nothing + diff --git a/Messages.hs b/Messages.hs new file mode 100644 --- /dev/null +++ b/Messages.hs @@ -0,0 +1,23 @@ + + +{-| Very simple IO module -- just the components that I actually need for + - String IO, and nothing more. (Prevents namespace conflict with ByteString + - IO elsewhere in the program). + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} + +module Messages + ( (<<) + , stdin + , stdout + , stderr + ) where + + +import System.IO + + +{-| An @iostream@ style operator. + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} +(<<) = hPutStrLn +infixr 4 << + diff --git a/Options.hs b/Options.hs new file mode 100644 --- /dev/null +++ b/Options.hs @@ -0,0 +1,51 @@ + +module Options + ( option + , anyString + , string + , initialChar + , module Text.ParserCombinators.Parsec + ) where + + +import Text.ParserCombinators.Parsec hiding + ( parse + , string + , oneOf + , option + , (<|>) + ) +import Control.Monad +import Control.Monad.Instances + + +noMore = string "--" + + +stringPrim = tokenPrim show nextPos + where + nextPos sp _ _ = incSourceLine sp 1 + +anyString = stringPrim Just + +string s = stringPrim $ (>> Just s) . guard . (== s) + +initialChar c = stringPrim test + where + test s@(c:_) = Just s + test _ = Nothing + +oneOf strings = choice $ map (try . string) strings + +option :: String -> [String] -> SParser String +option (s:hort) long = return [s] << option' (s:hort) long +option short (lon:g) = return lon << option' short (lon:g) +option [ ] [ ] = return [ ] + +option' short long = do + oneOf $ map (('-':) . (:[])) short ++ map ("--" ++) long + +(<<) = flip (>>) + +type SParser res = GenParser String () res + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,2 @@ + Native UUID generator bindings for at least Windows, OS X and Linux. + 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 = defaultMain + diff --git a/System/UUID/FromForeign.hs b/System/UUID/FromForeign.hs new file mode 100644 --- /dev/null +++ b/System/UUID/FromForeign.hs @@ -0,0 +1,32 @@ + +{-| Utilities for fetching the results from foreign functions. + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} + +{-# LANGUAGE ForeignFunctionInterface + #-} + +module System.UUID.FromForeign + ( runAndRead + ) where + + +import Data.UUID.Bytes + +import Foreign.C +import Foreign.ForeignPtr +import Foreign + + +{-| Allocate a pointer to capture the output of a foreign function, run the + - function and interpret the sixteen bytes following the pointer as a UUID. + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} +runAndRead :: (Ptr CChar -> IO ()) -> IO UUID +runAndRead procedure = do + fp <- mallocForeignPtrArray 16 + withForeignPtr fp procedure + bytes <- withForeignPtr fp $ peekArray 16 . castPtr + let + [x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, xA, xB, xC, xD, xE, xF] + = bytes + return $ UUID x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC xD xE xF + diff --git a/System/UUID/V1.hs b/System/UUID/V1.hs new file mode 100644 --- /dev/null +++ b/System/UUID/V1.hs @@ -0,0 +1,34 @@ + +{-| Obtain a Version 1 UUID from the system. + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} + +{-# LANGUAGE ForeignFunctionInterface + , CPP + #-} + +module System.UUID.V1 + ( uuid + ) where + + +import System.UUID.FromForeign + +import Foreign.C +import Foreign.Ptr + + +uuid = runAndRead native + + +#ifdef mingw32_HOST_OS + +foreign import stdcall unsafe "UuidCreateSequential" + native :: Ptr CChar -> IO () + +#else + +foreign import ccall unsafe "uuid_generate_time" + native :: Ptr CChar -> IO () + +#endif + diff --git a/System/UUID/V4.hs b/System/UUID/V4.hs new file mode 100644 --- /dev/null +++ b/System/UUID/V4.hs @@ -0,0 +1,34 @@ + +{-| Obtain a Version 1 UUID from the system. + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -} + +{-# LANGUAGE ForeignFunctionInterface + , CPP + #-} + +module System.UUID.V4 + ( uuid + ) where + + +import System.UUID.FromForeign + +import Foreign.C +import Foreign.Ptr + + +uuid = runAndRead native + + +#ifdef mingw32_HOST_OS + +foreign import stdcall unsafe "UuidCreate" + native :: Ptr CChar -> IO () + +#else + +foreign import ccall unsafe "uuid_generate_random" + native :: Ptr CChar -> IO () + +#endif + diff --git a/system-uuid.cabal b/system-uuid.cabal new file mode 100644 --- /dev/null +++ b/system-uuid.cabal @@ -0,0 +1,52 @@ +name : system-uuid +version : 0.0.0 +category : System +license : BSD3 +license-file : LICENSE +author : Jason Dusek +maintainer : jason.dusek@gmail.com +homepage : http://github.com/jsnx/system-uuid/ +synopsis : Bindings to system UUID functions. +description : + Bindings to the native UUID generator for a number of platforms. + + +cabal-version : >= 1.2 +build-type : Simple +extra-source-files : README + CONTRIBUTORS + Options.hs + Macros.hs + Messages.hs + + +library + build-depends : base + , containers + , regex-compat + , template-haskell + , parsec + exposed-modules : System.UUID.V1 + System.UUID.V4 + System.UUID.FromForeign + Data.UUID.Bytes + if os(linux) + extra-libraries : uuid + if os(mingw32) + extra-libraries : rpcrt4 + extensions : ForeignFunctionInterface + TemplateHaskell + PatternGuards + CPP + +executable hooty + main-is : Main.hs + if os(linux) + extra-libraries : uuid + if os(mingw32) + extra-libraries : rpcrt4 + extensions : ForeignFunctionInterface + TemplateHaskell + PatternGuards + CPP +