diff options
Diffstat (limited to 'CLPM')
| -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 |
6 files changed, 292 insertions, 55 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 |