Commit faf971d8 authored by Eric Timmons's avatar Eric Timmons
Browse files

Start work on clpmfile api-version 0.4

Add :git directive
parent c38af9b4
Pipeline #4596 passed with stages
in 29 minutes and 42 seconds
......@@ -33,7 +33,7 @@
(with-open-file (s (clpmfile-pathname clpmfile) :direction :output :if-exists if-exists)
(write-string ";;; -*- Mode: common-lisp; -*-" s)
(terpri s)
(prin1 '(:api-version "0.3") s)
(prin1 '(:api-version "0.4") s)
(terpri s)
(terpri s)
(dolist (source (sources))
......
......@@ -23,6 +23,8 @@
(defvar *clpmfile-version*)
(defgeneric clpmfile-pathname (clpmfile))
(defmethod clpmfile-pathname ((clpmfile context))
......@@ -105,6 +107,32 @@ source."
:name asd-file
:why t))))))
(defmethod parse-clpmfile-form (clpmfile (type (eql :git)) args)
"Parse a :git statement from a clpmfile into a vcs-project-requirement
instance."
(unless (equal *clpmfile-version* "0.4")
(error "This form requires API-VERSION 0.3"))
(destructuring-bind (name &key repository branch commit tag systems)
args
(assert repository)
(let* ((repo-description (list :git :repository repository))
(repo (make-repo-from-description repo-description))
(vcs-sources-ht (context-vcs-sources-ht clpmfile))
(source (ensure-gethash (repo-to-form repo) vcs-sources-ht
(make-source 'vcs-source :repo repo-description
:project-name name))))
(assert (xor branch commit tag))
(push (make-instance 'vcs-project-requirement
:systems systems
:name name
:source source
:branch branch
:commit commit
:tag tag
:why t)
(context-requirements clpmfile)))))
(defmethod parse-clpmfile-form (clpmfile (type (eql :github)) args)
"Parse a :github statement from a clpmfile into a vcs-project-requirement
......@@ -198,12 +226,15 @@ instance."
(defun read-clpmfile-from-stream (stream pathname)
(let ((clpmfile (make-instance 'context :name pathname))
(source-allowed-p t))
(source-allowed-p t)
*clpmfile-version*)
(uiop:with-safe-io-syntax ()
;; The first form in the stream must be an API declaration.
(let ((f (read stream nil)))
(unless (equal f '(:api-version "0.3"))
(error "Unknown clpmfile API version")))
(unless (or (equal f '(:api-version "0.3"))
(equal f '(:api-version "0.4")))
(error "Unknown clpmfile API version"))
(setf *clpmfile-version* (second f)))
(with-forms-from-stream (stream form)
(destructuring-bind (type . args) form
(when (and (eql type :source)
......
......@@ -133,14 +133,14 @@ can be named, global contexts, or anonymous."))
(defun copy-context (context)
(make-instance 'context
:name (context-name context)
:releases (copy-list (context-releases context))
:requirements (copy-list (context-requirements context))
:reverse-dependencies (copy-alist (context-reverse-dependencies context))
:user-sources (copy-list (context-user-sources context))
:fs-sources-ht (copy-hash-table (context-fs-sources-ht context))
:vcs-sources-ht (copy-hash-table (context-vcs-sources-ht context))
:system-releases (copy-tree (context-system-releases context))))
:name (context-name context)
:releases (copy-list (context-releases context))
:requirements (copy-list (context-requirements context))
:reverse-dependencies (copy-alist (context-reverse-dependencies context))
:user-sources (copy-list (context-user-sources context))
:fs-sources-ht (copy-hash-table (context-fs-sources-ht context))
:vcs-sources-ht (copy-hash-table (context-vcs-sources-ht context))
:system-releases (copy-tree (context-system-releases context))))
(defun global-context-pathname (name)
(clpm-data-pathname (list "contexts" name)))
......@@ -493,7 +493,8 @@ in place with the same name. Return the new requirement if it was modified."
(uiop:with-safe-io-syntax ()
;; The first form in the stream must be an API declaration.
(let ((f (read stream nil)))
(unless (equal f '(:api-version "0.3"))
(unless (or (equal f '(:api-version "0.3"))
(equal f '(:api-version "0.4")))
(error "Unknown context API version")))
(let ((out (make-instance 'context
:name name)))
......@@ -550,7 +551,7 @@ in place with the same name. Return the new requirement if it was modified."
(*print-pretty* t)
(*print-right-margin* nil))
(write-header "This is autogenerated by CLPM. Do not edit by hand." stream)
(format stream "~S~%~%" '(:api-version "0.3"))
(format stream "~S~%~%" '(:api-version "0.4"))
;; Sources
(write-section-header "sources" stream)
......
......@@ -9,7 +9,8 @@
#:clpm/repos/git
#:clpm/repos/github
#:clpm/repos/gitlab
#:clpm/repos/local-git-override)
#:clpm/repos/local-git-override
#:clpm/repos/plain-git)
(:reexport #:clpm/repos/defs)
(:reexport #:clpm/repos/git)
(:reexport #:clpm/repos/github)
......@@ -22,6 +23,8 @@
(defun make-repo-from-description (desc)
(destructuring-bind (repo-type &rest args) desc
(ecase repo-type
(:git
(apply #'make-instance 'plain-git-repo args))
(:github
(apply #'make-instance 'github-repo args))
(:gitlab
......
......@@ -18,7 +18,9 @@
(:export #:git-repo
#:git-repo-credentials
#:git-repo-local-dir
#:git-repo-uri-string))
#:git-repo-uri-string
#:git-uri/real-host
#:parse-git-uri))
(in-package #:clpm/repos/git)
......@@ -36,7 +38,7 @@
;; * URI parsing
(defclass git-uri (uri)
(defclass git-uri (puri:uri)
((user-name
:initform nil
:accessor git-uri/user-name)
......@@ -69,6 +71,8 @@
:ssh)
("file"
:file)
("git"
:git)
(t
:scp)))
;; Implicit file protocol
......@@ -87,7 +91,7 @@
(:scp
(puri:parse-uri (convert-scp-to-ssh uri-string)
:class 'git-uri))
((:http :https :ssh :file)
((:http :https :ssh :file :git)
(puri:parse-uri uri-string
:class 'git-uri)))))
......
;;;; Git repositories not hosted on a forge
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/repos/plain-git
(:use #:cl
#:alexandria
#:anaphora
#:clpm/cache
#:clpm/data
#:clpm/repos/defs
#:clpm/repos/git
#:split-sequence)
(:import-from #:puri)
(:export #:plain-git-repo))
(in-package #:clpm/repos/plain-git)
(defclass plain-git-repo (git-repo)
((repository
:initarg :repository
:reader git-repo-uri-string)))
(defmethod git-repo-credentials ((repo plain-git-repo))
nil)
(defun split-path (path)
(aprog1 (split-sequence #\/ path)
(dolist (segment it)
(assert (not (equal "" segment)))
(assert (not (starts-with #\. segment))))))
(defmethod git-repo-local-dir ((repo plain-git-repo))
"The cache directory for this repo is based on the hostname."
(let* ((uri (parse-git-uri (git-repo-uri-string repo)))
(host (git-uri/real-host uri))
(path (puri:uri-path uri))
(path-with.git (if (not (ends-with-subseq ".git" path))
(uiop:strcat path ".git")
path))
(split-path (split-path path-with.git)))
(clpm-cache-pathname
`("vcs"
,(if (eql (puri:uri-scheme uri) :file)
"gitfs"
"git")
,@(when (not (null host))
(list host))
,@split-path)
:ensure-directory t)))
(defmethod repo-lib-base-pathname ((repo plain-git-repo))
(let* ((uri (parse-git-uri (git-repo-uri-string repo)))
(host (git-uri/real-host uri))
(path (puri:uri-path uri))
(path-with.git (if (not (ends-with-subseq ".git" path))
(uiop:strcat path ".git")
path))
(split-path (split-path path-with.git)))
(clpm-data-pathname
`("vcs"
,(if (eql (puri:uri-scheme uri) :file)
"gitfs"
"git")
,@(when (not (null host))
(list host))
,@split-path)
:ensure-directory t)))
(defmethod repo-to-form ((repo plain-git-repo))
`(:git
:repository ,(git-repo-uri-string repo)))
......@@ -28,7 +28,7 @@ with zero configuration or helpers needed (other than ASDF, of course).
consists of a series of directives where each directive is a list starting
with a keyword. The directives are described below. Additionally, the first
directive in the file must be the ~:api-version~ directive. This document
describes version "0.3".
describes version "0.4".
*** ~:api-version~
......@@ -37,7 +37,7 @@ with zero configuration or helpers needed (other than ASDF, of course).
file is described in. Example:
#+begin_src common-lisp
(:api-version "0.3")
(:api-version "0.4")
#+end_src
*** ~:source~
......@@ -92,6 +92,27 @@ with zero configuration or helpers needed (other than ASDF, of course).
(such as ~((>= "1.1") (< "2"))~).
*** ~:git~
The git directive specifies a requirement that must be satisfied by a git
repository hosted at an arbitrary location. Unless specified otherwise,
every explicitly defined system (and their dependencies) are included in
the bundle.
#+begin_src common-lisp
(name &key repository branch commit tag systems)
#+end_src
+ ~name~ :: must be a string, unique in the file.
+ ~:repository~ :: must be a string, the url of the repository.
+ ~:branch~ :: If specified, must be a string naming the branch to use. If
none of branch, commit, or tag are specified, the branch defaults to the
default branch from the server.
+ ~:commit~ :: If specified, must be a string naming the commit to use.
+ ~:tag~ :: If specified, must be a string naming the tag to use.
+ ~:systems~ :: A list naming the systems to require in the bundle. If NIL,
all systems are required.
*** ~:github~
The github directive specifies a requirement that must be satisfied by a git
......
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