qire.fnl 44 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141
  1. ;;; Qire --- The Qi Remote Extension
  2. ;;;
  3. ;;; Copyright (C) 2020 Kevin "The Nuclear" Bloom <nuclearkev@dragora.org>
  4. ;;;
  5. ;;; This file is part of qire.
  6. ;;;
  7. ;;; Qire is free software: you can redistribute it and/or modify
  8. ;;; it under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation, either version 3 of the License, or
  10. ;;; (at your option) any later version.
  11. ;;;
  12. ;;; Qire is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with Qire. If not, see <http://www.gnu.org/licenses/>.
  19. ;; Error Codes:
  20. ;; 0 - no config found
  21. ;; 1 - no repos
  22. ;; 3 - invalid command
  23. (local view (include :fennelview))
  24. (local lf (include :lispy-fennel))
  25. (local str lf.str)
  26. (local list lf.list)
  27. (local tbl lf.tbl)
  28. (local iter lf.iteration)
  29. (local version "0.0.5")
  30. (local help-text
  31. "Qire - Qi Remote Extension
  32. Usage: qire COMMAND [OPTIONS...] [ARGUMENTS...]
  33. qire install,downgrade,info [-r,--repo repo] [-l,--local] [-f,--force] pkg1 [pkgs...]
  34. qire upgrade,search [-r,--repo repo] [-l,--local] [-f,--force] [pkgs...]
  35. qire install,upgrade,downgrade [-r,--repo repo] [-f,--force] -c,--category category
  36. qire search [-l, --local] -c,--category category
  37. qire fetch [-r,--repo repo] [-o,--output-directory dir] pkg1 [pkgs...]
  38. qire fetch [-r,--repo repo] -c,--category category
  39. qire sync,build-index repo1 [repos...]
  40. qire remove pkg
  41. qire remove -c,--category category
  42. qire clean,version,help
  43. Remote/Local Comamnds:
  44. install Install packages from the repo(s) or local filesystem
  45. upgrade Upgrade installed packages from the repo(s) or local filesystem
  46. downgrade Downgrade installed packages from the repo(s) or local filesystem
  47. search Search the repo(s) or local filesystem for a particular package
  48. info Display information on a package in the repo(s) or local filesystem
  49. Remote-Only Commands:
  50. sync Sync the local repo(s) tree
  51. fetch Fetch package from repo
  52. build-index Build index files for repos in config
  53. Local-Only Commands:
  54. remove Remove installed packages
  55. clean Clean out the Qire cache directory
  56. Options:
  57. -c, --category Supply a category name rather than a package name to an applicable command
  58. -f, --force Force a command to be reran
  59. -l, --local Run an applicable command locally
  60. -o, --output-directory Choose a different output directory for fetched packages
  61. -r, --repo Select which repo(s) you'd like to use
  62. Other Commands:
  63. version, --version Display the version
  64. help, --help Display this help information")
  65. (local many-options
  66. [;; commands
  67. :install
  68. :sync
  69. :upgrade
  70. :downgrade
  71. :fetch
  72. :search
  73. :remove
  74. :info
  75. :build-index])
  76. (local single-options
  77. [:-r :--repo
  78. :-o :--output-directory
  79. :-c :--category])
  80. (local no-options
  81. [:clean
  82. :help
  83. :version
  84. :-h :--help
  85. :-v :--version
  86. :-l :--local
  87. :-f :--force])
  88. (local etc/qire "/etc/qire/")
  89. (local var/cache/qire "/var/cache/qire/")
  90. (local graft-pkg-path
  91. (let [pipe (io.popen "qi -L | grep QI_PACKAGEDIR | cut -c 15-")
  92. pipe-data (pipe:read "*a")]
  93. (pipe:close)
  94. (..
  95. (str.take
  96. pipe-data
  97. -2)
  98. "/")))
  99. (fn wget! [url output-file]
  100. (if output-file
  101. (os.execute (.. "wget -q --show-progress " url " -O " output-file))
  102. (let [p (io.popen (.. "wget -q --show-progress -O - " url))
  103. d (p:read "*a")]
  104. (p:close)
  105. d)))
  106. ;;; extract-tr :: HTML -> List String
  107. (fn extract-tr [tb]
  108. (let [tr-pos (string.find tb "<tr")
  109. end-tr-pos (string.find tb "</tr>")]
  110. (if tr-pos
  111. (let [tr (string.sub tb tr-pos end-tr-pos)
  112. end-tr-pos-including-tr (+ end-tr-pos 5)
  113. a-href-pos (string.find tr "<a href=")
  114. end-a-pos (string.find tr "</a>")
  115. a (string.sub tr a-href-pos end-a-pos)
  116. href (. (str.split a "\"") 2)
  117. remaining (str.drop tb end-tr-pos-including-tr)]
  118. (if (or (string.find href ".tlz" -4)
  119. (and (string.find href "/")
  120. (not (= href "../"))))
  121. (list.append [href] (extract-tr remaining))
  122. (extract-tr remaining)))
  123. [])))
  124. ;;; find-package-txt :: HTML -> List String
  125. (fn find-package-txt [file]
  126. (let [table-pos (string.find file "<tbody>")
  127. end-table-pos (string.find file "</tbody>")
  128. table (string.sub file table-pos end-table-pos)]
  129. (extract-tr table)))
  130. (fn info-property [data prop]
  131. (if data
  132. (let [fir-pos (string.find data prop)]
  133. (if fir-pos
  134. (let [without (str.drop data fir-pos)
  135. end-pos (string.find without "\n")]
  136. (if end-pos
  137. (let [substring (str.take without end-pos)]
  138. (string.sub
  139. (str.drop
  140. substring
  141. (+ (length prop) 2))
  142. 1
  143. -2))))))))
  144. (fn get-txt-file-and-put [old-url url file-name repo-url]
  145. (print url)
  146. (let [full-tlz (list.last (str.split url "/"))
  147. list-tlz (list.reverse (str.split full-tlz "_"))
  148. path (str.drop old-url (length repo-url))]
  149. (if (< (length list-tlz) 3)
  150. (let [name (. (str.split full-tlz "%.") 1)
  151. meta-file-data (wget! (.. url ".txt"))
  152. after-name (. (str.split meta-file-data (.. "pkgname=" name)) 2)
  153. version (list.car
  154. (str.split
  155. (info-property after-name "pkgversion")
  156. "\n"))
  157. arch (list.car
  158. (str.split
  159. (info-property after-name "arch")
  160. "\n"))
  161. release (list.car
  162. (str.split
  163. (info-property after-name "release")
  164. "\n"))
  165. cat (.
  166. (str.split
  167. (list.car
  168. (str.split
  169. (info-property after-name "pkgcategory")
  170. "\n"))
  171. "\"")
  172. 2)]
  173. (file-name:write
  174. (.. name "_"
  175. version "_"
  176. arch "-"
  177. release "@"
  178. cat ".tlz "
  179. path " "
  180. 1 "\n")))
  181. (let [writeable-string (.. full-tlz " " path "\n")]
  182. (file-name:write writeable-string)))))
  183. (fn check-for-dirs [maybe-dir url file-name repo-url]
  184. (let [new-url (.. url maybe-dir)]
  185. (if (string.find maybe-dir "/")
  186. ;; yes, a dir - go deeper!
  187. new-url
  188. ;; not a dir
  189. (get-txt-file-and-put url new-url file-name repo-url))))
  190. (fn parse-html [page file-port repo-url]
  191. (let [html page.html
  192. url page.url
  193. package-txt (find-package-txt html)]
  194. (each [k v (ipairs package-txt)]
  195. (let [url? (check-for-dirs v url file-port repo-url)]
  196. (if (= (type url?) "string")
  197. (parse-html
  198. {:html (wget! url? nil)
  199. :url url?}
  200. file-port
  201. repo-url))
  202. nil))))
  203. ;; read-repo-list :: Either (List String, False) -> '(Repo-Id . Repo-Url)
  204. ;; (fn read-repo-list [only]
  205. ;; "Reads the config and returns '(<id> . <url>)"
  206. ;; (let [path (.. etc/qire "config")
  207. ;; file (io.open path "r")
  208. ;; file-data (file:read "*a")
  209. ;; comments-removed (iter.filter
  210. ;; (fn [x]
  211. ;; (not (string.find x "#" 1)))
  212. ;; (str.split file-data "\n"))
  213. ;; repo-strings (iter.filter
  214. ;; (fn [x]
  215. ;; (not (= "" x)))
  216. ;; (iter.map
  217. ;; (fn [x]
  218. ;; (if (string.find x "repo" 4)
  219. ;; (str.drop x 6)
  220. ;; x))
  221. ;; comments-removed))]
  222. ;; (iter.filter-map
  223. ;; (fn [x]
  224. ;; (let [repo-cons (str.split x " ")
  225. ;; id (. repo-cons 2)
  226. ;; url (. repo-cons 3)
  227. ;; make-repo-table (fn [cons] {:id id :url url})]
  228. ;; (if only
  229. ;; (if (tbl.find id only)
  230. ;; (make-repo-table repo-cons))
  231. ;; (make-repo-table repo-cons))))
  232. ;; repo-strings)))
  233. (fn read-config [only]
  234. "Reads the config and returns a tbl containing the default repos and the others.
  235. ONLY can be a list of Repo-Ids or a list containing `:all` to force all repos."
  236. (let [path (.. etc/qire "qirerc")
  237. file (io.open path "r")]
  238. (if file
  239. (let [file-data (file:read "*a")
  240. comments-removed (iter.filter
  241. (fn [x]
  242. (not (string.find x "#" 1)))
  243. (str.split file-data "\n"))
  244. default-list (iter.filter-map
  245. (fn [x]
  246. (if (and (not (= "" x))
  247. (string.find x "default" 1))
  248. (str.drop x 9)))
  249. comments-removed)
  250. default-setting (if (list.empty? default-list)
  251. []
  252. (str.split
  253. (. default-list 1)
  254. " "))
  255. repo-strings (iter.filter-map
  256. (fn [x]
  257. (if (and (not (= "" x))
  258. (string.find x "repo" 1))
  259. (str.drop x 6)))
  260. comments-removed)
  261. create-repo-tbl (fn [rs]
  262. (iter.filter-map
  263. (fn [x]
  264. (let [repo-cons (str.split x " ")
  265. trimmed (iter.filter
  266. (fn [s]
  267. (not
  268. (= s "")))
  269. repo-cons)
  270. id (. trimmed 1)
  271. url (. trimmed 2)
  272. make-repo-table (fn [cons] {:id id :url url})]
  273. (make-repo-table trimmed)))
  274. rs))
  275. all-repos (create-repo-tbl repo-strings)
  276. filter-defaults (fn [rs f] (iter.filter f rs))
  277. default-repos (if (and only (= (list.car only) :all))
  278. all-repos
  279. only
  280. (filter-defaults
  281. all-repos
  282. #(tbl.find $1.id only))
  283. (= (list.car default-setting) "all")
  284. all-repos
  285. (filter-defaults
  286. all-repos
  287. #(tbl.find $1.id default-setting)))
  288. other-repos (if (and only (= (list.car only) :all))
  289. []
  290. only
  291. (filter-defaults
  292. all-repos
  293. #(not (tbl.find $1.id only)))
  294. (= (list.car default-setting) "all")
  295. []
  296. (filter-defaults
  297. all-repos
  298. #(not (tbl.find $1.id default-setting))))]
  299. (file:close)
  300. (when (list.empty? repo-strings)
  301. (print "Error 1: Config lacks repos."))
  302. {:default default-repos
  303. :other other-repos})
  304. (do (print "Error 0: No config file found!")
  305. {:default [] :other []}))))
  306. ;;; exhaustively-get-data :: List (List ID URL HTML) -> File-Name -> List String
  307. (fn build-index! [only-repos out-dir]
  308. (let [output-dir (if out-dir
  309. (if (string.find out-dir "/" -1)
  310. out-dir
  311. (.. out-dir "/"))
  312. "./")
  313. repos-to-build (if (list.empty? only-repos)
  314. [:all]
  315. only-repos)
  316. config (read-config repos-to-build)
  317. repos config.default]
  318. (each [k repo (ipairs repos)]
  319. (let [index-name (.. output-dir repo.id ".index")
  320. file-port (io.open index-name "w+b")
  321. html (wget! repo.url nil)
  322. page {:html html :url repo.url}]
  323. (io.write (.. "Creating index for dragora-i586..."))
  324. (file-port:write "")
  325. (parse-html page file-port repo.url)
  326. (print (.. "Saved index to: " index-name))
  327. (file-port:close)))))
  328. (fn extract-package-values [pkg-data]
  329. (let [pkg-list (str.split pkg-data " ")
  330. pkg-name (. pkg-list 1)
  331. version (. pkg-list 2)
  332. release (. pkg-list 3)
  333. arch (. pkg-list 4)
  334. path (. pkg-list 5)
  335. without-version? (. pkg-list 6)]
  336. {:pkg-name pkg-name
  337. :version version
  338. :release release
  339. :arch arch
  340. :path path
  341. :without-version? without-version?}))
  342. (fn generate-full-tlz [pkg path?]
  343. "Returns the full .tlz file name for PKG. PKG must be of form: {:repo-id String :url Pkg-Data}.
  344. Optionally returns the path if PATH? is `true`."
  345. (let [epkg (extract-package-values pkg)
  346. file-name (if epkg.without-version?
  347. (.. epkg.pkg-name ".tlz")
  348. (.. epkg.pkg-name "-"
  349. epkg.version "-"
  350. epkg.arch "+"
  351. epkg.release ".tlz"))]
  352. (if path?
  353. {:tlz file-name :path epkg.path}
  354. file-name)))
  355. (fn exact-compare-repo [pkg query]
  356. (let [pkg-name (list.car (str.split pkg "_"))]
  357. (= pkg-name query)))
  358. (fn exact-compare-cat [pkg query tlz?]
  359. (let [tlz (if tlz?
  360. ".tlz"
  361. "")
  362. split-by-at (str.split pkg "@")
  363. cat-name (when (= (length split-by-at) 2)
  364. (list.car (str.split (. split-by-at 2) " ")))]
  365. ;; Not sure why but splitting by period "." and "\." doesn't work...
  366. (= cat-name (.. query tlz))))
  367. ;; Search-Type :: Either :lazy :exact
  368. ;; search-repo :: String -> Search-Type -> List ( (Repo-Id . Repo-Url) )
  369. (fn search-repos [query search-type repos]
  370. "Search in REPOS for QUERY. Returns '(<index-file-name> . <pkg-data>) of type
  371. pair? of string? . string?"
  372. (list.flatten
  373. (iter.filter-map
  374. (fn [repo]
  375. (let [index-file-name (.. etc/qire repo.id ".index")
  376. file (io.open index-file-name "r")]
  377. (if file
  378. (let [file-data (file:read "*a")
  379. pkg-list (str.split file-data "\n")
  380. ;; due to lua's `string.find` being unable to work with '-${text}'
  381. q (if (and query (string.find query "-"))
  382. (iter.reduce
  383. (fn [acc elem]
  384. (if (= acc "")
  385. elem
  386. (.. acc "%-" elem)))
  387. ""
  388. (str.split query "-"))
  389. query)
  390. pkgs (iter.filter-map
  391. (fn [x]
  392. (let [contains? (if query
  393. (string.find x q)
  394. (not (= x "")))]
  395. (if (and contains? (not query))
  396. {:pkg x
  397. :repo-id repo.id}
  398. (and contains? (= search-type :exact))
  399. (let [exact? (exact-compare-repo x query)]
  400. (if exact?
  401. {:pkg x
  402. :repo-id repo.id}))
  403. (and contains? (= search-type :category))
  404. (let [exact? (exact-compare-cat x query true)]
  405. (if exact?
  406. {:pkg x
  407. :repo-id repo.id}))
  408. contains?
  409. {:pkg x
  410. :repo-id repo.id})))
  411. pkg-list)]
  412. (if (and pkgs (not (list.empty? pkgs)))
  413. pkgs))
  414. (print (.. "No index file found for " repo.id ". Use `qire sync` to sync down the latest package tree.")))))
  415. repos)))
  416. (fn try-all-repos [config func]
  417. "CONFIG is the table returned from `read-config` and FUNC is a partially applied
  418. function who's last argument must be a list of repos.
  419. This function will attempt all repos starting with the defaults."
  420. (let [defaults config.default
  421. others config.other]
  422. (if (not
  423. (and (list.empty? defaults)
  424. (list.empty? others)))
  425. (let [found (func defaults)]
  426. (if (list.empty? found)
  427. (do (print
  428. "Found no results in default repos.")
  429. (let [others-found (func others)]
  430. (if (list.empty? others-found)
  431. (print "Found no results in other repos.")
  432. found)))
  433. found)))))
  434. ;; search-repo! :: String -> Either (List String, False) -> IO ()
  435. (fn search-repos! [query only-repos search-type]
  436. "Search the repo indexes for QUERY. This will find the first package with
  437. QUERY in the pkgname. Optionally, specify which repo you'd like to search via
  438. ONLY-REPO, which is of type `list?` of `string?`. SEARCH-TYPE is only set when
  439. searching via category and is usually set to :category."
  440. (let [config (read-config only-repos)
  441. s-type (if search-type
  442. search-type
  443. :lazy)
  444. pkgs (try-all-repos
  445. config
  446. (partial search-repos query s-type))]
  447. (when pkgs
  448. (each [k pkg (ipairs pkgs)]
  449. (when (not (= pkg.pkg ""))
  450. (let [name (list.car (str.split pkg.pkg " "))]
  451. (print
  452. (.. name
  453. " from <"
  454. pkg.repo-id
  455. ">"))))))))
  456. ;; CANNOT TEST THIS UNTIL THERE IS AN INDEX AVAILABLE!
  457. ;; sync-repos! :: Either (List String, False) -> IO ()
  458. (fn sync-repos! [only-repos]
  459. "Find repos in config and fetch their `packages.index` files. Saves each found
  460. index under `<repo-id>.index`."
  461. (let [repos-to-build (if (list.empty? only-repos)
  462. [:all]
  463. only-repos)
  464. config (read-config repos-to-build)
  465. repos config.default]
  466. (each [k repo (ipairs repos)]
  467. (do
  468. (print (.. "Updating " repo.id "..."))
  469. (let [path etc/qire
  470. url-index (.. repo.url "packages.index")
  471. index-name (.. path repo.id ".index")]
  472. (wget! url-index index-name) ;file called <repo-id>.index
  473. (print "Success!"))))))
  474. (fn parse-installed [pkg]
  475. (let [split-list (str.split pkg "_")]
  476. (if (> (length split-list) 1)
  477. (let [[arch back] (str.split (list.last split-list) "-")
  478. [release cat] (str.split back "@")
  479. version (. split-list 2)
  480. pkg-name (. split-list 1)]
  481. {:full pkg
  482. :pkg-name pkg-name
  483. :version version
  484. :arch arch
  485. :release release
  486. :cat cat})
  487. ;; lacks version in tlz name
  488. (let [file (io.open (.. graft-pkg-path pkg "/var/lib/qi/" pkg ".txt") "r")
  489. file-data (file:read "*a")]
  490. (file:close)
  491. (let [after-name (. (str.split file-data "pkgname=") 2)
  492. pkg-name (info-property after-name "pkgname")
  493. version (info-property after-name "pkgversion")
  494. arch (info-property after-name "arch")
  495. release (info-property after-name "release")
  496. cat (info-property after-name "pkgcategory")]
  497. {:full pkg
  498. :pkg-name pkg
  499. :version version
  500. :arch arch
  501. :release release
  502. :cat cat})))))
  503. (fn exact-compare-installed [pkg query]
  504. (let [p (parse-installed pkg)]
  505. (= p.pkg-name query)))
  506. ;; search-installed :: String -> Search-Type -> List ( (Pkg-Dir . Pkg-Name) )
  507. (fn search-installed [query search-type]
  508. "Search in `graft-pkg-path` for PKG-NAME. Returns all matches in the form
  509. '(<pkg-dir> . <pkg-name>)."
  510. (let [pipe (io.popen (.. "ls " graft-pkg-path))
  511. pkgs (pipe:read "*a")
  512. pkgs-list (str.split pkgs "\n")
  513. q (if (and query (string.find query "-"))
  514. (iter.reduce
  515. (fn [acc elem]
  516. (if (= acc "")
  517. elem
  518. (.. acc "%-" elem)))
  519. ""
  520. (str.split query "-"))
  521. query)]
  522. (pipe:close)
  523. (iter.filter-map
  524. (fn [pkg]
  525. (let [contains? (if query
  526. (string.find pkg q)
  527. (not (= pkg "")))
  528. found? (if (and contains? (not query))
  529. true
  530. (and contains? (= search-type :exact))
  531. (exact-compare-installed pkg query)
  532. (and contains? (= search-type :category))
  533. (exact-compare-cat pkg query false)
  534. contains?)]
  535. (if found?
  536. (.. graft-pkg-path pkg))))
  537. pkgs-list)))
  538. ;; search-installed! :: String -> IO ()
  539. (fn search-installed! [pkg-name search-type]
  540. "Search for PKG-NAME using SEARCH-INSTALLED. Prints out locations."
  541. (let [matches (search-installed pkg-name search-type)]
  542. (if (and (= search-type :lazy)
  543. (list.empty? matches))
  544. (print "Package not installed.")
  545. (and (= search-type :category)
  546. (list.empty? matches))
  547. (print (.. "No packages found in category: " pkg-name))
  548. (each [k pkg (ipairs matches)]
  549. (print
  550. (.. "Package found at: " pkg))))))
  551. (fn select-installed-match [query matches]
  552. (print (.. "Found multiple matches of '"
  553. query
  554. "', select which package:"))
  555. (each [idx pkg (ipairs matches)]
  556. (print
  557. (..
  558. "[" idx "] " pkg)))
  559. (io.write
  560. (..
  561. "[1-" (length matches) "/n]: "))
  562. (io.flush)
  563. (let [selection-string (io.read 1)
  564. selection (tonumber selection-string)]
  565. (if (and selection
  566. (>= selection 1)
  567. (<= selection (length matches)))
  568. (do
  569. (io.read 1)
  570. (. matches selection)))))
  571. ;; remove-packages! :: String -> IO ()
  572. (fn remove-packages! [pkg-names search-type]
  573. "Search for PKG-NAMES and delete them using qi."
  574. (let [pkgs (if (= search-type :exact)
  575. (iter.filter-map
  576. (fn [x]
  577. (let [pkgs (search-installed x search-type)]
  578. (if (list.empty? pkgs)
  579. (print (.. "No package found with by name: " x))
  580. (> (length pkgs) 1)
  581. (select-installed-match x pkgs)
  582. (. pkgs 1))))
  583. pkg-names)
  584. (let [category (. pkg-names 1)
  585. pkgs (search-installed category search-type)]
  586. (if (list.empty? pkgs)
  587. (do (print (.. "No package found with in category: " category))
  588. [])
  589. pkgs)))]
  590. (when (not (list.empty? pkgs))
  591. (do
  592. (each [k pkg (ipairs pkgs)]
  593. (print pkg))
  594. (io.write "Delete the above packages? [Y/n]: ")
  595. (io.flush)
  596. (when (tbl.find (io.read 1) ["Y" "y" "\n"])
  597. (each [k pkg (ipairs pkgs)]
  598. (os.execute
  599. (.. "qi remove " pkg))))))))
  600. (fn generate-path [pkg config method]
  601. "Build the full package .tlz name and path on the repo."
  602. (let [repos (list.append config.default config.other)
  603. [tlz path no-version] (str.split pkg.pkg " ")
  604. repo (. (iter.filter
  605. (fn [repo]
  606. (= pkg.repo-id repo.id))
  607. repos)
  608. 1)
  609. without-tlz (str.take tlz -5)] ;remove the ".tlz"
  610. (if (or (= :Upgrade method) (= :Downgrade method))
  611. (let [ipkg pkg.ipkg
  612. installed-file-tlz ipkg.full]
  613. (io.write
  614. (..
  615. installed-file-tlz
  616. " -> "
  617. without-tlz
  618. " from <"
  619. pkg.repo-id
  620. ">\n")))
  621. (io.write
  622. (..
  623. without-tlz
  624. " from <"
  625. pkg.repo-id
  626. ">\n")))
  627. (if no-version
  628. (let [pkg-name (list.car (str.split tlz "_"))]
  629. {:tlz (.. pkg-name ".tlz")
  630. :url (.. repo.url path pkg-name ".tlz")})
  631. {:tlz tlz
  632. :url (.. repo.url path tlz)})))
  633. (fn select-match [query matches]
  634. (print (.. "Found multiple matches of '"
  635. query
  636. "', select which package:"))
  637. (each [idx pkg-tbl (ipairs matches)]
  638. (let [name (list.car (str.split pkg-tbl.pkg " "))]
  639. (print
  640. (..
  641. "[" idx "] " name " from <" pkg-tbl.repo-id ">"))))
  642. (io.write
  643. (..
  644. "[1-" (length matches) "/n]: "))
  645. (io.flush)
  646. (let [selection-string (io.read 1)
  647. selection (tonumber selection-string)]
  648. (if (and selection
  649. (>= selection 1)
  650. (<= selection (length matches)))
  651. (do
  652. (io.read 1)
  653. (. matches selection)))))
  654. ;; TODO: qi update
  655. (fn multiple-n-grade-options [pkg-name ipkgs]
  656. (print (..
  657. "Multiple installed versions of "
  658. pkg-name
  659. ", select which to take action: "))
  660. (each [idx ipkg (ipairs ipkgs)]
  661. (print
  662. (..
  663. "[" idx "] " ipkg.full)))
  664. (io.write
  665. (..
  666. "[1-" (length ipkgs) "/n]: "))
  667. (io.flush)
  668. (let [selection-string (io.read 1)
  669. selection (tonumber selection-string)]
  670. (if (and selection
  671. (>= selection 1)
  672. (<= selection (length ipkgs)))
  673. (do
  674. (io.read 1)
  675. (. ipkgs selection)))))
  676. (fn n-grade-logic [method matched]
  677. "Logic for upgrading/downgrading. Since they're basically the same. MATCHED must
  678. be a table returned from `select-match`. Returns MATCHED with an `ipkg` table
  679. attached to it. (ipkg is returned from `parse-installed`)"
  680. (let [pkg-list (str.split matched.pkg "_")
  681. pkg-name (list.car pkg-list)
  682. pkg-version (. pkg-list 2)
  683. ipkg-strings (search-installed pkg-name :exact)
  684. up-or-down (match method
  685. :Upgrade
  686. {:past-tense "upgraded"
  687. :compare #(< $1 $2)
  688. :already (.. pkg-name " is already up-to-date!")}
  689. :Downgrade
  690. {:past-tense "downgraded"
  691. :compare #(> $1 $2)
  692. :already (.. pkg-name " is already old enough!")})]
  693. (if (list.empty? ipkg-strings)
  694. (print (.. "Don't have a version of "
  695. pkg-name
  696. " to be "
  697. up-or-down.past-tense
  698. "!"))
  699. (let [ipkgs (iter.filter-map
  700. (fn [p]
  701. (let [ipkg-str (list.last (str.split p "/"))
  702. just-name (list.last
  703. (str.split ipkg-str "/"))
  704. ipkg (parse-installed just-name)]
  705. (if (not
  706. (or
  707. (up-or-down.compare
  708. pkg-version
  709. ipkg.version)
  710. (= pkg-version
  711. ipkg.version)))
  712. ipkg)))
  713. ipkg-strings)]
  714. (if (list.empty? ipkgs)
  715. (print up-or-down.already)
  716. (= (length ipkgs) 1)
  717. (tbl.merge matched {:ipkg (list.car ipkgs)})
  718. (let [selection (multiple-n-grade-options pkg-name ipkgs)]
  719. (if selection
  720. (tbl.merge matched {:ipkg selection}))))))))
  721. (fn check-if-downloaded [file-name output-dir]
  722. (let [pipe (io.popen (.. "ls " output-dir))
  723. pipe-data (pipe:read "*a")
  724. pkg-list (str.split pipe-data "\n")]
  725. (pipe:close)
  726. (var file? false)
  727. (var sha? false)
  728. (each [x v (ipairs pkg-list)]
  729. (if (= v file-name)
  730. (set file? true)
  731. (= v (.. file-name ".sha256"))
  732. (set sha? true)))
  733. [file? sha?]))
  734. ;; Method :: {:Install :Upgrade :Downgrade :Fetch}
  735. ;; fetch-packages!
  736. ;; :: List ( String )
  737. ;; -> Method
  738. ;; -> Either (List String, Nil)
  739. ;; -> Either String Nil
  740. ;; -> IO ()
  741. (fn fetch-packages! [pkg-names method only-repos out-dir force? search-type]
  742. "Install or upgrade PKG-NAMES with command selected by METHOD. Optionally,
  743. from only ONLY-REPOS and, if you want to save the tlz and sha256 files in
  744. a different location, OUT-DIR. If FORCE?, redownload."
  745. (let [output-dir (if out-dir
  746. (if (string.find out-dir "/" -1)
  747. out-dir
  748. (.. out-dir "/"))
  749. var/cache/qire)
  750. qi-cmd (match method
  751. :Install "qi install "
  752. :Upgrade "qi upgrade "
  753. :Downgrade "qi upgrade "
  754. :Fetch (..
  755. "echo Saved package to "
  756. (if
  757. output-dir
  758. output-dir))
  759. _ "qi install ")
  760. config (read-config only-repos)
  761. pkgs (if (= search-type :category)
  762. (let [name (list.car pkg-names)
  763. matches (try-all-repos
  764. config
  765. (partial search-repos name :category))]
  766. (if (not matches)
  767. []
  768. (list.empty? matches)
  769. (do (print (.. "Found no packages in category: " name))
  770. [])
  771. (= method :Install)
  772. (iter.filter-map
  773. (fn [matched]
  774. (let [pkg-list (str.split matched.pkg "_")
  775. pkg-name (list.car pkg-list)
  776. pkg-version (list.cadr pkg-list)
  777. ipkgs (iter.filter
  778. (fn [p]
  779. (let [ipkg-str (list.last (str.split p "/"))
  780. just-name (list.last
  781. (str.split ipkg-str "/"))
  782. ipkg (parse-installed just-name)]
  783. (= pkg-version
  784. ipkg.version)))
  785. (search-installed pkg-name :exact))]
  786. (if (or force? (list.empty? ipkgs))
  787. matched
  788. (print (.. "You already have "
  789. pkg-name
  790. " installed, ignoring.")))))
  791. matches)
  792. (or (= method :Upgrade) (= method :Downgrade))
  793. (iter.filter-map
  794. (fn [matched]
  795. (n-grade-logic method matched))
  796. matches)
  797. matches))
  798. (iter.filter-map
  799. (fn [name]
  800. (let [matches (try-all-repos
  801. config
  802. (partial search-repos name :exact))
  803. matched (if (not matches)
  804. nil
  805. (list.empty? matches)
  806. (print (.. "Found no packages with query: " name))
  807. (= 1 (length matches))
  808. (. matches 1)
  809. (select-match name matches))]
  810. (if (not matched)
  811. nil
  812. (= method :Install)
  813. (let [pkg-list (str.split matched.pkg "_")
  814. pkg-name (list.car pkg-list)
  815. pkg-version (list.cadr pkg-list)
  816. ipkgs (iter.filter
  817. (fn [p]
  818. (let [ipkg-str (list.last (str.split p "/"))
  819. just-name (list.last
  820. (str.split ipkg-str "/"))
  821. ipkg (parse-installed just-name)]
  822. (= pkg-version
  823. ipkg.version)))
  824. (search-installed pkg-name :exact))]
  825. (if (or force? (list.empty? ipkgs))
  826. matched
  827. (print (.. "You already have "
  828. pkg-name
  829. " installed!"))))
  830. (or (= method :Upgrade) (= method :Downgrade))
  831. (n-grade-logic method matched)
  832. matched)))
  833. pkg-names))]
  834. (if (list.empty? pkgs)
  835. nil
  836. (let [files (iter.map
  837. (fn [pkg]
  838. (tbl.merge
  839. (generate-path pkg config method)
  840. pkg))
  841. pkgs)]
  842. (io.write
  843. (..
  844. method
  845. " the above package(s)? [Y/n]: "))
  846. (io.flush)
  847. (when (tbl.find (io.read 1) ["Y" "y" "\n"])
  848. (each [k file (ipairs files)]
  849. (let [file-name file.tlz
  850. url file.url
  851. [file? sha?] (check-if-downloaded file-name output-dir)]
  852. (when (or (not sha?) (not file?) force?)
  853. (print
  854. (..
  855. "Downloading "
  856. file-name
  857. "...\n")))
  858. (if (and (not force?) sha?)
  859. (do (print (.. (.. file-name ".sha256") " already fetched. Use -f to refetch."))
  860. (os.execute (.. "mv "
  861. var/cache/qire
  862. file-name
  863. ".sha256"
  864. " .")))
  865. (wget!
  866. (.. url ".sha256")
  867. (.. file-name ".sha256")))
  868. (if (and (not force?) file?)
  869. (do (print (.. file-name " already fetched. Use -f to refetch."))
  870. (os.execute (.. "mv "
  871. var/cache/qire
  872. file-name
  873. " .")))
  874. (wget! url file-name))
  875. (let [cmd (.. "sha256sum -c "
  876. file-name
  877. ".sha256")
  878. pipe (io.popen cmd)
  879. pipe-data (pipe:read "*a")]
  880. (pipe:close)
  881. (if (string.find pipe-data "OK")
  882. (do (os.execute (.. qi-cmd file-name))
  883. (if (not (= "./" output-dir))
  884. (os.execute (.. "mv "
  885. file-name
  886. " "
  887. file-name
  888. ".sha256"
  889. " "
  890. output-dir))))
  891. (print "Failed sha256 checksum!"))))))))))
  892. (fn fetch-info-installed! [name]
  893. (let [ipkg-string (list.car (search-installed name :exact))]
  894. (if ipkg-string
  895. (let [pkg (list.last (str.split ipkg-string "/"))
  896. file (io.open (.. graft-pkg-path pkg "/var/lib/qi/" pkg ".txt") "r")
  897. data (file:read "*a")]
  898. (file:close)
  899. (let [lines (str.split data "\n\n")
  900. desc (iter.reduce
  901. (fn [acc elem]
  902. (.. acc (str.drop elem 3) "\n"))
  903. ""
  904. (str.split (. lines 1) "\n"))
  905. pkgname (info-property data "pkgname")
  906. pkgversion (info-property data "pkgversion")
  907. below-pkgname (. (str.split data (.. "pkgname=" pkgname)) 2)
  908. arch (info-property below-pkgname "arch")
  909. release (info-property data "release")
  910. cat (info-property below-pkgname "pkgcategory")
  911. homepage (info-property data "homepage")
  912. license (info-property data "license")]
  913. (print
  914. (.. desc
  915. "Package Name: " pkgname "\n"
  916. "Version: " pkgversion "\n"
  917. "Architecture: " arch "\n"
  918. "Release Number: " release "\n"
  919. "Category: " cat "\n"
  920. "License(s): " license "\n"
  921. "Homepage: " homepage)))))))
  922. (fn fetch-info! [name only-repos]
  923. (let [config (read-config only-repos)
  924. pkg (let [matches (try-all-repos
  925. config
  926. (partial search-repos name :exact))]
  927. (if (or (not matches)
  928. (list.empty? matches))
  929. nil
  930. (= 1 (length matches))
  931. (. matches 1)
  932. (select-match name matches)))]
  933. (when pkg
  934. (let [file (generate-path pkg config)]
  935. (print "Fetching information...")
  936. (let [url (.. file.url ".txt")
  937. data (wget! url)
  938. lines (str.split data "\n\n")
  939. desc (iter.reduce
  940. (fn [acc elem]
  941. (.. acc (str.drop elem 3) "\n"))
  942. ""
  943. (str.split (. lines 1) "\n"))
  944. pkgname (info-property data "pkgname")
  945. pkgversion (info-property data "pkgversion")
  946. below-pkgname (. (str.split data (.. "pkgname=" pkgname)) 2)
  947. arch (info-property below-pkgname "arch")
  948. release (info-property data "release")
  949. cat (info-property below-pkgname "pkgcategory")
  950. homepage (info-property data "homepage")
  951. license (info-property data "license")]
  952. (print
  953. (.. desc
  954. "Package Name: " pkgname "\n"
  955. "Version: " pkgversion "\n"
  956. "Architecture: " arch "\n"
  957. "Release Number: " release "\n"
  958. "Category: " cat "\n"
  959. "License(s): " license "\n"
  960. "Homepage: " homepage "\n"
  961. "Repository: <" pkg.repo-id ">")))))))
  962. (fn clear-cache! []
  963. (os.execute (.. "rm -f " var/cache/qire "*"))
  964. (print "Cache cleared!"))
  965. (fn qi [method paths-to-tlzs]
  966. (let [cmd (match method
  967. :Install "qi install "
  968. :Upgrade "qi upgrade "
  969. "qi install")]
  970. (each [v pkg (ipairs paths-to-tlzs)]
  971. (os.execute (.. cmd pkg)))))
  972. (fn read-args [args]
  973. "Accepts the full table of arguments and returns the each options with their
  974. arguments in a table as such: `{:-r [\"dragora-noarch\"] :-i [\"qi\"]}` "
  975. (var arg-table {})
  976. (var current nil)
  977. (var current-single nil)
  978. (each [k v (pairs args)]
  979. (when (> k 0)
  980. (let [multi-cmd? (tbl.find v many-options)
  981. single-cmd? (tbl.find v single-options)
  982. no-cmd? (tbl.find v no-options)]
  983. (if multi-cmd?
  984. (do (tset arg-table v [])
  985. (set current v))
  986. current-single
  987. (do (tset arg-table current-single [v])
  988. (set current-single nil))
  989. (and single-cmd? current)
  990. (set current-single v)
  991. single-cmd?
  992. (do (tset arg-table v [])
  993. (set current v))
  994. no-cmd?
  995. (tset arg-table v [])
  996. current
  997. (tset arg-table current (list.append (. arg-table current) [v]))))))
  998. arg-table)
  999. (fn main [args]
  1000. (let [args-table (read-args args)
  1001. repos (or args-table.-r args-table.--repo)
  1002. dir? (or args-table.-o args-table.--output-directory)
  1003. dir (if dir? (list.car dir?))
  1004. local? (or args-table.-l args-table.--local)
  1005. force? (or args-table.-f args-table.--force)
  1006. cat? (or args-table.-c args-table.--category)
  1007. cat (if cat? (list.car cat?))]
  1008. (match args-table
  1009. {:install pkgs} (if cat
  1010. (if local?
  1011. (print "Error 3: Invalid command!")
  1012. (fetch-packages! [cat] :Install repos dir force? :category))
  1013. (if local?
  1014. (qi :Install pkgs)
  1015. (fetch-packages! pkgs :Install repos dir force? :exact)))
  1016. {:upgrade pkgs?} (if cat
  1017. (if local?
  1018. (print "Error 3: Invalid command!")
  1019. (fetch-packages! [cat] :Upgrade repos dir force? :category))
  1020. (if local?
  1021. (qi :Upgrade pkgs)
  1022. (if pkgs
  1023. (fetch-packages! pkgs :Upgrade repos dir force? :exact)
  1024. (let [pkgz (search-installed nil :exact)
  1025. just-pkg-names (iter.map
  1026. (fn [p]
  1027. (let [g graft-pkg-path
  1028. just-pkg (str.split p g)]
  1029. (print (view just-pkg))
  1030. (. (str.split (. just-pkg 2) "_") 1)))
  1031. pkgz)]
  1032. ;; TODO: `list.unique` may run slow, needs tested on
  1033. ;; real system.
  1034. (fetch-packages! (list.unique just-pkg-names)
  1035. :Upgrade
  1036. repos
  1037. dir
  1038. force?
  1039. :exact)))))
  1040. {:downgrade pkgs} (if cat
  1041. (if local?
  1042. (print "Error 3: Invalid command!")
  1043. (fetch-packages! [cat] :Downgrade repos dir force? :category))
  1044. (if local?
  1045. (qi :Downgrade pkgs)
  1046. (fetch-packages! pkgs :Downgrade repos dir force? :exact)))
  1047. {:info pkgs} (if local?
  1048. (fetch-info-installed! (. pkgs 1))
  1049. (fetch-info! (. pkgs 1) repos))
  1050. {:search pkgs} (if cat
  1051. (if local?
  1052. (search-installed! cat :category)
  1053. (search-repos! cat repos :category))
  1054. (if local?
  1055. (if pkgs
  1056. (search-installed! (. pkgs 1) :lazy)
  1057. (search-installed! nil :lazy))
  1058. (if pkgs
  1059. (search-repos! (. pkgs 1) repos)
  1060. (search-repos! nil repos))))
  1061. {:fetch pkgs} (fetch-packages! pkgs :Fetch repos dir)
  1062. {:sync only-repos} (sync-repos! only-repos)
  1063. {:build-index only-repos} (build-index! only-repos dir)
  1064. {:remove pkgs} (if cat
  1065. (remove-packages! [cat] :category)
  1066. (remove-packages! pkgs :exact))
  1067. {:clean a?} (clear-cache!)
  1068. {:version a?} (print version)
  1069. {:--version a?} (print version)
  1070. {:help a?} (print help-text)
  1071. {:--help a?} (print help-text)
  1072. _ (print "Unknown command. Try --help for more information!"))))
  1073. (main arg)