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.OS
import System.Platform

from Text import class Text(indexOf,split,subString),
	instance Text String, instance + String
import Text.JSON

import Archives.Tar

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] = 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

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
	  , 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

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

	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 ++ 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`
	| 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 (addDir PACKAGE_FILE) w
	| isError pkg
		= (Error $ fromError pkg, w)
	# pkg = fromOk pkg
	= 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
	= 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 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)
# (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) = unTar changeFileName (parseTar $ fromString tar.HTTPResponse.rsp_data) w
| isEmpty err
	= (Ok "Installed.", w)
	= (Error "Failed to untar.", w)
where
	dir = MODULE_DIR </> depName d
	pkg_json = dir </> PACKAGE_FILE
	err_append = " while installing " + depName d + "."

	changeFileName :: (String -> String)
	changeFileName
		= toString
		o ((++) (fromString dir))
		o dropWhile ((<>) OS_PATH_SEPARATOR)
		o fromString

	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"
		, server_name = REPOSITORY
		, server_port = PORT
		}

	platform :: String
	platform = case CURRENT_PLATFORM of
		Linux32   = "linux32"
		Linux64   = "linux64"
		Mac       = "mac"
		Windows32 = "win32"
		Windows64 = "win64"