Add very basic installation task

6 files changed, 116 insertions, 25 deletions

diff --git a/CLPM/Package.dcl b/CLPM/Package.dcl
index 3ddf521..5499a5d 100644
--- a/CLPM/Package.dcl
+++ b/CLPM/Package.dcl
@@ -46,9 +46,7 @@ PACKAGE_FILE :== "clpm.json"
 	  }
 
 :: Dependency
-	= Git Url GitTag
-	| Download Url
-	| Package PackageName VersionRequirement
+	= Package PackageName VersionRequirement
 
 :: Options
 	= { show_result       :: Bool
@@ -104,3 +102,5 @@ resolveDependencies :: Repository Package -> MaybeErrorString [(Dependency, Vers
 
 getRecursivePaths :: Package *World -> (MaybeErrorString [Path], *World)
 optionsToFlags :: Options -> [String]
+
+install :: Dependency Version *World -> *(MaybeErrorString (), *World)
diff --git a/CLPM/Package.icl b/CLPM/Package.icl
index 3f3001f..fedb224 100644
--- a/CLPM/Package.icl
+++ b/CLPM/Package.icl
@@ -19,8 +19,12 @@ import Data.Functor
 import Data.List
 import Data.Tuple
 
+import Internet.HTTP
+
+import System.Directory
 import System.File
 import System.FilePath
+import System.Platform
 
 from Text import class Text(indexOf,subString),
 	instance Text String, instance + String
@@ -247,3 +251,37 @@ optionsToFlags opts
 	++ ["-h " + toString opts.Options.heap_size + "k"]
 	++ ["-s " + toString opts.Options.stack_size + "k"]
 	++ opts.Options.extra_flags
+
+install :: Dependency Version *World -> *(MaybeErrorString (), *World)
+install d v w
+# (tar,w) = doRequest req w
+| isError tar
+	= (Error $ fromError tar, w)
+# (err,w) = writeFile (depName d + ".tar.gz") (fromOk tar).rsp_data w
+| isError err
+	= (Error $ toString (fromError err) + " while installing " + depName d + ".", w)
+# (err,w) = createDirectory (MODULE_DIR </> depName d) w
+| isError err
+	= (Error $ snd (fromError err) + " while installing " + depName d + ".", w)
+# (r,w) = syscall ("tar xzf '" + depName d + ".tar.gz' -C '" + MODULE_DIR </> depName d + "' --strip-components=1\0") w
+# (err,w) = deleteFile (depName d + ".tar.gz") w
+| r <> 0
+	= (Error $ "Failed to unpack " + depName d + ".tar.gz.", w)
+| isError err
+	= (Error $ snd (fromError err) + " while installing " + depName d + ".", w)
+= (Ok (), w)
+where
+	req =
+		{ newHTTPRequest
+		& req_path = "/repo/" + depName d + "/" + toString v + "/" + platform + ".tar.gz"
+		, server_name = REPOSITORY
+		, server_port = PORT
+		}
+
+	platform :: String
+	platform = case CURRENT_PLATFORM of
+		Linux32   = "linux32"
+		Linux64   = "linux64"
+		Mac       = "mac"
+		Windows32 = "win32"
+		Windows64 = "win64"
diff --git a/CLPM/Repository.dcl b/CLPM/Repository.dcl
index f9dce62..8dcf751 100644
--- a/CLPM/Repository.dcl
+++ b/CLPM/Repository.dcl
@@ -10,7 +10,6 @@ from CLPM.Package import
 	:: VersionRequirement
 
 REPOSITORY :== "clpm.camilstaps.nl"
-TIMEOUT :== 10000
 PORT :== 80
 
 :: Repository :== [RepositoryItem]
diff --git a/CLPM/Repository.icl b/CLPM/Repository.icl
index 587715f..d0b089d 100644
--- a/CLPM/Repository.icl
+++ b/CLPM/Repository.icl
@@ -5,8 +5,6 @@ import StdClass
 from StdFunc import flip, o
 import StdOverloaded
 
-import TCPIP
-
 import Control.Applicative
 import Control.Monad
 
@@ -22,37 +20,25 @@ from Text import instance + String
 import Text.JSON
 
 import CLPM.Package
+import CLPM.Util
 
 derive JSONDecode RepositoryItem, RepositoryItemVersion
 
 getRepository :: Url *World -> *(MaybeErrorString Repository, *World)
 getRepository repo w
-# (ip,w) = lookupIPAddress repo w
-| isNothing ip
-	= (Error $ "DNS lookup for " + repo + " failed.", w)
-# (Just ip) = ip
-# (rpt,chan,w) = connectTCP_MT (Just TIMEOUT) (ip, PORT) w
-| rpt == TR_Expired
-	= (Error $ "Connection to " + repo + " timed out.", w)
-| rpt == TR_NoSuccess
-	= (Error $ "Could not connect to " + repo + ".", w)
-# (Just {sChannel,rChannel}) = chan
-# (rpt,i,sChannel,w) = send_MT (Just TIMEOUT) req sChannel w
-| rpt <> TR_Success
-	= (Error $ "Could not request repository from " + repo + ".", w)
-# (resp,rChannel,w) = appFst3 (parseResponse o toString) $ receive rChannel w
-| isNothing resp
-	= (Error $ "Server did not respond with HTTP.", w)
-# repo = fromJSON $ fromString (fromJust resp).rsp_data
+# (resp,w) = doRequest req w
+| isError resp
+	= (Error $ fromError resp, w)
+# repo = fromJSON $ fromString (fromOk resp).rsp_data
 | isNothing repo
 	= (Error $ "Server did not return a repository.", w)
-# w = closeChannel sChannel (closeRChannel rChannel w)
 = (Ok $ fromJust repo, w)
 where
-	req = toByteSeq
+	req =
 		{ newHTTPRequest
 		& req_path = "/list.php"
 		, server_name = REPOSITORY
+		, server_port = PORT
 		}
 
 getVersions :: (PackageName Repository -> [RepositoryItemVersion])
diff --git a/CLPM/Util.dcl b/CLPM/Util.dcl
index b750058..3e3a0c2 100644
--- a/CLPM/Util.dcl
+++ b/CLPM/Util.dcl
@@ -2,6 +2,12 @@ definition module CLPM.Util
 
 from Data.Error import :: MaybeError, :: MaybeErrorString
 
+from Internet.HTTP import :: HTTPRequest, :: HTTPResponse
+
 class Parse a where Parse :: [Char] -> MaybeErrorString a
 
 parse :: (String -> MaybeErrorString a) | Parse a
+
+doRequest :: HTTPRequest *World -> *(MaybeErrorString HTTPResponse, *World)
+
+syscall :: !String !*World -> !*(!Int, !*World)
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"
+}