wip, suckless to support imports + simple web publishing

examples/site/bar.ss

@@ -0,0 +1,35 @@
+; это страница, на которую ссылается foo.ss
+
+(define (bar-page)
+
+[html :html [kw]
+ [html :head [kw]
+   [html :title [kw] Suckless HTML Page]
+   [html :meta [kw :charset UTF-8]]
+   [html :style [kw]
+     [css body [kw font-family sans-serif margin-left 20px max-width 1024px]]
+     [css table [kw border-collapse collapse width auto]]
+
+     [css (list td th) [kw border [sym (unwords 1px solid #ccc)]
+                           padding 8px
+                           text-align left]]
+
+     [css th [kw background-color #f2f2f2 white-space nowrap]]
+     [css .che [kw margin-right 8px]]
+   ]
+ ]
+
+ [html :body [kw]
+   [html :h1 [kw] Some other page]
+   [html :h2 [kw] Built with Suckless Script]
+
+   [html :p [kw] This is an example page generated using hbs2.]
+
+   Just some text
+
+ ]]
+
+)
+
+
+

examples/site/foo.ss

@@ -0,0 +1,96 @@
+; это наш "сайт" -- poo.ss
+
+; просто какой-то левый json
+[define source [json:file miscellaneous/fuzzy-parse/nix/pkgs.json]]
+
+(define (foo-page bar)
+
+[html :html [kw]
+  [html :head [kw]
+    [html :title [kw] Suckless HTML Page]
+    [html :meta [kw :charset UTF-8]]
+    [html :style [kw]
+      [css body [kw font-family sans-serif margin-left 20px max-width 1024px]]
+      [css table [kw border-collapse collapse width auto]]
+
+      [css (list td th) [kw border [sym (unwords 1px solid #ccc)]
+                            padding 8px
+                            text-align left]]
+
+      [css th [kw background-color #f2f2f2 white-space nowrap]]
+      [css .che [kw margin-right 8px]]
+    ]
+  ]
+
+  [html :body [kw]
+    [html :h1 [kw] Super Cool HBS2 Suckless Script Example Page]
+    [html :h2 [kw] Built with Suckless Script]
+
+    [html :p [kw] This is an example page generated using hbs2.]
+
+    [html :p [kw] [html :a [kw href [concat ../../tree/ bar]] Referes to bar ] ]
+
+    [html :form [kw action # method POST]
+      [html :label [kw for cb1]
+        [html :input [kw :type checkbox name checkbox1 :id cb1 :class che]]
+        I agree with the terms
+      ]
+      [html :br]
+      [html :input [kw :type text :name username :placeholder "Enter your name"]]
+      [html :br]
+      [html :input [kw :type submit :value Submit]]
+    ]
+
+    [html :br]
+
+    [html :p [kw]
+      This text contains
+
+      [html :b [kw] bold]
+
+      chr:comma
+
+      [html :i [kw] italic]
+
+      :and
+
+      [html :u [kw] :underlined]
+
+      styles.
+    ]
+
+    [html :br]
+
+    ; Unicode test section
+    [html :p [kw] Russian: Привет, мир!]
+    [html :p [kw] Chinese: 你好，世界！]
+    [html :p [kw] Korean: 안녕하세요, 세계!]
+
+    [html :br]
+
+    [html :table [kw]
+      [html :thead [kw]
+        [html :tr [kw]
+          [html :th [kw] Package]
+          [html :th [kw] Version]
+        ]
+      ]
+
+      [html :tbody [kw]
+        [map [fn 1 [html :tr [kw] [html :th [kw] [car _1]]
+                   [html :td [kw] [nth 1 _1]]  ] ] source]
+      ]
+    ]
+
+    [html :br]
+
+    [html :p [kw]
+      For more information, visit
+      [html :a [kw href http://example.com] our website]
+      "."
+    ]
+  ]
+]
+
+)
+

examples/site/site.ss

@@ -0,0 +1,44 @@
+
+; [eval [cons :begin [top:file bar.ss]]]
+
+(import bar.ss)
+(import foo.ss)
+
+(define site-root-ref :4X65y4YvUjRL2gtA9Ec3YDDP4bnxjTGhfjpoah96t3z1)
+
+(define (as-html n) [kw :file-name n :mime-type "text/html; charset=utf-8"]) ; метаданные что бы hbs2-peer отображал как вебстраницу
+
+(define bar.html (bar-page)) ; генерим страничку
+
+(define bar.hash (hbs2:tree:metadata:string [as-html :bar.html] bar.html)) ; сохраняем как дерево с метаданными
+
+(define foo.html (foo-page bar.hash))
+
+(define foo.hash (hbs2:tree:metadata:string [as-html :foo.html] foo.html)) ; сохраняем как дерево с метаданными
+
+(define grove [hbs2:grove:annotated [kw webroot foo.hash] [list foo.hash bar.hash]])
+
+; println :bar.html space "hash:" space bar.hash
+
+println Grove: space grove ; hello.hash
+
+hbs2:lwwref:update site-root-ref grove
+
+; newline
+
+; print [hbs2:lwwref:get site-root-ref]
+
+(define url [sym [join / http://localhost:5000/ref site-root-ref]]) ; вычисляем url
+
+; newline
+
+; print url
+
+; print bar.html
+
+; print foo.html
+
+; print site-root-ref
+
+(call:proc "firefox" url) ; вызываем фарфокс
+

hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs

@@ -28,12 +28,14 @@ import Codec.Serialise
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Cont
 import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy (ByteString)
 import Data.Either
 import Data.Set qualified as Set
 import Data.HashMap.Strict qualified as HM
 import Data.Maybe
 import Data.Text.Encoding qualified as TE
 import Data.Text qualified as Text
+import Data.Text.IO qualified as TIO
 
 import Magic.Data
 import Magic.Init       (magicLoadDefault,magicOpen)
@@ -59,11 +61,14 @@ metaFromSyntax syn =
     t x = Text.pack (show $ pretty x)
 
 
-metaDataEntries :: forall c m . ( IsContext c
+type ForMetadata c m = ( IsContext c
                        , MonadUnliftIO m
                        , Exception (BadFormException c)
                        , HasStorage m
                        , HasClientAPI StorageAPI UNIX m
+                       )
+
+metaDataEntries :: forall c m . ( ForMetadata c m
                                 ) => MakeDictM c m ()
 metaDataEntries = do
 
@@ -199,126 +204,38 @@ file-name: "qqq.txt"
 
      _ -> throwIO (BadFormException @c nil)
 
-  brief "creates a merkle tree with metadata"
-    $ returns "string" "hash"
-    $ args [ arg "list-of-options" "..." ]
-    $ desc ( "options:" <> line
-             <> indent 4 (
-                  vcat [ opt ":stdin" "read data from stdin"
-                       , opt ":auto"  "create metadata from file using libmagic"
-                       , opt  "[kw [encrypted group-key-hash]]" "encrypt metadata with given group key"
-                       , opt  "dict" "custom metadata dictionary"
-                       , opt  "filename : string-like" "file name, ignored if stdin option set"
-                       ])
-             )
-    $ examples [qc|
-Create not encrypted merkle tree for string from stdin without metadata
 
-$ echo TEST | hbs2-cli hbs2:tree:metadata:create :stdin
+  let metadataCreateMan = brief "creates a tree with metadata"
-7dGqTtoehsgn7bADcVTyp93tq2FfuQgtBuVvYL46jdyz
+  let kw = arg "kw" "opts"
 
-;; empty metadata
+  metadataCreateMan $ args [kw, arg "string" "filename"] $
-
+    entry $ bindMatch "hbs2:tree:metadata:file" $ \case
-hbs2-cli hbs2:tree:metadata:get 7dGqTtoehsgn7bADcVTyp93tq2FfuQgtBuVvYL46jdyz
+      [ syn@(ListVal{}), StringLike fn ] -> do
-
+          meta0 <- liftIO do
-Create merkle tree with custom metadata
-
-$ echo TEST | hbs2-cli hbs2:tree:metadata:create :stdin [kw hello world]
-2ASBLBPRUMrHoSkNYsRWwJQiiXuSGDZTaCXAdDTdeJY6
-
-$ hbs2-cli hbs2:tree:metadata:get  2ASBLBPRUMrHoSkNYsRWwJQiiXuSGDZTaCXAdDTdeJY6
-hello: "world"
-
-$ hbs2-cli  hbs2:tree:metadata:get 7YyWZ44sWpHvrqnFxL8G8HJo4o4p659diusZoHyhXCTx
-((mime-type: "text/plain; charset=us-ascii") (file-name: "MetaData.hs"))
-
-$ hbs2-cli hbs2:tree:metadata:create :auto ./lambda.svg
-3fv5ym8NhY8zat37NaTvY9PDcwJqMLUD73ewHxtHysWg
-
-Create encrypted tree metadata with a new groupkey
-
-$ hbs2-cli [define pks [list EiwWxY3xwTfnLKJdzzxNMZgA2ZvYAZd9e8B8pFeCtnrn]] \
-  and [define gk [hbs2:groupkey:store [hbs2:groupkey:create pks]]] \
-  and [hbs2:tree:metadata:create :auto [kw :encrypted gk] ./lambda.svg]
-
-BFLcbpNEqngsJ8gzx3ps4ETXfpUMGgjEETNEVgR18KG4
-
-Check group key
-
-$ hbs2-cli hbs2:tree:metadata:get-gk BFLcbpNEqngsJ8gzx3ps4ETXfpUMGgjEETNEVgR18KG4y
-
-GixS4wssCD4x7LzvHve2JhFCghW1Hwia2tiGTfTTef1u
-
-Check metadata
-
-$ hbs2-cli hbs2:tree:metadata:get BFLcbpNEqngsJ8gzx3ps4ETXfpUMGgjEETNEVgR18KG4y
-
-mime-type: "image/svg+xml; charset=us-ascii"
-file-name: "lambda.svg"
-
-List group key
-
-$ hbs2-cli hbs2:groupkey:list-public-keys [hbs2:groupkey:load GixS4wssCD4x7LzvHve2JhFCghW1Hwia2tiGTfTTef1u]
-("EiwWxY3xwTfnLKJdzzxNMZgA2ZvYAZd9e8B8pFeCtnrn")
-    |]
-    $ entry $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do
-        case syn of
-
-          args -> do
-            opts' <- for args $ \case
-              SymbolVal "stdin"     -> pure [Stdin]
-
-              SymbolVal "auto"      -> pure [Auto]
-
-              ListVal [ListVal [SymbolVal "encrypted", StringLike key]]
-                -> do
-                  pure [Encrypted key]
-
-              ListVal ws  -> do
-                pure [MetaDataEntry x y | ListVal [SymbolVal x, StringLike y] <- ws ]
-
-              StringLike rest  -> do
-                pure [MetaDataFile rest]
-
-              _ -> pure mempty
-
-            let opts = mconcat opts' & Set.fromList
-            let inFile = headMay [ x | MetaDataFile x <- universeBi opts ]
-
-            lbs <- case (Set.member Stdin opts, inFile) of
-                     (True, _) -> liftIO LBS.getContents
-                     (False, Just fn) -> liftIO (LBS.readFile fn)
-                     (_, Nothing) -> liftIO LBS.getContents
-
-            meta0 <- if not (Set.member Auto opts) || isNothing inFile then
-                       pure (mempty :: HashMap Text Text)
-                     else liftIO do
-                        let fn = fromJust inFile
             magic <- magicOpen [MagicMimeType,MagicMime,MagicMimeEncoding]
             magicLoadDefault magic
             mime <- magicFile magic fn
             pure $ HM.fromList [ ("file-name", Text.pack (takeFileName fn))
                                , ("mime-type", Text.pack mime)
                                ]
+          doCreateMetadataTree meta0 syn (liftIO $ LBS.readFile fn)
 
-            let meta1  = HM.fromList [  (txt n, txt e) | MetaDataEntry n e <- universeBi opts ]
+      _ -> throwIO (BadFormException @c nil)
 
-            let enc = headMay [ e | x@(Encrypted e) <- universeBi opts ]
+  metadataCreateMan $ args [kw] $
+    entry $ bindMatch "hbs2:tree:metadata:stdin" $ \case
+        [syn@(ListVal{})] -> do
+          doCreateMetadataTree mempty syn (liftIO LBS.getContents)
 
-            gk <- runMaybeT do
+        _ -> throwIO (BadFormException @c nil)
-                    s <- toMPlus enc
-                    g <- lift $ loadGroupKey (fromString s)
-                    toMPlus g
 
-            when (isJust enc && isNothing gk) do
+  metadataCreateMan $ args [kw, arg "string" "input"] $
-              error $ show $  "Can't load group key" <+> pretty enc
+    entry $ bindMatch "hbs2:tree:metadata:string" $ \case
+        [ syn@(ListVal{}), TextLike content ] -> do
+          -- liftIO $ TIO.putStr content
+          doCreateMetadataTree mempty syn (pure $ LBS.fromStrict $ TE.encodeUtf8 content)
 
-            sto <- getStorage
+        _ -> throwIO (BadFormException @c nil)
-
-            href <- lift (createTreeWithMetadata sto  gk (meta0 <> meta1) lbs)
-                      `orDie` "encryption error"
-
-            pure $ mkStr (show $ pretty href)
 
   entry $ bindMatch "cbor:base58" $ \case
     [ LitStrVal x ] -> do
@@ -327,3 +244,47 @@ $ hbs2-cli hbs2:groupkey:list-public-keys [hbs2:groupkey:load GixS4wssCD4x7LzvHv
     _ -> throwIO (BadFormException @c nil)
 
 
+groupKeyFromSyntax :: Syntax c -> Maybe HashRef
+groupKeyFromSyntax = \case
+  ListVal es -> headMay [ v | ListVal [ TextLike "gk", HashLike v ] <- es ]
+  _ -> Nothing
+
+loadGroupKeyFromSyntax :: ( ForMetadata c m )
+                       => Syntax c
+                       -> RunM c m (Maybe (GroupKey 'Symm 'HBS2Basic))
+
+loadGroupKeyFromSyntax syn = runMaybeT do
+  hash <- groupKeyFromSyntax syn & toMPlus
+  toMPlus =<< lift (loadGroupKey hash)
+
+metadataFromSyntax :: Syntax c -> HashMap Text Text
+metadataFromSyntax = \case
+  ListVal es -> HM.fromList [ (k,v) | ListVal [ TextLike k, TextLike v] <- es, k /= "gk" ]
+  _ -> mempty
+
+
+doCreateMetadataTree :: forall c m . ForMetadata c m
+                     => HashMap Text Text
+                     -> Syntax c
+                     -> m ByteString
+                     -> RunM c m (Syntax c)
+doCreateMetadataTree meta0 syn getLbs = do
+  let meta = metadataFromSyntax syn
+  let gkh  = groupKeyFromSyntax syn
+
+  gk <- loadGroupKeyFromSyntax syn
+
+  when (isJust gkh && isNothing gk) do
+    throwIO (GroupKeyNotFound 1)
+
+  sto <- getStorage
+
+  lbs <- lift getLbs
+
+  href <- lift (createTreeWithMetadata sto  gk (meta0 <> meta) lbs)
+             >>= orThrow StorageError
+
+  pure $ mkStr (show $ pretty href)
+
+
+

hbs2-cli/lib/HBS2/CLI/Run/Tree.hs

@@ -25,6 +25,15 @@ import Data.Text qualified as Text
 import Control.Monad.Except
 import Codec.Serialise
 
+pattern GroveHashes :: forall {c}. [HashRef] -> [Syntax c]
+pattern GroveHashes hashes <- ( groveHashes -> hashes )
+
+groveHashes :: [Syntax c] -> [HashRef]
+groveHashes = \case
+  [ ListVal (HashLikeList hashes) ] -> hashes
+  HashLikeList hashes -> hashes
+  _ -> mempty
+
 treeEntries :: forall c m . ( IsContext c
                                 , MonadUnliftIO m
                                 , Exception (BadFormException c)
@@ -65,7 +74,7 @@ It's just an easy way to create a such thing, you may browse it by hbs2 cat -H
         _ -> throwIO (BadFormException @c nil)
 
   entry $ bindMatch "hbs2:grove:annotated" $ \case
-    (ListVal ann : HashLikeList hashes@(x:_)) -> lift do
+    (ListVal ann : GroveHashes hashes) -> lift do
       sto <- getStorage
 
       let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) hashes

hbs2-peer/app/HttpWorker.hs

@@ -227,11 +227,11 @@ getTreeHash sto what'' = void $ flip runContT pure do
              ]
 
     let webroot = headMay [ w
-                          | i < 2, ListVal [SymbolVal "webroot", HashLike w] <- meta
+                          | i < 3, ListVal [SymbolVal "webroot", HashLike w] <- meta
                           ]
 
     case webroot of
-      Just x | i < 2 -> again (x, succ i)
+      Just x | i < 3 -> again (x, succ i)
 
       _ -> do
 

miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs

@@ -617,7 +617,8 @@ eval' dict0 syn' = handle (handleForm syn') $ do
 
     let dict = dict0 <> dict1
 
-    -- liftIO $ print $ show $ "TRACE EXP" <+> pretty syn
+    -- liiftIO $ print $ show $ "TRACE EXP" <+> pretty syn
+    let importDecls = HS.fromList [  "define", "define-macro" :: Id ]
 
     case syn' of
 
@@ -653,6 +654,23 @@ eval' dict0 syn' = handle (handleForm syn') $ do
 
       ListVal [ SymbolVal "eval", e ] -> eval e >>= eval
 
+      ListVal [ SymbolVal "import", StringLike fn ] -> do
+        -- FIXME: fancy-error-handling
+        syn <- liftIO (TIO.readFile fn) <&> parseTop >>= either(error.show) pure
+
+        let decls = [ fixContext d
+                    | d@(ListVal (SymbolVal what : rest)) <- syn
+                    , what `HS.member` importDecls
+                    ]
+
+        -- liftIO $ mapM_ (print . pretty) decls
+
+        mapM_ eval decls
+
+        pure nil
+
+        -- error $ show $ "fucked!"  <+> pretty fn
+
       ListVal [SymbolVal "define", SymbolVal what, e] -> do
         ev <- eval e
         bind what ev>> pure nil