Networking!

4 files changed, 156 insertions, 59 deletions

diff --git a/README.md b/README.md
index cad48d7..8d20d91 100644
--- a/README.md
+++ b/README.md
@@ -21,6 +21,10 @@ All stack items are signed bigints.
 - `o`: outputs the top value as an ascii char
 - `O`: outputs the top value as a number
 - `g`: gets a character and pushes the ascii value
+- `C`: open a socket connection to specified ip address, in 32- or 128-bit format for ipv4 or ipv6 resp., and port. Returns identifier
+- `w`: takes identifier and char; writes char to specified socket (leaves socket on stack)
+- `t`: takes identifier; takes char from specified socket and pushes it (leaves socket on stack)
+- `c`: takes identifier; closes that connection
 - `F<bla>[code]`: define a function named "bla" with the body "code"
 - `<bla>`: call the function named "bla"
 - `$`: outputs a stackdump
diff --git a/rip.hs b/rip.hs
index 3ca7a29..3efd081 100644
--- a/rip.hs
+++ b/rip.hs
@@ -2,14 +2,18 @@ module Main where
 
 import System.Environment
 import System.Exit
+import System.IO
 import System.IO.Error
 import Control.Exception
 import Control.Monad
 import Data.Char
 import Data.Either
 import Data.Maybe
-import Data.List as List
-import Data.Map.Strict as Map
+import Data.List
+import qualified Data.Map.Strict as Map
+import Data.Map.Strict ((!))
+import Network.Socket
+import Numeric
 
 type Stackelem = Integer
 
@@ -41,13 +45,36 @@ fromLeft (Left l) = l
 ordI :: (Integral a) => Char -> a
 ordI = fromIntegral . ord
 
-safeGetChar :: IO (Maybe Char)
-safeGetChar =
+pad :: a -> Int -> [a] -> [a]
+pad c n s
+    | length s >= n = s
+    | otherwise = c : pad c (n-1) s
+
+getBytes :: Stackelem -> [Int]
+getBytes = reverse . getBytes'
+
+getBytes' :: Stackelem -> [Int]
+getBytes' 0 = []
+getBytes' n = fromIntegral m : getBytes' q
+    where (q,m) = divMod n 256
+
+hex :: (Integral a, Show a) => a -> String
+hex n = showHex n ""
+
+pairs :: [a] -> [(a,a)]
+pairs [] = []
+pairs (a:b:cs) = (a,b) : pairs cs
+
+safeHGetChar :: Handle -> IO (Maybe Char)
+safeHGetChar h =
     catch
-        (liftM Just getChar)
+        (liftM Just $ hGetChar h)
         ((\ex -> if isEOFError ex then return Nothing else ioError ex)
             :: IOError -> IO (Maybe Char))
 
+safeGetChar :: IO (Maybe Char)
+safeGetChar = safeHGetChar stdin
+
 
 parenpairs :: Char -> Char -> String -> Either String [(Int,Int)]
 parenpairs open close s = go 0 [] s -- index, stack, string
@@ -104,41 +131,45 @@ getfuncname' (_:xs) =
         then Left "No closing '>' in function name"
         else Right name
     where 
-        maybeidx = List.findIndex (== '>') xs
+        maybeidx = findIndex (== '>') xs
         name = take (fromJust maybeidx) xs
 
 -- returns the resulting stack
 -- rip: Rip InterPreter (recursive acronym)
-rip :: String -> IO [Stackelem]
-rip s = rip' s Map.empty []
-
---       code         function map            stack      resulting stack
-rip' :: String -> Map.Map String String -> [Stackelem] -> IO [Stackelem]
-rip' [] _ st = return st
-rip' code@(x:xs) fns st = do
+rip :: String -> IO ([Stackelem],Map.Map Stackelem Handle)
+rip s = rip' s Map.empty Map.empty []
+
+--       code         function map              filedesc table            stack      resulting stack
+rip' :: String  -- code
+     -> Map.Map String String  -- function map
+     -> Map.Map Stackelem Handle  -- filedecs table
+     -> [Stackelem]  -- stack
+     -> IO ([Stackelem],Map.Map Stackelem Handle)  -- resulting stack and filedesc table
+rip' [] _ conns st = return (st,conns)
+rip' code@(x:xs) fns conns st = do
     if c_debugmode then print st else return ()
     case x of
         n | '0' <= n && n <= '9' ->
-            rip' xs fns (fromIntegral (ord n - ord '0') : st)
+            rip' xs fns conns (fromIntegral (ord n - ord '0') : st)
 
         'P' ->
-            rip' xs fns (tail st)
+            rip' xs fns conns (tail st)
 
         'S' ->
-            rip' xs fns (b:a:cs)
+            rip' xs fns conns (b:a:cs)
                 where (a:b:cs) = st
 
         'D' ->
-            rip' xs fns (head st : st)
+            rip' xs fns conns (head st : st)
 
         'i' ->
-            rip' xs fns (head st + 1 : tail st)
+            rip' xs fns conns (head st + 1 : tail st)
 
         'd' ->
-            rip' xs fns (head st - 1 : tail st)
+            rip' xs fns conns (head st - 1 : tail st)
 
         'r' ->
-            rip' xs fns res
+            rip' xs fns conns res
                 where
                     n = fromIntegral $ head st
                     newst = tail st
@@ -146,7 +177,7 @@ rip' code@(x:xs) fns st = do
                     res = tail begin ++ head begin : rest
 
         'R' ->
-            rip' xs fns res
+            rip' xs fns conns res
                 where
                     n = fromIntegral $ head st
                     newst = tail st
@@ -154,46 +185,46 @@ rip' code@(x:xs) fns st = do
                     res = last begin : init begin ++ rest  --SLOW!
 
         'l' ->
-            rip' xs fns (fromIntegral (length st) : st)
+            rip' xs fns conns (fromIntegral (length st) : st)
 
         'a' ->
-            rip' xs fns (a + b : cs)
+            rip' xs fns conns (a + b : cs)
                 where (b:a:cs) = st
 
         's' ->
-            rip' xs fns (a - b : cs)
+            rip' xs fns conns (a - b : cs)
                 where (b:a:cs) = st
 
         'm' ->
-            rip' xs fns (a * b : cs)
+            rip' xs fns conns (a * b : cs)
                 where (b:a:cs) = st
 
         'q' ->
-            rip' xs fns (a `div` b : cs)
+            rip' xs fns conns (a `div` b : cs)
                 where (b:a:cs) = st
 
         'M' ->
-            rip' xs fns (a `mod` b : cs)
+            rip' xs fns conns (a `mod` b : cs)
                 where (b:a:cs) = st
 
         'p' ->
-            rip' xs fns (a ^ b : cs)
+            rip' xs fns conns (a ^ b : cs)
                 where (b:a:cs) = st
 
         'G' ->
-            rip' xs fns (booltoint (a > b) : cs)
+            rip' xs fns conns (booltoint (a > b) : cs)
                 where (b:a:cs) = st
 
         'L' ->
-            rip' xs fns (booltoint (a < b) : cs)
+            rip' xs fns conns (booltoint (a < b) : cs)
                 where (b:a:cs) = st
 
         'E' ->
-            rip' xs fns (booltoint (a == b) : cs)
+            rip' xs fns conns (booltoint (a == b) : cs)
                 where (b:a:cs) = st
 
         'n' ->
-            rip' xs fns (booltoint (head st == 0) : tail st)
+            rip' xs fns conns (booltoint (head st == 0) : tail st)
 
         'I' ->
             let maybecb = getcodeblock xs
@@ -203,9 +234,9 @@ rip' code@(x:xs) fns st = do
                 Right (inblock,afterblock) ->
                     if head st /= 0
                         then do
-                            newstack <- rip' inblock fns (tail st)
-                            rip' afterblock fns newstack
-                        else rip' afterblock fns (tail st)
+                            (newstack,newconns) <- rip' inblock fns conns (tail st)
+                            rip' afterblock fns newconns newstack
+                        else rip' afterblock fns conns (tail st)
 
         'W' ->
             let maybecb = getcodeblock xs
@@ -214,16 +245,16 @@ rip' code@(x:xs) fns st = do
 
                 Right (inblock,afterblock) ->
                     let
-                        doloop st = do
-                            newstack <- rip' inblock fns st
+                        doloop st cn = do
+                            (newstack,newconns) <- rip' inblock fns cn st
                             if head newstack /= 0
-                                then doloop $ tail newstack
-                                else return $ tail newstack
+                                then doloop (tail newstack) newconns
+                                else return (tail newstack,newconns)
                     in if head st /= 0
                         then do
-                            newstack <- doloop (tail st)
-                            rip' afterblock fns newstack
-                        else rip' afterblock fns (tail st)
+                            (newstack,newconns) <- doloop (tail st) conns
+                            rip' afterblock fns newconns newstack
+                        else rip' afterblock fns conns (tail st)
 
         'o' -> do
             let n = fromIntegral (head st)
@@ -232,16 +263,46 @@ rip' code@(x:xs) fns st = do
                 (\ex -> riperror $ "Invalid character value " ++ (show n))
                 (\c -> do
                     putChar c
-                    rip' xs fns (tail st))
+                    rip' xs fns conns (tail st))
                 res
 
         'O' -> do
             putStr $ show (head st)
-            rip' xs fns (tail st)
+            rip' xs fns conns (tail st)
 
         'g' -> do
             n <- liftM (maybe (-1) ord) safeGetChar
-            rip' xs fns (fromIntegral n : st)
+            rip' xs fns conns (fromIntegral n : st)
+
+        'C' -> do
+            let (portint:hostnameint:newst) = st
+                hostname =
+                    if hostnameint < 2^32
+                        then intercalate "." $ map show $ getBytes hostnameint
+                        else intercalate ":" $ map (\(a,b) -> pad '0' 2 (hex a) ++ pad '0' 2 (hex b)) $ pairs $ pad 0 16 $ getBytes hostnameint
+            addrinfo <- liftM head $ getAddrInfo (Just $ defaultHints {addrSocketType = Stream}) (Just hostname) (Just $ show portint)
+            sock <- socket (addrFamily addrinfo) Stream defaultProtocol
+            connect sock (addrAddress addrinfo)
+            h <- socketToHandle sock ReadWriteMode
+            let ident = fromIntegral $ succ $ Map.size conns
+            rip' xs fns (Map.insert ident h conns) $ ident : newst
+
+        'c' -> do
+            let (ident:newst) = st
+            hClose $ conns ! ident
+            let newconns = Map.delete ident conns
+            rip' xs fns newconns newst
+
+        'w' -> do
+            let (c:newst@(ident:_)) = st
+            hPutChar (conns ! ident) $ chr $ fromIntegral c
+            rip' xs fns conns newst
+
+        't' -> do
+            let (ident:_) = st
+            c <- liftM (maybe (-1) ordI) $ safeHGetChar $ conns ! ident
+            --c <- liftM ordI $ hGetChar $ conns ! ident
+            rip' xs fns conns $ c : st
 
         '<' ->
             case (getfuncname code) of
@@ -250,8 +311,8 @@ rip' code@(x:xs) fns st = do
                     Nothing -> riperror $ "Function '" ++ name ++ "' not found"
                     Just s -> let newcode = drop (length name + 1) xs
                         in do
-                            newstack <- rip' s fns st
-                            rip' newcode fns newstack
+                            (newstack,newconns) <- rip' s fns conns st
+                            rip' newcode fns newconns newstack
 
         'F' -> case (getfuncname xs) of
             Left s -> riperror s
@@ -260,22 +321,22 @@ rip' code@(x:xs) fns st = do
                 Nothing -> case (getcodeblock $ drop (length name + 2) xs) of
                     Left s -> riperror s
                     Right (inblock,afterblock) ->
-                        rip' afterblock (Map.insert name inblock fns) st
+                        rip' afterblock (Map.insert name inblock fns) conns st
 
         '#' -> case (getfuncname xs) of
             Left s -> riperror s
             Right name -> do
                 contents <- readFile name
-                rip' (contents ++ drop (length name + 2) xs) fns st
+                rip' (contents ++ drop (length name + 2) xs) fns conns st
 
-        '\'' -> rip' (tail xs) fns $ ordI (head xs) : st
+        '\'' -> rip' (tail xs) fns conns $ ordI (head xs) : st
 
         '$' -> do
-            (putStrLn . List.intercalate " " . List.map show . reverse) st
-            rip' xs fns st
+            (putStrLn . intercalate " " . map show . reverse) st
+            rip' xs fns conns st
 
         c | isSpace c ->
-            rip' xs fns st
+            rip' xs fns conns st
 
         _ -> riperror $ "Unknown command '" ++ [x,'\'']
 
diff --git a/stdlib.rip b/stdlib.rip
index af428c3..432a9cf 100644
--- a/stdlib.rip
+++ b/stdlib.rip
@@ -1,7 +1,7 @@
 0I[prints string; destructive]
 F<strprint>[
 	<strrev>
-	97aDm
+	28p
 	SDW[
 		D3RD3rM o D3rq
 	D]
@@ -10,23 +10,23 @@ F<strprint>[
 
 0I[takes string char; returns string+char]
 F<strpush>[
-	S97aDmma
+	S28pma
 ]
 
 0I[reverses string in place]
 F<strrev>[
 	0S
 	DW[
-		D 97aDm D 3r M 3r q 3r S 97aDm m a S
+		D 28p D 3r M 3r q 3r S 28p m a S
 	D]
 	P
 ]
 
 0I[concatenates two strings]
 F<strcat>[
-	<strrev> 97aDm S
+	<strrev> 28p S
 	DW[
-		S D 3r S D 3R M 4R 97aDmma 3r S D 3r q
+		S D 3r S D 3R M 4R 28pma 3r S D 3r q
 	D]
 	PP
 ]
@@ -35,7 +35,7 @@ F<strcat>[
 F<mkstr>[
 	0S
 	DW[
-		D2aR 3R 97aDm m a S d
+		D2aR 3R 28p m a S d
 	D]
 	P
 ]
@@ -145,3 +145,10 @@ F<varget>[
 	<varhaulup>
 	SP
 ]
+
+
+0I[takes socket and string; sends string to socket]
+F<strsend>[
+	<strrev>
+	DW[D28pM3RSwS28pqD]P
+]
diff --git a/stdlibtest.rip b/stdlibtest.rip
index 6e2a8a1..8ca17a1 100644
--- a/stdlibtest.rip
+++ b/stdlibtest.rip
@@ -12,3 +12,28 @@
 
 'h'o'i 3<mkstr> <vardel>
 'd'o'e'i 4<mkstr> <vardel>
+
+
+0I[
+	27pd 238mp m i  0I[127.0.0.1]
+	39iDDmmm  0I[3000]
+	C
+
+	gDiW[
+		w
+	gDi]
+	c
+]
+
+'C'o'n'n'e'c't'i'n'g' 't'o' '1'7'8'.'6'2'.'2'3'9'.'7'9':'8'0'.'.'. 9i 6Dmdd<mkstr><strprint>
+0I[178.62.239.79]
+
+98a9im8a 88mdd<strpush> 83m9imd<strpush> 89imd<strpush>  89im C
+'G'E'T' '/' 'H'T'T'P'/'1'.'1'
+'H'o's't':' 't'o'm's'm'e'd'i'n'g'.'c'o'm'
+'
+6Dmi<mkstr><strsend>
+tDiW[
+	o
+tDi]
+Pc