Improved installation

1 files changed, 66 insertions, 27 deletions

diff --git a/CLPM/Package.icl b/CLPM/Package.icl
index 82f4dad..1cfe4fa 100644
--- a/CLPM/Package.icl
+++ b/CLPM/Package.icl
@@ -26,7 +26,7 @@ import System.File
 import System.FilePath
 import System.Platform
 
-from Text import class Text(indexOf,subString),
+from Text import class Text(indexOf,split,subString),
 	instance Text String, instance + String
 import Text.JSON
 
@@ -71,24 +71,28 @@ where
 	Parse cs
 	| isMember ';' cs = Parse h >>= \h` -> Parse t >>= Ok o Compound h`
 		with (h,t) = span ((==) ';') cs
-	Parse ['~':cs]
-	| isEmpty r1 || isEmpty rev
-		= Error "Unexpected end of Satisfy."
-	| otherwise
-		= p maj >>= \ma ->
-			p min >>= \mi ->
-			p rev >>= \re ->
-			Ok $ Satisfy (ma,mi,re)
+	Parse ['~':cs] = Satisfy <$> Parse cs
+	Parse ['>=':cs] = AtLeast <$> Parse cs
+	Parse ['<=':cs] = AtMost <$> Parse cs
+	Parse [c:_] = Error $ "Unexpected character '" + {c} + "' in VersionRequirement."
+
+instance Parse (Maybe Int, Maybe Int, Maybe Int)
+where
+	Parse cs
+	| isEmpty r1 || isEmpty rev = Error "Unexpected end of MaybeVersion"
+	= Parse maj >>= \m -> Parse min >>= \mi -> Parse rev >>= \r -> Ok (m,mi,r)
 	where
 		(maj,[_:r1])  = span ((<>) '.') cs
 		(min,[_:rev]) = span ((<>) '.') r1
 
-		p :: [Char] -> MaybeErrorString (Maybe Int)
-		p ['?'] = Ok Nothing
-		p cs
-		| all isDigit cs = Ok $ Just $ toInt $ toString cs
-		| otherwise = Error "Unexpected character in Satisfy."
-	Parse [c:_] = Error $ "Unexpected character '" + {c} + "' in VersionRequirement."
+instance Parse Version
+where
+	Parse cs
+	| isEmpty r1 || isEmpty rev = Error "Unexpected end of Version"
+	= Parse maj >>= \m -> Parse min >>= \mi -> Parse rev >>= \r -> Ok (m,mi,r)
+	where
+		(maj,[_:r1])  = span ((<>) '.') cs
+		(min,[_:rev]) = span ((<>) '.') r1
 
 :: StoredPackage
 	= { name    :: Maybe PackageName
@@ -115,7 +119,6 @@ where
 
 depName :: Dependency -> PackageName
 depName (Package n _) = n
-// TODO
 
 satisfies :: VersionRequirement Version -> Bool
 satisfies (AtLeast r)       v       = r <= v
@@ -215,7 +218,10 @@ where
 	res chosen [] = Ok chosen
 	res chosen [d=:(Package p req):ds]
 	| isNothing chosen` = case
-			[res [(d,riv.RepositoryItemVersion.version):chosen] ds \\ riv <- resolve p req rep] of
+			[res
+				[(d,riv.RepositoryItemVersion.version):chosen]
+				(ds ++ map (fromOk o parse) riv.RepositoryItemVersion.depends)
+			\\ riv <- resolve p req rep] of
 		[] = Error $ "No suitable version for " + p + ":" + toString req + "."
 		os = if (all isError os) (hd os) (hd $ filter isOk os)
 	# (Just chosen`) = chosen`
@@ -237,11 +243,16 @@ where
 	getPaths` ps pks [d:ds] w
 	| isMember (depName d) [p.Package.name \\ p <- pks]
 		= getPaths` ps pks ds w
-	# (pkg,w) = readPackage (MODULE_DIR </> (depName d) </> PACKAGE_FILE) w
+	# (pkg,w) = readPackage (addDir PACKAGE_FILE) w
 	| isError pkg
 		= (Error $ fromError pkg, w)
 	# pkg = fromOk pkg
-	= getPaths` (removeDup $ ps ++ pkg.Package.paths) [pkg:pks] ds w
+	= getPaths`
+		(removeDup $ ps ++ map addDir pkg.Package.paths)
+		[pkg:pks] (ds ++ pkg.Package.depends) w
+	where
+		addDir = (</>) (MODULE_DIR </> depName d) o fix
+		fix = foldl1 (</>) o split "/"
 
 optionsToFlags :: Options -> [String]
 optionsToFlags opts
@@ -252,25 +263,53 @@ optionsToFlags opts
 	++ ["-s " + toString opts.Options.stack_size + "k"]
 	++ opts.Options.extra_flags
 
-install :: Dependency Version *World -> *(MaybeErrorString (), *World)
+install :: Dependency Version *World -> *(MaybeErrorString String, *World)
 install d v w
+# (clup,w) = cleanup w
+| isError clup
+	= (Error $ fromError clup, w)
+| not $ fromOk clup
+	= (Ok "Already up to date.", w)
 # (tar,w) = doRequest req w
 | isError tar
 	= (Error $ fromError tar, w)
-# (err,w) = writeFile (depName d + ".tar.gz") (fromOk tar).rsp_data w
+# (Ok tar) = tar
+| tar.HTTPResponse.rsp_code < 200 || 299 < tar.HTTPResponse.rsp_code
+	= (Error $ "Invalid response code " + toString tar.HTTPResponse.rsp_code + ".", w)
+# (err,w) = writeFile (depName d + ".tar.gz") tar.rsp_data w
 | isError err
-	= (Error $ toString (fromError err) + " while installing " + depName d + ".", w)
-# (err,w) = createDirectory (MODULE_DIR </> depName d) w
+	= (Error $ toString (fromError err) + err_append, w)
+# (err,w) = createDirectory dir 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
+	= (Error $ snd (fromError err) + err_append, w)
+# (r,w) = syscall ("tar xzf '" + depName d + ".tar.gz' -C '" + dir + "' --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)
+	= (Error $ snd (fromError err) + err_append, w)
+= (Ok "Installed.", w)
 where
+	dir = MODULE_DIR </> depName d
+	pkg_json = dir </> PACKAGE_FILE
+	err_append = " while installing " + depName d + "."
+
+	cleanup :: *World -> *(MaybeErrorString Bool, *World)
+	cleanup w
+	# (ex,w) = fileExists dir w
+	| not ex = (Ok True, w)
+	# (ex,w) = fileExists pkg_json w
+	| not ex
+		# (err,w) = recursivelyRemove dir w
+		| isError err = (Error $ fromError err, w)
+		| otherwise   = (Ok True, w)
+	# (pkg,w) = readPackage pkg_json w
+	| isError pkg = (Error $ "Corrupted " + PACKAGE_FILE + ".", w)
+	| (fromOk pkg).Package.version == v = (Ok False, w)
+	# (err,w) = recursivelyRemove dir w
+	| isError err = (Error $ fromError err, w)
+	| otherwise   = (Ok True, w)
+
 	req =
 		{ newHTTPRequest
 		& req_path = "/repo/" + depName d + "/" + toString v + "/" + platform + ".tar.gz"