HGRC Quarry Fossil Service
Simple tools for lasting software

Infrastructure as a Service / Nemoptera

A solid foundation to fork, tweak, and enhance.

Public | Owner: Infrastructure as a Service | Default branch: trunk | Last update: 2026-11-08 15:56

Artifact 46056b200e00092b7ffdaa3a4049fcd86b2d5092275f113767af9bb3fe2aa3d2:


(defmodule nemoptera_setup
  (export all))

(defun installed-flag () "data/installed.flag")

(defun installed? ()
  (case (file:read_file_info (installed-flag))
    (`#(ok ,_) 'true)
    (_ 'false)))

(defun check-env ()
  (list (check-otp)
        (check-lfe)
        (check-fossil)
        (check-dir "data" "Data directory")
        (check-sqlite)))

(defun check-otp ()
  (entry "Erlang/OTP" 'true
         (lists:flatten (list "OTP " (erlang:system_info 'otp_release)))))

(defun check-lfe ()
  (case (lists:keyfind 'lfe 1 (application:loaded_applications))
    ('false (entry "LFE" 'false "LFE is not loaded"))
    ((tuple _ _ version) (entry "LFE" 'true (lists:flatten (list "LFE " version))))))

(defun check-fossil ()
  (case (nemoptera_fossil:run '("version"))
    (`#(ok ,out) (entry "fossil" 'true (first-line out)))
    (`#(error ,reason) (entry "fossil" 'false (nemoptera_fossil:error-message reason)))))

(defun check-dir (dir label)
  (let ((probe (filename:join dir ".write-probe")))
    (filelib:ensure_dir probe)
    (case (file:write_file probe #"ok")
      ('ok
       (file:delete probe)
       (entry label 'true dir))
      (`#(error ,reason)
       (entry label 'false (lists:flatten (io_lib:format "~s is not writable: ~p" (list dir reason))))))))

(defun check-sqlite ()
  (let ((probe "data/setup-probe.db"))
    (filelib:ensure_dir probe)
    (case (esqlite3:open probe)
      (`#(ok ,conn)
       (esqlite3:close conn)
       (file:delete probe)
       (entry "SQLite3" 'true "esqlite can create a database"))
      (other
       (entry "SQLite3" 'false (lists:flatten (io_lib:format "~p" (list other))))))))

(defun entry (name ok detail)
  (maps:from_list (list (tuple 'name name) (tuple 'ok ok) (tuple 'detail detail))))

(defun all-ok? (checks)
  (lists:all (lambda (check) (maps:get 'ok check)) checks))

(defun finish (fields)
  (let ((checks (check-env)))
    (cond
      ((not (all-ok? checks)) `#(error "The environment check failed."))
      ((nemoptera_text:blank? (maps:get 'site_name fields)) `#(error "Site name is required."))
      ((nemoptera_text:blank? (maps:get 'site_url fields)) `#(error "Site URL is required."))
      ((nemoptera_text:blank? (maps:get 'username fields)) `#(error "Administrator username is required."))
      ((< (length (maps:get 'password fields "")) 8) `#(error "Password must be at least 8 characters."))
      ((not (=:= (maps:get 'password fields) (maps:get 'password2 fields)))
       `#(error "The two passwords do not match."))
      ('true (write-install fields)))))

(defun write-install (fields)
  (let* ((db-path (default-text fields 'db_path "data/nemoptera.db"))
         (repo-dir (default-text fields 'repo_dir "data/repos"))
         (dir-check (check-dir repo-dir "Repository directory")))
    (if (maps:get 'ok dir-check)
        (case (nemoptera_config:write (list (tuple 'db_path db-path)
                                           (tuple 'repo_dir repo-dir)))
          ('ok
           (nemoptera_config:reload)
           (case (nemoptera_crypto:load-or-create-key)
             (`#(ok ,_)
              (case (nemoptera_db:open db-path)
                (`#(ok ,_) (store-site-and-admin fields))
                (other `#(error ,(lists:flatten (io_lib:format "Database: ~p" (list other)))))))
             (`#(error ,reason) `#(error ,(lists:flatten (io_lib:format "Key: ~p" (list reason)))))))
          (`#(error ,reason) `#(error ,(lists:flatten (io_lib:format "Config: ~p" (list reason))))))
        `#(error ,(maps:get 'detail dir-check)))))

(defun store-site-and-admin (fields)
  (let ((now (nemoptera_text:now-iso))
        (hash (nemoptera_crypto:hash-password (maps:get 'password fields))))
    (case (nemoptera_db:q "INSERT INTO admin_user(username,password_hash,created_at,updated_at) VALUES(?,?,?,?);"
                         (list (maps:get 'username fields) hash now now))
      (`#(error ,reason) `#(error ,(lists:flatten (io_lib:format "Administrator: ~p" (list reason)))))
      (`#(EXIT ,reason) `#(error ,(lists:flatten (io_lib:format "Administrator: ~p" (list reason)))))
      (_
       (put-setting "site_name" (maps:get 'site_name fields))
       (put-setting "site_url" (trim-slash (maps:get 'site_url fields)))
       (put-setting "site_tagline" (maps:get 'site_tagline fields ""))
       (put-setting "site_description" (maps:get 'site_description fields ""))
       (put-setting "loose_title" (default-text fields 'loose_title "Repositories"))
       (put-setting "custom_shortcuts" (maps:get 'custom_shortcuts fields ""))
       (case (file:write_file (installed-flag) #"ok")
         ('ok 'ok)
         (`#(error ,reason) `#(error ,(lists:flatten (io_lib:format "Install flag: ~p" (list reason))))))))))

(defun put-setting (key value)
  (nemoptera_db:q "INSERT OR REPLACE INTO site_settings(key,value) VALUES(?,?);"
                 (list key (nemoptera_text:to-str value))))

(defun default-text (fields key default)
  (let ((value (maps:get key fields default)))
    (if (nemoptera_text:blank? value) default (nemoptera_text:to-str value))))

(defun trim-slash (value)
  (let ((text (nemoptera_text:to-str value)))
    (if (and (> (length text) 0) (=:= (lists:last text) 47))
        (trim-slash (lists:sublist text 1 (- (length text) 1)))
        text)))

(defun first-line (out)
  (hd (string:split (nemoptera_text:to-str out) "\n" 'leading)))

Clone

You can clone this repository with the following command:

fossil clone https://hgrc.dev/IaaS/Nemoptera Nemoptera.fossil

Contribute

The best way to contribute is through e-mail. See the project documentation for more details.