module Robotics.NXT.Protocol (
withNXT,
defaultDevice,
setOutputState,
setOutputStateConfirm,
getOutputState,
resetMotorPosition,
setInputMode,
setInputModeConfirm,
getInputValues,
resetInputScaledValue,
getVersion,
getDeviceInfo,
getBatteryLevel,
isBatteryRechargeable,
keepAlive,
keepAliveConfirm,
getSleepTimeout,
getLastKeepAliveTime,
stopEverything,
shutdown,
startProgram,
startProgramConfirm,
stopProgram,
stopProgramConfirm,
stopProgramExisting,
ensureStartProgram,
getCurrentProgramName,
messageWrite,
messageWriteConfirm,
messageRead,
maybeMessageRead,
ensureMessageRead,
playSoundFile,
playSoundFileConfirm,
playTone,
stopSoundPlayback,
stopSoundPlaybackConfirm,
lowspeedGetStatus,
lowspeedWrite,
lowspeedWriteConfirm,
lowspeedRead,
openWrite,
openWriteLinear,
write,
writeConfirm,
close,
closeConfirm,
delete,
deleteConfirm,
deleteExisting,
getModuleID,
listModules,
requestFirstModule,
requestNextModule,
closeModuleHandle,
closeModuleHandleConfirm,
readIOMap,
writeIOMap,
writeIOMapConfirm,
initialize,
terminate,
runNXT,
execNXT
) where
import qualified Data.ByteString as B
import Control.Exception
import Control.Monad.State
import Data.Bits
import Data.Char
import Data.List hiding (delete)
import Data.Maybe
import Data.Ratio
import Data.Time.Clock.POSIX
import Data.Word
import System.IO
import qualified System.Hardware.Serialport as S
#if (!defined(mingw32_HOST_OS) && !defined(windows_HOST_OS))
import System.Posix.Signals
#endif
import Text.Printf
import Robotics.NXT.Data
import Robotics.NXT.Errors
import Robotics.NXT.Types
import Robotics.NXT.Internals
defaultDevice :: FilePath
defaultDevice = "/dev/rfcomm0"
debug :: Bool
debug = False
initialize :: FilePath -> IO NXTInternals
initialize device = do
#if (!defined(mingw32_HOST_OS) && !defined(windows_HOST_OS))
let signals = foldl (flip addSignal) emptySignalSet [virtualTimerExpired]
blockSignals signals
#endif
h <- S.openSerial device S.defaultSerialSettings { S.commSpeed = S.CS115200, S.timeout = 1000 }
#if (!defined(mingw32_HOST_OS) && !defined(windows_HOST_OS))
unblockSignals signals
#endif
when debug $ hPutStrLn stderr "initialized"
return $ NXTInternals h Nothing [] Nothing Nothing
terminate :: NXTInternals -> IO ()
terminate i = do
i' <- execNXT stopEverything i
let h = nxthandle i'
S.closeSerial h
when debug $ hPutStrLn stderr "terminated"
withNXT :: FilePath -> NXT a -> IO a
withNXT device action = mask $ \restore -> do
i <- initialize device
(r, i') <- restore (runNXT action i) `onException` terminate i
terminate i'
return r
sendData :: [Word8] -> NXT ()
sendData message = do
h <- getsNXT nxthandle
let len = toUWord . length $ message
packet = len ++ message
n <- liftIO . S.send h . B.pack $ packet
when (n /= length packet) $ liftIO $ failNXT' "not all data has been send"
when debug $ liftIO . hPutStrLn stderr $ "sent: " ++ show packet
receiveData :: NXT [Word8]
receiveData = do
h <- getsNXT nxthandle
len <- liftIO $ S.recv h 2
let len' = fromUWord . B.unpack $ len
packet <- liftIO $ S.recv h len'
let unpacket = B.unpack packet
when debug $ liftIO . hPutStrLn stderr $ "received: " ++ show unpacket
return unpacket
getVersion :: NXT Version
getVersion = do
when debug $ liftIO . hPutStrLn stderr $ "getversion"
let send = [0x01, 0x88]
sendData send
receive <- receiveData
case receive of
[0x02, 0x88, 0x00, pMinor, pMajor, fMinor, fMajor] ->
return $ Version (FirmwareVersion fMajor' fMinor') (ProtocolVersion pMajor' pMinor')
where fMajor' = fromIntegral fMajor
fMinor' = fromIntegral fMinor
pMajor' = fromIntegral pMajor
pMinor' = fromIntegral pMinor
_:_:e:_ -> liftIO $ failNXT "getVersion" e
_ -> liftIO $ failNXT' "getVersion"
getDeviceInfo :: NXT DeviceInfo
getDeviceInfo = do
when debug $ liftIO . hPutStrLn stderr $ "getdeviceinfo"
let send = [0x01, 0x9B]
sendData send
receive <- receiveData
case receive of
0x02:0x9B:0x00:info | length info == 30 -> do
modifyNXT (\s -> s { address = Just btaddress })
return $ DeviceInfo name' btaddress btstrength flashfree
where (name, info') = splitAt 15 info
name' = dataToString0 name
btaddress = map toUpper . intercalate ":" . map (printf "%02x") . take 6 $ info'
btstrength = fromULong . take 4 . drop 7 $ info'
flashfree = fromULong . take 4 . drop 11 $ info'
_:_:e:_ -> liftIO $ failNXT "getDeviceInfo" e
_ -> liftIO $ failNXT' "getDeviceInfo"
startProgram :: FileName -> NXT ()
startProgram = startProgram' False
startProgramConfirm :: FileName -> NXT ()
startProgramConfirm = startProgram' True
startProgram' :: Bool -> FileName -> NXT ()
startProgram' confirm filename = do
when debug $ liftIO . hPutStrLn stderr $ "startprogram"
let send = [request confirm, 0x00] ++ nameToData filename
sendData send
when confirm $ do
receive <- receiveData
case receive of
[0x02, 0x00, 0x00] -> return ()
[_, _, e] -> liftIO $ failNXT "startProgram" e
_ -> liftIO $ failNXT' "startProgram"
stopProgram :: NXT ()
stopProgram = stopProgram' False False
stopProgramConfirm :: NXT ()
stopProgramConfirm = stopProgram' True False
stopProgramExisting :: NXT ()
stopProgramExisting = stopProgram' True True
stopProgram' :: Bool -> Bool -> NXT ()
stopProgram' confirm running = do
when debug $ liftIO . hPutStrLn stderr $ "stopprogram"
let send = [request confirm, 0x01]
sendData send
when confirm $ do
receive <- receiveData
case receive of
[0x02, 0x01, 0x00] -> return ()
[0x02, 0x01, 0xEC] -> when running $ liftIO $ failNXT "stopProgram" 0xEC
[_, _, e] -> liftIO $ failNXT "stopProgram" e
_ -> liftIO $ failNXT' "stopProgram"
ensureStartProgram :: FileName -> NXT ()
ensureStartProgram filename = do
stopAndWait
startAndWait
where stopAndWait = do
stopProgramConfirm
name <- getCurrentProgramName
unless (isNothing name) stopAndWait
startAndWait = do
startProgramConfirm filename
name <- getCurrentProgramName
unless (isJust name) startAndWait
playSoundFile :: LoopPlayback -> FileName -> NXT ()
playSoundFile = playSoundFile' False
playSoundFileConfirm :: LoopPlayback -> FileName -> NXT ()
playSoundFileConfirm = playSoundFile' True
playSoundFile' :: Bool -> LoopPlayback -> FileName -> NXT ()
playSoundFile' confirm loop filename = do
when debug $ liftIO . hPutStrLn stderr $ "playsoundfile"
let send = [request confirm, 0x02, fromIntegral . fromEnum $ loop] ++ nameToData filename
sendData send
when confirm $ do
receive <- receiveData
case receive of
[0x02, 0x02, 0x00] -> return ()
[_, _, e] -> liftIO $ failNXT "playSoundFile" e
_ -> liftIO $ failNXT' "playSoundFile"
playTone :: Frequency -> Duration -> NXT ()
playTone frequency duration = do
when debug $ liftIO . hPutStrLn stderr $ "playtone"
let send = [0x80, 0x03] ++ toUWord frequency ++ toUWord (toMilliseconds duration)
sendData send
where toMilliseconds :: Duration -> Integer
toMilliseconds d = floor (d * 1000)
setOutputState :: OutputPort -> OutputPower -> [OutputMode] -> RegulationMode -> TurnRatio -> RunState -> TachoLimit -> NXT ()
setOutputState = setOutputState' False
setOutputStateConfirm :: OutputPort -> OutputPower -> [OutputMode] -> RegulationMode -> TurnRatio -> RunState -> TachoLimit -> NXT ()
setOutputStateConfirm = setOutputState' True
setOutputState' :: Bool -> OutputPort -> OutputPower -> [OutputMode] -> RegulationMode -> TurnRatio -> RunState -> TachoLimit -> NXT ()
setOutputState' confirm output power mode regulation turn runstate tacholimit
| power >= 100 && power <= 100 && turn >= 100 && turn <= 100 = do
when debug $ liftIO . hPutStrLn stderr $ "setoutputstate"
let send = [request confirm, 0x04, fromIntegral . fromEnum $ output] ++ toSByte power ++ [modebyte, regulation'] ++ toSByte turn ++ [runstate'] ++ toULong tacholimit
sendData send
when confirm $ do
receive <- receiveData
case receive of
[0x02, 0x04, 0x00] -> return ()
[_, _, e] -> liftIO $ failNXT "setOutputState" e
_ -> liftIO $ failNXT' "setOutputState"
| otherwise = liftIO . throwIO $ PatternMatchFail "setOutputState"
where modebyte = foldl (.|.) 0x00 . map convmode $ mode
where convmode m = case m of
MotorOn -> 0x01
Brake -> 0x02
Regulated -> 0x04
regulation' = case regulation of
RegulationModeIdle -> 0x00
RegulationModeMotorSpeed -> 0x01
RegulationModeMotorSync -> 0x02
runstate' = case runstate of
MotorRunStateIdle -> 0x00
MotorRunStateRampUp -> 0x10
MotorRunStateRunning -> 0x20
MotorRunStateRampDown -> 0x40
MotorRunStateHold -> 0x60
getOutputState :: OutputPort -> NXT OutputState
getOutputState output = do
when debug $ liftIO . hPutStrLn stderr $ "getoutputstate"
let send = [0x00, 0x06, fromIntegral . fromEnum $ output]
sendData send
receive <- receiveData
case receive of
0x02:0x06:0x00:port:power:modebyte:regulation:turn:runstate:values
| length values == 16 && fromEnum output == fromIntegral port ->
return $ OutputState output (fromSByte [power]) mode regulation' (fromSByte [turn]) runstate' tacholimit tachocount blocktachocount rotationcount
where mode = motoron ++ brake ++ regulated
motoron = [MotorOn | testBit modebyte 0]
brake = [Brake | testBit modebyte 1]
regulated = [Regulated | testBit modebyte 2]
regulation' = case regulation of
0x00 -> RegulationModeIdle
0x01 -> RegulationModeMotorSpeed
0x02 -> RegulationModeMotorSync
_ -> throw $ PatternMatchFail "getOutputState"
runstate' = case runstate of
0x00 -> MotorRunStateIdle
0x10 -> MotorRunStateRampUp
0x20 -> MotorRunStateRunning
0x40 -> MotorRunStateRampDown
0x60 -> MotorRunStateHold
_ -> throw $ PatternMatchFail "getOutputState"
tacholimit = fromULong . take 4 $ values
tachocount = fromSLong . take 4 . drop 4 $ values
blocktachocount = fromSLong . take 4 . drop 8 $ values
rotationcount = fromSLong . take 4 . drop 12 $ values
_:_:e:_ -> liftIO $ failNXT "getOutputState" e
_ -> liftIO $ failNXT' "getOutputState"
setInputMode :: InputPort -> SensorType -> SensorMode -> NXT ()
setInputMode = setInputMode' False
setInputModeConfirm :: InputPort -> SensorType -> SensorMode -> NXT ()
setInputModeConfirm = setInputMode' True
setInputMode' :: Bool -> InputPort -> SensorType -> SensorMode -> NXT ()
setInputMode' confirm input sensortype sensormode = do
when debug $ liftIO . hPutStrLn stderr $ "setinputmode"
let send = [request confirm, 0x05, fromIntegral . fromEnum $ input, sensortype', sensormode']
sendData send
when confirm $ do
receive <- receiveData
case receive of
[0x02, 0x05, 0x00] -> return ()
[_, _, e] -> liftIO $ failNXT "setInputMode" e
_ -> liftIO $ failNXT' "setInputMode"
where sensortype' = case sensortype of
NoSensor -> 0x00
Switch -> 0x01
Temperature -> 0x02
Reflection -> 0x03
Angle -> 0x04
LightActive -> 0x05
LightInactive -> 0x06
SoundDB -> 0x07
SoundDBA -> 0x08
Custom -> 0x09
Lowspeed -> 0x0A
Lowspeed9V -> 0x0B
NoOfSensorTypes -> 0x0C
sensormode' = case sensormode of
RawMode -> 0x00
BooleanMode -> 0x20
TransitionCntMode -> 0x40
PeriodCounterMode -> 0x60
PctFullScaleMode -> 0x80
CelsiusMode -> 0xA0
FahrenheitMode -> 0xC0
AngleStepsMode -> 0xE0
getInputValues :: InputPort -> NXT InputValue
getInputValues input = do
when debug $ liftIO . hPutStrLn stderr $ "getinputvalues"
let send = [0x00, 0x07, fromIntegral . fromEnum $ input]
sendData send
receive <- receiveData
case receive of
0x02:0x07:0x00:port:valid:calibrated:sensortype:sensormode:values
| length values == 8 && fromEnum input == fromIntegral port ->
return $ InputValue input valid' calibrated' sensortype' sensormode' raw normalized scaled calibratedv
where valid' = valid /= 0x00
calibrated' = calibrated /= 0x00
sensortype' = case sensortype of
0x00 -> NoSensor
0x01 -> Switch
0x02 -> Temperature
0x03 -> Reflection
0x04 -> Angle
0x05 -> LightActive
0x06 -> LightInactive
0x07 -> SoundDB
0x08 -> SoundDBA
0x09 -> Custom
0x0A -> Lowspeed
0x0B -> Lowspeed9V
0x0C -> NoOfSensorTypes
_ -> throw $ PatternMatchFail "getInputValues"
sensormode' = case sensormode of
0x00 -> RawMode
0x20 -> BooleanMode
0x40 -> TransitionCntMode
0x60 -> PeriodCounterMode
0x80 -> PctFullScaleMode
0xA0 -> CelsiusMode
0xC0 -> FahrenheitMode
0xE0 -> AngleStepsMode
_ -> throw $ PatternMatchFail "getInputValues"
raw = fromUWord . take 2 $ values
normalized = fromUWord . take 2 . drop 2 $ values
scaled = fromSWord . take 2 . drop 4 $ values
calibratedv = fromSWord . take 2 . drop 6 $ values
_:_:e:_ -> liftIO $ failNXT "getInputValues" e
_ -> liftIO $ failNXT' "getInputValues"
resetInputScaledValue :: InputPort -> NXT ()
resetInputScaledValue input = do
when debug $ liftIO . hPutStrLn stderr $ "resetinputscaledvalue"
let send = [0x80, 0x08, fromIntegral . fromEnum $ input]
sendData send
messageWrite :: Inbox -> String -> NXT ()
messageWrite = messageWrite' False
messageWriteConfirm :: Inbox -> String -> NXT ()
messageWriteConfirm = messageWrite' True
messageWrite' :: Bool -> Inbox -> String -> NXT ()
messageWrite' confirm inbox message
| length message <= 58 = do
when debug $ liftIO . hPutStrLn stderr $ "messagewrite"
let message' = messageToData message
send = [request confirm, 0x09, fromIntegral . fromEnum $ inbox] ++ (toUByte . length $ message') ++ message'
sendData send
when confirm $ do
receive <- receiveData
case receive of
[0x02, 0x09, 0x00] -> return ()
[_, _, e] -> liftIO $ failNXT "messageWrite" e
_ -> liftIO $ failNXT' "messageWrite"
| otherwise = liftIO . throwIO $ PatternMatchFail "messageWrite"
resetMotorPosition :: OutputPort -> MotorReset -> NXT ()
resetMotorPosition output reset = do
when debug $ liftIO . hPutStrLn stderr $ "resetmotorposition"
case reset of
InternalPosition -> do
mid <- getModuleID "Output.mod"
writeIOMap (fromJust mid) (fromEnum output * 32 + 18) [0x08]
_ -> do
let send = [0x80, 0x0A, fromIntegral . fromEnum $ output, fromIntegral . fromEnum $ reset]
sendData send
getBatteryLevel :: NXT Voltage
getBatteryLevel = do
when debug $ liftIO . hPutStrLn stderr $ "getbatterylevel"
let send = [0x00, 0x0B]
sendData send
receive <- receiveData
case receive of
[0x02, 0x0B, 0x00, v1, v2] -> return $ fromUWord [v1, v2] % 1000
_:_:e:_ -> liftIO $ failNXT "getBatteryLevel" e
_ -> liftIO $ failNXT' "getBatteryLevel"
isBatteryRechargeable :: NXT Bool
isBatteryRechargeable = do
when debug $ liftIO . hPutStrLn stderr $ "isbatteryrechargeable"
mid <- getModuleID "Ui.mod"
r <- readIOMap (fromJust mid) 35 1
return $ (/=) 0 (head r)
stopSoundPlayback :: NXT ()
stopSoundPlayback = stopSoundPlayback' False
stopSoundPlaybackConfirm :: NXT ()
stopSoundPlaybackConfirm = stopSoundPlayback' True
stopSoundPlayback' :: Bool -> NXT ()
stopSoundPlayback' confirm = do
when debug $ liftIO . hPutStrLn stderr $ "stopsoundplayback"
let send = [request confirm, 0x0C]
sendData send
when confirm $ do
receive <- receiveData
case receive of
[0x02, 0x0C, 0x00] -> return ()
[_, _, e] -> liftIO $ failNXT "stopSoundPlayback" e
_ -> liftIO $ failNXT' "stopSoundPlayback"
keepAlive :: NXT ()
keepAlive = keepAlive' False >> return ()
keepAliveConfirm :: NXT ()
keepAliveConfirm = keepAlive' True >> return ()
keepAlive' :: Bool -> NXT Duration
keepAlive' confirm = do
when debug $ liftIO . hPutStrLn stderr $ "keepalive"
current <- liftIO getPOSIXTime
modifyNXT (\s -> s { lastkeepalive = Just current })
let send = [request confirm, 0x0D]
sendData send
if confirm
then do
receive <- receiveData
case receive of
0x02:0x0D:0x00:limit -> do
let l = fromRational $ fromULong limit % 1000
modifyNXT (\s -> s { sleeptime = Just l })
return l
_:_:e:_ -> liftIO $ failNXT "keepAlive" e
_ -> liftIO $ failNXT' "keepAlive"
else return 0
getSleepTimeout :: NXT Duration
getSleepTimeout = do
sleep <- getsNXT sleeptime
case sleep of
Just s -> return s
Nothing -> keepAlive' True
getLastKeepAliveTime :: NXT (Maybe POSIXTime)
getLastKeepAliveTime = getsNXT lastkeepalive
lowspeedGetStatus :: InputPort -> NXT Int
lowspeedGetStatus input = do
when debug $ liftIO . hPutStrLn stderr $ "lowspeedgetstatus"
let send = [0x00, 0x0E, fromIntegral . fromEnum $ input]
sendData send
receive <- receiveData
case receive of
[0x02, 0x0E, 0x00, bytes] -> return $ fromUByte [bytes]
0x02:0x10:0x20:_ -> lowspeedGetStatus input
_:_:e:_ -> liftIO $ failNXT "lowSpeedGetStatus" e
_ -> liftIO $ failNXT' "lowSpeedGetStatus"
lowspeedWrite :: InputPort -> RxDataLength -> TxData -> NXT ()
lowspeedWrite = lowspeedWrite' False
lowspeedWriteConfirm :: InputPort -> RxDataLength -> TxData -> NXT ()
lowspeedWriteConfirm = lowspeedWrite' True
lowspeedWrite' :: Bool -> InputPort -> RxDataLength -> TxData -> NXT ()
lowspeedWrite' confirm input rx txdata
| length txdata <= 16 && rx <= 16 = do
when debug $ liftIO . hPutStrLn stderr $ "lowspeedwrite"
let send = [request confirm, 0x0F, fromIntegral . fromEnum $ input] ++ (toUByte . length $ txdata) ++ toUByte rx ++ txdata
sendData send
when confirm $ do
receive <- receiveData
case receive of
[0x02, 0x0F, 0x00] -> return ()
[_, _, e] -> liftIO $ failNXT "lowspeedWrite" e
_ -> liftIO $ failNXT' "lowspeedWrite"
| otherwise = liftIO . throwIO $ PatternMatchFail "lowspeedWrite"
lowspeedRead :: InputPort -> NXT RxData
lowspeedRead input = do
when debug $ liftIO . hPutStrLn stderr $ "lowspeedread"
let send = [0x00, 0x10, fromIntegral . fromEnum $ input]
sendData send
receive <- receiveData
case receive of
0x02:0x10:0x00:rx:rxdata
| length rxdata == 16 && rx <= 16 -> return $ take (fromUByte [rx]) rxdata
0x02:0x10:0x20:_ -> lowspeedRead input
_:_:e:_ -> liftIO $ failNXT "lowSpeedRead" e
_ -> liftIO $ failNXT' "lowSpeedRead"
getCurrentProgramName :: NXT (Maybe String)
getCurrentProgramName = do
when debug $ liftIO . hPutStrLn stderr $ "getcurrentprogramname"
let send = [0x00, 0x11]
sendData send
receive <- receiveData
case receive of
0x02:0x11:0x00:filename | length filename == 20 -> return $ Just $ dataToString0 filename
0x02:0x11:0xEC:_ -> return Nothing
_:_:e:_ -> liftIO $ failNXT "getCurrentProgramName" e
_ -> liftIO $ failNXT' "getCurrentProgramName"
messageRead :: RemoteInbox -> RemoveMessage -> NXT String
messageRead inbox remove = do
m <- maybeMessageRead inbox remove
case m of
Just m' -> return m'
Nothing -> liftIO $ failNXT "messageRead" 0x40
ensureMessageRead :: RemoteInbox -> RemoveMessage -> NXT String
ensureMessageRead inbox remove = do
m <- maybeMessageRead inbox remove
case m of
Just m' -> return m'
Nothing -> ensureMessageRead inbox remove
maybeMessageRead :: RemoteInbox -> RemoveMessage -> NXT (Maybe String)
maybeMessageRead inbox remove = do
when debug $ liftIO . hPutStrLn stderr $ "messageRead"
let inbox' = fromIntegral . fromEnum $ inbox
send = [0x00, 0x13, inbox', fromIntegral . fromEnum $ Inbox0, fromIntegral . fromEnum $ remove]
sendData send
receive <- receiveData
case receive of
0x02:0x13:0x00:inbox'':size:message
| inbox'' == inbox' && length message == 59 && size <= 59 -> return $ Just $ dataToString0 message
0x02:0x13:0x40:_ -> return Nothing
_:_:e:_ -> liftIO $ failNXT "messageRead" e
_ -> liftIO $ failNXT' "messageRead"
stopEverything :: NXT ()
stopEverything = do
when debug $ liftIO . hPutStrLn stderr $ "stopeverything"
mapM_ stopMotor [A ..]
mapM_ stopSensor [One ..]
where stopMotor x = setOutputState x 0 [] RegulationModeIdle 0 MotorRunStateIdle 0
stopSensor x = setInputMode x NoSensor RawMode
shutdown :: NXT ()
shutdown = do
when debug $ liftIO . hPutStrLn stderr $ "shutdown"
mid <- getModuleID "IOCtrl.mod"
writeIOMap (fromJust mid) 0 [0x00, 0x5A]
openWrite :: FileName -> FileSize -> NXT FileHandle
openWrite filename filesize = do
when debug $ liftIO . hPutStrLn stderr $ "openwrite"
let send = [0x01, 0x81] ++ nameToData filename ++ toULong filesize
sendData send
receive <- receiveData
case receive of
[0x02, 0x81, 0x00, h] -> return $ fromUByte [h]
_:_:e:_ -> liftIO $ failNXT "openWrite" e
_ -> liftIO $ failNXT' "openWrite"
openWriteLinear :: FileName -> FileSize -> NXT FileHandle
openWriteLinear filename filesize = do
when debug $ liftIO . hPutStrLn stderr $ "openwritelinear"
let send = [0x01, 0x89] ++ nameToData filename ++ toULong filesize
sendData send
receive <- receiveData
case receive of
[0x02, 0x89, 0x00, h] -> return $ fromUByte [h]
_:_:e:_ -> liftIO $ failNXT "openWriteLinear" e
_ -> liftIO $ failNXT' "openWriteLinear"
write :: FileHandle -> FileData -> NXT ()
write = write' False
writeConfirm :: FileHandle -> FileData -> NXT ()
writeConfirm = write' True
write' :: Bool -> FileHandle -> FileData -> NXT ()
write' confirm filehandle filedata
| length filedata <= 61 = do
when debug $ liftIO . hPutStrLn stderr $ "write"
let send = [request' confirm, 0x83] ++ toUByte filehandle ++ filedata
sendData send
when confirm $ do
receive <- receiveData
case receive of
[0x02, 0x83, 0x00, h, bw1, bw2]
| fromUByte [h] == filehandle && length filedata == fromUWord [bw1, bw2] -> return ()
_:_:e:_ -> liftIO $ failNXT "write" e
_ -> liftIO $ failNXT' "write"
| otherwise = liftIO . throwIO $ PatternMatchFail "write"
close :: FileHandle -> NXT ()
close = close' False
closeConfirm :: FileHandle -> NXT ()
closeConfirm = close' True
close' :: Bool -> FileHandle -> NXT ()
close' confirm filehandle = do
when debug $ liftIO . hPutStrLn stderr $ "close"
let send = [request' confirm, 0x84] ++ toUByte filehandle
sendData send
when confirm $ do
receive <- receiveData
case receive of
[0x02, 0x84, 0x00, h]
| fromUByte [h] == filehandle -> return ()
_:_:e:_ -> liftIO $ failNXT "close" e
_ -> liftIO $ failNXT' "close"
delete :: FileName -> NXT ()
delete = delete' False False
deleteConfirm :: FileName -> NXT ()
deleteConfirm = delete' True False
deleteExisting :: FileName -> NXT ()
deleteExisting = delete' True True
delete' :: Bool -> Bool -> FileName -> NXT ()
delete' confirm existence filename = do
when debug $ liftIO . hPutStrLn stderr $ "delete"
let send = [request' confirm, 0x85] ++ nameToData filename
sendData send
when confirm $ do
receive <- receiveData
case receive of
0x02:0x85:0x00:f
| dataToString0 f == filename -> return ()
0x02:0x85:0x87:_ -> when existence $ liftIO $ failNXT "delete" 0x87
_:_:e:_ -> liftIO $ failNXT "delete" e
_ -> liftIO $ failNXT' "delete"
requestFirstModule :: ModuleName -> NXT (ModuleHandle, Maybe ModuleInfo)
requestFirstModule modulename = do
when debug $ liftIO . hPutStrLn stderr $ "requestfirstmodule"
let send = [0x01, 0x90] ++ nameToData modulename
sendData send
receive <- receiveData
case receive of
0x02:0x90:0x00:h:values
| length values == 30 -> return (fromUByte [h], Just $ ModuleInfo name moduleid size iomapsize)
where name = dataToString0 . take 20 $ values
moduleid = fromULong . take 4 . drop 20 $ values
size = fromULong . take 4 . drop 24 $ values
iomapsize = fromUWord . take 2 . drop 28 $ values
0x02:0x90:0x90:h:_ -> return (fromUByte [h], Nothing)
_:_:e:_ -> liftIO $ failNXT "requestFirstModule" e
_ -> liftIO $ failNXT' "requestFirstModule"
requestNextModule :: ModuleHandle -> NXT (ModuleHandle, Maybe ModuleInfo)
requestNextModule modulehandle = do
when debug $ liftIO . hPutStrLn stderr $ "requestnextmodule"
let send = [0x01, 0x91] ++ toUByte modulehandle
sendData send
receive <- receiveData
case receive of
0x02:0x91:0x00:h:values
| length values == 30 -> return (fromUByte [h], Just $ ModuleInfo name moduleid size iomapsize)
where name = dataToString0 . take 20 $ values
moduleid = fromULong . take 4 . drop 20 $ values
size = fromULong . take 4 . drop 24 $ values
iomapsize = fromUWord . take 2 . drop 28 $ values
0x02:0x91:0x90:h:_ -> return (fromUByte [h], Nothing)
_:_:e:_ -> liftIO $ failNXT "requestNextModule" e
_ -> liftIO $ failNXT' "requestNextModule"
closeModuleHandle :: ModuleHandle -> NXT ()
closeModuleHandle = closeModuleHandle' False
closeModuleHandleConfirm :: ModuleHandle -> NXT ()
closeModuleHandleConfirm = closeModuleHandle' True
closeModuleHandle' :: Bool -> ModuleHandle -> NXT ()
closeModuleHandle' confirm modulehandle = do
when debug $ liftIO . hPutStrLn stderr $ "closemodulehandle"
let send = [request' confirm, 0x92] ++ toUByte modulehandle
sendData send
when confirm $ do
receive <- receiveData
case receive of
[0x02, 0x92, 0x00, h]
| fromUByte [h] == modulehandle -> return ()
_:_:e:_ -> liftIO $ failNXT "closeModuleHandle" e
_ -> liftIO $ failNXT' "closeModuleHandle"
listModules :: ModuleName -> NXT [ModuleInfo]
listModules modulename = do
(h, first) <- requestFirstModule modulename
case first of
Nothing -> do
closeModuleHandle h
return []
Just first' -> do
(h', other) <- next h
closeModuleHandle h'
return (first':other)
where next h = do
(h', mi) <- requestNextModule h
case mi of
Just mi' -> do
(h'', mi'') <- next h'
return (h'', mi':mi'')
Nothing -> return (h', [])
readIOMap :: ModuleID -> IOMapOffset -> IOMapLength -> NXT IOMapData
readIOMap moduleid offset len
| offset >= 0 && len <= 119 = do
when debug $ liftIO . hPutStrLn stderr $ "readiomap"
let send = [0x01, 0x94] ++ toULong moduleid ++ toUWord offset ++ toUWord len
sendData send
receive <- receiveData
case receive of
0x02:0x94:0x00:mid1:mid2:mid3:mid4:r1:r2:values
| fromULong [mid1, mid2, mid3, mid4] == moduleid && fromUWord [r1, r2] == len -> return values
_:_:e:_ -> liftIO $ failNXT "readIOMap" e
_ -> liftIO $ failNXT' "readIOMap"
| otherwise = liftIO . throwIO $ PatternMatchFail "readIOMap"
writeIOMap :: ModuleID -> IOMapOffset -> IOMapData -> NXT ()
writeIOMap = writeIOMap' False
writeIOMapConfirm :: ModuleID -> IOMapOffset -> IOMapData -> NXT ()
writeIOMapConfirm = writeIOMap' True
writeIOMap' :: Bool -> ModuleID -> IOMapOffset -> IOMapData -> NXT ()
writeIOMap' confirm moduleid offset mapdata
| offset >= 0 && length mapdata <= 54 = do
when debug $ liftIO . hPutStrLn stderr $ "writeiomap"
let send = [request' confirm, 0x95] ++ toULong moduleid ++ toUWord offset ++ toUWord (length mapdata) ++ mapdata
sendData send
when confirm $ do
receive <- receiveData
case receive of
[0x02, 0x95, 0x00, mid1, mid2, mid3, mid4, w1, w2]
| fromULong [mid1, mid2, mid3, mid4] == moduleid && fromUWord [w1, w2] == length mapdata -> return ()
_:_:e:_ -> liftIO $ failNXT "writeIOMap" e
_ -> liftIO $ failNXT' "writeIOMap"
| otherwise = liftIO . throwIO $ PatternMatchFail "writeIOMap"
getModuleID :: ModuleName -> NXT (Maybe ModuleID)
getModuleID modulename | '*' `elem` modulename = return Nothing
| otherwise = do
mods <- getsNXT modules
let modulename' = map toLower modulename
case modulename' `lookup` mods of
Just (ModuleInfo _ mid _ _) -> return $ Just mid
Nothing -> do
(h, mi) <- requestFirstModule modulename'
closeModuleHandle h
case mi of
Just mi'@(ModuleInfo _ mid _ _) -> do
modifyNXT (\s -> s { modules = (modulename', mi'):mods })
return $ Just mid
Nothing -> return Nothing
request :: Bool -> Word8
request confirm | confirm = 0x00
| otherwise = 0x80
request' :: Bool -> Word8
request' confirm | confirm = 0x01
| otherwise = 0x81