Add very basic installation task

1 files changed, 62 insertions, 0 deletions

diff --git a/CLPM/Util.icl b/CLPM/Util.icl
index a3d016e..2d4004e 100644
--- a/CLPM/Util.icl
+++ b/CLPM/Util.icl
@@ -2,7 +2,69 @@ implementation module CLPM.Util
 
 import StdEnv
 
+import TCPIP
+
+import Control.Applicative
+import Control.Monad
+
 import Data.Error
+from Data.Func import $
+import Data.Functor
+import Data.List
+import Data.Tuple
+
+import Internet.HTTP
+
+from Text import instance + String
+
+TIMEOUT :== Just 10000
 
 parse :: (String -> MaybeErrorString a) | Parse a
 parse = Parse o fromString
+
+doRequest :: HTTPRequest *World -> *(MaybeErrorString HTTPResponse, *World)
+doRequest req w
+# (ip,w) = lookupIPAddress server_name w
+| isNothing ip
+	= (Error $ "DNS lookup for " + server_name + " failed.", w)
+# (Just ip) = ip
+# (rpt,chan,w) = connectTCP_MT TIMEOUT (ip, req.server_port) w
+| rpt == TR_Expired
+	= (Error $ "Connection to " + server_name + " timed out.", w)
+| rpt == TR_NoSuccess
+	= (Error $ "Could not connect to " + server_name + ".", w)
+# (Just {sChannel,rChannel}) = chan
+# (rpt,i,sChannel,w) = send_MT TIMEOUT (toByteSeq req) sChannel w
+| rpt <> TR_Success
+	= (Error $ "Could not send request to " + server_name + ".", w)
+# (rpt,resp,rChannel,w) = receive_MT TIMEOUT rChannel w
+| rpt <> TR_Success
+	= (Error $ "Did not receive a reply from " + server_name + ".", w)
+# resp = join $ parseResponse <$> toString <$> resp
+| isNothing resp
+	# w = closeChannel sChannel (closeRChannel rChannel w)
+	= (Error $ "Server did not respond with HTTP.", w)
+# (resp,rChannel,w) = receiveRest (fromJust resp) rChannel w
+# w = closeChannel sChannel (closeRChannel rChannel w)
+= (resp,w)
+where
+	server_name = req.server_name
+
+	/*receiveRest :: HTTPResponse !*(ch .a) !*env
+		-> *(MaybeErrorString HTTPResponse, !*(ch .a), !*env)
+		| Receive ch & ChannelEnv env*/
+	receiveRest resp chan w
+	# cl = lookup "Content-Length" resp.HTTPResponse.rsp_headers
+	| isNothing cl
+		= (Ok resp, chan, w)
+	| size resp.rsp_data >= toInt (fromJust cl)
+		= (Ok resp, chan, w)
+	# (rpt,newresp,chan,w) = receive_MT TIMEOUT chan w
+	| rpt <> TR_Success
+		= (Error $ server_name + " hung up during transmission.", chan, w)
+	= receiveRest {resp & rsp_data=resp.rsp_data + toString (fromJust newresp)} chan w
+
+syscall :: !String !*World -> !*(!Int, !*World)
+syscall cmd w = code {
+	ccall system "s:I:A"
+}