module Database.Alteryx.Fields
(
getValue,
getAllVariableData,
parseFieldType,
putValue,
renderFieldType
) where
import Control.Applicative
import Control.Lens
import Control.Monad
import Data.Bimap as Bimap (Bimap, fromList, lookup, lookupR)
import Data.Binary
import Data.Binary.C()
import Data.Binary.Get
import Data.Binary.Put
import Data.Bits
import Data.Decimal (Decimal)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import Data.Int
import Data.Text as T
import Data.Text.Encoding
import Data.Time
import Foreign.C.Types
import Database.Alteryx.Types
fieldTypeMap :: Bimap FieldType Text
fieldTypeMap =
Bimap.fromList
[
(FTBool, "Bool"),
(FTByte, "Byte"),
(FTInt16, "Int16"),
(FTInt32, "Int32"),
(FTInt64, "Int64"),
(FTFixedDecimal, "FixedDecimal"),
(FTFloat, "Float"),
(FTDouble, "Double"),
(FTString, "String"),
(FTWString, "WString"),
(FTVString, "V_String"),
(FTVWString, "V_WString"),
(FTDate, "Date"),
(FTTime, "Time"),
(FTDateTime, "DateTime"),
(FTBlob, "Blob"),
(FTSpatialObject, "SpatialObj"),
(FTUnknown, "Unknown")
]
putValue :: Field -> Maybe FieldValue -> Put
putValue field value =
let putFixedString :: Maybe Int -> Int -> T.Text -> (T.Text -> BS.ByteString) -> Put
putFixedString size bytesPerCharacter text encoder = do
let stringBS = encoder text
let numPaddingBytes = case size of
Nothing -> error "putValue: No size given for string value"
Just x -> bytesPerCharacter * x BS.length stringBS
putByteString stringBS
replicateM_ numPaddingBytes $ putWord8 0
putWord8 0
size = field ^. fieldSize
fType = field ^. fieldType
encodeLatin1 :: T.Text -> BS.ByteString
encodeLatin1 = BSC.pack . T.unpack
in do
case value of
Just (FVBool x) -> error "putBool unimplemented"
Just (FVByte x) -> do
putWord8 $ fromIntegral x
putWord8 0
Just (FVInt16 x) -> do
putWord16le $ fromIntegral x
putWord8 0
Just (FVInt32 x) -> do
putWord32le $ fromIntegral x
putWord8 0
Just (FVInt64 x) -> do
putWord64le $ fromIntegral x
putWord8 0
Just (FVFixedDecimal x) -> error "putFixedDecimal unimplemented"
Just (FVFloat x) -> do
let y = realToFrac x :: CFloat
put y
putWord8 0
Just (FVDouble x) -> do
let y = realToFrac x :: CDouble
put y
putWord8 0
Just (FVString x) | fType == FTDate -> putFixedString (Just 10) 1 x encodeUtf8
Just (FVString x) | fType == FTTime -> putFixedString (Just 8) 1 x encodeUtf8
Just (FVString x) | fType == FTDateTime -> putFixedString (Just 19) 1 x encodeUtf8
Just (FVString x) -> putFixedString size 1 x encodeLatin1
Just (FVWString x) -> putFixedString size 2 x encodeUtf16LE
Just (FVVString x) -> error "putVString unimplemented"
Just (FVVWString x) -> error "putVWString unimplemented"
Just (FVDate x) -> error "putDate unimplemented"
Just (FVTime x) -> error "putTime unimplemented"
Just (FVDateTime x) -> error "putDateTime unimplemented"
Just (FVBlob x) -> error "putBlob unimplemented"
Just (FVSpatialObject x) -> error "putSpatialObject unimplemented"
Just (FVUnknown) -> error "putUnknown unimplemented"
Nothing ->
case field ^. fieldType of
FTByte -> putWord8 0 >> putWord8 1
FTInt16 -> putWord16le 0 >> putWord8 1
FTInt32 -> putWord32le 0 >> putWord8 1
FTInt64 -> putWord64le 0 >> putWord8 1
FTFloat -> put (0 :: CFloat) >> putWord8 1
FTDouble -> put (0 :: CDouble) >> putWord8 1
x -> error $ "putValue unimplemented for null values of type " ++ show x
getAllVariableData :: Get BS.ByteString
getAllVariableData = do
numBytes <- fromIntegral <$> getWord32le
getByteString numBytes
getVariableData :: Get (Maybe BS.ByteString)
getVariableData = do
numBytesSize <- lookAhead $ odd <$> getWord8
numBytes <- (`shiftR` 1) <$>
if numBytesSize
then fromIntegral <$> getWord8
else getWord32le
bs <- getByteString $ fromIntegral numBytes
return $ Just bs
linkedVariableData :: Get (Maybe BS.ByteString)
linkedVariableData = do
offsetToVarData <- getWord32le
let isUsingSmallStringOptimization = (offsetToVarData .&. 0x80000000) == 0 &&
(offsetToVarData .&. 0x30000000) /= 0
case offsetToVarData of
0 -> return $ Just BS.empty
1 -> return $ Nothing
_ | isUsingSmallStringOptimization -> do
let byte1 = fromIntegral $ (offsetToVarData .&. 0x000000FF) :: Word8
let byte2 = fromIntegral $ (offsetToVarData .&. 0x0000FF00) `shiftR` 8 :: Word8
let byte3 = fromIntegral $ (offsetToVarData .&. 0x00FF0000) `shiftR` 16 :: Word8
return $ Just $ BS.pack [ byte1, byte2, byte3 ]
_ -> lookAhead $ do
x <- getByteString $ fromIntegral $ offsetToVarData 4
bs <- getVariableData
return bs
getValue :: Field -> Get (Maybe FieldValue)
getValue field =
let getFixedStringWithSize :: Maybe Int -> Int -> (BS.ByteString -> Text) -> Get (Maybe Text)
getFixedStringWithSize size charBytes decoder =
let mNumBytes = (charBytes*) <$> size
in case mNumBytes of
Just numBytes -> do
bs <- getByteString numBytes
isNull <- getWord8
return $ if isNull > 0
then Nothing
else Just $ T.takeWhile (/= '\0') $ decoder bs
Nothing -> error "getValue: String field had no size"
getFixedString :: Int -> (BS.ByteString -> Text) -> Get (Maybe Text)
getFixedString = getFixedStringWithSize $ field ^. fieldSize
getVarString :: (BS.ByteString -> Text) -> Get (Maybe Text)
getVarString f = fmap f <$> linkedVariableData
getWithNullByte :: Get a -> Get (Maybe a)
getWithNullByte getter = do
x <- getter
isNull <- getWord8
return $ if isNull > 0
then Nothing
else Just x
in case field ^. fieldType of
FTBool -> error "getBool unimplemented"
FTByte -> fmap (FVByte . fromIntegral) <$> getWithNullByte getWord8
FTInt16 -> fmap (FVInt16 . fromIntegral) <$> getWithNullByte getWord16le
FTInt32 -> fmap (FVInt32 . fromIntegral) <$> getWithNullByte getWord32le
FTInt64 -> fmap (FVInt64 . fromIntegral) <$> getWithNullByte getWord64le
FTFixedDecimal -> fmap FVString <$> getFixedString 1 decodeLatin1
FTFloat -> fmap (FVFloat . realToFrac) <$> getWithNullByte (get :: Get CFloat)
FTDouble -> fmap (FVDouble . realToFrac) <$> getWithNullByte (get :: Get CDouble)
FTString -> fmap FVString <$> getFixedString 1 decodeLatin1
FTWString -> fmap FVWString <$> getFixedString 2 decodeUtf16LE
FTVString -> fmap FVVString <$> getVarString decodeLatin1
FTVWString -> fmap FVVWString <$> getVarString decodeUtf16LE
FTDate -> fmap FVString <$> getFixedStringWithSize (Just 10) 1 decodeLatin1
FTTime -> fmap FVString <$> getFixedStringWithSize (Just 8) 1 decodeLatin1
FTDateTime -> fmap FVString <$> getFixedStringWithSize (Just 19) 1 decodeLatin1
FTBlob -> error "getBlob unimplemented"
FTSpatialObject -> error "getSpatialObject unimplemented"
FTUnknown -> error "getUnknown unimplemented"
parseFieldType :: Text -> FieldType
parseFieldType text =
case Bimap.lookupR text fieldTypeMap of
Nothing -> FTUnknown
Just x -> x
renderFieldType :: FieldType -> Text
renderFieldType fieldType =
case Bimap.lookup fieldType fieldTypeMap of
Nothing -> error $ "No field type assigned to " ++ show fieldType
Just x -> x