aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Joshua S. Grant <jgrant@parenthetical.io>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu)
  #:use-module (guix i18n)
  #:use-module (guix diagnostics)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (guix packages)
  #:use-module (gnu packages)
  #:use-module (gnu services)
  #:export (use-package-modules
            use-service-modules
            use-system-modules))

;;; Commentary:
;;;
;;; This composite module re-exports core parts the (gnu …) public modules.
;;;
;;; Code:

(eval-when (eval load compile)
  (begin
    (define %public-modules
      '((gnu system)
        (gnu system mapped-devices)
        (gnu system file-systems)
        (gnu bootloader)
        (gnu bootloader grub)
        (gnu system keyboard)
        (gnu system pam)
        (gnu system shadow)                       ; 'user-account'
        (gnu system linux-initrd)
        (gnu system nss)
        (gnu services)
        (gnu services base)
        (gnu packages)
        (gnu packages base)
        (guix gexp)))                             ; so gexps can be used

    (for-each (let ((i (module-public-interface (current-module))))
                (lambda (m)
                  (module-use! i (resolve-interface m))))
              %public-modules)))

(define (%try-use-modules modules location make-hint)
  "Attempt to load all of MODULES.  Report errors as coming from LOCATION, a
<location> record, and use MAKE-HINT to produce a fix hint."
  (define (location->string loc)
    (match loc
      (#f "")
      (($ <location> file line column)
       (format #f "~a:~a:~a: " file line column))))

  (for-each (lambda (module)
              (catch 'misc-error
                (lambda ()
                  (process-use-modules `((,module))))
                (lambda _
                  (raise
                   (apply
                    make-compound-condition
                    (formatted-message (G_ "module ~a not found")
                                       module)
                    (condition
                     (&error-location (location location)))
                    (or (and=> (make-hint module) list)
                        '()))))))
            modules))

(define (package-module-hint module)
  (define last-name
    (match module
      ((_ ... last)
       (symbol->string last))))

  (match (find-packages-by-name last-name)
    (()
     (condition
      (&fix-hint
       (hint (G_ "\
You may use @command{guix package --show=foo | grep location} to search
for the location of package @code{foo}.
If you get the line @code{location: gnu/packages/bar.scm:174:2},
add @code{bar} to the @code{use-package-modules} form.")))))
    ((package _ ...)
     (condition
      (&fix-hint
       (hint (format #f (G_ "\
Try adding @code{(use-package-modules ~a)}.")
                     (basename (location-file (package-location package))
                               ".scm"))))))))

(define (service-module-hint module)
  (define last-name
    (match module
      ((_ ... last)
       last)))

  (match (lookup-service-types last-name)
    (()
     (condition
      (&fix-hint
       (hint (format #f (G_ "\
You may use @command{guix system search ~a} to search for a service
matching @code{~a}.
If you get the line @code{location: gnu/services/foo.scm:188:2},
add @code{foo} to the @code{use-service-modules} form.")
                     last-name last-name)))))
    ((package _ ...)
     (condition
      (&fix-hint
       (hint (format #f (G_ "\
Try adding @code{(use-service-modules ~a)}.")
                     (basename (location-file (service-type-location package))
                               ".scm"))))))))

(define-syntax-rule (try-use-modules hint modules ...)
  (eval-when (expand load eval)
    (%try-use-modules '(modules ...)
                      (source-properties->location
                       (current-source-location))
                      hint)))

(define-syntax-rule (use-package-modules module ...)
  (try-use-modules package-module-hint
                   (gnu packages module) ...))

(define-syntax-rule (use-service-modules module ...)
  (try-use-modules service-module-hint
                   (gnu services module) ...))

(define-syntax-rule (use-system-modules module ...)
  (try-use-modules (const #f)                     ;no hint
                   (gnu system module) ...))

;;; gnu.scm ends here
like simple and lean web pages, feel free to load the
+minimal CC0-licensed stylesheet at")
+ (pre "https://ctftilde.koszko.org/resources/ctftilde.css")
+ (p "into your HTML documents :)")
+
+ (h2 "Gemini user directory")
+ (p "Don't you also feel that \"Web\" is sometimes too much? Wouldn't you
+love to let others view your blog (or whatever you publish) using a friendlier
+technology? Here's how to: put your files under")
+ (pre "/srv/gemini-users/$YOUR_USERNAME/")
+ (p "They will immediately become available under")
+ (pre "gemini://ctftilde.koszko.org/~$YOUR_USERNAME")
+ (p "Make sure not to miss gemtext, the minimal markup language desined for
+Gemini.")
+ (ul
+ (li (a (@ (href "https://geminiprotocol.net/"))
+ "Project Gemini website"))
+ (li (a (@ (href "gemini://geminiprotocol.net/"))
+ "Project Gemini capsule (over the gemini protocol)")))
+
+ (h2 "Cron")
+ (p "We've made the effort to have a working")
+ (pre "crontab")
+ (p "command. Use it as you would on any GNU+Linux distro!"))))
+
(define query-param-regex
(make-regexp "^([^=]+)(=(.*))?"))
@@ -172,7 +218,8 @@ registration page.")
(and (not (regexp-exec start-with-lowercase-regex username))
"Username must start with a lowercase letter."))
,(lambda _
- (and (false-if-exception (getpwnam username))
+ (and (false-if-exception (getpwnam (format #f "ctftilde-~a"
+ username)))
"This username is unavailable."))))
("password"
@@ -192,7 +239,7 @@ registration page.")
(and (not (regexp-exec email-regex email))
"Provided email is not valid.")))))))
-(cant:define-endpoint %endset main-page
+(cant:define-endpoint %endset registration-page
("registration") '()
(define legal-POST?
@@ -216,21 +263,24 @@ registration page.")
(cond
((and legal-POST? (eq? '() params-mistakes))
- (write (list (format #f "ctftilde-~a" (assoc-ref params "username"))
- (encrypt-password (assoc-ref params "password")))
- (%daemon-write-port))
+ (let ((username (format #f "ctftilde-~a" (assoc-ref params "username"))))
- (contents->html
- (match (read (%daemon-read-port))
+ (write (list username (encrypt-password (assoc-ref params "password")))
+ (%daemon-write-port))
+
+ (contents->html
+ (match (read (%daemon-read-port))
- ('(ok)
- `((h1 "Done")
- (p ,(format #f "Try connecting via ssh to ~a@ctftilde.koszko.org."
- (assoc-ref params "username")))))
+ ('(ok)
+ `((h1 "Done")
+ (p ,(format #f "Try connecting via ssh to ~a@ctftilde.koszko.org."
+ username))
+ (p "Also, please don't abuse our server's resources. Let others use
+the platform, too :)")))
- (_
- `((h1 "Ooops!")
- (p "Something went wrong X("))))))
+ (_
+ `((h1 "Ooops!")
+ (p "Something went wrong X(")))))))
(else
(contents->html
diff --git a/ctftilde/src/guile/ctftilde/users.scm b/ctftilde/src/guile/ctftilde/users.scm
index 3d17362..aaaae51 100644
--- a/ctftilde/src/guile/ctftilde/users.scm
+++ b/ctftilde/src/guile/ctftilde/users.scm
@@ -6,6 +6,7 @@
#:use-module ((ice-9 exceptions) #:select
(raise-exception with-exception-handler))
#:use-module ((ice-9 match) #:select (match))
+ #:use-module ((ice-9 regex) #:select (match:substring))
#:use-module ((system repl debug) #:select (terminal-width))
@@ -61,6 +62,18 @@
(dynamic-wind noop loop (cut closedir dir))))
+(define ctftilde-user-regex
+ (make-regexp "^ctftilde-(.*)"))
+
+(define (strip-ctftilde username)
+ (match (regexp-exec ctftilde-user-regex username)
+
+ (#f
+ username)
+
+ ((= (cut match:substring <> 1) stripped-username)
+ stripped-username)))
+
(define (*delete-user username)
@@ -74,8 +87,10 @@
(false-if-exception (delete-file creation-file))
(system* "userdel" "-rf" username)
- (system* "rm" "-rf" (string-append "/srv/gemini-users/" username))
- (system* "rm" "-rf" (string-append "/srv/http-users/" username))
+ (system* "rm" "-rf" (string-append "/srv/gemini-users/"
+ (strip-ctftilde username)))
+ (system* "rm" "-rf" (string-append "/srv/http-users/"
+ (strip-ctftilde username)))
(sync)
(false-if-exception (delete-file deletion-file))
(sync)))
@@ -94,21 +109,25 @@
(make-regexp "^[a-zA-Z][a-zA-Z0-9-]*$"))
(define* (*make-user username encrypted-password #:optional recreated-user-uid)
+ (define home-dir
+ (string-append "/home/ctftilde/" (strip-ctftilde username)))
+
(define (add-user)
- (when (> (apply system*
- `("useradd"
- "--shell" "/run/current-system/profile/bin/bash"
- "--home-dir" ,(string-append "/home/ctftilde/" username)
- "--create-home"
- ,@(or (and=> recreated-user-uid
- (compose (cut list "--uid" <>)
- number->string))
- '())
- "--gid" "hackers"
- "-p" ,encrypted-password
- ,username))
- 0)
- (raise-exception "User could not be added.")))
+ (if (> (apply system*
+ `("useradd"
+ "--shell" "/run/current-system/profile/bin/bash"
+ "--home-dir" ,home-dir
+ "--create-home"
+ ,@(or (and=> recreated-user-uid
+ (compose (cut list "--uid" <>)
+ number->string))
+ '())
+ "--gid" "hackers"
+ "-p" ,encrypted-password
+ ,username))
+ 0)
+ (raise-exception "User could not be added.")
+ (chmod home-dir #o700)))
(define (add-user-files)
(define user
@@ -116,7 +135,7 @@
(define (make-user-file path-format what)
(define path
- (format #f path-format username))
+ (format #f path-format (strip-ctftilde username)))
(unless (file-exists? path)
(match what