basis/http/download/download.factor

   1 ! Copyright (C) 2024 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors calendar checksums combinators.short-circuit
   4 http.client io io.directories io.encodings.binary io.files
   5 io.files.info io.files.unique io.pathnames kernel math
   6 math.order math.parser present sequences shuffle splitting ;
   7
   8 IN: http.download
   9
  10 : file-too-old-or-not-exists? ( path duration -- ? )
  11     [ ?file-info [ created>> ] ?call ]
  12     [ ago ] bi*
  13     over [ before? ] [ 2drop t ] if ;
  14
  15 : delete-when-old ( path duration -- deleted? )
  16     dupd file-too-old-or-not-exists? [ ?delete-file t ] [ drop f ] if ;
  17
  18 : file-matches-checksum? ( path checksum-type bytes -- ? )
  19     [ checksum-file ] dip = ;
  20
  21 : delete-when-checksum-mismatches ( path checksum-type bytes -- deleted? )
  22     dupdd file-matches-checksum? [ drop f ] [ ?delete-file t ] if ;
  23
  24 : file-size= ( path n -- ? ) [ ?file-info [ size>> ] ?call ] dip = ;
  25
  26 : file-zero-size? ( path -- ? ) 0 file-size= ;
  27
  28 : delete-when-zero-size ( path -- deleted-or-not-exists? )
  29     dup file-exists? [
  30         dup file-zero-size? [ ?delete-file t ] [ drop f ] if
  31     ] [
  32         drop t
  33     ] if ;
  34
  35 : delete-when-file-size-mismatches? ( path size -- deleted? )
  36     dupd file-size= [ drop f ] [ ?delete-file t ] if ;
  37
  38 : download-name ( url -- name )
  39     present file-name "?" split1 drop "/" ?tail drop ;
  40
  41 <PRIVATE
  42
  43 : increment-file-extension ( path -- path' )
  44     dup file-extension
  45     [ ?tail drop ]
  46     [
  47         [ string>number ]
  48         [ 1 + number>string append ]
  49         [ ".1" 3append ] ?if
  50     ] bi ;
  51
  52 : ?parenthesis-number ( str -- n/f )
  53     [
  54         {
  55             [ "(" head? ]
  56             [ ")" tail? ]
  57             [ rest but-last string>number ]
  58         } 1&&
  59     ] [ drop f ] ?unless ;
  60
  61 : increment-file-name ( path -- path' )
  62     [
  63         file-stem " " split1-last
  64         [ ?parenthesis-number ]
  65         [ 1 + number>string "(" ")" surround " " glue ]
  66         [ "(1)" append " " glue ] ?if
  67     ] [
  68         file-extension
  69     ] bi "." glue ;
  70
  71 : find-next-incremented-name ( path -- path' )
  72     dup file-exists? [
  73         increment-file-name find-next-incremented-name
  74     ] when ;
  75
  76 : next-download-name ( url -- name )
  77     download-name find-next-incremented-name ;
  78
  79 : http-write-request ( url -- )
  80     <get-request> [ write ] with-http-request drop ;
  81
  82 : download-temporary-name ( url -- prefix suffix )
  83     [ "temp." ".temp" ] dip download-name prepend ;
  84
  85 PRIVATE>
  86
  87 : download-to ( url path -- path )
  88     [
  89         [ download-temporary-name binary ] keep
  90         '[ _ http-write-request ] with-unique-file-writer
  91     ] dip [ move-file ] keep ;
  92
  93 : download-once-to ( url path -- path )
  94     dup file-exists? [ nip ] [ download-to ] if ;
  95
  96 : download-once ( url -- path )
  97     dup download-name download-once-to ;
  98
  99 : download-outdated-to ( url path duration -- path )
 100     2dup delete-when-old [ drop download-to ] [ drop nip ] if ;
 101
 102 : download ( url -- path )
 103     dup download-name download-to ;