Commit f0793db4 authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

kernel: Produce hyperlinks to web views of commits.

* guix/jupyter/environment.scm (%vcs-web-views): New variable.
(channel-commit-hyperlink): New procedure.
* guix-jupyter-kernel.scm (channels->shtml): Use it.
parent c779ce76
;;; Guix-kernel -- Guix kernel for Jupyter
;;; Copyright (C) 2018 Evgeny Panfilov <epanfilov@gmail.com>
;;; Copyright (C) 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
;;; Copyright (C) 2018, 2019 Inria
;;; Copyright (C) 2018, 2019, 2020 Inria
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
......@@ -167,7 +167,8 @@ NAME with MANIFEST."
,@(map (lambda (channel)
`(tr (tc (a (@ (href ,(channel-url channel)))
(code ,(channel-name channel))))
(tc (code ,(or (channel-commit channel)
(tc (code ,(if (channel-commit channel)
(channel-commit-hyperlink channel)
(channel-branch channel))))))
channels)))))
......
;;; Guix-kernel -- Guix kernel for Jupyter
;;; Copyright (C) 2019 Ludovic Courtès <ludovic.courtes@inria.fr>
;;; Copyright (C) 2019, 2020 Ludovic Courtès <ludovic.courtes@inria.fr>
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
......@@ -20,13 +20,17 @@
#:use-module (guix channels)
#:use-module (guix inferior)
#:use-module (guix profiles)
#:use-module ((guix utils) #:select (string-replace-substring))
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (web uri)
#:export (open-default-inferior
specifications->manifest))
specifications->manifest
channel-commit-hyperlink))
(define %user-profile
(string-append %profile-directory "/current-guix"))
......@@ -73,3 +77,38 @@ of the SPECS could not be resolved."
specs)))
(define %vcs-web-views
;; Hard-coded list of host names and corresponding web view URL templates.
(let ((labhub-url (lambda (repository-url commit)
(string-append
(if (string-suffix? ".git" repository-url)
(string-drop-right repository-url 4)
repository-url)
"/commit/" commit))))
`(("git.savannah.gnu.org"
,(lambda (repository-url commit)
(string-append (string-replace-substring repository-url
"/git/" "/cgit/")
"/commit/?id=" commit)))
("notabug.org" ,labhub-url)
("framagit.org" ,labhub-url)
("gitlab.com" ,labhub-url)
("gitlab.inria.fr" ,labhub-url)
("github.com" ,labhub-url))))
;; Taken and adapted from (guix scripts pull).
(define* (channel-commit-hyperlink channel
#:optional
(commit (channel-commit channel)))
"Return a hyperlink for COMMIT in CHANNEL, using COMMIT as the hyperlink's
text. The hyperlink links to a web view of COMMIT, when available."
(let* ((url (channel-url channel))
(uri (string->uri url))
(host (and uri (uri-host uri))))
(if host
(match (assoc host %vcs-web-views)
(#f
commit)
((_ template)
`(a (@ (href ,(template url commit))) ,commit)))
commit)))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment