diff options
| -rw-r--r-- | CLPM/Package.dcl | 42 | ||||
| -rw-r--r-- | CLPM/Package.icl | 185 | ||||
| -rw-r--r-- | CLPM/Repository.dcl | 36 | ||||
| -rw-r--r-- | CLPM/Repository.icl | 69 | ||||
| -rw-r--r-- | CLPM/Util.dcl | 7 | ||||
| -rw-r--r-- | CLPM/Util.icl | 8 | ||||
| -rw-r--r-- | clpm.icl | 44 | ||||
| -rw-r--r-- | clpm.json | 5 |
8 files changed, 331 insertions, 65 deletions
diff --git a/CLPM/Package.dcl b/CLPM/Package.dcl index 9c685d2..3ddf521 100644 --- a/CLPM/Package.dcl +++ b/CLPM/Package.dcl @@ -1,12 +1,19 @@ definition module CLPM.Package +from StdClass import class Ord from StdFile import class <<< +from StdOverloaded import class <, class ==, class toString +from StdTuple import instance < (a,b,c) | < a & < b & < c from Data.Error import :: MaybeError, :: MaybeErrorString from Data.Maybe import :: Maybe from Text.JSON import :: JSONNode, generic JSONEncode, generic JSONDecode +from CLPM.Repository import :: Repository, :: RepositoryItem +from CLPM.Util import class Parse + DEFAULT_NAME :== "Unnamed package" +DEFAULT_VERSION :== (0,1,0) DEFAULT_DESC :== "Empty description" DEFAULT_AUTHOR :== "Unknown author" DEFAULT_URL :== "http://clean.cs.ru.nl" @@ -28,6 +35,7 @@ PACKAGE_FILE :== "clpm.json" :: Package = { name :: PackageName + , version :: Version , desc :: Description , author :: Author , url :: Url @@ -38,13 +46,9 @@ PACKAGE_FILE :== "clpm.json" } :: Dependency - = { dep_name :: PackageName - , dep_source :: PackageSource - } - -:: PackageSource = Git Url GitTag | Download Url + | Package PackageName VersionRequirement :: Options = { show_result :: Bool @@ -56,6 +60,7 @@ PACKAGE_FILE :== "clpm.json" } :: PackageName :== String +:: Version :== (Int, Int, Int) :: Description :== String :: Author :== String :: Url :== String @@ -66,15 +71,36 @@ PACKAGE_FILE :== "clpm.json" | Tag String | Latest +:: VersionRequirement + = AtLeast Version + | AtMost Version + | Satisfy (Maybe Int, Maybe Int, Maybe Int) + | Compound VersionRequirement VersionRequirement + derive JSONEncode StoredPackage derive JSONDecode StoredPackage instance <<< Package -toPackage :: StoredPackage -> Package +instance toString Version + +instance == Dependency +instance == VersionRequirement +instance == GitTag + +instance Parse Dependency +instance Parse VersionRequirement + +depName :: Dependency -> PackageName + +satisfies :: VersionRequirement Version -> Bool + +toPackage :: StoredPackage -> MaybeErrorString Package toStoredPackage :: Package -> StoredPackage -readPackage :: String -> *World -> *(Maybe Package, *World) -getRecursivePaths :: Package *World -> (MaybeErrorString [Path], *World) +readPackage :: String *World -> *(MaybeErrorString Package, *World) + +resolveDependencies :: Repository Package -> MaybeErrorString [(Dependency, Version)] +getRecursivePaths :: Package *World -> (MaybeErrorString [Path], *World) optionsToFlags :: Options -> [String] diff --git a/CLPM/Package.icl b/CLPM/Package.icl index 2eee207..3f3001f 100644 --- a/CLPM/Package.icl +++ b/CLPM/Package.icl @@ -1,9 +1,14 @@ implementation module CLPM.Package import _SystemArray +import StdBool import StdFile -from StdFunc import o +from StdFunc import flip, o import StdList +import StdOverloaded +import StdTuple + +import GenEq import Control.Applicative import Control.Monad @@ -11,6 +16,7 @@ import Control.Monad import Data.Error from Data.Func import $ import Data.Functor +import Data.List import Data.Tuple import System.File @@ -20,11 +26,69 @@ from Text import class Text(indexOf,subString), instance Text String, instance + String import Text.JSON +import CLPM.Repository +import CLPM.Util + derive JSONEncode StoredPackage, StoredOptions derive JSONDecode StoredPackage, StoredOptions +instance <<< Package +where + (<<<) f p = f <<< (jsonPrettyPrint $ toJSON $ toStoredPackage p) + +instance toString Version +where toString (a,b,c) = toString a + "." + toString b + "." + toString c + +instance toString VersionRequirement +where + toString (AtLeast v) = ">=" + toString v + toString (AtMost v) = "<=" + toString v + toString (Satisfy (a,b,c)) = "~" + pt a + "." + pt b + "." + pt c + where pt Nothing = "?"; pt (Just i) = toString i + toString (Compound r1 r2) = toString r1 + ";" + toString r2 + +derive gEq Dependency, VersionRequirement, GitTag +instance == Dependency where (==) a b = gEq{|*|} a b +instance == VersionRequirement where (==) a b = gEq{|*|} a b +instance == GitTag where (==) a b = gEq{|*|} a b + +instance Parse Dependency +where + Parse cs + | not (isMember ':' cs) = Error "Dependency should contain a ':'." + | isEmpty vr = Error $ "No VersionRequirement for " + toString p + "." + | otherwise = Parse vr >>= Ok o Package (toString p) + where + (p,[_:vr]) = span ((<>) ':') cs + +instance Parse VersionRequirement +where + Parse [] = Error "Unexpected end of VersionRequirement." + 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) + 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." + :: StoredPackage = { name :: Maybe PackageName + , version :: Maybe Version , desc :: Maybe Description , author :: Maybe Author , url :: Maybe Url @@ -34,8 +98,7 @@ derive JSONDecode StoredPackage, StoredOptions , options :: Maybe StoredOptions } -:: StoredDependency :== (PackageName, StoredPackageSource) -:: StoredPackageSource :== String +:: StoredDependency :== String :: StoredOptions = { show_result :: Maybe Bool @@ -46,25 +109,35 @@ derive JSONDecode StoredPackage, StoredOptions , extra_flags :: Maybe [String] } -toPackage :: StoredPackage -> Package -toPackage spkg - = { Package - | name = fromJust $ spkg.StoredPackage.name <|> Just DEFAULT_NAME - , desc = fromJust $ spkg.StoredPackage.desc <|> Just DEFAULT_DESC - , author = fromJust $ spkg.StoredPackage.author <|> Just DEFAULT_AUTHOR - , url = fromJust $ spkg.StoredPackage.url <|> Just DEFAULT_URL - , main = fromJust $ spkg.StoredPackage.main <|> Just DEFAULT_MAIN - , depends = map toDep $ fromJust $ spkg.StoredPackage.depends <|> Just [] - , paths = fromJust $ spkg.StoredPackage.paths <|> Just DEFAULT_PATHS - , options = toOptions spkg.StoredPackage.options - } +depName :: Dependency -> PackageName +depName (Package n _) = n +// TODO + +satisfies :: VersionRequirement Version -> Bool +satisfies (AtLeast r) v = r <= v +satisfies (AtMost r) v = r >= v +satisfies (Satisfy (a,b,c)) (d,e,f) + | isJust a && d <> fromJust a = False + | isJust b && e <> fromJust b = False + | isJust c && f <> fromJust c = False + | otherwise = True +satisfies (Compound r1 r2) v = satisfies r1 v && satisfies r2 v + +toPackage :: StoredPackage -> MaybeErrorString Package +toPackage spkg = sequence (map parse depends`) >>= \ds -> Ok + { Package + | name = fromJust $ spkg.StoredPackage.name <|> Just DEFAULT_NAME + , version = fromJust $ spkg.StoredPackage.version <|> Just DEFAULT_VERSION + , desc = fromJust $ spkg.StoredPackage.desc <|> Just DEFAULT_DESC + , author = fromJust $ spkg.StoredPackage.author <|> Just DEFAULT_AUTHOR + , url = fromJust $ spkg.StoredPackage.url <|> Just DEFAULT_URL + , main = fromJust $ spkg.StoredPackage.main <|> Just DEFAULT_MAIN + , depends = ds + , paths = fromJust $ spkg.StoredPackage.paths <|> Just DEFAULT_PATHS + , options = toOptions spkg.StoredPackage.options + } where - toDep :: StoredDependency -> Dependency - toDep (name, src) - = { dep_name = name, dep_source = toPackSource src } - - toPackSource :: StoredPackageSource -> PackageSource - toPackSource sps = Git sps Latest + depends` = fromJust $ spkg.StoredPackage.depends <|> Just [] toOptions :: (Maybe StoredOptions) -> Options toOptions Nothing = DEFAULT_OPTIONS @@ -91,27 +164,25 @@ where } toStoredPackage :: Package -> StoredPackage -toStoredPackage pkg - = { StoredPackage - | name = Just pkg.Package.name - , desc = Just pkg.Package.desc - , author = Just pkg.Package.author - , url = Just pkg.Package.url - , main = Just pkg.Package.main - , depends = listToMaybeList $ map toStoredDep pkg.Package.depends - , paths = listToMaybeList pkg.Package.paths - , options = Just $ toStoredOpts pkg.Package.options - } +toStoredPackage pkg = + { StoredPackage + | name = Just pkg.Package.name + , version = Just pkg.Package.version + , desc = Just pkg.Package.desc + , author = Just pkg.Package.author + , url = Just pkg.Package.url + , main = Just pkg.Package.main + , depends = listToMaybeList $ map toStoredDep pkg.Package.depends + , paths = listToMaybeList pkg.Package.paths + , options = Just $ toStoredOpts pkg.Package.options + } where listToMaybeList :: [a] -> Maybe [a] listToMaybeList [] = Nothing listToMaybeList xs = Just xs toStoredDep :: Dependency -> StoredDependency - toStoredDep d = (d.dep_name, toStoredPackSource d.dep_source) - - toStoredPackSource :: PackageSource -> StoredPackageSource - toStoredPackSource (Git url t) = url + toStoredDep (Package d _) = d // TODO toStoredOpts :: Options -> StoredOptions @@ -125,13 +196,33 @@ where , extra_flags = listToMaybeList opts.Options.extra_flags } -instance <<< Package -where - (<<<) f p = f <<< (jsonPrettyPrint $ toJSON $ toStoredPackage p) +readPackage :: String *World -> *(MaybeErrorString Package, *World) +readPackage f w +# (f`,w) = readFile f w +| isError f` = (Error $ flip (+) (" " + f + ".") $ toString $ fromError f`, w) +# pkg = fromJSON $ fromString $ fromOk f` +| isNothing pkg = (Error "Failed to parse JSON.", w) += (toPackage $ fromJust pkg, w) -readPackage :: String -> *World -> *(Maybe Package, *World) -readPackage f = appFst parse o readFile f -where parse = join o fmap (fmap toPackage o fromJSON o fromString) o error2mb +resolveDependencies :: Repository Package -> MaybeErrorString [(Dependency, Version)] +resolveDependencies rep pkg = res [] pkg.Package.depends +where + res :: [(Dependency, Version)] [Dependency] -> MaybeErrorString [(Dependency, Version)] + 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 + [] = Error $ "No suitable version for " + p + ":" + toString req + "." + os = if (all isError os) (hd os) (hd $ filter isOk os) + # (Just chosen`) = chosen` + | satisfies req chosen` + = res chosen ds + | otherwise + = Error $ "Conflict for " + p + ": " + + toString req + " is needed, but " + + toString chosen` + " is to be installed." + where + chosen` = lookup d chosen getRecursivePaths :: Package *World -> (MaybeErrorString [Path], *World) getRecursivePaths pkg w = getPaths` pkg.Package.paths [] pkg.Package.depends w @@ -140,12 +231,12 @@ where -> (MaybeErrorString [Path], *World) getPaths` ps _ [] w = (Ok ps, w) getPaths` ps pks [d:ds] w - | isMember d.dep_name [p.Package.name \\ p <- pks] + | isMember (depName d) [p.Package.name \\ p <- pks] = getPaths` ps pks ds w - # (pkg,w) = readPackage (MODULE_DIR </> d.dep_name </> PACKAGE_FILE) w - | isNothing pkg - = (Error $ "Could not read " + PACKAGE_FILE + " for " + d.dep_name + ".",w) - # pkg = fromJust pkg + # (pkg,w) = readPackage (MODULE_DIR </> (depName d) </> PACKAGE_FILE) w + | isError pkg + = (Error $ fromError pkg, w) + # pkg = fromOk pkg = getPaths` (removeDup $ ps ++ pkg.Package.paths) [pkg:pks] ds w optionsToFlags :: Options -> [String] diff --git a/CLPM/Repository.dcl b/CLPM/Repository.dcl new file mode 100644 index 0000000..f9dce62 --- /dev/null +++ b/CLPM/Repository.dcl @@ -0,0 +1,36 @@ +definition module CLPM.Repository + +from Data.Error import :: MaybeError, :: MaybeErrorString +from Data.Maybe import :: Maybe + +from Text.JSON import :: JSONNode, generic JSONDecode + +from CLPM.Package import + :: PackageName, :: Version, :: Description, :: Author, :: Url, + :: VersionRequirement + +REPOSITORY :== "clpm.camilstaps.nl" +TIMEOUT :== 10000 +PORT :== 80 + +:: Repository :== [RepositoryItem] + +:: RepositoryItem + = { name :: PackageName + , desc :: Description + , author :: Author + , url :: Url + , versions :: [RepositoryItemVersion] + } + +:: RepositoryItemVersion + = { version :: Version + , depends :: [(PackageName, String)] + } + +derive JSONDecode RepositoryItem, RepositoryItemVersion + +getRepository :: Url *World -> *(MaybeErrorString Repository, *World) + +getVersions :: (PackageName Repository -> [RepositoryItemVersion]) +resolve :: PackageName VersionRequirement Repository -> [RepositoryItemVersion] diff --git a/CLPM/Repository.icl b/CLPM/Repository.icl new file mode 100644 index 0000000..587715f --- /dev/null +++ b/CLPM/Repository.icl @@ -0,0 +1,69 @@ +implementation module CLPM.Repository + +import StdBool +import StdClass +from StdFunc import flip, o +import StdOverloaded + +import TCPIP + +import Control.Applicative +import Control.Monad + +import Data.Error +from Data.Func import $ +import Data.Functor +import Data.Maybe +import Data.Tuple + +import Internet.HTTP + +from Text import instance + String +import Text.JSON + +import CLPM.Package + +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 +| isNothing repo + = (Error $ "Server did not return a repository.", w) +# w = closeChannel sChannel (closeRChannel rChannel w) += (Ok $ fromJust repo, w) +where + req = toByteSeq + { newHTTPRequest + & req_path = "/list.php" + , server_name = REPOSITORY + } + +getVersions :: (PackageName Repository -> [RepositoryItemVersion]) +getVersions = flip (getvs []) +where + getvs :: [RepositoryItemVersion] Repository PackageName -> [RepositoryItemVersion] + getvs vs [] p = vs + getvs vs [i:r] p + | i.RepositoryItem.name == p = getvs (vs ++ i.RepositoryItem.versions) r p + | otherwise = getvs vs r p + +resolve :: PackageName VersionRequirement Repository -> [RepositoryItemVersion] +resolve p req rep = [v \\ ri <- rep, v <- ri.versions + | ri.RepositoryItem.name == p && satisfies req v.RepositoryItemVersion.version] diff --git a/CLPM/Util.dcl b/CLPM/Util.dcl new file mode 100644 index 0000000..b750058 --- /dev/null +++ b/CLPM/Util.dcl @@ -0,0 +1,7 @@ +definition module CLPM.Util + +from Data.Error import :: MaybeError, :: MaybeErrorString + +class Parse a where Parse :: [Char] -> MaybeErrorString a + +parse :: (String -> MaybeErrorString a) | Parse a diff --git a/CLPM/Util.icl b/CLPM/Util.icl new file mode 100644 index 0000000..a3d016e --- /dev/null +++ b/CLPM/Util.icl @@ -0,0 +1,8 @@ +implementation module CLPM.Util + +import StdEnv + +import Data.Error + +parse :: (String -> MaybeErrorString a) | Parse a +parse = Parse o fromString @@ -24,6 +24,7 @@ import System.Directory import System.File import CLPM.Package +import CLPM.Repository :: Action = NoAction @@ -33,6 +34,8 @@ import CLPM.Package :: Arguments = { package_file :: String , action :: Action + , repository :: String + , clm_options :: [String] } instance zero Arguments @@ -40,6 +43,8 @@ where zero = { package_file = PACKAGE_FILE , action = NoAction + , repository = REPOSITORY + , clm_options = [] } Start w @@ -50,11 +55,11 @@ Start w # (_,w) = fclose io w = w # (pkg,w) = readPackage args.package_file w -| isNothing pkg - # io = io <<< "Could not parse " <<< args.package_file <<< '\n' +| isError pkg + # io = io <<< fromError pkg <<< "\n" # (_,w) = fclose io w = w -# pkg = fromJust pkg +# (Ok pkg) = pkg # (io,w) = do args pkg io w # (_,w) = fclose io w = w @@ -63,24 +68,41 @@ 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 pkg io w + Make = make args.clm_options pkg io w install :: Package *File *World -> *(*File, *World) install pkg io w # (e,w) = fileExists MODULE_DIR w # w = if e w (snd $ createDirectory MODULE_DIR w) -# (r,w) = syscall "echo hello" w -# io = io <<< r <<< "\n" +# (repo,w) = getRepository REPOSITORY w +| isError repo + = (io <<< fromError repo <<< "\n", w) +# (Ok repo) = repo +# io = foldl printRepo io repo +# solv = resolveDependencies repo pkg +| isError solv + = (io <<< fromError solv <<< "\n", w) +# (Ok solv) = solv +# io = io <<< "Dependencies:\n" +# io = printDeps io solv = (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 :: Package *File *World -> *(*File, *World) -make pkg io w +make :: [String] Package *File *World -> *(*File, *World) +make opts pkg io w # (ps,w) = getRecursivePaths pkg w | isError ps = (io <<< fromError ps <<< "\n", w) # ps = fromOk ps # (r,w) = syscall (foldl (+) "clm" [" -I " + p \\ p <- ps] + - foldl (+) "" [" " + f \\ f <- optionsToFlags pkg.options] + + foldl (+) "" [" " + f \\ f <- optionsToFlags pkg.options ++ opts] + " " + pkg.main + " -o " + pkg.main) w = (io,w) @@ -89,6 +111,10 @@ parseArgs miss args [] = (miss, args) parseArgs miss args ["-p":name:rest] = parseArgs miss {args & package_file = name} rest +parseArgs miss args ["-r":repo:rest] + = parseArgs miss {args & repository = repo} rest +parseArgs miss args ["-c":opt:rest] + = parseArgs miss {args & clm_options = args.clm_options ++ [opt]} rest parseArgs miss args ["install":rest] = parseArgs miss {args & action = Install} rest parseArgs miss args ["make":rest] @@ -1,5 +1,6 @@ { "name": "CLPM", + "version": [0,1,0], "desc": "Clean Package Manger", "author": "Camil Staps", "url": "https://github.com/camilstaps/clpm", @@ -9,7 +10,9 @@ "$CLEAN_HOME/lib/clean-platform/OS-Linux", "$CLEAN_HOME/lib/clean-platform/OS-Posix", "$CLEAN_HOME/lib/clean-platform/OS-Independent", - "$CLEAN_HOME/lib/Generics" + "$CLEAN_HOME/lib/clean-platform/OS-Independent/Deprecated/StdLib", + "$CLEAN_HOME/lib/Generics", + "$CLEAN_HOME/lib/TCPIP" ], "options": { "show_result": false, |