From 21aa1d1f11c369323d8c3bf71648bd0a8321ca61 Mon Sep 17 00:00:00 2001 From: Aleksey Veresov Date: Mon, 12 Apr 2021 01:01:22 +0300 Subject: Device protocol is almost done! --- src/Device.hs | 140 +++++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 124 insertions(+), 16 deletions(-) (limited to 'src/Device.hs') diff --git a/src/Device.hs b/src/Device.hs index 2e099dc..71e6943 100644 --- a/src/Device.hs +++ b/src/Device.hs @@ -1,8 +1,43 @@ +{-# LANGUAGE BinaryLiterals #-} module Device where import Prelude hiding (Word) import Data.Word (Word32, Word16, Word8) +import Data.IORef +import Data.Char +import Data.List +import Control.Monad.Reader (ask) +import Control.Monad.IO.Class (liftIO) +import System.IO +import Data.String +import Data.ByteString import Machine +import Network.Socket + + +getSock :: Long -> Emulator (Maybe Handle) +getSock a | a < 0x900000 = do { m <- ask; liftIO $ sock (c0 m) (s0 m) } + | a < 0xa00000 = do { m <- ask; liftIO $ sock (c1 m) (s1 m) } + | a < 0xb00000 = do { m <- ask; liftIO $ sock (c2 m) (s2 m) } + | a < 0xc00000 = do { m <- ask; liftIO $ sock (c3 m) (s3 m) } + | a < 0xd00000 = do { m <- ask; liftIO $ sock (c4 m) (s4 m) } + | a < 0xe00000 = do { m <- ask; liftIO $ sock (c5 m) (s5 m) } + | a < 0xf00000 = do { m <- ask; liftIO $ sock (c6 m) (s6 m) } + | otherwise = do { m <- ask; liftIO $ sock (c7 m) (s7 m) } + where + sock c (Just s) = do + cval <- readIORef c + case cval of + (Just val) -> return $ Just val + Nothing -> do + (newsock, _) <- accept s + handle <- socketToHandle newsock ReadWriteMode + writeIORef c $ Just handle + return $ Just handle + sock _ _ = return Nothing + + +toStr = Prelude.map (chr . fromEnum) . unpack ------------------------------------------------------------------------------- @@ -10,29 +45,66 @@ import Machine -- Protocol itself is simple, -- suem send commands to devices, they response. -- Example communication: --- s: h afebabe +-- s: h ababe -- d: o 07 --- s: W afebabe 1999 +-- s: W ababe 1999 -- d: o -- d: i --- s: l afebab3 +-- s: l abab3 -- d: x -- All numbers are in hex and have correct length -- (zeroes on the left are mandatory). -- requests -device_get_high_byte = 'h' -- <7 hexes>; 2 hexes in response -device_get_low_byte = 'l' -- <7 hexes>; 2 hexes in response -device_get_word = 'w' -- <7 hexes>; 4 hexes in response +device_get_high_byte = "h" -- <5 hexes>; 2 hexes in response +device_get_low_byte = "l" -- <5 hexes>; 2 hexes in response +device_get_word = "w" -- <5 hexes>; 4 hexes in response -device_set_high_byte = 'H' -- <7 hexes> <2 hexes> -device_set_low_byte = 'L' -- <7 hexes> <2 hexes> -device_set_word = 'W' -- <7 hexes> <4 hexes> +device_set_high_byte = "H" -- <5 hexes> <2 hexes> +device_set_low_byte = "L" -- <5 hexes> <2 hexes> +device_set_word = "W" -- <5 hexes> <4 hexes> -- responses -device_interrupt = 'i' -- and nothing else -device_ok = 'o' -- maybe number in response to get (with correct size) -device_bad = 'x' -- and nothing else =) +device_interrupt = "i" -- and nothing else +device_ok = "o" -- maybe number in response to get (with correct size) +device_bad = "x" -- and nothing else =) + + +toHex :: Long -> Int -> String +toHex _ 0 = "" +toHex num digits = toHex (div num 16) (digits - 1) + ++ ["0123456789abcdef" + !! fromIntegral (num `mod` fromIntegral 16)] + +fromHex :: String -> Int -> Long -> Long +fromHex _ 0 a = a +fromHex (d:ds) n a = fromHex ds (n - 1) + (a * (fromIntegral 16) + maybe (error "") fromIntegral + (Data.List.elemIndex d "0123456789abcdef")) + + +readOk :: Handle -> Emulator () +readOk h = do + line <- liftIO $ Data.ByteString.hGetLine h + if line == fromString device_ok + then return () + else if line == fromString device_bad + then error "Device sent BAD signal." + else if line == fromString device_interrupt + then readOk h -- doInterrupt + else error "Unknown Device Protocol Line." + +readOkWord :: Handle -> Emulator Word +readOkWord h = do + line <- liftIO $ Data.ByteString.hGetLine h + if fromString device_ok `Data.ByteString.isPrefixOf` line + then let (_:ltail) = Prelude.drop (Prelude.length device_ok) (toStr line) + in return $ fromIntegral $ fromHex ltail 4 (fromIntegral 0) + else if line == fromString device_bad + then error "Device sent BAD signal." + else if line == fromString device_interrupt + then readOkWord h -- doInterrupt + else error "Unknown Device Protocol Line." ------------------------------------------------------------------------------- @@ -43,15 +115,51 @@ deviceGetByte a | a `mod` 2 == 0 = return 0xFF | otherwise = return 0xFF deviceGetWord :: Long -> Emulator Word -deviceGetWord a = return 0xFFFF +deviceGetWord a = do + handle <- getSock a + if handle == Nothing + then return 0xffff + else do + let (Just h) = handle + liftIO $ hPut h $ fromString $ + device_get_word ++ " " ++ toHex a 5 ++"\n" + readOkWord h deviceSetByte :: Long -> Byte -> Emulator () -deviceSetByte a b | a `mod` 2 == 0 = return () - | otherwise = return () +deviceSetByte a b + | a `mod` 2 == 0 = do + handle <- getSock a + if handle == Nothing + then return () + else do + let (Just h) = handle + liftIO $ hPut h $ fromString $ + device_set_high_byte ++ " " ++ toHex a 5 ++ " " + ++ toHex (fromIntegral b) 2 ++"\n" + readOk h + | otherwise = do + handle <- getSock a + if handle == Nothing + then return () + else do + let (Just h) = handle + liftIO $ hPut h $ fromString $ + device_set_low_byte ++ " " ++ toHex a 5 ++ " " + ++ toHex (fromIntegral b) 2 ++"\n" + readOk h deviceSetWord :: Long -> Word -> Emulator () -deviceSetWord a w = return () +deviceSetWord a w = do + handle <- getSock a + if handle == Nothing + then return () + else do + let (Just h) = handle + liftIO $ hPut h $ fromString $ + device_set_word ++ " " ++ toHex a 5 ++ " " + ++ toHex (fromIntegral w) 4 ++"\n" + readOk h ------------------------------------------------------------------------------- -- cgit v1.2.3