diff options
| -rw-r--r-- | CLPM/Package.dcl | 2 | ||||
| -rw-r--r-- | CLPM/Package.icl | 93 | ||||
| -rw-r--r-- | CLPM/Repository.dcl | 4 | ||||
| -rw-r--r-- | CLPM/Util.dcl | 5 | ||||
| -rw-r--r-- | CLPM/Util.icl | 34 | ||||
| -rw-r--r-- | clpm.icl | 14 | ||||
| -rw-r--r-- | clpm.json | 14 |
7 files changed, 122 insertions, 44 deletions
diff --git a/CLPM/Package.dcl b/CLPM/Package.dcl index aed3c9a..4a070e2 100644 --- a/CLPM/Package.dcl +++ b/CLPM/Package.dcl @@ -103,4 +103,4 @@ resolveDependencies :: Repository Package -> MaybeErrorString [(Dependency, Vers getRecursivePaths :: Package *World -> (MaybeErrorString [Path], *World) optionsToFlags :: Options -> [String] -install :: Dependency Version *World -> *(MaybeErrorString (), *World) +install :: Dependency Version *World -> *(MaybeErrorString String, *World) 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" diff --git a/CLPM/Repository.dcl b/CLPM/Repository.dcl index 8dcf751..97a568c 100644 --- a/CLPM/Repository.dcl +++ b/CLPM/Repository.dcl @@ -9,7 +9,7 @@ from CLPM.Package import :: PackageName, :: Version, :: Description, :: Author, :: Url, :: VersionRequirement -REPOSITORY :== "clpm.camilstaps.nl" +REPOSITORY :== "local.clpm.camilstaps.nl" PORT :== 80 :: Repository :== [RepositoryItem] @@ -24,7 +24,7 @@ PORT :== 80 :: RepositoryItemVersion = { version :: Version - , depends :: [(PackageName, String)] + , depends :: [String] } derive JSONDecode RepositoryItem, RepositoryItemVersion diff --git a/CLPM/Util.dcl b/CLPM/Util.dcl index 3e3a0c2..76583f0 100644 --- a/CLPM/Util.dcl +++ b/CLPM/Util.dcl @@ -1,13 +1,18 @@ definition module CLPM.Util from Data.Error import :: MaybeError, :: MaybeErrorString +from Data.Maybe import :: Maybe from Internet.HTTP import :: HTTPRequest, :: HTTPResponse +from System.FilePath import :: FilePath + class Parse a where Parse :: [Char] -> MaybeErrorString a +instance Parse Int, (Maybe Int) parse :: (String -> MaybeErrorString a) | Parse a doRequest :: HTTPRequest *World -> *(MaybeErrorString HTTPResponse, *World) syscall :: !String !*World -> !*(!Int, !*World) +recursivelyRemove :: !FilePath !*World -> *(MaybeErrorString (), !*World) diff --git a/CLPM/Util.icl b/CLPM/Util.icl index 2d4004e..282c580 100644 --- a/CLPM/Util.icl +++ b/CLPM/Util.icl @@ -15,10 +15,26 @@ import Data.Tuple import Internet.HTTP +import System.Directory +import System.File +import System.FilePath + from Text import instance + String TIMEOUT :== Just 10000 +instance Parse Int +where + Parse [] = Error "Empty string for Int." + Parse cs + | all isDigit cs = Ok $ toInt $ toString cs + | otherwise = Error "Unexpected character in Int." + +instance Parse (Maybe Int) +where + Parse ['?'] = Ok $ Nothing + Parse cs = Just <$> Parse cs + parse :: (String -> MaybeErrorString a) | Parse a parse = Parse o fromString @@ -68,3 +84,21 @@ syscall :: !String !*World -> !*(!Int, !*World) syscall cmd w = code { ccall system "s:I:A" } + +recursivelyRemove :: !FilePath !*World -> *(MaybeErrorString (), !*World) +recursivelyRemove fp w +| isMember (last $ takeWhile ((<>) "") $ iterate (snd o splitFileName) fp) + [".", ".."] = (Ok (), w) +# (inf,w) = getFileInfo fp w +| isError inf = cast (inf, w) +| not (fromOk inf).directory = cast $ deleteFile fp w +# (fps,w) = readDirectory fp w +| isError fps = cast (fps,w) +# (rem,w) = appFst sequence $ + seqList (map (recursivelyRemove o ((</>) fp)) (fromOk fps)) w +| isError rem = (Error $ fromError rem,w) += cast $ removeDirectory fp w +where + cast :: (MaybeOSError a, *World) -> (MaybeErrorString (), *World) + cast (Error e, w) = (Error $ snd e, w) + cast (Ok _, w) = (Ok (), w) @@ -90,15 +90,15 @@ cmd_install pkg io w = (io <<< fromError solv <<< "\r\n", w) # (Ok solv) = solv # io = io <<< "Installing dependencies:\r\n" -# (io,w) = installAll solv io w -= (io,w) += installAll solv io w where 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 + #! f = f <<< "Installing " <<< depName d <<< ":" <<< toString v <<< "...\r\n" + #! (err,w) = install d v w | isError err = (f <<< fromError err <<< "\r\n", w) + #! f = f <<< fromOk err <<< "\r\n" = installAll ds f w cmd_make :: [String] Package *File *World -> *(*File, *World) @@ -109,9 +109,11 @@ cmd_make opts pkg io w | isError ps = (io <<< fromError ps <<< "\r\n", w) # ps = fromOk ps -# (r,w) = syscall (foldl (+) "clm" [" -I " + p \\ p <- ps] + +# cmd = foldl (+) "clm" [" -I " + p \\ p <- ps] + foldl (+) "" [" " + f \\ f <- optionsToFlags pkg.options ++ opts] + - " " + fromJust pkg.main + " -o " + fromJust pkg.main) w + " " + fromJust pkg.main + " -o " + fromJust pkg.main +#! io = io <<< cmd <<< "\r\n" +#! (r,w) = syscall cmd w = (io,w) parseArgs :: (Arguments [String] -> ([String], Arguments)) @@ -6,16 +6,14 @@ "url": "https://github.com/camilstaps/clpm", "main": "clpm", "paths": [ - "$CLEAN_HOME/lib/clean-platform/OS-Linux-64", - "$CLEAN_HOME/lib/clean-platform/OS-Linux", - "$CLEAN_HOME/lib/clean-platform/OS-Posix", - "$CLEAN_HOME/lib/clean-platform/OS-Independent", - "$CLEAN_HOME/lib/clean-platform/OS-Independent/Deprecated/StdLib", - "$CLEAN_HOME/lib/Generics", "$CLEAN_HOME/lib/TCPIP" ], "options": { "show_result": false, - "show_time": false - } + "show_time": false, + "heap_size": 10000 + }, + "depends": [ + "clean-platform:~0.?.?" + ] } |