storage.f

   1 REQUIRE STR@ ~ac/lib/str5.f
   2 REQUIRE new-hash ~pinka/lib/hash-table2.f
   3 REQUIRE cat ~ygrek/lib/cat.f
   4 REQUIRE AsQWord ~pinka/spf/quoted-word.f
   5 REQUIRE OCCUPY ~pinka/samples/2005/lib/append-file.f
   6 REQUIRE MD5 ~clf/md5-ts.f
   7 REQUIRE LAY-PATH ~pinka/samples/2005/lib/lay-path.f \ creation of path directories
   8 REQUIRE NUMBER ~ygrek/lib/parse.f
   9 REQUIRE list-make ~ygrek/lib/list/make.f
  10 REQUIRE list-ext ~ygrek/lib/list/ext.f
  11 REQUIRE FileLines=> ~ygrek/lib/filelines.f
  12
  13 MODULE: storage
  14 : datadir S" data" ;
  15 ;MODULE
  16
  17 [UNDEFINED] WINAPI: [IF]
  18 REQUIRE READDIR ~ygrek/lib/linux/findfile.f
  19 WARNING @ WARNING 0!
  20 : FIND-FILES-R FIND-FILES ;
  21 WARNING !
  22 USER FIND-FILES-DEPTH
  23 [THEN]
  24 REQUIRE ITERATE-FILES ~profit/lib/iterate-files.f
  25
  26 \ TODO locking
  27
  28 : /PAD 1024 1- ;
  29 : STR>PAD ( s -- a u )
  30   DUP STR@ /PAD MIN >R PAD R@ CMOVE
  31   STRFREE
  32   PAD R> 2DUP + 0 SWAP C! ;
  33
  34 : FORCE-PATH-CATCH 2DUP LAY-PATH-CATCH ;
  35
  36 MODULE: storage
  37 MODULE: detail
  38
  39 : fullpath ( `path -- `path' ) datadir " {s}/{s}" STR>PAD ;
  40 : dirname ( `name -- `dir ) MD5 fullpath ;
  41 : name-version-file ( `name version -- `file ) -ROT dirname " {s}/{n}" STR>PAD ;
  42 : update-catalog ( `name n -- `name n )
  43   DUP 0 <> IF EXIT THEN \ no need to update - it is already there
  44   >R
  45   2DUP `catalog fullpath FORCE-PATH-CATCH DROP ATTACH-LINE-CATCH DROP \ FIXME logging here
  46   R> ;
  47
  48 EXPORT
  49
  50 \ NB instead of CUT-FILENAME and FIND-FILES better use simply READDIR but it is not implemented on Win32
  51 : get-versions ( `name -- nl ) dirname LAMBDA{ NIP IF 2DROP EXIT THEN CUT-FILENAME NUMBER IF % THEN } %[ FIND-FILES ]% ;
  52 : latest-version ( `name - n ) get-versions 0 OVER ['] MAX list::iter SWAP list::free ;
  53 : store ( `content `name -- ) 2DUP latest-version update-catalog 1+ name-version-file
  54   FORCE-PATH-CATCH DROP OCCUPY-CATCH DROP ; \ FIXME logging here
  55
  56 : exists ( `name -- ? ) dirname FILE-EXIST ;
  57 : get-xml-version ( `name version -- h TRUE | FALSE )
  58    name-version-file __cat IF STRFREE FALSE EXIT THEN
  59    ( s ) small-hash { s h }
  60    s STR@ `content h HASH!
  61    s STRFREE
  62    h TRUE ;
  63
  64 : get-xml-latest ( `name -- h TRUE | FALSE )
  65    2DUP latest-version ?DUP 0 = IF 2DROP FALSE EXIT THEN
  66    get-xml-version ;
  67
  68 : all=> ( --> a u \ <-- ) PRO `catalog fullpath FileLines=> DUP STR@ CONT ;
  69
  70 ;MODULE
  71 ;MODULE
  72
  73 /TEST
  74
  75 ALSO storage
  76 \ `page detail::dirname :NONAME . . TYPE CR ; READDIR
  77 \ `page get-versions
  78
  79 \ `test1 `page store
  80 \ `test2 `page store
  81 \ `page exists .
  82 \ `page latest-version .
  83
  84 `MainPage.xml FILE `MainPage store
  85 `article.xml FILE `article store
  86 `Rules.xml FILE `Rules store