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