version-control.scm (11791B)
1 (define-module (mt services version-control) 2 #:use-module (gnu artwork) 3 #:use-module (gnu services) 4 #:use-module (gnu services base) 5 #:use-module (gnu services shepherd) 6 #:use-module ((gnu services version-control) #:prefix gnu:) 7 #:use-module (gnu services web) 8 #:use-module (gnu system shadow) 9 #:use-module ((gnu packages version-control) #:select (git)) 10 #:use-module (gnu packages admin) 11 #:use-module (guix deprecation) 12 #:use-module (guix records) 13 #:use-module (guix gexp) 14 #:use-module (guix store) 15 #:use-module (srfi srfi-1) 16 #:use-module (srfi srfi-26) 17 #:use-module (ice-9 format) 18 #:use-module (ice-9 match) 19 #:use-module (mt packages version-control) 20 #:export (git-daemon-service 21 git-daemon-service-type 22 git-daemon-configuration 23 git-daemon-configuration? 24 stagit-services 25 stagit-configuration 26 stagit-configuration?)) 27 28 ;;; Commentary: 29 ;;; 30 ;;; Version Control related services. 31 ;;; 32 ;;; Code: 33 34 35 ;;; 36 ;;; Git daemon. 37 ;;; 38 39 (define-record-type* <git-daemon-configuration> 40 git-daemon-configuration 41 make-git-daemon-configuration 42 git-daemon-configuration? 43 (package git-daemon-configuration-package ;file-like 44 (default git)) 45 (export-all? git-daemon-configuration-export-all ;boolean 46 (default #f)) 47 (base-path git-daemon-configuration-base-path ;string | #f 48 (default "/srv/git")) 49 (user-path git-daemon-configuration-user-path ;string | #f 50 (default #f)) 51 (listen git-daemon-configuration-listen ;list of string 52 (default '())) 53 (port git-daemon-configuration-port ;number | #f 54 (default #f)) 55 (whitelist git-daemon-configuration-whitelist ;list of string 56 (default '())) 57 (extra-options git-daemon-configuration-extra-options ;list of string 58 (default '()))) 59 60 (define git-daemon-shepherd-service 61 (match-lambda 62 (($ <git-daemon-configuration> 63 package export-all? base-path user-path 64 listen port whitelist extra-options) 65 (let* ((git (file-append package "/bin/git")) 66 (command `(,git 67 "daemon" "--syslog" "--reuseaddr" 68 ,@(if export-all? 69 '("--export-all") 70 '()) 71 ,@(if base-path 72 `(,(string-append "--base-path=" base-path)) 73 '()) 74 ,@(if user-path 75 `(,(string-append "--user-path=" user-path)) 76 '()) 77 ,@(map (cut string-append "--listen=" <>) listen) 78 ,@(if port 79 `(,(string-append 80 "--port=" (number->string port))) 81 '()) 82 ,@extra-options 83 ,@whitelist))) 84 (list (shepherd-service 85 (documentation "Run the git-daemon.") 86 (requirement '(user-processes networking)) 87 (provision '(git-daemon)) 88 (start #~(make-forkexec-constructor '#$command 89 #:user "git" 90 #:group "git")) 91 (stop #~(make-kill-destructor)))))))) 92 93 (define git-daemon-service-type 94 (service-type 95 (name 'git-daemon) 96 (extensions 97 (list (service-extension shepherd-root-service-type 98 git-daemon-shepherd-service))) 99 (description 100 "Expose Git repositories over the insecure @code{git://} TCP-based 101 protocol.") 102 (default-value (git-daemon-configuration)))) 103 104 (define-record-type* <stagit-configuration> 105 stagit-configuration 106 make-stagit-configuration 107 stagit-configuration? 108 (package stagit-configuration-package ;file-like 109 (default stagit)) 110 (www-home stagit-configuration-www-home ;string 111 (default "/var/www/stagit")) 112 (gitolite-home stagit-configuration-gitolite-home ;string 113 (default "/var/lib/gitolite")) 114 (logo stagit-configuration-logo ;file-like 115 (default (file-append %artwork-repository 116 "/logo/head-only/Guix-head.svg"))) 117 (stylesheet stagit-configuration-stylesheet ;file-like 118 (default (plain-file "style.css" 119 "\n"))) 120 (clone-domain stagit-configuration-clone-domain) ;string 121 (admin-pubkey stagit-configuration-admin-pubkey)) ;file-like 122 123 ;; Activation-time setup for stagit. 124 ;; TODO: Cleanup 125 126 (define (stagit-activation config) 127 (let* ((package (stagit-configuration-package config)) 128 (www-home (stagit-configuration-www-home config)) 129 (gitolite-home (stagit-configuration-gitolite-home config)) 130 (logo (stagit-configuration-logo config)) 131 (stylesheet (stagit-configuration-stylesheet config)) 132 (clone-domain (stagit-configuration-clone-domain config)) 133 (gitolite-hooks (string-append gitolite-home "/local/hooks/common")) 134 (git-home (string-append gitolite-home "/repositories")) 135 (post-receive (create-stagit-hook package 136 www-home 137 git-home 138 clone-domain))) 139 #~(begin 140 (use-modules (ice-9 match)) 141 142 (let* ((user-info (getpwnam "git")) 143 (logo (string-append #$www-home "/logo.svg")) 144 (stylesheet (string-append #$www-home "/style.css")) 145 (post-receive (string-append #$gitolite-hooks "/post-receive"))) 146 ;; Setup files as the root user. 147 (if (not (file-exists? #$www-home)) 148 (mkdir-p #$www-home)) 149 (chown #$www-home (passwd:uid user-info) 150 (passwd:gid user-info)) 151 152 ;; Setup files as the git user. 153 (match (primitive-fork) 154 (0 155 (dynamic-wind 156 (const #t) 157 (lambda () 158 ;; Switch to the git user. 159 (setgid (passwd:gid user-info)) 160 (setuid (passwd:uid user-info)) 161 162 ;; Setup files. 163 (if (file-exists? logo) 164 (delete-file logo)) 165 (symlink #$logo logo) 166 167 (if (file-exists? stylesheet) 168 (delete-file stylesheet)) 169 (symlink #$stylesheet stylesheet) 170 171 (mkdir-p #$gitolite-hooks) 172 (if (file-exists? post-receive) 173 (delete-file post-receive)) 174 (symlink #$post-receive post-receive) 175 176 ;; Return to main thread. 177 (primitive-exit 0)) 178 (lambda () 179 (primitive-exit 1)))) 180 (pid (waitpid pid))))))) 181 182 ;; Create a post-receive hook. 183 ;; TODO: Cleanup 184 ;; TODO: Implement cache 185 186 (define* (create-stagit-hook stagit 187 www-home 188 git-home 189 clone-domain) 190 (program-file "post-receive" 191 #~(begin 192 (use-modules (ice-9 ftw) 193 (ice-9 rdelim)) 194 195 ;; Ignore private repositories. 196 (if (not (file-exists? "git-daemon-export-ok")) 197 (exit 0)) 198 199 ;; Set correct file permissions. 200 (umask #o022) 201 202 (call-with-input-file "config" 203 (lambda (file) 204 (while #t (let ((line (read-line file))) 205 (if (eof-object? line) (break)) 206 (if (string-prefix? "\tdescription" line) 207 (call-with-output-file "description" 208 (lambda (out) 209 (display (string-drop line 15) out)))) 210 (if (string-prefix? "\towner" line) 211 (call-with-output-file "owner" 212 (lambda (out) 213 (display (string-drop line 9) out)))))))) 214 215 216 ;; Generate repository-specific content. 217 (let* ((src (getcwd)) 218 (name (basename src ".git")) 219 (dest (string-append #$www-home "/" name))) 220 (call-with-output-file "url" 221 (lambda (out) 222 (display (string-append "git://" #$clone-domain 223 "/" name) out))) 224 (display "[stagit] Building ") 225 (display dest) 226 (display "\n") 227 (if (not (file-exists? dest)) 228 (mkdir dest)) 229 (chdir dest) 230 (system* (string-append #$stagit "/bin/stagit") 231 src)) 232 233 ;; Generate index-specific content. 234 (chdir #$git-home) 235 (let ((index (string-append #$www-home "/index.html")) 236 (args (scandir (getcwd) 237 ;; Ignore hidden files 238 (lambda (name) 239 (and 240 (file-exists? (string-append name "/git-daemon-export-ok")) 241 (not (char=? (string-ref name 0) 242 #\.))))))) 243 (display "[stagit] Building ") 244 (display index) 245 (display "\n") 246 (call-with-output-file index 247 (lambda (out) 248 (waitpid 249 (spawn (string-append #$stagit "/bin/stagit-index") 250 (append (list "stagit-index") 251 args) 252 #:output out)))))))) 253 254 (define (stagit-services stagit-configuration) 255 (list (service gnu:gitolite-service-type 256 (gnu:gitolite-configuration 257 (admin-pubkey 258 (stagit-configuration-admin-pubkey stagit-configuration)) 259 (home-directory 260 (stagit-configuration-gitolite-home stagit-configuration)) 261 (rc-file 262 (gnu:gitolite-rc-file 263 ;; Use the hooks generated by the activation script 264 (local-code "$ENV{HOME}/local") 265 (git-config-keys "gitweb\\.description gitweb\\.owner"))))) 266 (service git-daemon-service-type 267 (git-daemon-configuration 268 (base-path (string-append (stagit-configuration-gitolite-home stagit-configuration) 269 "/repositories")))) 270 (simple-service 'stagit-activation 271 activation-service-type 272 (stagit-activation stagit-configuration))))