extra/build-from-source/build-from-source.factor

   1 ! Copyright (C) 2023 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs calendar calendar.format cli.git
   4 combinators combinators.short-circuit continuations formatting
   5 github html.parser html.parser.analyzer http.client
   6 http.download io io.directories io.encodings.string
   7 io.encodings.utf8 io.files io.launcher io.pathnames json kernel
   8 layouts math namespaces qw semver sequences sequences.extras
   9 sorting sorting.human sorting.specification splitting system
  10 unicode ;
  11 IN: build-from-source
  12
  13 INITIALIZED-SYMBOL: use-gitlab-git-uris [ f ]
  14 INITIALIZED-SYMBOL: use-github-git-uris [ f ]
  15
  16 INITIALIZED-SYMBOL: build-from-source-directory [ "resource:build-from-source/" ]
  17
  18 SYMBOL: out-directory
  19
  20 : dll-out-directory ( -- path )
  21     vm-path parent-directory cell-bits "dlls%s-out" sprintf append-path
  22     dup make-directories ;
  23
  24 : get-out-directory ( -- path )
  25     out-directory get [ dll-out-directory ] unless* ;
  26
  27 : with-out-directory ( path quot -- )
  28     [ out-directory ] dip with-variable ; inline
  29
  30 : remake-directory ( path -- )
  31     [ ?delete-tree ] [ make-directories ] bi ;
  32
  33 : prepend-current-path ( path -- path' )
  34     current-directory get prepend-path ;
  35
  36 : find-dlls ( path -- paths )
  37     recursive-directory-files
  38     [ file-name >lower ".dll" tail? ] filter ;
  39
  40 ERROR: no-output-file path ;
  41 : copy-output-file-as ( name new-name -- )
  42     [ prepend-current-path dup file-exists? [ no-output-file ] unless ]
  43     [ get-out-directory prepend-path ] bi* copy-file ;
  44
  45 : copy-vm-file-as ( name new-name -- )
  46     [ prepend-current-path ]
  47     [ vm-path parent-directory prepend-path ] bi* copy-file ;
  48
  49 : copy-output-file ( name -- )
  50     prepend-current-path get-out-directory copy-file-into ;
  51
  52 : copy-output-files ( seq -- )
  53     [ copy-output-file ] each ;
  54
  55 : delete-output-file ( name -- )
  56     get-out-directory prepend-path ?delete-file ;
  57
  58 : delete-output-files ( seq -- )
  59     [ delete-output-file ] each ;
  60
  61 : with-build-directory-as ( name quot -- )
  62     [ prepend-current-path dup remake-directory ] dip with-directory ; inline
  63
  64 : with-build-directory ( quot -- ) [ "build" ] dip with-build-directory-as ; inline
  65
  66 : get-build-from-source-directory ( -- path )
  67     build-from-source-directory get ;
  68
  69 : build-from-source-directory-directory-cpu ( -- path )
  70     get-build-from-source-directory cpu name>> append-path ;
  71
  72 : with-build-from-source-cpu-directory ( quot -- )
  73     [ build-from-source-directory-directory-cpu dup make-directories ] dip with-directory ; inline
  74
  75 : build-from-source-directory-gitlab ( -- path )
  76     get-build-from-source-directory "gitlab" append-path ;
  77
  78 : gitlab-disk-path ( base org/user project -- path )
  79     3append-path
  80     build-from-source-directory-gitlab prepend-path absolute-path ;
  81
  82 : gitlab-tag-disk-checkout-path ( base org/user project tag -- path )
  83     [ gitlab-disk-path ] dip append-path absolute-path ;
  84
  85 : with-build-from-source-gitlab-no-checkout-directory ( base org/user quot -- )
  86     [ build-from-source-directory-gitlab prepend-path dup make-directories ] dip with-directory ; inline
  87
  88 : gitlab-git-uri ( base org/user project -- uri ) "git://%s/%s/%s" sprintf ;
  89 : gitlab-http-uri ( base org/user project -- uri ) "http://%s/%s/%s" sprintf ;
  90 : gitlab-https-uri ( base org/user project -- uri ) "https://%s/%s/%s" sprintf ;
  91
  92 : gitlab-uri ( base org/user project -- uri )
  93     use-gitlab-git-uris get [ gitlab-git-uri ] [ gitlab-https-uri ] if ;
  94
  95 : sync-gitlab-no-checkout-repository ( base org/user project -- )
  96     [ 2drop ] [ gitlab-uri ] [ nipd append-path ] 3tri
  97     '[
  98         _ _ sync-no-checkout-repository-as wait-for-success
  99     ] with-build-from-source-gitlab-no-checkout-directory ;
 100
 101 : with-no-checkout-gitlab-repo ( base org/user project quot -- )
 102     [
 103         [ sync-gitlab-no-checkout-repository ]
 104         [ gitlab-disk-path ] 3bi
 105     ] dip with-directory ; inline
 106
 107 : build-from-source-directory-github ( -- path )
 108     get-build-from-source-directory "github" append-path ;
 109
 110 : github-disk-path ( org/user project -- path )
 111     append-path
 112     build-from-source-directory-github prepend-path absolute-path ;
 113
 114 : github-tag-disk-checkout-path ( org/user project tag -- path )
 115     [ github-disk-path ] dip append-path absolute-path ;
 116
 117 : with-build-from-source-github-no-checkout-directory ( org/user quot -- )
 118     [ build-from-source-directory-github prepend-path dup make-directories ] dip with-directory ; inline
 119
 120 : github-uri ( org/user project -- uri )
 121     use-github-git-uris get [ github-git-uri ] [ github-https-uri ] if ;
 122
 123 : sync-github-no-checkout-repository ( org/user project -- )
 124     [ drop ] [ github-uri ] [ nip git-directory-name ] 2tri
 125     '[
 126         _ _ sync-no-checkout-repository-as wait-for-success
 127     ] with-build-from-source-github-no-checkout-directory ;
 128
 129 : check-build-completed ( path -- path' file-contents/f )
 130     "factor-build-completed" append-path
 131     dup file-exists? [ dup utf8 file-contents ] [ f ] if ;
 132
 133 : with-github-worktree-tag ( org/user project tag quot -- )
 134     [
 135         {
 136             [ drop sync-github-no-checkout-repository ]
 137             [ drop github-disk-path ]
 138             [ github-tag-disk-checkout-path ]
 139             [ 2nip ]
 140         } 3cleave
 141     ] dip
 142     '[
 143         _ _
 144         over "build-from-source considering github %s" sprintf print
 145         over check-build-completed [
 146             2nip "- %s already built at %s" sprintf print
 147         ] [
 148             [
 149                 over "%s\n- deleting old build..." sprintf write
 150                 2dup [ ?delete-tree "deleted!" print ]
 151                 [ "- %s building..." sprintf write ] bi*
 152                 [ git-worktree-force-add wait-for-success ] keepd
 153                 _ with-directory
 154                 "done!" print
 155                 now timestamp>rfc3339
 156             ] dip utf8 set-file-contents
 157         ] if*
 158     ] with-directory ; inline
 159
 160 : with-gitlab-worktree-tag ( base org/user project tag quot -- )
 161     [
 162         {
 163             [ drop sync-gitlab-no-checkout-repository ]
 164             [ drop gitlab-disk-path ]
 165             [ gitlab-tag-disk-checkout-path ]
 166             [ 3nip ]
 167         } 4cleave
 168     ] dip
 169     '[
 170         _ _
 171         dup "build-from-source considering gitlab %s" sprintf print
 172         over check-build-completed [
 173             2nip "- %s already built at %s" sprintf print
 174         ] [
 175             [
 176                 over "%s\n- deleting old build..." sprintf write
 177                 2dup [ ?delete-tree "deleted!" print ]
 178                 [ "- %s building..." sprintf write ] bi*
 179                 [ git-worktree-force-add wait-for-success ] keepd
 180                 _ with-directory
 181                 "done!" print
 182                 now timestamp>rfc3339
 183             ] dip utf8 set-file-contents
 184         ] if*
 185     ] with-directory ; inline
 186
 187 : ?download ( path -- )
 188     dup file-name file-exists? [ drop ] [ download drop ] if ; inline
 189
 190 : with-tar-gz ( path quot -- )
 191     '[
 192         _ dup "build-from-source considering tar.gz %s" sprintf print
 193         dup file-name ".tar.gz" ?tail drop check-build-completed [
 194             2nip "- already built at %s" sprintf print
 195         ] [
 196             "- building..." write
 197             [
 198                 [ ?download ]
 199                 [ file-name { "tar" "xvfz" } swap suffix try-process ]
 200                 [ file-name ".tar.gz" ?tail drop ] tri
 201                 prepend-current-path _ with-directory
 202                 now timestamp>rfc3339
 203             ] dip utf8 set-file-contents
 204             "done!" print
 205         ] if*
 206     ] with-build-from-source-cpu-directory ; inline
 207
 208 : split-python-version ( version -- array )
 209     {
 210         { [ dup "a" swap subseq? ] [ [ "a" split1 "99" or "alpha" swap ] keep 4array ] }
 211         { [ dup "b" swap subseq? ] [ [ "b" split1 "99" or "beta" swap ] keep 4array ] }
 212         { [ dup "rc" swap subseq? ] [ [ "rc" split1 "99" or "rc" swap ] keep 4array ] }
 213         [ "z" "99" pick 4array ]
 214     } cond ;
 215
 216 : latest-python ( tags -- tag )
 217     [ [ CHAR: . = ] count 2 >= ] filter
 218     [ split-python-version ] map
 219     [ first ] collect-by
 220     { human<=> } sort-keys-with-spec
 221     last second human-sort last fourth ;
 222
 223 : latest-semver-tags-matching ( owner repo tag-head -- ref-json/f semver/f )
 224     list-repository-tags-matching
 225     [ "ref" of "/" split1-last nip [ >semver ] [ 2drop f ] recover ] zip-with
 226     sift-values sort-values ?last ?first2 ;
 227
 228 : latest-solr ( -- tag-json semver ) "apache" "solr" "releases/solr" latest-semver-tags-matching ;
 229 : latest-lucene ( -- tag-json semver ) "apache" "lucene" "releases/lucene" latest-semver-tags-matching ;
 230
 231 : digit-or-dot? ( str -- ? )
 232     { [ digit? ] [ CHAR: . = ] } 1|| ;
 233
 234 : tag-refs ( tags -- tags' )
 235     [ "ref" of ] map
 236     [ "refs/tags/" ?head drop ] map ;
 237
 238 : python-tags ( -- tags )
 239     "python" "cpython" "v" list-repository-tags-matching tag-refs ;
 240
 241 : tags>latest-python2 ( tags -- tag ) [ "v2." head? ] filter latest-python ;
 242 : latest-python2 ( -- tag ) python-tags tags>latest-python2 ;
 243 : tags>latest-python3 ( tags -- tag )
 244     [ "v3." head? ] filter
 245     [ "." split1-last nip [ digit? ] all? ] filter
 246     latest-python ;
 247 : latest-python3 ( -- tag ) python-tags tags>latest-python3 ;
 248
 249 : rustup-update ( -- )
 250     qw{ rustup update stable } try-process
 251     qw{ rustup update nightly } try-process ;
 252
 253 : latest-fftw ( -- path )
 254     "https://ftp.fftw.org/pub/fftw/" [
 255         http-get nip
 256         parse-html find-links concat
 257         [ name>> text = ] filter
 258         [ text>> ] map
 259         [ "fftw-" head? ] filter
 260         [ ".tar.gz" tail? ] filter
 261         human-sort last
 262     ] keep prepend-path ;
 263
 264 : latest-libressl ( -- path )
 265     "https://ftp.openbsd.org/pub/OpenBSD/LibreSSL/" [
 266         http-get nip parse-html find-links concat
 267         [ name>> text = ] filter
 268         [ text>> ] map
 269         [ "libressl-" head? ] filter
 270         [ ".tar.gz" tail? ] filter last
 271     ] keep prepend ;
 272
 273 : latest-pcre-tar-gz ( -- path )
 274     "https://ftp.exim.org/pub/pcre/" [
 275         http-get nip parse-html find-links concat
 276         [ name>> text = ] filter [ text>> ] map
 277         [ "pcre-" head? ] filter
 278         [ ".tar.gz" tail? ] filter last
 279     ] keep prepend ;
 280
 281 : cairo-versions ( -- version )
 282     "https://gitlab.freedesktop.org/api/v4/projects/956/repository/tags"
 283     http-get nip utf8 decode json> [ "name" of ] map ;
 284
 285 : blas-versions ( -- seq )
 286     "xianyi" "OpenBLAS" "v" list-repository-tags-matching
 287     tag-refs human-sort ;
 288
 289 : duckdb-versions ( -- seq )
 290     "duckdb" "duckdb" "v" list-repository-tags-matching
 291     tag-refs human-sort ;
 292
 293 : grpc-versions ( -- seq )
 294     "grpc" "grpc" "v" list-repository-tags-matching
 295     tag-refs human-sort ;
 296
 297 : capnproto-versions ( -- seq )
 298     "capnproto" "capnproto" "v" list-repository-tags-matching
 299     tag-refs human-sort ;
 300
 301 : pcre2-versions ( -- seq )
 302     "PCRE2Project" "pcre2" "pcre2-" list-repository-tags-matching
 303     tag-refs human-sort ;
 304
 305 : pcre2-release-versions ( -- seq )
 306     pcre2-versions
 307     [ "-" split length 2 = ] filter ;
 308
 309 : lz4-versions ( -- seq )
 310     "lz4" "lz4" "v" list-repository-tags-matching
 311     tag-refs human-sort ;
 312
 313 : openal-versions ( -- seq )
 314     "kcat" "openal-soft" "" list-repository-tags-matching
 315     tag-refs
 316     [ [ digit-or-dot? ] all? ] filter
 317     human-sort ;
 318
 319 : openssl-release-versions ( -- seq )
 320     "openssl" "openssl" "openssl-" list-repository-tags-matching
 321     tag-refs
 322     [ [ CHAR: - = ] count 1 = ] filter
 323     human-sort ;
 324
 325 : openssl-dev-versions ( -- seq )
 326     "openssl" "openssl" "openssl-" list-repository-tags-matching
 327     tag-refs human-sort ;
 328
 329 : postgres-versions ( -- seq )
 330     "postgres" "postgres" "REL_" list-repository-tags-matching
 331     tag-refs human-sort ;
 332
 333 : postgres-release-versions ( -- seq )
 334     postgres-versions
 335     ! no RC1 or BETA1
 336     [ "_" split1-last nip [ digit? ] all? ] filter ;
 337
 338 : raylib-versions ( -- seq )
 339     "raysan5" "raylib" "" list-repository-tags-matching
 340     tag-refs human-sort ;
 341
 342 : raylib-release-versions ( -- seq )
 343     raylib-versions [ "-" swap subseq? ] reject ;
 344
 345 : raygui-versions ( -- seq )
 346     "raysan5" "raygui" "" list-repository-tags-matching
 347     tag-refs human-sort ;
 348
 349 : raygui-release-versions ( -- seq )
 350     raygui-versions [ "-" swap subseq? ] reject ;
 351
 352 : ripgrep-versions ( -- seq )
 353     "BurntSushi" "ripgrep" "" list-repository-tags-matching
 354     tag-refs
 355     [ [ digit-or-dot? ] all? ] filter
 356     human-sort ;
 357
 358 : snappy-versions ( -- seq )
 359     "google" "snappy" "" list-repository-tags-matching
 360     tag-refs human-sort ;
 361
 362 : sqlite-versions ( -- seq )
 363     "sqlite" "sqlite" "version-" list-repository-tags-matching
 364     tag-refs human-sort ;
 365
 366 : winflexbison-versions ( -- seq )
 367     "lexxmark" "winflexbison" "v" list-repository-tags-matching
 368     tag-refs [ "v." head? ] reject human-sort ;
 369
 370 : yaml-versions ( -- seq )
 371     "yaml" "libyaml" "" list-repository-tags-matching
 372     tag-refs [ [ digit-or-dot? ] all? ] filter human-sort ;
 373
 374 : zeromq-versions ( -- seq )
 375     "zeromq" "libzmq" "" list-repository-tags-matching
 376     tag-refs human-sort ;
 377
 378 : zlib-versions ( -- seq )
 379     "madler" "zlib" "v" list-repository-tags-matching
 380     tag-refs human-sort ;
 381
 382 : zstd-versions ( -- seq )
 383     "facebook" "zstd" "v" list-repository-tags-matching
 384     tag-refs human-sort
 385     [
 386         {
 387             [ length 2 >= ]
 388             [ "v" head? ]
 389             [ second digit? ]
 390             [ last digit? ]
 391         } 1&&
 392     ] filter ;