Add very basic installation task

8 files changed, 144 insertions, 57 deletions

diff --git a/.gitignore b/.gitignore
index 2e3fccd..5c15575 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,2 +1,3 @@
 Clean System Files/
 clpm
+clpm_modules
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"
+}
diff --git a/clpm.icl b/clpm.icl
index 26b98f4..a3382d1 100644
--- a/clpm.icl
+++ b/clpm.icl
@@ -26,6 +26,7 @@ import System.File
 
 import CLPM.Package
 import CLPM.Repository
+import CLPM.Util
 
 CLPM_VERSION :== (0,1,0)
 
@@ -37,7 +38,7 @@ CLPM_VERSION :== (0,1,0)
 :: Arguments
 	= { package_file :: String
 	  , action       :: Action
-	  , repository   :: String
+	  //, repository   :: String
 	  , clm_options  :: [String]
 	  , show_help    :: Bool
 	  }
@@ -47,7 +48,7 @@ where
 	zero
 		= { package_file = PACKAGE_FILE
 		  , action       = NoAction
-		  , repository   = REPOSITORY
+		  //, repository   = REPOSITORY
 		  , clm_options  = []
 		  , show_help    = False
 		  }
@@ -56,13 +57,13 @@ Start w
 # (io,w) = stdio w
 # ((missed, args), w) = appFst (parseArgs zero o tl) $ getCommandLine w
 | not (isEmpty missed)
-	# io = foldr (flip (<<<)) io ["Unknown option: " + m + "\n" \\ m <- missed]
+	# io = foldr (flip (<<<)) io ["Unknown option: " + m + "\r\n" \\ m <- missed]
 	= snd $ fclose io w
 | args.show_help
 	= snd $ fclose (io <<< HELP_TEXT) w
 # (pkg,w) = readPackage args.package_file w
 | isError pkg
-	# io = io <<< fromError pkg <<< "\n"
+	# io = io <<< fromError pkg <<< "\r\n"
 	# (_,w) = fclose io w
 	= w
 # (Ok pkg) = pkg
@@ -73,39 +74,38 @@ Start w
 do :: Arguments Package *File *World -> *(*File, *World)
 do args pkg io w = case args.action of
 	NoAction = (io,w)
-	Install  = install pkg io w
-	Make     = make args.clm_options pkg io w
+	Install  = cmd_install pkg io w
+	Make     = cmd_make args.clm_options pkg io w
 
-install :: Package *File *World -> *(*File, *World)
-install pkg io w
+cmd_install :: Package *File *World -> *(*File, *World)
+cmd_install pkg io w
 # (e,w) = fileExists MODULE_DIR w
 # w = if e w (snd $ createDirectory MODULE_DIR w)
 # (repo,w) = getRepository REPOSITORY w
 | isError repo
-	= (io <<< fromError repo <<< "\n", w)
+	= (io <<< fromError repo <<< "\r\n", w)
 # (Ok repo) = repo
-# io = foldl printRepo io repo
 # solv = resolveDependencies repo pkg
 | isError solv
-	= (io <<< fromError solv <<< "\n", w)
+	= (io <<< fromError solv <<< "\r\n", w)
 # (Ok solv) = solv
-# io = io <<< "Dependencies:\n"
-# io = printDeps io solv
+# io = io <<< "Installing dependencies:\r\n"
+# (io,w) = installAll solv io w
 = (io,w)
 where
-	printRepo :: *File RepositoryItem -> *File
-	printRepo f ri = f <<< ri.RepositoryItem.name <<< "\t" <<<
-		foldl (+++) "" [toString v.RepositoryItemVersion.version + ", " \\ v <- ri.RepositoryItem.versions]
-		<<< "\n"
-
-	printDeps :: *File [(Dependency, Version)] -> *File
-	printDeps f ds = foldl (<<<) f [depName d + "\t" + toString v + "\n" \\ (d,v) <- ds]
-
-make :: [String] Package *File *World -> *(*File, *World)
-make opts pkg io w
+	installAll :: [(Dependency, Version)] *File *World -> *(*File, *World)
+	installAll [] f w = (f,w)
+	installAll [(d,v):ds] f w
+	# f = f <<< "Installing " <<< depName d <<< ":" <<< toString v <<< "...\r\n"
+	# (err,w) = install d v w
+	| isError err = (f <<< fromError err <<< "\r\n", w)
+	= installAll ds f w
+
+cmd_make :: [String] Package *File *World -> *(*File, *World)
+cmd_make opts pkg io w
 # (ps,w) = getRecursivePaths pkg w
 | isError ps
-	= (io <<< fromError ps <<< "\n", w)
+	= (io <<< fromError ps <<< "\r\n", w)
 # ps = fromOk ps
 # (r,w) = syscall (foldl (+) "clm" [" -I " + p \\ p <- ps] +
 	foldl (+) "" [" " + f \\ f <- optionsToFlags pkg.options ++ opts] +
@@ -120,17 +120,12 @@ where
 	pa miss args ["-h":rest]      = pa miss {args & show_help = True} rest
 	pa miss args ["--help":rest]  = pa miss {args & show_help = True} rest
 	pa miss args ["-p":name:rest] = pa miss {args & package_file = name} rest
-	pa miss args ["-r":repo:rest] = pa miss {args & repository = repo} rest
+	//pa miss args ["-r":repo:rest] = pa miss {args & repository = repo} rest
 	pa miss args ["-c":opt:rest]  = pa miss {args & clm_options = args.clm_options ++ [opt]} rest
 	pa miss args ["install":rest] = pa miss {args & action = Install} rest
 	pa miss args ["make":rest]    = pa miss {args & action = Make} rest
 	pa miss args [a:rest]         = pa [a:miss] args rest
 
-syscall :: !String !*World -> !*(!Int, !*World)
-syscall cmd w = code {
-	ccall system "s:I:A"
-}
-
 HELP_TEXT =:
 	"CLPM - A Clean Package Manager - v" + toString CLPM_VERSION + "\r\n\r\n" +
 	"Usage: clpm <command> [option]\r\n\r\n" +
@@ -151,8 +146,8 @@ where
 		  "Print this help text")
 		, ("-p <FILE>",
 		  "Use FILE as package file instead of package.json")
-		, ("-r <HOST>",
-		  "Use HOST as repository provider instead of " + REPOSITORY)
+		//, ("-r <HOST>",
+		//  "Use HOST as repository provider instead of " + REPOSITORY)
 		]
 
 	pad :: Int Int String -> String