path: root/CLPM/Package.icl

implementation module CLPM.Package

import _SystemArray
import StdBool
import StdFile
from StdFunc import flip, o
import StdList
import StdOverloaded
import StdTuple

import GenEq

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

import System.Directory
import System.File
import System.FilePath
import System.Platform

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
	  , main    :: Maybe Path
	  , depends :: Maybe [StoredDependency]
	  , paths   :: Maybe [Path]
	  , options :: Maybe StoredOptions
	  }

:: StoredDependency :== String

:: StoredOptions
	= { show_result       :: Maybe Bool
	  , show_constructors :: Maybe Bool
	  , show_time         :: Maybe Bool
	  , heap_size         :: Maybe Int
	  , stack_size        :: Maybe Int
	  , extra_flags       :: Maybe [String]
	  }

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    = spkg.StoredPackage.main
	, depends = ds
	, paths   = fromJust $ spkg.StoredPackage.paths <|> Just DEFAULT_PATHS
	, options = toOptions spkg.StoredPackage.options
	}
where
	depends` = fromJust $ spkg.StoredPackage.depends <|> Just []

	toOptions :: (Maybe StoredOptions) -> Options
	toOptions Nothing = DEFAULT_OPTIONS
	toOptions (Just opts) =
		{ Options
		| show_result       = fromJust $
			opts.StoredOptions.show_result <|>
			Just DEFAULT_OPTIONS.Options.show_result
		, show_constructors = fromJust $
			opts.StoredOptions.show_constructors <|>
			Just DEFAULT_OPTIONS.Options.show_constructors
		, show_time = fromJust $
			opts.StoredOptions.show_time <|>
			Just DEFAULT_OPTIONS.Options.show_time
		, heap_size = fromJust $
			opts.StoredOptions.heap_size <|>
			Just DEFAULT_OPTIONS.Options.heap_size
		, stack_size = fromJust $
			opts.StoredOptions.stack_size <|>
			Just DEFAULT_OPTIONS.Options.stack_size
		, extra_flags = fromJust $
			opts.StoredOptions.extra_flags <|>
			Just DEFAULT_OPTIONS.Options.extra_flags
		}

toStoredPackage :: Package -> StoredPackage
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    = 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 (Package d _) = d
	// TODO

	toStoredOpts :: Options -> StoredOptions
	toStoredOpts opts =
		{ StoredOptions
		| show_result       = Just opts.Options.show_result
		, show_constructors = Just opts.Options.show_constructors
		, show_time         = Just opts.Options.show_time
		, heap_size         = Just opts.Options.heap_size
		, stack_size        = Just opts.Options.stack_size
		, extra_flags       = listToMaybeList opts.Options.extra_flags
		}

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)

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
where
	getPaths` :: [Path] [Package] [Dependency] *World
		-> (MaybeErrorString [Path], *World)
	getPaths` ps _   []     w = (Ok ps, w)
	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
	| isError pkg
		= (Error $ fromError pkg, w)
	# pkg = fromOk pkg
	= getPaths` (removeDup $ ps ++ pkg.Package.paths) [pkg:pks] ds w

optionsToFlags :: Options -> [String]
optionsToFlags opts
	= if opts.Options.show_result [] ["-nr"]
	++ if opts.Options.show_constructors ["-sc"] ["-b"]
	++ if opts.Options.show_time ["-t"] ["-nt"]
	++ ["-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"