Device protocol is almost done!

4 files changed, 145 insertions, 24 deletions

diff --git a/src/Control.hs b/src/Control.hs
index 65b3831..a6a6271 100644
--- a/src/Control.hs
+++ b/src/Control.hs
@@ -276,6 +276,7 @@ setByte :: Long -> Byte -> Emulator ()
 setByte a b | a < 0x8 = return ()
             | a < 0x7e0000 = with ram $ \ram ->
                 VM.write ram (fromIntegral a) b
+            | a < 0x800000 = return ()
             | otherwise = deviceSetByte a b
 
  -- TODO: only even addresses are allowed
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
 
 
 -------------------------------------------------------------------------------
diff --git a/src/Machine.hs b/src/Machine.hs
index a1ea028..75ad877 100644
--- a/src/Machine.hs
+++ b/src/Machine.hs
@@ -12,6 +12,7 @@ import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Reader (MonadReader, ReaderT, ask)
 import Control.Monad.Trans (MonadIO)
 import Network.Socket
+import System.IO
 import Utils
 
 
@@ -35,7 +36,15 @@ data Machine = Machine {
     s4  :: Maybe Socket,
     s5  :: Maybe Socket,
     s6  :: Maybe Socket,
-    s7  :: Maybe Socket
+    s7  :: Maybe Socket,
+    c0  :: IORef (Maybe Handle),
+    c1  :: IORef (Maybe Handle),
+    c2  :: IORef (Maybe Handle),
+    c3  :: IORef (Maybe Handle),
+    c4  :: IORef (Maybe Handle),
+    c5  :: IORef (Maybe Handle),
+    c6  :: IORef (Maybe Handle),
+    c7  :: IORef (Maybe Handle)
 }
 
 -- Emulator is a monad which contains Machine and allows easy change of it.
diff --git a/src/Suem.hs b/src/Suem.hs
index 6b2779a..7f55891 100644
--- a/src/Suem.hs
+++ b/src/Suem.hs
@@ -434,10 +434,6 @@ data Config = Config Int      -- frequence
                      (Maybe ConfigSocket)
                      (Maybe ConfigSocket)
 
-ipString :: String -> Word32
-ipString = fromIntegral . sum . map (\(n,o) -> toInteger o * 256 ^ n)
-         . zip [0..] . reverse . fromIPv4 . read
-
 makeSocket :: Maybe ConfigSocket -> IO (Maybe Socket)
 makeSocket (Just (ConfigUnix a)) = do
     sock <- socket AF_UNIX Stream defaultProtocol
@@ -446,9 +442,7 @@ makeSocket (Just (ConfigUnix a)) = do
     return $ Just sock
 makeSocket (Just (ConfigInet a)) = do
     sock <- socket AF_INET Stream defaultProtocol
-    Network.Socket.bind sock $ SockAddrInet
-                                (read $ tail $ dropWhile (/= ':') a)
-                                (ipString    $ takeWhile (/= ':') a)
+    Network.Socket.bind sock $ SockAddrInet (read a) 0x0100007f
     Network.Socket.listen sock 1024
     return $ Just sock
 makeSocket Nothing = return Nothing
@@ -478,8 +472,17 @@ makeMachine ramData romData s0 s1 s2 s3 s4 s5 s6 s7 = do
     ms5 <- makeSocket s5
     ms6 <- makeSocket s6
     ms7 <- makeSocket s7
+    mc0 <- newIORef Nothing
+    mc1 <- newIORef Nothing
+    mc2 <- newIORef Nothing
+    mc3 <- newIORef Nothing
+    mc4 <- newIORef Nothing
+    mc5 <- newIORef Nothing
+    mc6 <- newIORef Nothing
+    mc7 <- newIORef Nothing
     return $ Machine pc sr drs ars usp ssp ramData romData
                      ms0 ms1 ms2 ms3 ms4 ms5 ms6 ms7
+                     mc0 mc1 mc2 mc3 mc4 mc5 mc6 mc7
     where pcval = (fromIntegral $ romData V.! 4) * 256 * 256 * 256 +
                   (fromIntegral $ romData V.! 5) * 256 * 256 +
                   (fromIntegral $ romData V.! 6) * 256 +