system-uuid (empty) → 0.0.0
raw patch · 13 files changed
+492/−0 lines, 13 filesdep +basedep +containersdep +parsecsetup-changed
Dependencies added: base, containers, parsec, regex-compat, template-haskell
Files
- CONTRIBUTORS +2/−0
- Data/UUID/Bytes.hs +55/−0
- LICENSE +31/−0
- Macros.hs +54/−0
- Main.hs +118/−0
- Messages.hs +23/−0
- Options.hs +51/−0
- README +2/−0
- Setup.hs +4/−0
- System/UUID/FromForeign.hs +32/−0
- System/UUID/V1.hs +34/−0
- System/UUID/V4.hs +34/−0
- system-uuid.cabal +52/−0
+ CONTRIBUTORS view
@@ -0,0 +1,2 @@+ Jason Dusek+
+ Data/UUID/Bytes.hs view
@@ -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 ]+
+ LICENSE view
@@ -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. +
+ Macros.hs view
@@ -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++++
+ Main.hs view
@@ -0,0 +1,118 @@+{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -++ SYNOPSIS+ hooty (-1|-4)? (-n <number to make>)?++ 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 <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+
+ Messages.hs view
@@ -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 <<+
+ Options.hs view
@@ -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 +
+ README view
@@ -0,0 +1,2 @@+ Native UUID generator bindings for at least Windows, OS X and Linux.+
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main = defaultMain+
+ System/UUID/FromForeign.hs view
@@ -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+
+ System/UUID/V1.hs view
@@ -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+
+ System/UUID/V4.hs view
@@ -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+
+ system-uuid.cabal view
@@ -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+