{-# LANGUAGE OverloadedStrings #-} 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 -- | Retrieves the bytesting representing all variable data for the current record getAllVariableData :: Get BS.ByteString getAllVariableData = do numBytes <- fromIntegral <$> getWord32le getByteString numBytes -- | Retrieves the variable data portion for a single field getVariableData :: Get (Maybe BS.ByteString) getVariableData = do -- numBytes <- fromIntegral <$> (`shiftR` 1) <$> getWord8 numBytesSize <- lookAhead $ odd <$> getWord8 numBytes <- (`shiftR` 1) <$> if numBytesSize then fromIntegral <$> getWord8 else getWord32le bs <- getByteString $ fromIntegral numBytes return $ Just bs -- | When parsing a field that has variable data, looks ahead to grab this variable data. 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 -- TODO: WRONG! 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 -- TODO: WRONG! FTTime -> fmap FVString <$> getFixedStringWithSize (Just 8) 1 decodeLatin1 -- TODO: WRONG! FTDateTime -> fmap FVString <$> getFixedStringWithSize (Just 19) 1 decodeLatin1 -- TODO: WRONG! 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