From 23e690b302eeb5aa8f5cfd2e2d717221ef91092b Mon Sep 17 00:00:00 2001 From: voidlizard Date: Mon, 3 Feb 2025 12:25:54 +0300 Subject: [PATCH] wip, suckless to support imports + simple web publishing --- examples/site/bar.ss | 35 ++++ examples/site/foo.ss | 96 +++++++++ examples/site/site.ss | 44 ++++ hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs | 197 +++++++----------- hbs2-cli/lib/HBS2/CLI/Run/Tree.hs | 11 +- hbs2-peer/app/HttpWorker.hs | 4 +- .../Data/Config/Suckless/Script/Internal.hs | 20 +- 7 files changed, 285 insertions(+), 122 deletions(-) create mode 100644 examples/site/bar.ss create mode 100644 examples/site/foo.ss create mode 100644 examples/site/site.ss diff --git a/examples/site/bar.ss b/examples/site/bar.ss new file mode 100644 index 00000000..e2cc7a7d --- /dev/null +++ b/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 + + ]] + +) + + + diff --git a/examples/site/foo.ss b/examples/site/foo.ss new file mode 100644 index 00000000..fa2585c4 --- /dev/null +++ b/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] + "." + ] + ] +] + +) + diff --git a/examples/site/site.ss b/examples/site/site.ss new file mode 100644 index 00000000..cc52120e --- /dev/null +++ b/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) ; вызываем фарфокс + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs index 60c81932..1ea0afed 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs +++ b/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 - , MonadUnliftIO m - , Exception (BadFormException c) - , HasStorage m - , HasClientAPI StorageAPI UNIX m +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 -7dGqTtoehsgn7bADcVTyp93tq2FfuQgtBuVvYL46jdyz + let metadataCreateMan = brief "creates a tree with metadata" + let kw = arg "kw" "opts" -;; empty metadata + metadataCreateMan $ args [kw, arg "string" "filename"] $ + entry $ bindMatch "hbs2:tree:metadata:file" $ \case + [ syn@(ListVal{}), StringLike fn ] -> do + meta0 <- liftIO do + 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) -hbs2-cli hbs2:tree:metadata:get 7dGqTtoehsgn7bADcVTyp93tq2FfuQgtBuVvYL46jdyz + _ -> throwIO (BadFormException @c nil) -Create merkle tree with custom metadata + metadataCreateMan $ args [kw] $ + entry $ bindMatch "hbs2:tree:metadata:stdin" $ \case + [syn@(ListVal{})] -> do + doCreateMetadataTree mempty syn (liftIO LBS.getContents) -$ echo TEST | hbs2-cli hbs2:tree:metadata:create :stdin [kw hello world] -2ASBLBPRUMrHoSkNYsRWwJQiiXuSGDZTaCXAdDTdeJY6 + _ -> throwIO (BadFormException @c nil) -$ hbs2-cli hbs2:tree:metadata:get 2ASBLBPRUMrHoSkNYsRWwJQiiXuSGDZTaCXAdDTdeJY6 -hello: "world" + metadataCreateMan $ args [kw, arg "string" "input"] $ + 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) -$ 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) - ] - - let meta1 = HM.fromList [ (txt n, txt e) | MetaDataEntry n e <- universeBi opts ] - - let enc = headMay [ e | x@(Encrypted e) <- universeBi opts ] - - gk <- runMaybeT do - s <- toMPlus enc - g <- lift $ loadGroupKey (fromString s) - toMPlus g - - when (isJust enc && isNothing gk) do - error $ show $ "Can't load group key" <+> pretty enc - - sto <- getStorage - - href <- lift (createTreeWithMetadata sto gk (meta0 <> meta1) lbs) - `orDie` "encryption error" - - pure $ mkStr (show $ pretty href) + _ -> throwIO (BadFormException @c nil) 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) + + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs b/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs index a868899b..ffecff12 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs +++ b/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 diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index 7283aac6..5f723d90 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/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 diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs index c43d84d1..9632f436 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/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