Skip to content

Instantly share code, notes, and snippets.

@joshmyzie2

joshmyzie2/gist:ae2969fdbc78020fb8bb

Created July 5, 2015 00:19
Show Gist options
  • Save joshmyzie2/ae2969fdbc78020fb8bb to your computer and use it in GitHub Desktop.
Save joshmyzie2/ae2969fdbc78020fb8bb to your computer and use it in GitHub Desktop.
Download ZIP
Raw
gistfile1.diff
From 01128793be847a7fae59578aed9cc415cd87e1cc Mon Sep 17 00:00:00 2001
From: me <me@example.com>
Date: Sat, 4 Jul 2015 23:51:41 +0000
Subject: [PATCH] Add the guid kdb type using the uuid haskell package.
---
kdb-haskell.cabal | 1 +
src/Database/Kdb/Internal/IPC.hs | 14 ++++++++++
src/Database/Kdb/Internal/Types/KdbTypes.hs | 43 +++++++++++++++++++++++++++++
3 files changed, 58 insertions(+)
diff --git a/kdb-haskell.cabal b/kdb-haskell.cabal
index eef0118..d7089b4 100644
--- a/kdb-haskell.cabal
+++ b/kdb-haskell.cabal
@@ -42,6 +42,7 @@ library
, network, io-streams, exceptions, attoparsec
, cpu
, time
+ , uuid
, bytestring
, data-default-class, lens
-- see if possible to get rid of: necessary for the
diff --git a/src/Database/Kdb/Internal/IPC.hs b/src/Database/Kdb/Internal/IPC.hs
index 7b6afb5..2eaac94 100644
--- a/src/Database/Kdb/Internal/IPC.hs
+++ b/src/Database/Kdb/Internal/IPC.hs
@@ -58,6 +58,8 @@ import qualified Data.ByteString as B
import Data.Int (Int16, Int32, Int64)
import Data.Maybe
import Data.Monoid
+import Data.UUID (UUID)
+import qualified Data.UUID as U
import qualified Data.Vector as V
import Data.Vector.Storable ()
import qualified Data.Vector.Storable as SV
@@ -118,6 +120,7 @@ qIPCBytes mode size qobj =
-- TODO: Get rid of all these unsafeCoerce calls, it's unsanitary
qBytes :: Value -> Builder
qBytes v@(A (KBool !x)) = putType v <> BB.word8 x
+qBytes v@(A (KGuid !x)) = putType v <> BB.lazyByteString (U.toByteString x)
qBytes v@(A (KByte !x)) = putType v <> BB.word8 x
qBytes v@(A (KShort !x)) = putType v <> BB.word16Host (unsafeCoerce x)
qBytes v@(A (KInt !x)) = putType v <> BB.word32Host (unsafeCoerce x)
@@ -135,6 +138,7 @@ qBytes v@(A (KMinute !x)) = putType v <> BB.word32Host (unsafeCoerce x)
qBytes v@(A (KSecond !x)) = putType v <> BB.word32Host (unsafeCoerce x)
qBytes v@(A (KTime !x)) = putType v <> BB.word32Host (unsafeCoerce x)
qBytes v@(V (KBoolV !x)) = putListHeader v <> fromWord8V (unsafeCoerce x)
+qBytes v@(V (KGuidV !x)) = putListHeader v <> fromGuidV (unsafeCoerce x)
qBytes v@(V (KByteV !x)) = putListHeader v <> fromWord8V (unsafeCoerce x)
qBytes v@(V (KShortV !x)) = putListHeader v <> fromWord16V (unsafeCoerce x)
qBytes v@(V (KIntV !x)) = putListHeader v <> fromWord32V (unsafeCoerce x)
@@ -183,6 +187,10 @@ fromWord64V :: SV.Vector Word64 -> Builder
fromWord64V = genFnFromWordNVB BB.word64Host
{-# INLINE fromWord64V #-}
+fromGuidV :: SV.Vector UUID -> Builder
+fromGuidV = genFnFromWordNVB (BB.lazyByteString . U.toByteString)
+{-# INLINE fromGuidV #-}
+
-- | Function to write Q type in ByteString.
putType :: Value -> Builder
putType = BB.word8 . KT.qType
@@ -234,6 +242,10 @@ endianessParser = A.anyWord8 >>=
x -> fail $! "Unknown endianess: " ++ show x
{-# INLINE endianessParser #-}
+-- | Parser for a guid.
+guidParser :: A.Parser UUID
+guidParser = U.fromWords <$> anyWord32be <*> anyWord32be <*> anyWord32be <*> anyWord32be
+
-- | Parser for a symbol.
--
-- Consumes all bytes until and including the first '\0' byte and returns
@@ -263,6 +275,7 @@ vectorParser :: End.Endianness -- ^ Endianness to parse.
-> Int -- ^ Number of elements in the vector.
-> A.Parser KT.Vector -- ^ Parsed vector.
vectorParser _ !t !len | t == KT.boolVT = KBoolV <$> SV.replicateM len A.anyWord8
+vectorParser _ !t !len | t == KT.guidVT = KGuidV <$> SV.replicateM len guidParser
vectorParser _ !t !len | t == KT.byteVT = KByteV <$> SV.replicateM len A.anyWord8
vectorParser !e !t !len | t == KT.shortVT = KShortV <$> SV.replicateM len (int16 e)
vectorParser !e !t !len | t == KT.intVT = KIntV <$> SV.replicateM len (int32 e)
@@ -322,6 +335,7 @@ fullValueParser !e = A.anyWord8 >>= valueParser e
-- | Parser for values.
valueParser :: End.Endianness -> Word8 -> A.Parser KT.Value
valueParser _ !t | t == KT.boolT = A . KBool <$> A.anyWord8
+valueParser _ !t | t == KT.guidT = A . KGuid <$> guidParser
valueParser _ !t | t == KT.byteT = A . KByte <$> A.anyWord8
valueParser !e !t | t == KT.shortT = A . KShort <$> int16 e
valueParser !e !t | t == KT.intT = A . KInt <$> int32 e
diff --git a/src/Database/Kdb/Internal/Types/KdbTypes.hs b/src/Database/Kdb/Internal/Types/KdbTypes.hs
index 4e2d11d..2c4341e 100644
--- a/src/Database/Kdb/Internal/Types/KdbTypes.hs
+++ b/src/Database/Kdb/Internal/Types/KdbTypes.hs
@@ -22,6 +22,7 @@ module Database.Kdb.Internal.Types.KdbTypes (
-- * K Types
-- *ktypes
, boolT
+ , guidT
, byteT
, shortT
, intT
@@ -39,6 +40,7 @@ module Database.Kdb.Internal.Types.KdbTypes (
, secondT
, timeT
, boolVT
+ , guidVT
, byteVT
, shortVT
, intVT
@@ -66,6 +68,7 @@ module Database.Kdb.Internal.Types.KdbTypes (
-- * Constructors
-- $constructors
, bool
+ , guid
, byte
, short
, int
@@ -83,6 +86,7 @@ module Database.Kdb.Internal.Types.KdbTypes (
, second
, time
, boolV
+ , guidV
, byteV
, shortV
, intV
@@ -109,6 +113,7 @@ module Database.Kdb.Internal.Types.KdbTypes (
-- * Null values
-- $nulls
, nullBool
+ , nullGuid
, nullByte
, nullShort
, nullInt
@@ -130,6 +135,8 @@ import Data.Int (Int16, Int32, Int64)
import Data.List (foldl')
import qualified Data.Time as Time
import Data.Typeable (Typeable)
+import Data.UUID (UUID)
+import qualified Data.UUID as U
import qualified Data.Vector as V
import qualified Data.Vector.Storable as SV
import Data.Word
@@ -154,6 +161,8 @@ import System.IO.Unsafe (unsafePerformIO)
data Atom
-- | Boolean atom
= KBool {-# UNPACK #-} !Word8
+ -- | Guid atom
+ | KGuid {-# UNPACK #-} !UUID
-- | Byte atom
| KByte {-# UNPACK #-} !Word8
-- | Short atom
@@ -190,6 +199,7 @@ data Atom
instance NFData Atom where
rnf (KBool x) = rnf x
+ rnf (KGuid x) = rnf x
rnf (KByte x) = rnf x
rnf (KShort x) = rnf x
rnf (KInt x) = rnf x
@@ -211,6 +221,8 @@ instance NFData Atom where
data Vector
-- | Boolean vector
= KBoolV {-# UNPACK #-} !(SV.Vector Word8)
+ -- | Guid vector
+ | KGuidV {-# UNPACK #-} !(SV.Vector UUID)
-- | Byte vector
| KByteV {-# UNPACK #-} !(SV.Vector Word8)
-- | Short vector
@@ -247,6 +259,7 @@ data Vector
instance NFData Vector where
rnf (KBoolV x) = rnf x
+ rnf (KGuidV x) = rnf x
rnf (KByteV x) = rnf x
rnf (KShortV x) = rnf x
rnf (KIntV x) = rnf x
@@ -294,6 +307,11 @@ boolT :: Word8
boolT = -1
{-# INLINE boolT #-}
+-- | Kdb @Word8@ type for Guid atom.
+guidT :: Word8
+guidT = -2
+{-# INLINE guidT #-}
+
-- | Kdb @Word8@ value for Byte atom.
byteT :: Word8
byteT = -4
@@ -379,6 +397,11 @@ boolVT :: Word8
boolVT = negate boolT
{-# INLINE boolVT #-}
+-- | Kdb @Word8@ value for Guid vector.
+guidVT :: Word8
+guidVT = negate guidT
+{-# INLINE guidVT #-}
+
-- | Kdb @Word8@ value for Byte vector.
byteVT :: Word8
byteVT = negate byteT
@@ -477,6 +500,7 @@ dictT = 99
-- | Gets q type of the object.
qType :: Value -> Word8
qType (A (KBool _)) = fromIntegral boolT
+qType (A (KGuid _)) = fromIntegral guidT
qType (A (KByte _)) = fromIntegral byteT
qType (A (KShort _)) = fromIntegral shortT
qType (A (KInt _)) = fromIntegral intT
@@ -494,6 +518,7 @@ qType (A (KMinute _)) = fromIntegral minuteT
qType (A (KSecond _)) = fromIntegral secondT
qType (A (KTime _)) = fromIntegral timeT
qType (V (KBoolV _)) = fromIntegral boolVT
+qType (V (KGuidV _)) = fromIntegral guidVT
qType (V (KByteV _)) = fromIntegral byteVT
qType (V (KShortV _)) = fromIntegral shortVT
qType (V (KIntV _)) = fromIntegral intVT
@@ -534,6 +559,7 @@ vectorSize a v = 6 + sizeOf a * SV.length v
-- Used to calculate total bytes needed to build the ByteString for IPC to Q server
size :: Value -> Int
size (A (KBool x)) = atomSize x
+size (A (KGuid x)) = atomSize x
size (A (KByte x)) = atomSize x
size (A (KShort x)) = atomSize x
size (A (KInt x)) = atomSize x
@@ -551,6 +577,7 @@ size (A (KMinute x)) = atomSize x
size (A (KSecond x)) = atomSize x
size (A (KTime x)) = atomSize x
size (V (KBoolV x)) = vectorSize (undefined :: Word8) x
+size (V (KGuidV x)) = vectorSize (undefined :: UUID) x
size (V (KByteV x)) = vectorSize (undefined :: Word8) x
size (V (KShortV x)) = vectorSize (undefined :: Int16) x
size (V (KIntV x)) = vectorSize (undefined :: Int32) x
@@ -574,6 +601,7 @@ size (KDict l r) = 1 + (size . V $ l) + (size . V $ r)
numElements :: Value -> Int
numElements (V (KBoolV x)) = SV.length x
+numElements (V (KGuidV x)) = SV.length x
numElements (V (KByteV x)) = SV.length x
numElements (V (KShortV x)) = SV.length x
numElements (V (KIntV x)) = SV.length x
@@ -610,6 +638,11 @@ bool :: Bool -> Value
bool = A . KBool . toBool
{-# INLINEABLE bool #-}
+-- | Creates a Guid atom.
+guid :: UUID -> Value
+guid = A . KGuid
+{-# INLINEABLE guid #-}
+
-- | Creates a Byte atom.
byte :: Word8 -> Value
byte = A . KByte
@@ -704,6 +737,11 @@ boolV :: [Bool] -> Value
boolV = V . KBoolV . SV.fromList . map toBool
{-# INLINEABLE boolV #-}
+-- | Creates a Guid vector.
+guidV :: [UUID] -> Value
+guidV = V . KGuidV . SV.fromList
+{-# INLINEABLE guidV #-}
+
-- | Creates a Byte vector.
byteV :: [Word8] -> Value
byteV = V . KByteV . SV.fromList
@@ -838,6 +876,11 @@ nullBool :: Value
nullBool = A . KBool . toBool $ False
{-# INLINEABLE nullBool #-}
+-- | Null value for Guid atom.
+nullGuid :: Value
+nullGuid = A (KGuid U.nil)
+{-# INLINEABLE nullGuid #-}
+
-- | Null value for Byte atom.
nullByte :: Value
nullByte = A (KByte 0)
--
1.9.0
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment