{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, OverloadedStrings, BangPatterns #-}
module System.Hardware.MercuryApi
(
create
, connect
, read
, executeTagOp
, reboot
, destroy
, withReader
, paramList
, paramGet
, paramSet
, paramSetBasics
, paramSetReadPlanFilter
, paramSetReadPlanTagop
, addTransportListener
, removeTransportListener
, gpiGet
, gpoSet
, firmwareLoad
, firmwareLoadFile
, hexListener
, opcodeListener
, packBytesIntoWords
, passwordToWords
, mkFilterGen2
, paramName
, paramID
, paramType
, paramUnits
, bytesToHex
, bytesToHexWithSpaces
, hexToBytes
, displayTimestamp
, displayLocalTimestamp
, displayData
, displayGpio
, displayTagData
, displayTagReadData
, displayParamType
, displayRegion
, displayRegionDescription
, parseRegion
, apiVersion
, sparkFunAntennas
, defaultReadPlan
, killPasswordAddress
, accessPasswordAddress
, Reader
, ParamValue
, TransportListenerId
, TransportListener
, PinNumber
, AntennaPort
, GEN2_Password
, MillisecondsSinceEpoch
, MercuryException (..)
, ReadPlan (..)
, TagOp (..)
, TagFilter (..)
, FilterOn (..)
, TagReadData (..)
, GpioPin (..)
, TagData (..)
, GEN2_TagData (..)
, ReadWrite (..)
, StatusType (..)
, Status (..)
, Param (..)
, ParamType (..)
, Region (..)
, TagProtocol (..)
, MetadataFlag (..)
, GEN2_Bank (..)
, GEN2_LockBits (..)
, GEN2_WriteMode (..)
, PowerMode (..)
, TransportDirection (..)
) where
import Prelude hiding (read)
import Control.Applicative ( (<$>) )
import Control.Exception ( Exception, IOException, throwIO, try, bracket )
import Control.Monad ( when )
import qualified Data.ByteString as B
import qualified Data.HashMap.Strict as H
import Data.IORef ( IORef, newIORef, atomicModifyIORef' )
import Data.List ( intercalate )
import Data.Monoid ( (<>) )
import qualified Data.Text as T
import qualified Data.Text.IO as T ( hPutStrLn )
import Data.Typeable ( Typeable )
import Data.Word ( Word8, Word16, Word32 )
import Foreign
( Int32,
Ptr,
FunPtr,
ForeignPtr,
nullPtr,
withForeignPtr,
Storable(peek, poke),
Bits((.&.), (.|.), bit, shiftL, shiftR, testBit),
castPtr,
mallocForeignPtrBytes,
addForeignPtrFinalizer,
with,
toBool,
withArrayLen,
peekArray,
allocaArray,
allocaBytes,
alloca )
import Foreign.C
( CStringLen,
CString,
CInt(..),
CTime(..),
CSize(..),
Errno(..),
withCAString,
newCAString,
throwErrnoIfNull,
errnoToIOError )
import Text.Printf ( printf )
import System.Clock
( TimeSpec(nsec, sec), Clock(Monotonic), getTime )
import System.Console.ANSI
( SGR(Reset, SetColor),
ConsoleLayer(Foreground),
ColorIntensity(Vivid),
Color(Cyan, Magenta),
hSupportsANSI,
hSetSGR )
import System.IO ( Handle, hFlush )
import qualified System.IO.Unsafe as U ( unsafePerformIO )
import Text.Read (readMaybe)
import System.Hardware.MercuryApi.Enums
import System.Hardware.MercuryApi.Records
import System.Hardware.MercuryApi.ParamValue
newtype Reader = Reader (ForeignPtr ReaderEtc)
type RawStatus = Word32
type RawType = Word32
type RawTransportListener =
CBool -> Word32 -> Ptr Word8 -> Word32 -> Ptr () -> IO ()
data TransportDirection = Rx
| Tx
deriving (Eq, Ord, Show, Read, Bounded, Enum)
type TransportListener = TransportDirection
-> B.ByteString
-> Word32
-> IO ()
newtype TransportListenerId = TransportListenerId Integer deriving (Eq)
newtype Locale = Locale ()
foreign import ccall safe "glue.h c_TMR_create"
c_TMR_create :: Ptr ReaderEtc
-> CString
-> IO RawStatus
foreign import ccall safe "glue.h c_TMR_connect"
c_TMR_connect :: Ptr ReaderEtc
-> IO RawStatus
foreign import ccall safe "glue.h c_TMR_destroy"
c_TMR_destroy :: Ptr ReaderEtc
-> IO RawStatus
foreign import ccall unsafe "glue.h &c_TMR_destroy"
p_TMR_destroy :: FunPtr (Ptr ReaderEtc -> IO ())
foreign import ccall safe "glue.h c_TMR_read"
c_TMR_read :: Ptr ReaderEtc
-> Word32
-> Ptr Word32
-> IO RawStatus
foreign import ccall safe "glue.h c_TMR_hasMoreTags"
c_TMR_hasMoreTags :: Ptr ReaderEtc
-> IO RawStatus
foreign import ccall safe "glue.h c_TMR_getNextTag"
c_TMR_getNextTag :: Ptr ReaderEtc
-> Ptr TagReadData
-> IO RawStatus
foreign import ccall unsafe "tmr_tag_data.h TMR_TRD_init"
c_TMR_TRD_init :: Ptr TagReadData
-> IO RawStatus
foreign import ccall safe "glue.h c_TMR_executeTagOp"
c_TMR_executeTagOp :: Ptr ReaderEtc
-> Ptr TagOp
-> Ptr TagFilter
-> Ptr List16
-> IO RawStatus
foreign import ccall safe "glue.h c_TMR_gpoSet"
c_TMR_gpoSet :: Ptr ReaderEtc
-> Word8
-> Ptr GpioPin
-> IO RawStatus
foreign import ccall safe "glue.h c_TMR_gpiGet"
c_TMR_gpiGet :: Ptr ReaderEtc
-> Ptr Word8
-> Ptr GpioPin
-> IO RawStatus
foreign import ccall safe "glue.h c_TMR_firmwareLoad"
c_TMR_firmwareLoad :: Ptr ReaderEtc
-> Ptr Word8
-> Word32
-> IO RawStatus
foreign import ccall safe "glue.h c_TMR_paramSet"
c_TMR_paramSet :: Ptr ReaderEtc
-> RawParam
-> Ptr ()
-> IO RawStatus
foreign import ccall safe "glue.h c_TMR_paramGet"
c_TMR_paramGet :: Ptr ReaderEtc
-> RawParam
-> Ptr ()
-> IO RawStatus
foreign import ccall safe "glue.h c_TMR_reboot"
c_TMR_reboot :: Ptr ReaderEtc
-> IO RawStatus
foreign import ccall unsafe "glue.h c_default_read_plan"
c_default_read_plan :: Ptr ReadPlan
-> IO ()
foreign import ccall safe "glue.h c_TMR_paramList"
c_TMR_paramList :: Ptr ReaderEtc
-> Ptr RawParam
-> Ptr Word32
-> IO RawStatus
foreign import ccall "wrapper"
wrapTransportListener :: RawTransportListener
-> IO (FunPtr RawTransportListener)
foreign import ccall unsafe "glue.h c_TMR_addTransportListener"
c_TMR_addTransportListener :: Ptr ReaderEtc
-> FunPtr RawTransportListener
-> CString
-> IO RawStatus
foreign import ccall unsafe "glue.h c_TMR_removeTransportListener"
c_TMR_removeTransportListener :: Ptr ReaderEtc
-> CString
-> IO RawStatus
foreign import ccall unsafe "glue.h c_TMR_strerr"
c_TMR_strerr :: Ptr ReaderEtc
-> RawStatus
-> IO CString
foreign import ccall unsafe "tm_reader.h TMR_paramName"
c_TMR_paramName :: RawParam
-> CString
foreign import ccall unsafe "tmr_tag_data.h TMR_hexToBytes"
c_TMR_hexToBytes :: CString
-> Ptr Word8
-> Word32
-> Ptr Word32
-> IO RawStatus
foreign import ccall unsafe "tmr_tag_data.h TMR_bytesToHex"
c_TMR_bytesToHex :: Ptr Word8
-> Word32
-> CString
-> IO ()
foreign import ccall unsafe "glue.h c_new_c_locale"
c_new_c_locale :: IO (Ptr Locale)
foreign import ccall unsafe "glue.h c_format_time"
c_format_time :: CString
-> CSize
-> CString
-> CTime
-> CBool
-> Ptr Locale
-> IO CInt
data MercuryException =
MercuryException
{ meStatusType :: StatusType
, meStatus :: Status
, meMessage :: T.Text
, meLocation :: T.Text
, meParam :: T.Text
, meUri :: T.Text
}
deriving (Eq, Ord, Show, Read, Typeable)
instance Exception MercuryException
statusGetType :: RawStatus -> RawType
statusGetType stat = stat `shiftR` 24
errnoBit :: Int
errnoBit = 15
statusIsErrno :: StatusType -> RawStatus -> Bool
statusIsErrno ERROR_TYPE_COMM rstat = rstat `testBit` errnoBit
statusIsErrno _ _ = False
statusGetErrno :: RawStatus -> Errno
statusGetErrno rstat = Errno $ fromIntegral $ rstat .&. (bit errnoBit - 1)
checkStatus' :: Ptr ReaderEtc
-> RawStatus
-> T.Text
-> T.Text
-> IO T.Text
-> IO ()
checkStatus' rdr rstat loc param getUri = do
let t = toStatusType $ statusGetType rstat
stat = toStatus rstat
case t of
SUCCESS_TYPE -> return ()
_ -> do
uri <- getUri
if statusIsErrno t rstat
then do
let errno = statusGetErrno rstat
ioe = errnoToIOError (T.unpack loc) errno Nothing
(Just $ T.unpack uri)
throwIO ioe
else do
cstr <- c_TMR_strerr rdr rstat
msg <- textFromCString cstr
let exc = MercuryException
{ meStatusType = t
, meStatus = stat
, meMessage = msg
, meLocation = loc
, meParam = param
, meUri = uri
}
throwIO exc
checkStatus :: Ptr ReaderEtc -> RawStatus -> T.Text -> T.Text -> IO ()
checkStatus rdr rstat loc param =
checkStatus' rdr rstat loc param (textFromCString $ uriPtr rdr)
uniqueCounter :: IORef Integer
{-# NOINLINE uniqueCounter #-}
uniqueCounter = U.unsafePerformIO $ newIORef 0
newUnique :: IO Integer
newUnique = atomicModifyIORef' uniqueCounter f
where f x = (x + 1, x)
castToCStringLen :: Integral a => a -> Ptr Word8 -> CStringLen
castToCStringLen len ptr = (castPtr ptr, fromIntegral len)
paramPairs :: [(Param, T.Text)]
paramPairs = map f [minBound..maxBound]
where
f p = (p, U.unsafePerformIO $ textFromCString $ c_TMR_paramName $ fromParam p)
paramMap :: H.HashMap Param T.Text
paramMap = H.fromList paramPairs
paramMapReverse :: H.HashMap T.Text Param
paramMapReverse = H.fromList $ map swap paramPairs
where swap (x, y) = (y, x)
paramName :: Param -> T.Text
paramName p = paramMap H.! p
paramID :: T.Text -> Param
paramID name = H.lookupDefault PARAM_NONE name paramMapReverse
create :: T.Text
-> IO Reader
create deviceUri = do
B.useAsCStringLen (textToBS deviceUri) $ \(cs, len) -> do
fp <- mallocForeignPtrBytes (sizeofReaderEtc + len)
withForeignPtr fp $ \p -> do
status <- c_TMR_create p cs
checkStatus' p status "create" "" (return deviceUri)
addForeignPtrFinalizer p_TMR_destroy fp
return $ Reader fp
withReaderEtc :: Reader
-> T.Text
-> T.Text
-> (Ptr ReaderEtc -> IO RawStatus)
-> IO ()
withReaderEtc (Reader fp) location param func = do
withForeignPtr fp $ \p -> do
status <- func p
checkStatus p status location param
connect :: Reader -> IO ()
connect rdr = withReaderEtc rdr "connect" "" c_TMR_connect
destroy :: Reader -> IO ()
destroy rdr = withReaderEtc rdr "destroy" "" c_TMR_destroy
withReader :: T.Text
-> (Reader -> IO a)
-> IO a
withReader uri = bracket (create uri) destroy
hasMoreTags :: Ptr CBool -> Ptr ReaderEtc -> IO RawStatus
hasMoreTags boolPtr rdrPtr = do
status <- c_TMR_hasMoreTags rdrPtr
let (moreTags, status') = case toStatus status of
ERROR_NO_TAGS -> (cFalse, 0)
_ -> (cTrue, status)
poke boolPtr moreTags
return status'
tShow :: Show a => a -> T.Text
tShow = T.pack . show
readLoop :: Reader
-> Word32
-> Ptr TagReadData
-> Ptr CBool
-> Int
-> [TagReadData]
-> IO [TagReadData]
readLoop rdr tagCount trdPtr boolPtr !tagNum !trds = do
let tagNum' = tagNum + 1
progress = "(" <> tShow tagNum' <> " of " <> tShow tagCount <> ")"
withReaderEtc rdr "read"
("hasMoreTags " <> progress)
(hasMoreTags boolPtr)
moreTags <- toBool' <$> peek boolPtr
if moreTags
then do
c_TMR_TRD_init trdPtr
withReaderEtc rdr "read" ("getNextTag " <> progress)
$ \p -> c_TMR_getNextTag p trdPtr
trd <- peek trdPtr
readLoop rdr tagCount trdPtr boolPtr tagNum' (trd : trds)
else do
return $ reverse trds
read :: Reader
-> Word32
-> IO [TagReadData]
read rdr timeoutMs = do
alloca $ \tagCountPtr -> do
withReaderEtc rdr "read" "" $ \p -> c_TMR_read p timeoutMs tagCountPtr
tagCount <- peek tagCountPtr
alloca $ \trdPtr -> alloca $
\boolPtr -> readLoop rdr tagCount trdPtr boolPtr 0 []
executeTagOp :: Reader -> TagOp -> Maybe TagFilter -> IO B.ByteString
executeTagOp rdr tagOp tagFilter = alloca $ \pOp -> alloca $ \pFilt -> do
eth1 <- try $ poke pOp tagOp
case eth1 of
Left err -> throwPE rdr err "executeTagOp" "tagop"
Right _ -> return ()
pFilt' <- case tagFilter of
Nothing -> return nullPtr
Just tf -> do
eth2 <- try $ poke pFilt tf
case eth2 of
Left err -> throwPE rdr err "executeTagOp" "filter"
Right _ -> return pFilt
results <- getList16 $ \pList -> do
withReaderEtc rdr "executeTagOp" (tagOpName tagOp) $ \pRdr -> do
c_TMR_executeTagOp pRdr pOp pFilt' (castPtr pList)
return $ B.pack results
gpoSet :: Reader -> [GpioPin] -> IO ()
gpoSet rdr gpios = do
withArrayLen gpios $ \len gpioPtr -> do
eth <- try $ castLen "[GpioPin]" len
case eth of
Left err -> throwPE rdr err "gpoSet" ""
Right len' -> do
withReaderEtc rdr "gpoSet" "" $ \pRdr -> do
c_TMR_gpoSet pRdr len' gpioPtr
gpiGet :: Reader -> IO [GpioPin]
gpiGet rdr = do
let maxLen = maxBound
with maxLen $ \lenPtr -> do
allocaArray (fromIntegral maxLen) $ \gpioPtr -> do
withReaderEtc rdr "gpiGet" "" $ \pRdr -> do
c_TMR_gpiGet pRdr lenPtr gpioPtr
len <- peek lenPtr
peekArray (fromIntegral len) gpioPtr
firmwareLoad :: Reader
-> B.ByteString
-> IO ()
firmwareLoad = firmwareLoad' ""
firmwareLoad' :: T.Text -> Reader -> B.ByteString -> IO ()
firmwareLoad' filename rdr firmware = do
B.useAsCStringLen firmware $ \(fwPtr, fwLen) -> do
withReaderEtc rdr "firmwareLoad" filename $
\p -> c_TMR_firmwareLoad p (castPtr fwPtr) (fromIntegral fwLen)
firmwareLoadFile :: Reader
-> FilePath
-> IO ()
firmwareLoadFile rdr filename = do
firmware <- B.readFile filename
firmwareLoad' (T.pack filename) rdr firmware
throwPE :: Reader -> ParamException -> T.Text -> T.Text -> IO a
throwPE (Reader fp) (ParamException statusType status msg) loc param = do
uri <- withForeignPtr fp (textFromCString . uriPtr)
throwIO $ MercuryException
{ meStatusType = statusType
, meStatus = status
, meMessage = msg
, meLocation = loc
, meParam = param
, meUri = uri
}
unimplementedParam :: ParamException
unimplementedParam =
ParamException ERROR_TYPE_BINDING ERROR_UNIMPLEMENTED_PARAM
"The given parameter is not yet implemented in the Haskell binding."
invalidParam :: ParamType -> ParamType -> ParamException
invalidParam expected actual =
ParamException ERROR_TYPE_BINDING ERROR_INVALID_PARAM_TYPE
( "Expected " <> displayParamType expected <>
" but got " <> displayParamType actual )
paramSet :: ParamValue a => Reader -> Param -> a -> IO ()
paramSet rdr param value = do
let pt = paramType param
pt' = pType value
rp = fromParam param
pName = T.pack $ show param
when (pt == ParamTypeUnimplemented) $
throwPE rdr unimplementedParam "paramSet" pName
when (pt /= pt') $
throwPE rdr (invalidParam pt pt') "paramSet" pName
eth <- try $ pSet value $ \pp -> withReaderEtc rdr "paramSet" pName $
\p -> c_TMR_paramSet p rp pp
case eth of
Left err -> throwPE rdr err "paramSet" pName
Right _ -> return ()
withReturnType :: (a -> IO a) -> IO a
withReturnType f = f undefined
paramGet :: ParamValue a => Reader -> Param -> IO a
paramGet rdr param = withReturnType $ \returnType -> do
let pt = paramType param
pt' = pType returnType
rp = fromParam param
pName = T.pack $ show param
when (pt == ParamTypeUnimplemented) $
throwPE rdr unimplementedParam "paramGet" pName
when (pt /= pt') $
throwPE rdr (invalidParam pt pt') "paramGet" pName
pGet $ \pp -> withReaderEtc rdr "paramGet" pName $
\p -> c_TMR_paramGet p rp pp
paramSetBasics :: Reader
-> Region
-> Int32
-> [AntennaPort]
-> IO ()
paramSetBasics rdr rgn pwr ant = do
paramSet rdr PARAM_REGION_ID rgn
paramSet rdr PARAM_RADIO_READPOWER pwr
paramSet rdr PARAM_RADIO_WRITEPOWER pwr
plan <- paramGet rdr PARAM_READ_PLAN
paramSet rdr PARAM_READ_PLAN plan { rpAntennas = ant }
when (not $ null ant) $ paramSet rdr PARAM_TAGOP_ANTENNA (head ant)
paramSetReadPlanFilter :: Reader -> Maybe TagFilter -> IO ()
paramSetReadPlanFilter rdr filt = do
plan <- paramGet rdr PARAM_READ_PLAN
paramSet rdr PARAM_READ_PLAN plan { rpFilter = filt }
paramSetReadPlanTagop :: Reader -> Maybe TagOp -> IO ()
paramSetReadPlanTagop rdr op = do
plan <- paramGet rdr PARAM_READ_PLAN
paramSet rdr PARAM_READ_PLAN plan { rpTagop = op }
defaultReadPlan :: ReadPlan
defaultReadPlan = U.unsafePerformIO $ do
alloca $ \p -> do
c_default_read_plan p
peek p
sparkFunAntennas :: [AntennaPort]
sparkFunAntennas = [1]
reboot :: Reader -> IO ()
reboot rdr = withReaderEtc rdr "reboot" "" c_TMR_reboot
paramList :: Reader -> IO [Param]
paramList rdr = do
let maxParams = paramMax + 1
alloca $ \nParams -> do
poke nParams (fromIntegral maxParams)
allocaArray (fromIntegral maxParams) $ \params -> do
withReaderEtc rdr "paramList" "" $ \p -> c_TMR_paramList p params nParams
actual <- peek nParams
result <- peekArray (min (fromIntegral actual) (fromIntegral maxParams)) params
return $ map toParam result
txToDirection :: Bool -> TransportDirection
txToDirection True = Tx
txToDirection False = Rx
callTransportListener :: TransportListener -> RawTransportListener
callTransportListener listener tx dataLen dataPtr timeout _ = do
bs <- B.packCStringLen (castToCStringLen dataLen dataPtr)
listener (txToDirection $ toBool tx) bs timeout
addTransportListener :: Reader
-> TransportListener
-> IO TransportListenerId
addTransportListener rdr listener = do
unique <- newUnique
funPtr <- wrapTransportListener (callTransportListener listener)
cs <- newCAString (show unique)
withReaderEtc rdr "addTransportListener" "" $
\p -> c_TMR_addTransportListener p funPtr cs
return (TransportListenerId unique)
removeTransportListener :: Reader
-> TransportListenerId
-> IO ()
removeTransportListener rdr (TransportListenerId unique) = do
withCAString (show unique) $ \cs -> do
withReaderEtc rdr "removeTransportListener" "" $
\p -> c_TMR_removeTransportListener p cs
hexListener :: Handle -> IO TransportListener
hexListener h = do
useColor <- hSupportsANSI h
return (listenerImpl h useColor False)
opcodeListener :: Handle -> IO TransportListener
opcodeListener h = do
useColor <- hSupportsANSI h
return (listenerImpl h useColor True)
listenerImpl :: Handle -> Bool -> Bool -> TransportListener
listenerImpl h useColor printOpcode dir dat _ = do
setColors useColor [SetColor Foreground Vivid (color dir)]
opc <- if printOpcode
then opcodeAndTime dat
else return []
mapM_ (T.hPutStrLn h) $ lstn opc (prefix dir)
setColors useColor [Reset]
flushColor useColor
where
setColors False _ = return ()
setColors True sgr = hSetSGR h sgr
flushColor False = return ()
flushColor True = hFlush h
prefix Tx = "Sending: "
prefix Rx = "Received:"
color Tx = Magenta
color Rx = Cyan
lstn opc pfx =
zipWith T.append (pfx : repeat " ") (opc ++ displayData dat)
extractOpcode :: B.ByteString -> T.Text
extractOpcode bs
| B.length bs < 3 = "too short"
| otherwise = opcodeName (bs `B.index` 2)
opcodeAndTime :: B.ByteString -> IO [T.Text]
opcodeAndTime bs = do
now <- getTime Monotonic
let opcode = extractOpcode bs
tm = printf "%d.%09d" (sec now) (nsec now)
return [pad 30 opcode <> T.pack tm]
hexToBytes :: T.Text -> Maybe B.ByteString
hexToBytes hex = U.unsafePerformIO $ do
let hexBs = textToBS hex
hexLen = B.length hexBs
bufLen = 1 + (hexLen `div` 2)
alloca $ \pLen -> allocaBytes bufLen $ \buf -> B.useAsCString hexBs $ \cs -> do
status <- c_TMR_hexToBytes cs buf (fromIntegral bufLen) pLen
outLen <- peek pLen
if (status == 0)
then Just <$> B.packCStringLen (castPtr buf, fromIntegral outLen)
else return Nothing
bytesToHex :: B.ByteString -> T.Text
bytesToHex bytes = U.unsafePerformIO $ do
let bytesLen = B.length bytes
bufLen = 1 + bytesLen * 2
allocaBytes bufLen $ \buf -> B.useAsCString bytes $ \cs -> do
c_TMR_bytesToHex (castPtr cs) (fromIntegral bytesLen) buf
textFromBS <$> B.packCString buf
bytesToHexWithSpaces :: B.ByteString -> T.Text
bytesToHexWithSpaces = T.pack . intercalate " " . map (printf "%02x") . B.unpack
pad :: Int -> T.Text -> T.Text
pad x t = t <> T.replicate (x - T.length t) " "
displayData :: B.ByteString -> [T.Text]
displayData bytes
| B.null bytes = []
| otherwise =
let (bs1, bs2) = B.splitAt 16 bytes
(bs1a, bs1b) = B.splitAt 8 bs1
dotify x = if x < 0x20 || x >= 0x7f then 0x2e else x
hex = map (pad 25 . bytesToHexWithSpaces) [bs1a, bs1b]
ascii = B.map dotify bs1
txt = T.concat $ hex ++ ["|", textFromBS ascii, "|"]
in txt : displayData bs2
displayByteString :: B.ByteString -> T.Text
displayByteString bs =
"<" <> bytesToHex bs <> "> (" <> T.pack (show $ B.length bs) <> " bytes)"
displayTagData :: TagData -> [T.Text]
displayTagData td =
concat
[ [ "TagData"
, " epc = " <> displayByteString (tdEpc td)
, " protocol = " <> tShow (tdProtocol td)
, " crc = " <> T.pack (printf "0x%04x" $ tdCrc td)
]
, case tdGen2 td of
Nothing -> []
Just gen2 -> [" gen2.pc = " <> displayByteString (g2Pc gen2)]
]
indent :: [T.Text] -> [T.Text]
indent = map (" " <>)
cLocale :: Ptr Locale
{-# NOINLINE cLocale #-}
cLocale = U.unsafePerformIO $ throwErrnoIfNull "newlocale" c_new_c_locale
formatTimestamp :: MillisecondsSinceEpoch -> CBool -> String -> IO T.Text
formatTimestamp t local z = do
let (seconds, millis) = t `divMod` 1000
fmt = "%Y-%m-%dT%H:%M:%S" ++ printf ".%03d" millis ++ z
bufSize = 80
withCAString fmt $ \cFmt -> allocaBytes bufSize $ \buf -> do
ret <- c_format_time buf (fromIntegral bufSize) cFmt
(CTime $ fromIntegral seconds) local cLocale
if ret < 0
then return $ T.pack $ printf "%d.%03d" seconds millis
else textFromCString buf
displayTimestamp :: MillisecondsSinceEpoch
-> T.Text
displayTimestamp t = U.unsafePerformIO $ formatTimestamp t cFalse "Z"
displayLocalTimestamp :: MillisecondsSinceEpoch
-> IO T.Text
displayLocalTimestamp t = formatTimestamp t cTrue "%z"
displayGpio :: [GpioPin] -> [T.Text]
displayGpio gpios = "Gpio" : map dispGpio gpios
where
dispGpio gpio = " pin " <> tShow (gpId gpio) <>
(if (gpHigh gpio) then " high" else " low ") <>
(if (gpOutput gpio) then " output" else " input")
displayTagReadData :: TagReadData -> [T.Text]
displayTagReadData trd =
concat
[ [ "TagReadData" ]
, indent (displayTagData $ trTag trd)
, [ " metadataFlags = " <> T.intercalate "|" (map fl $ trMetadataFlags trd)
, " phase = " <> tShow (trPhase trd)
, " antenna = " <> tShow (trAntenna trd)
]
, indent (displayGpio $ trGpio trd)
, [ " readCount = " <> tShow (trReadCount trd)
, " rssi = " <> tShow (trRssi trd)
, " frequency = " <> tShow (trFrequency trd)
, " timestamp = " <> displayTimestamp (trTimestamp trd)
]
, dat "data" (trData trd)
, dat "epcMemData" (trEpcMemData trd)
, dat "tidMemData" (trTidMemData trd)
, dat "userMemData" (trUserMemData trd)
, dat "reservedMemData" (trReservedMemData trd)
]
where
nDrop = T.length "METADATA_FLAG_"
fl = T.drop nDrop . tShow
dat name bs =
if B.null bs
then []
else indent ((name <> ": " <> T.pack (show $ B.length bs) <> " bytes")
: indent (displayData bs))
regionPrefix :: T.Text
regionPrefix = "REGION_"
displayRegion :: Region -> T.Text
displayRegion = T.toLower . T.pack . drop (T.length regionPrefix) . show
parseRegion :: T.Text -> Maybe Region
parseRegion = readMaybe . T.unpack . T.toUpper . T.append regionPrefix
packBytesIntoWords :: B.ByteString -> [Word16]
packBytesIntoWords bs = pbw (B.unpack bs)
where pbw [] = []
pbw [x] = [pk x 0]
pbw (x1:x2:xs) = pk x1 x2 : pbw xs
pk x1 x2 = (fromIntegral x1 `shiftL` 8) .|. fromIntegral x2
passwordToWords :: GEN2_Password -> [Word16]
passwordToWords pwd = map fromIntegral [pwd `shiftR` 16, pwd .&. 0xffff]
mkFilterGen2 :: GEN2_Bank
-> Word32
-> B.ByteString
-> TagFilter
mkFilterGen2 bank bitPointer mask =
TagFilterGen2
{ tfInvert = False
, tfFilterOn = FilterOnBank bank
, tfBitPointer = bitPointer
, tfMaskBitLength = fromIntegral $ 8 * B.length mask
, tfMask = mask
}
killPasswordAddress :: Word32
killPasswordAddress = 0
accessPasswordAddress :: Word32
accessPasswordAddress = 2