Device protocol is almost done!

1 files changed, 124 insertions, 16 deletions

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
 
 
 -------------------------------------------------------------------------------