1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141 |
- ;;; Qire --- The Qi Remote Extension
- ;;;
- ;;; Copyright (C) 2020 Kevin "The Nuclear" Bloom <nuclearkev@dragora.org>
- ;;;
- ;;; This file is part of qire.
- ;;;
- ;;; Qire is free software: you can redistribute it and/or modify
- ;;; it under the terms of the GNU General Public License as published by
- ;;; the Free Software Foundation, either version 3 of the License, or
- ;;; (at your option) any later version.
- ;;;
- ;;; Qire is distributed in the hope that it will be useful,
- ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;;; GNU General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU General Public License
- ;;; along with Qire. If not, see <http://www.gnu.org/licenses/>.
- ;; Error Codes:
- ;; 0 - no config found
- ;; 1 - no repos
- ;; 3 - invalid command
- (local view (include :fennelview))
- (local lf (include :lispy-fennel))
- (local str lf.str)
- (local list lf.list)
- (local tbl lf.tbl)
- (local iter lf.iteration)
- (local version "0.0.5")
- (local help-text
- "Qire - Qi Remote Extension
- Usage: qire COMMAND [OPTIONS...] [ARGUMENTS...]
- qire install,downgrade,info [-r,--repo repo] [-l,--local] [-f,--force] pkg1 [pkgs...]
- qire upgrade,search [-r,--repo repo] [-l,--local] [-f,--force] [pkgs...]
- qire install,upgrade,downgrade [-r,--repo repo] [-f,--force] -c,--category category
- qire search [-l, --local] -c,--category category
- qire fetch [-r,--repo repo] [-o,--output-directory dir] pkg1 [pkgs...]
- qire fetch [-r,--repo repo] -c,--category category
- qire sync,build-index repo1 [repos...]
- qire remove pkg
- qire remove -c,--category category
- qire clean,version,help
- Remote/Local Comamnds:
- install Install packages from the repo(s) or local filesystem
- upgrade Upgrade installed packages from the repo(s) or local filesystem
- downgrade Downgrade installed packages from the repo(s) or local filesystem
- search Search the repo(s) or local filesystem for a particular package
- info Display information on a package in the repo(s) or local filesystem
- Remote-Only Commands:
- sync Sync the local repo(s) tree
- fetch Fetch package from repo
- build-index Build index files for repos in config
- Local-Only Commands:
- remove Remove installed packages
- clean Clean out the Qire cache directory
- Options:
- -c, --category Supply a category name rather than a package name to an applicable command
- -f, --force Force a command to be reran
- -l, --local Run an applicable command locally
- -o, --output-directory Choose a different output directory for fetched packages
- -r, --repo Select which repo(s) you'd like to use
- Other Commands:
- version, --version Display the version
- help, --help Display this help information")
- (local many-options
- [;; commands
- :install
- :sync
- :upgrade
- :downgrade
- :fetch
- :search
- :remove
- :info
- :build-index])
- (local single-options
- [:-r :--repo
- :-o :--output-directory
- :-c :--category])
- (local no-options
- [:clean
- :help
- :version
- :-h :--help
- :-v :--version
- :-l :--local
- :-f :--force])
- (local etc/qire "/etc/qire/")
- (local var/cache/qire "/var/cache/qire/")
- (local graft-pkg-path
- (let [pipe (io.popen "qi -L | grep QI_PACKAGEDIR | cut -c 15-")
- pipe-data (pipe:read "*a")]
- (pipe:close)
- (..
- (str.take
- pipe-data
- -2)
- "/")))
- (fn wget! [url output-file]
- (if output-file
- (os.execute (.. "wget -q --show-progress " url " -O " output-file))
- (let [p (io.popen (.. "wget -q --show-progress -O - " url))
- d (p:read "*a")]
- (p:close)
- d)))
- ;;; extract-tr :: HTML -> List String
- (fn extract-tr [tb]
- (let [tr-pos (string.find tb "<tr")
- end-tr-pos (string.find tb "</tr>")]
- (if tr-pos
- (let [tr (string.sub tb tr-pos end-tr-pos)
- end-tr-pos-including-tr (+ end-tr-pos 5)
- a-href-pos (string.find tr "<a href=")
- end-a-pos (string.find tr "</a>")
- a (string.sub tr a-href-pos end-a-pos)
- href (. (str.split a "\"") 2)
- remaining (str.drop tb end-tr-pos-including-tr)]
- (if (or (string.find href ".tlz" -4)
- (and (string.find href "/")
- (not (= href "../"))))
- (list.append [href] (extract-tr remaining))
- (extract-tr remaining)))
- [])))
- ;;; find-package-txt :: HTML -> List String
- (fn find-package-txt [file]
- (let [table-pos (string.find file "<tbody>")
- end-table-pos (string.find file "</tbody>")
- table (string.sub file table-pos end-table-pos)]
- (extract-tr table)))
- (fn info-property [data prop]
- (if data
- (let [fir-pos (string.find data prop)]
- (if fir-pos
- (let [without (str.drop data fir-pos)
- end-pos (string.find without "\n")]
- (if end-pos
- (let [substring (str.take without end-pos)]
- (string.sub
- (str.drop
- substring
- (+ (length prop) 2))
- 1
- -2))))))))
- (fn get-txt-file-and-put [old-url url file-name repo-url]
- (print url)
- (let [full-tlz (list.last (str.split url "/"))
- list-tlz (list.reverse (str.split full-tlz "_"))
- path (str.drop old-url (length repo-url))]
- (if (< (length list-tlz) 3)
- (let [name (. (str.split full-tlz "%.") 1)
- meta-file-data (wget! (.. url ".txt"))
- after-name (. (str.split meta-file-data (.. "pkgname=" name)) 2)
- version (list.car
- (str.split
- (info-property after-name "pkgversion")
- "\n"))
- arch (list.car
- (str.split
- (info-property after-name "arch")
- "\n"))
- release (list.car
- (str.split
- (info-property after-name "release")
- "\n"))
- cat (.
- (str.split
- (list.car
- (str.split
- (info-property after-name "pkgcategory")
- "\n"))
- "\"")
- 2)]
- (file-name:write
- (.. name "_"
- version "_"
- arch "-"
- release "@"
- cat ".tlz "
- path " "
- 1 "\n")))
- (let [writeable-string (.. full-tlz " " path "\n")]
- (file-name:write writeable-string)))))
- (fn check-for-dirs [maybe-dir url file-name repo-url]
- (let [new-url (.. url maybe-dir)]
- (if (string.find maybe-dir "/")
- ;; yes, a dir - go deeper!
- new-url
- ;; not a dir
- (get-txt-file-and-put url new-url file-name repo-url))))
- (fn parse-html [page file-port repo-url]
- (let [html page.html
- url page.url
- package-txt (find-package-txt html)]
- (each [k v (ipairs package-txt)]
- (let [url? (check-for-dirs v url file-port repo-url)]
- (if (= (type url?) "string")
- (parse-html
- {:html (wget! url? nil)
- :url url?}
- file-port
- repo-url))
- nil))))
- ;; read-repo-list :: Either (List String, False) -> '(Repo-Id . Repo-Url)
- ;; (fn read-repo-list [only]
- ;; "Reads the config and returns '(<id> . <url>)"
- ;; (let [path (.. etc/qire "config")
- ;; file (io.open path "r")
- ;; file-data (file:read "*a")
- ;; comments-removed (iter.filter
- ;; (fn [x]
- ;; (not (string.find x "#" 1)))
- ;; (str.split file-data "\n"))
- ;; repo-strings (iter.filter
- ;; (fn [x]
- ;; (not (= "" x)))
- ;; (iter.map
- ;; (fn [x]
- ;; (if (string.find x "repo" 4)
- ;; (str.drop x 6)
- ;; x))
- ;; comments-removed))]
- ;; (iter.filter-map
- ;; (fn [x]
- ;; (let [repo-cons (str.split x " ")
- ;; id (. repo-cons 2)
- ;; url (. repo-cons 3)
- ;; make-repo-table (fn [cons] {:id id :url url})]
- ;; (if only
- ;; (if (tbl.find id only)
- ;; (make-repo-table repo-cons))
- ;; (make-repo-table repo-cons))))
- ;; repo-strings)))
- (fn read-config [only]
- "Reads the config and returns a tbl containing the default repos and the others.
- ONLY can be a list of Repo-Ids or a list containing `:all` to force all repos."
- (let [path (.. etc/qire "qirerc")
- file (io.open path "r")]
- (if file
- (let [file-data (file:read "*a")
- comments-removed (iter.filter
- (fn [x]
- (not (string.find x "#" 1)))
- (str.split file-data "\n"))
- default-list (iter.filter-map
- (fn [x]
- (if (and (not (= "" x))
- (string.find x "default" 1))
- (str.drop x 9)))
- comments-removed)
- default-setting (if (list.empty? default-list)
- []
- (str.split
- (. default-list 1)
- " "))
- repo-strings (iter.filter-map
- (fn [x]
- (if (and (not (= "" x))
- (string.find x "repo" 1))
- (str.drop x 6)))
- comments-removed)
- create-repo-tbl (fn [rs]
- (iter.filter-map
- (fn [x]
- (let [repo-cons (str.split x " ")
- trimmed (iter.filter
- (fn [s]
- (not
- (= s "")))
- repo-cons)
- id (. trimmed 1)
- url (. trimmed 2)
- make-repo-table (fn [cons] {:id id :url url})]
- (make-repo-table trimmed)))
- rs))
- all-repos (create-repo-tbl repo-strings)
- filter-defaults (fn [rs f] (iter.filter f rs))
- default-repos (if (and only (= (list.car only) :all))
- all-repos
- only
- (filter-defaults
- all-repos
- #(tbl.find $1.id only))
- (= (list.car default-setting) "all")
- all-repos
- (filter-defaults
- all-repos
- #(tbl.find $1.id default-setting)))
- other-repos (if (and only (= (list.car only) :all))
- []
- only
- (filter-defaults
- all-repos
- #(not (tbl.find $1.id only)))
- (= (list.car default-setting) "all")
- []
- (filter-defaults
- all-repos
- #(not (tbl.find $1.id default-setting))))]
- (file:close)
- (when (list.empty? repo-strings)
- (print "Error 1: Config lacks repos."))
- {:default default-repos
- :other other-repos})
- (do (print "Error 0: No config file found!")
- {:default [] :other []}))))
- ;;; exhaustively-get-data :: List (List ID URL HTML) -> File-Name -> List String
- (fn build-index! [only-repos out-dir]
- (let [output-dir (if out-dir
- (if (string.find out-dir "/" -1)
- out-dir
- (.. out-dir "/"))
- "./")
- repos-to-build (if (list.empty? only-repos)
- [:all]
- only-repos)
- config (read-config repos-to-build)
- repos config.default]
- (each [k repo (ipairs repos)]
- (let [index-name (.. output-dir repo.id ".index")
- file-port (io.open index-name "w+b")
- html (wget! repo.url nil)
- page {:html html :url repo.url}]
- (io.write (.. "Creating index for dragora-i586..."))
- (file-port:write "")
- (parse-html page file-port repo.url)
- (print (.. "Saved index to: " index-name))
- (file-port:close)))))
- (fn extract-package-values [pkg-data]
- (let [pkg-list (str.split pkg-data " ")
- pkg-name (. pkg-list 1)
- version (. pkg-list 2)
- release (. pkg-list 3)
- arch (. pkg-list 4)
- path (. pkg-list 5)
- without-version? (. pkg-list 6)]
- {:pkg-name pkg-name
- :version version
- :release release
- :arch arch
- :path path
- :without-version? without-version?}))
- (fn generate-full-tlz [pkg path?]
- "Returns the full .tlz file name for PKG. PKG must be of form: {:repo-id String :url Pkg-Data}.
- Optionally returns the path if PATH? is `true`."
- (let [epkg (extract-package-values pkg)
- file-name (if epkg.without-version?
- (.. epkg.pkg-name ".tlz")
- (.. epkg.pkg-name "-"
- epkg.version "-"
- epkg.arch "+"
- epkg.release ".tlz"))]
- (if path?
- {:tlz file-name :path epkg.path}
- file-name)))
- (fn exact-compare-repo [pkg query]
- (let [pkg-name (list.car (str.split pkg "_"))]
- (= pkg-name query)))
- (fn exact-compare-cat [pkg query tlz?]
- (let [tlz (if tlz?
- ".tlz"
- "")
- split-by-at (str.split pkg "@")
- cat-name (when (= (length split-by-at) 2)
- (list.car (str.split (. split-by-at 2) " ")))]
- ;; Not sure why but splitting by period "." and "\." doesn't work...
- (= cat-name (.. query tlz))))
- ;; Search-Type :: Either :lazy :exact
- ;; search-repo :: String -> Search-Type -> List ( (Repo-Id . Repo-Url) )
- (fn search-repos [query search-type repos]
- "Search in REPOS for QUERY. Returns '(<index-file-name> . <pkg-data>) of type
- pair? of string? . string?"
- (list.flatten
- (iter.filter-map
- (fn [repo]
- (let [index-file-name (.. etc/qire repo.id ".index")
- file (io.open index-file-name "r")]
- (if file
- (let [file-data (file:read "*a")
- pkg-list (str.split file-data "\n")
- ;; due to lua's `string.find` being unable to work with '-${text}'
- q (if (and query (string.find query "-"))
- (iter.reduce
- (fn [acc elem]
- (if (= acc "")
- elem
- (.. acc "%-" elem)))
- ""
- (str.split query "-"))
- query)
- pkgs (iter.filter-map
- (fn [x]
- (let [contains? (if query
- (string.find x q)
- (not (= x "")))]
- (if (and contains? (not query))
- {:pkg x
- :repo-id repo.id}
- (and contains? (= search-type :exact))
- (let [exact? (exact-compare-repo x query)]
- (if exact?
- {:pkg x
- :repo-id repo.id}))
- (and contains? (= search-type :category))
- (let [exact? (exact-compare-cat x query true)]
- (if exact?
- {:pkg x
- :repo-id repo.id}))
- contains?
- {:pkg x
- :repo-id repo.id})))
- pkg-list)]
- (if (and pkgs (not (list.empty? pkgs)))
- pkgs))
- (print (.. "No index file found for " repo.id ". Use `qire sync` to sync down the latest package tree.")))))
- repos)))
- (fn try-all-repos [config func]
- "CONFIG is the table returned from `read-config` and FUNC is a partially applied
- function who's last argument must be a list of repos.
- This function will attempt all repos starting with the defaults."
- (let [defaults config.default
- others config.other]
- (if (not
- (and (list.empty? defaults)
- (list.empty? others)))
- (let [found (func defaults)]
- (if (list.empty? found)
- (do (print
- "Found no results in default repos.")
- (let [others-found (func others)]
- (if (list.empty? others-found)
- (print "Found no results in other repos.")
- found)))
- found)))))
- ;; search-repo! :: String -> Either (List String, False) -> IO ()
- (fn search-repos! [query only-repos search-type]
- "Search the repo indexes for QUERY. This will find the first package with
- QUERY in the pkgname. Optionally, specify which repo you'd like to search via
- ONLY-REPO, which is of type `list?` of `string?`. SEARCH-TYPE is only set when
- searching via category and is usually set to :category."
- (let [config (read-config only-repos)
- s-type (if search-type
- search-type
- :lazy)
- pkgs (try-all-repos
- config
- (partial search-repos query s-type))]
- (when pkgs
- (each [k pkg (ipairs pkgs)]
- (when (not (= pkg.pkg ""))
- (let [name (list.car (str.split pkg.pkg " "))]
- (print
- (.. name
- " from <"
- pkg.repo-id
- ">"))))))))
- ;; CANNOT TEST THIS UNTIL THERE IS AN INDEX AVAILABLE!
- ;; sync-repos! :: Either (List String, False) -> IO ()
- (fn sync-repos! [only-repos]
- "Find repos in config and fetch their `packages.index` files. Saves each found
- index under `<repo-id>.index`."
- (let [repos-to-build (if (list.empty? only-repos)
- [:all]
- only-repos)
- config (read-config repos-to-build)
- repos config.default]
- (each [k repo (ipairs repos)]
- (do
- (print (.. "Updating " repo.id "..."))
- (let [path etc/qire
- url-index (.. repo.url "packages.index")
- index-name (.. path repo.id ".index")]
- (wget! url-index index-name) ;file called <repo-id>.index
- (print "Success!"))))))
- (fn parse-installed [pkg]
- (let [split-list (str.split pkg "_")]
- (if (> (length split-list) 1)
- (let [[arch back] (str.split (list.last split-list) "-")
- [release cat] (str.split back "@")
- version (. split-list 2)
- pkg-name (. split-list 1)]
- {:full pkg
- :pkg-name pkg-name
- :version version
- :arch arch
- :release release
- :cat cat})
- ;; lacks version in tlz name
- (let [file (io.open (.. graft-pkg-path pkg "/var/lib/qi/" pkg ".txt") "r")
- file-data (file:read "*a")]
- (file:close)
- (let [after-name (. (str.split file-data "pkgname=") 2)
- pkg-name (info-property after-name "pkgname")
- version (info-property after-name "pkgversion")
- arch (info-property after-name "arch")
- release (info-property after-name "release")
- cat (info-property after-name "pkgcategory")]
- {:full pkg
- :pkg-name pkg
- :version version
- :arch arch
- :release release
- :cat cat})))))
- (fn exact-compare-installed [pkg query]
- (let [p (parse-installed pkg)]
- (= p.pkg-name query)))
- ;; search-installed :: String -> Search-Type -> List ( (Pkg-Dir . Pkg-Name) )
- (fn search-installed [query search-type]
- "Search in `graft-pkg-path` for PKG-NAME. Returns all matches in the form
- '(<pkg-dir> . <pkg-name>)."
- (let [pipe (io.popen (.. "ls " graft-pkg-path))
- pkgs (pipe:read "*a")
- pkgs-list (str.split pkgs "\n")
- q (if (and query (string.find query "-"))
- (iter.reduce
- (fn [acc elem]
- (if (= acc "")
- elem
- (.. acc "%-" elem)))
- ""
- (str.split query "-"))
- query)]
- (pipe:close)
- (iter.filter-map
- (fn [pkg]
- (let [contains? (if query
- (string.find pkg q)
- (not (= pkg "")))
- found? (if (and contains? (not query))
- true
- (and contains? (= search-type :exact))
- (exact-compare-installed pkg query)
- (and contains? (= search-type :category))
- (exact-compare-cat pkg query false)
- contains?)]
- (if found?
- (.. graft-pkg-path pkg))))
- pkgs-list)))
- ;; search-installed! :: String -> IO ()
- (fn search-installed! [pkg-name search-type]
- "Search for PKG-NAME using SEARCH-INSTALLED. Prints out locations."
- (let [matches (search-installed pkg-name search-type)]
- (if (and (= search-type :lazy)
- (list.empty? matches))
- (print "Package not installed.")
- (and (= search-type :category)
- (list.empty? matches))
- (print (.. "No packages found in category: " pkg-name))
- (each [k pkg (ipairs matches)]
- (print
- (.. "Package found at: " pkg))))))
- (fn select-installed-match [query matches]
- (print (.. "Found multiple matches of '"
- query
- "', select which package:"))
- (each [idx pkg (ipairs matches)]
- (print
- (..
- "[" idx "] " pkg)))
- (io.write
- (..
- "[1-" (length matches) "/n]: "))
- (io.flush)
- (let [selection-string (io.read 1)
- selection (tonumber selection-string)]
- (if (and selection
- (>= selection 1)
- (<= selection (length matches)))
- (do
- (io.read 1)
- (. matches selection)))))
- ;; remove-packages! :: String -> IO ()
- (fn remove-packages! [pkg-names search-type]
- "Search for PKG-NAMES and delete them using qi."
- (let [pkgs (if (= search-type :exact)
- (iter.filter-map
- (fn [x]
- (let [pkgs (search-installed x search-type)]
- (if (list.empty? pkgs)
- (print (.. "No package found with by name: " x))
- (> (length pkgs) 1)
- (select-installed-match x pkgs)
- (. pkgs 1))))
- pkg-names)
- (let [category (. pkg-names 1)
- pkgs (search-installed category search-type)]
- (if (list.empty? pkgs)
- (do (print (.. "No package found with in category: " category))
- [])
- pkgs)))]
- (when (not (list.empty? pkgs))
- (do
- (each [k pkg (ipairs pkgs)]
- (print pkg))
- (io.write "Delete the above packages? [Y/n]: ")
- (io.flush)
- (when (tbl.find (io.read 1) ["Y" "y" "\n"])
- (each [k pkg (ipairs pkgs)]
- (os.execute
- (.. "qi remove " pkg))))))))
- (fn generate-path [pkg config method]
- "Build the full package .tlz name and path on the repo."
- (let [repos (list.append config.default config.other)
- [tlz path no-version] (str.split pkg.pkg " ")
- repo (. (iter.filter
- (fn [repo]
- (= pkg.repo-id repo.id))
- repos)
- 1)
- without-tlz (str.take tlz -5)] ;remove the ".tlz"
- (if (or (= :Upgrade method) (= :Downgrade method))
- (let [ipkg pkg.ipkg
- installed-file-tlz ipkg.full]
- (io.write
- (..
- installed-file-tlz
- " -> "
- without-tlz
- " from <"
- pkg.repo-id
- ">\n")))
- (io.write
- (..
- without-tlz
- " from <"
- pkg.repo-id
- ">\n")))
- (if no-version
- (let [pkg-name (list.car (str.split tlz "_"))]
- {:tlz (.. pkg-name ".tlz")
- :url (.. repo.url path pkg-name ".tlz")})
- {:tlz tlz
- :url (.. repo.url path tlz)})))
- (fn select-match [query matches]
- (print (.. "Found multiple matches of '"
- query
- "', select which package:"))
- (each [idx pkg-tbl (ipairs matches)]
- (let [name (list.car (str.split pkg-tbl.pkg " "))]
- (print
- (..
- "[" idx "] " name " from <" pkg-tbl.repo-id ">"))))
- (io.write
- (..
- "[1-" (length matches) "/n]: "))
- (io.flush)
- (let [selection-string (io.read 1)
- selection (tonumber selection-string)]
- (if (and selection
- (>= selection 1)
- (<= selection (length matches)))
- (do
- (io.read 1)
- (. matches selection)))))
- ;; TODO: qi update
- (fn multiple-n-grade-options [pkg-name ipkgs]
- (print (..
- "Multiple installed versions of "
- pkg-name
- ", select which to take action: "))
- (each [idx ipkg (ipairs ipkgs)]
- (print
- (..
- "[" idx "] " ipkg.full)))
- (io.write
- (..
- "[1-" (length ipkgs) "/n]: "))
- (io.flush)
- (let [selection-string (io.read 1)
- selection (tonumber selection-string)]
- (if (and selection
- (>= selection 1)
- (<= selection (length ipkgs)))
- (do
- (io.read 1)
- (. ipkgs selection)))))
- (fn n-grade-logic [method matched]
- "Logic for upgrading/downgrading. Since they're basically the same. MATCHED must
- be a table returned from `select-match`. Returns MATCHED with an `ipkg` table
- attached to it. (ipkg is returned from `parse-installed`)"
- (let [pkg-list (str.split matched.pkg "_")
- pkg-name (list.car pkg-list)
- pkg-version (. pkg-list 2)
- ipkg-strings (search-installed pkg-name :exact)
- up-or-down (match method
- :Upgrade
- {:past-tense "upgraded"
- :compare #(< $1 $2)
- :already (.. pkg-name " is already up-to-date!")}
- :Downgrade
- {:past-tense "downgraded"
- :compare #(> $1 $2)
- :already (.. pkg-name " is already old enough!")})]
- (if (list.empty? ipkg-strings)
- (print (.. "Don't have a version of "
- pkg-name
- " to be "
- up-or-down.past-tense
- "!"))
- (let [ipkgs (iter.filter-map
- (fn [p]
- (let [ipkg-str (list.last (str.split p "/"))
- just-name (list.last
- (str.split ipkg-str "/"))
- ipkg (parse-installed just-name)]
- (if (not
- (or
- (up-or-down.compare
- pkg-version
- ipkg.version)
- (= pkg-version
- ipkg.version)))
- ipkg)))
- ipkg-strings)]
- (if (list.empty? ipkgs)
- (print up-or-down.already)
- (= (length ipkgs) 1)
- (tbl.merge matched {:ipkg (list.car ipkgs)})
- (let [selection (multiple-n-grade-options pkg-name ipkgs)]
- (if selection
- (tbl.merge matched {:ipkg selection}))))))))
- (fn check-if-downloaded [file-name output-dir]
- (let [pipe (io.popen (.. "ls " output-dir))
- pipe-data (pipe:read "*a")
- pkg-list (str.split pipe-data "\n")]
- (pipe:close)
- (var file? false)
- (var sha? false)
- (each [x v (ipairs pkg-list)]
- (if (= v file-name)
- (set file? true)
- (= v (.. file-name ".sha256"))
- (set sha? true)))
- [file? sha?]))
- ;; Method :: {:Install :Upgrade :Downgrade :Fetch}
- ;; fetch-packages!
- ;; :: List ( String )
- ;; -> Method
- ;; -> Either (List String, Nil)
- ;; -> Either String Nil
- ;; -> IO ()
- (fn fetch-packages! [pkg-names method only-repos out-dir force? search-type]
- "Install or upgrade PKG-NAMES with command selected by METHOD. Optionally,
- from only ONLY-REPOS and, if you want to save the tlz and sha256 files in
- a different location, OUT-DIR. If FORCE?, redownload."
- (let [output-dir (if out-dir
- (if (string.find out-dir "/" -1)
- out-dir
- (.. out-dir "/"))
- var/cache/qire)
- qi-cmd (match method
- :Install "qi install "
- :Upgrade "qi upgrade "
- :Downgrade "qi upgrade "
- :Fetch (..
- "echo Saved package to "
- (if
- output-dir
- output-dir))
- _ "qi install ")
- config (read-config only-repos)
- pkgs (if (= search-type :category)
- (let [name (list.car pkg-names)
- matches (try-all-repos
- config
- (partial search-repos name :category))]
- (if (not matches)
- []
- (list.empty? matches)
- (do (print (.. "Found no packages in category: " name))
- [])
- (= method :Install)
- (iter.filter-map
- (fn [matched]
- (let [pkg-list (str.split matched.pkg "_")
- pkg-name (list.car pkg-list)
- pkg-version (list.cadr pkg-list)
- ipkgs (iter.filter
- (fn [p]
- (let [ipkg-str (list.last (str.split p "/"))
- just-name (list.last
- (str.split ipkg-str "/"))
- ipkg (parse-installed just-name)]
- (= pkg-version
- ipkg.version)))
- (search-installed pkg-name :exact))]
- (if (or force? (list.empty? ipkgs))
- matched
- (print (.. "You already have "
- pkg-name
- " installed, ignoring.")))))
- matches)
- (or (= method :Upgrade) (= method :Downgrade))
- (iter.filter-map
- (fn [matched]
- (n-grade-logic method matched))
- matches)
- matches))
- (iter.filter-map
- (fn [name]
- (let [matches (try-all-repos
- config
- (partial search-repos name :exact))
- matched (if (not matches)
- nil
- (list.empty? matches)
- (print (.. "Found no packages with query: " name))
- (= 1 (length matches))
- (. matches 1)
- (select-match name matches))]
- (if (not matched)
- nil
- (= method :Install)
- (let [pkg-list (str.split matched.pkg "_")
- pkg-name (list.car pkg-list)
- pkg-version (list.cadr pkg-list)
- ipkgs (iter.filter
- (fn [p]
- (let [ipkg-str (list.last (str.split p "/"))
- just-name (list.last
- (str.split ipkg-str "/"))
- ipkg (parse-installed just-name)]
- (= pkg-version
- ipkg.version)))
- (search-installed pkg-name :exact))]
- (if (or force? (list.empty? ipkgs))
- matched
- (print (.. "You already have "
- pkg-name
- " installed!"))))
- (or (= method :Upgrade) (= method :Downgrade))
- (n-grade-logic method matched)
- matched)))
- pkg-names))]
- (if (list.empty? pkgs)
- nil
- (let [files (iter.map
- (fn [pkg]
- (tbl.merge
- (generate-path pkg config method)
- pkg))
- pkgs)]
- (io.write
- (..
- method
- " the above package(s)? [Y/n]: "))
- (io.flush)
- (when (tbl.find (io.read 1) ["Y" "y" "\n"])
- (each [k file (ipairs files)]
- (let [file-name file.tlz
- url file.url
- [file? sha?] (check-if-downloaded file-name output-dir)]
- (when (or (not sha?) (not file?) force?)
- (print
- (..
- "Downloading "
- file-name
- "...\n")))
- (if (and (not force?) sha?)
- (do (print (.. (.. file-name ".sha256") " already fetched. Use -f to refetch."))
- (os.execute (.. "mv "
- var/cache/qire
- file-name
- ".sha256"
- " .")))
- (wget!
- (.. url ".sha256")
- (.. file-name ".sha256")))
- (if (and (not force?) file?)
- (do (print (.. file-name " already fetched. Use -f to refetch."))
- (os.execute (.. "mv "
- var/cache/qire
- file-name
- " .")))
- (wget! url file-name))
- (let [cmd (.. "sha256sum -c "
- file-name
- ".sha256")
- pipe (io.popen cmd)
- pipe-data (pipe:read "*a")]
- (pipe:close)
- (if (string.find pipe-data "OK")
- (do (os.execute (.. qi-cmd file-name))
- (if (not (= "./" output-dir))
- (os.execute (.. "mv "
- file-name
- " "
- file-name
- ".sha256"
- " "
- output-dir))))
- (print "Failed sha256 checksum!"))))))))))
- (fn fetch-info-installed! [name]
- (let [ipkg-string (list.car (search-installed name :exact))]
- (if ipkg-string
- (let [pkg (list.last (str.split ipkg-string "/"))
- file (io.open (.. graft-pkg-path pkg "/var/lib/qi/" pkg ".txt") "r")
- data (file:read "*a")]
- (file:close)
- (let [lines (str.split data "\n\n")
- desc (iter.reduce
- (fn [acc elem]
- (.. acc (str.drop elem 3) "\n"))
- ""
- (str.split (. lines 1) "\n"))
- pkgname (info-property data "pkgname")
- pkgversion (info-property data "pkgversion")
- below-pkgname (. (str.split data (.. "pkgname=" pkgname)) 2)
- arch (info-property below-pkgname "arch")
- release (info-property data "release")
- cat (info-property below-pkgname "pkgcategory")
- homepage (info-property data "homepage")
- license (info-property data "license")]
- (print
- (.. desc
- "Package Name: " pkgname "\n"
- "Version: " pkgversion "\n"
- "Architecture: " arch "\n"
- "Release Number: " release "\n"
- "Category: " cat "\n"
- "License(s): " license "\n"
- "Homepage: " homepage)))))))
- (fn fetch-info! [name only-repos]
- (let [config (read-config only-repos)
- pkg (let [matches (try-all-repos
- config
- (partial search-repos name :exact))]
- (if (or (not matches)
- (list.empty? matches))
- nil
- (= 1 (length matches))
- (. matches 1)
- (select-match name matches)))]
- (when pkg
- (let [file (generate-path pkg config)]
- (print "Fetching information...")
- (let [url (.. file.url ".txt")
- data (wget! url)
- lines (str.split data "\n\n")
- desc (iter.reduce
- (fn [acc elem]
- (.. acc (str.drop elem 3) "\n"))
- ""
- (str.split (. lines 1) "\n"))
- pkgname (info-property data "pkgname")
- pkgversion (info-property data "pkgversion")
- below-pkgname (. (str.split data (.. "pkgname=" pkgname)) 2)
- arch (info-property below-pkgname "arch")
- release (info-property data "release")
- cat (info-property below-pkgname "pkgcategory")
- homepage (info-property data "homepage")
- license (info-property data "license")]
- (print
- (.. desc
- "Package Name: " pkgname "\n"
- "Version: " pkgversion "\n"
- "Architecture: " arch "\n"
- "Release Number: " release "\n"
- "Category: " cat "\n"
- "License(s): " license "\n"
- "Homepage: " homepage "\n"
- "Repository: <" pkg.repo-id ">")))))))
- (fn clear-cache! []
- (os.execute (.. "rm -f " var/cache/qire "*"))
- (print "Cache cleared!"))
- (fn qi [method paths-to-tlzs]
- (let [cmd (match method
- :Install "qi install "
- :Upgrade "qi upgrade "
- "qi install")]
- (each [v pkg (ipairs paths-to-tlzs)]
- (os.execute (.. cmd pkg)))))
- (fn read-args [args]
- "Accepts the full table of arguments and returns the each options with their
- arguments in a table as such: `{:-r [\"dragora-noarch\"] :-i [\"qi\"]}` "
- (var arg-table {})
- (var current nil)
- (var current-single nil)
- (each [k v (pairs args)]
- (when (> k 0)
- (let [multi-cmd? (tbl.find v many-options)
- single-cmd? (tbl.find v single-options)
- no-cmd? (tbl.find v no-options)]
- (if multi-cmd?
- (do (tset arg-table v [])
- (set current v))
- current-single
- (do (tset arg-table current-single [v])
- (set current-single nil))
- (and single-cmd? current)
- (set current-single v)
- single-cmd?
- (do (tset arg-table v [])
- (set current v))
- no-cmd?
- (tset arg-table v [])
- current
- (tset arg-table current (list.append (. arg-table current) [v]))))))
- arg-table)
- (fn main [args]
- (let [args-table (read-args args)
- repos (or args-table.-r args-table.--repo)
- dir? (or args-table.-o args-table.--output-directory)
- dir (if dir? (list.car dir?))
- local? (or args-table.-l args-table.--local)
- force? (or args-table.-f args-table.--force)
- cat? (or args-table.-c args-table.--category)
- cat (if cat? (list.car cat?))]
- (match args-table
- {:install pkgs} (if cat
- (if local?
- (print "Error 3: Invalid command!")
- (fetch-packages! [cat] :Install repos dir force? :category))
- (if local?
- (qi :Install pkgs)
- (fetch-packages! pkgs :Install repos dir force? :exact)))
- {:upgrade pkgs?} (if cat
- (if local?
- (print "Error 3: Invalid command!")
- (fetch-packages! [cat] :Upgrade repos dir force? :category))
- (if local?
- (qi :Upgrade pkgs)
- (if pkgs
- (fetch-packages! pkgs :Upgrade repos dir force? :exact)
- (let [pkgz (search-installed nil :exact)
- just-pkg-names (iter.map
- (fn [p]
- (let [g graft-pkg-path
- just-pkg (str.split p g)]
- (print (view just-pkg))
- (. (str.split (. just-pkg 2) "_") 1)))
- pkgz)]
- ;; TODO: `list.unique` may run slow, needs tested on
- ;; real system.
- (fetch-packages! (list.unique just-pkg-names)
- :Upgrade
- repos
- dir
- force?
- :exact)))))
- {:downgrade pkgs} (if cat
- (if local?
- (print "Error 3: Invalid command!")
- (fetch-packages! [cat] :Downgrade repos dir force? :category))
- (if local?
- (qi :Downgrade pkgs)
- (fetch-packages! pkgs :Downgrade repos dir force? :exact)))
- {:info pkgs} (if local?
- (fetch-info-installed! (. pkgs 1))
- (fetch-info! (. pkgs 1) repos))
- {:search pkgs} (if cat
- (if local?
- (search-installed! cat :category)
- (search-repos! cat repos :category))
- (if local?
- (if pkgs
- (search-installed! (. pkgs 1) :lazy)
- (search-installed! nil :lazy))
- (if pkgs
- (search-repos! (. pkgs 1) repos)
- (search-repos! nil repos))))
- {:fetch pkgs} (fetch-packages! pkgs :Fetch repos dir)
- {:sync only-repos} (sync-repos! only-repos)
- {:build-index only-repos} (build-index! only-repos dir)
- {:remove pkgs} (if cat
- (remove-packages! [cat] :category)
- (remove-packages! pkgs :exact))
- {:clean a?} (clear-cache!)
- {:version a?} (print version)
- {:--version a?} (print version)
- {:help a?} (print help-text)
- {:--help a?} (print help-text)
- _ (print "Unknown command. Try --help for more information!"))))
- (main arg)
|