karchnu
/
halogen-websocket-ipc-playzone
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

PlayingWithParsers == HomeInterface

beta
Philippe Pittoli 2023-07-23 22:43:37 +02:00
parent 016f0e03c5
commit 1101ab70bd
1 changed files with 102 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

224
drop/PlayingWithParsers.purs
View File

@ -1,47 +1,31 @@
-- | `App.HomeInterface` presents the website and its features. -- | `App.HomeInterface` presents the website and its features.
module App.HomeInterface where module App.HomeInterface where
import Prelude import Prelude (Unit, map, show, ($), (<>))
import DomainParser as DomainParser
import Control.Alt ((<|>)) --import Data.Either (Either(..))
import Control.Lazy (defer) -- import Data.Maybe (Maybe(..), maybe)
import Data.Array (many, length, snoc, last) -- import Data.Tuple (Tuple(..))
import Data.Either (Either(..))
import Data.Foldable (fold, foldl)
import Data.Maybe (Maybe(..))
import Data.Array.NonEmpty as NonEmpty
import Data.String.CodeUnits as CU
import Data.String as S -- length
-- import Data.String.Regex as R
-- import Data.String.Regex.Flags as RF
import Data.Tuple (Tuple(..))
import Effect.Aff.Class (class MonadAff) import Effect.Aff.Class (class MonadAff)
import Effect (Effect)
import Halogen as H import Halogen as H
import Halogen.HTML as HH import Halogen.HTML as HH
import Parsing
-- import Halogen.HTML.Events as HE -- import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP import Halogen.HTML.Properties as HP
import Parsing
import Parsing.Combinators as PC
import Parsing.Combinators.Array (many1)
import Parsing (Parser, runParser)
import Parsing.String
import Parsing.String.Basic
import Parsing.String.Basic (alphaNum, letter)
import Parsing.String (char, string, eof)
-- import TryPureScript (h1, h3, p, text, render, code)
import Bulma (h1, h3, p, text, code)
import Bulma as Bulma import Bulma as Bulma
type Input = Unit type Input = Unit
--type Action = Unit
data Action = UpdateStuff String data Action = UpdateStuff String
-- type State = Unit
type State = { stuff :: String }
data Query a = DoNothing a data Query a = DoNothing a
type Output = Unit type Output = Unit
type Slot = H.Slot Query Output type Slot = H.Slot Query Output
type State = { stuff :: String }
component :: forall m. MonadAff m => H.Component Query Input Output m component :: forall m. MonadAff m => H.Component Query Input Output m
component = component =
H.mkComponent H.mkComponent
@ -52,29 +36,53 @@ component =
} }
} }
-- handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
-- handleAction _ = pure unit
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of handleAction = case _ of
UpdateStuff val -> H.modify_ _ { stuff = val } UpdateStuff val -> H.modify_ _ { stuff = val }
-- initialState :: forall input. input -> State
-- initialState _ = unit
initialState :: forall input. input -> State initialState :: forall input. input -> State
initialState _ = { stuff: "" } initialState _ = { stuff: "" }
render :: forall m. State -> H.ComponentHTML Action () m list_of_domains_to_test :: Array String
render state list_of_domains_to_test
= HH.div_ $ = [ "ex.net"
[ Bulma.hero_danger "A simple input" "Nothing much to see" , "??"
, Bulma.section_small $
[ h1 "Examples of domain parsing in Purescript"
] <> test_domains [ "ex.net"
, "e-x.net" , "e-x.net"
, "way-too-long--way-too-long--way-too-long--way-too-long--way-too-long.net" , "way-too-long--way-too-long--way-too-long--way-too-long--way-too-long.net"
, "way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.net" , "way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.net"
, "e-.net" , "e-.net"
, "-x.net" , "-x.net"
, "truc-blah.example.com" , "truc-blah.example.com"
, "te.s-t.net" , "te.s-t.net"
, "example.com" , "example.com"
] ]
render :: forall m. State -> H.ComponentHTML Action () m
render state
= HH.div_
[ Bulma.hero_danger
"THIS IS AN ALPHA RELEASE"
"Come back later!"
, Bulma.section_small
[ Bulma.h1 "Welcome to netlib.re"
, Bulma.subtitle "Free domain names"
, Bulma.hr
, render_description
, render_second_line
, render_why_and_contact
, Bulma.hr
, render_how_and_code
]
, Bulma.hero_danger "A simple input" "Nothing much to see"
, Bulma.section_small $
[ Bulma.h1 "Examples of domain parsing in Purescript"
] <> test_domains list_of_domains_to_test
, Bulma.section_small [ render_stuff ] , Bulma.section_small [ render_stuff ]
] ]
where where
@ -86,11 +94,11 @@ render state
render_stuff = Bulma.columns_ [ b [ title "stuff" render_stuff = Bulma.columns_ [ b [ title "stuff"
, stuff_input , stuff_input
] ]
, b [ title "result" --, b [ title "result"
, p $ case runParser state.stuff parse_stuff of -- , p $ case runParser state.stuff DomainParser.parse_stuff of
Left _ -> "NOT OKAY" -- Left _ -> "NOT OKAY"
Right _ -> "OKAY" -- Right _ -> "OKAY"
] -- ]
] ]
stuff_input stuff_input
@ -107,95 +115,57 @@ render state
-- tests_on_domain :: String -> _ -- tests_on_domain :: String -> _
tests_on_domain d tests_on_domain d
= b [ Bulma.strong $ d <> " -> [ldhstr, label, subdomain, domain]" = b [ Bulma.strong $ d <> " -> [ldhstr, label, subdomain, domain]"
, p $ d <> " : ldhstr : " <> (show $ runParser d ldhstr) , p $ d <> " : ldhstr : " <> (show $ runParser d DomainParser.ldhstr)
, p $ d <> " : label : " <> (show $ runParser d label) , p $ d <> " : label : " <> (show $ runParser d DomainParser.label)
, p $ d <> " : subdomain : " <> (show $ runParser d subdomain) , p $ d <> " : subdomain : " <> (show $ runParser d DomainParser.subdomain)
, p $ d <> " : domain : " <> (show $ runParser d domain) , p $ d <> " : domain : " <> (show $ runParser d DomainParser.domain)
] ]
aye :: Parser String Char render_description = Bulma.columns_ [ render_basics, render_no_expert ]
aye = defer \_ -> char 'a' *> aye render_basics
= b [ title "What is provided?"
, p "Reserve a domain name in <something>.netlib.re for free."
, p "Manage your own DNS zone."
]
render_no_expert
= b [ title "No need to be an expert!"
, p """
This website will help you through your configuration, as much as we can.
"""
]
render_second_line = Bulma.columns_ [ render_no_housing, render_updates ]
render_no_housing
= b [ title "No housing, just a name"
, p """
We don't provide housing for your services or websites,
just a name.
"""
]
render_updates
= b [ title "Automatic updates"
, p "Update your current address with a simple script."
]
ayebee :: Parser String Boolean render_why_and_contact = Bulma.columns_ [ render_why, render_contact ]
ayebee = do render_why
_ <- char 'a' = b [ title "Why?"
b <- char 'b' <|> char 'B' , p "Because everyone should be able to have a place on the Internet."
pure (b == 'B') , p "We provide you a name, build something meaningful with it."
]
render_contact
= b [ title "Contact"
, p "You have a question, you saw a bug or you just want to chat?"
, p "You can contact us: ..."
]
parse_stuff :: Parser String Boolean render_how_and_code = Bulma.columns_ [ render_how, render_code ]
parse_stuff = do render_how
void $ label = b [ title "How does this work?"
void $ eof , p "We pay for the domain names (netlib.re and codelib.re) and let you have a subdomain."
pure true , p "This service helps you manage your domain (a subdomain of netlib.re or codelib.re)."
]
render_code
= b [ title "I want to see the code!"
-- From RFC 1035: <domain> ::= <subdomain> | " " , p "The project is fully open-source (ISC licence)."
domain :: Parser String String , p "There are 3 parts: libipc, micro-services (authentication and dnsmanager) and this website."
domain = PC.try (string " ") <|> sub_eof ]
sub_eof :: Parser String String
sub_eof = do
sub <- subdomain
-- TODO: optional "." at the end?
eof
if S.length sub > 255
then fail $ "domain length is > 255 bytes (" <> show (S.length sub) <> ")"
else pure sub
-- From RFC 1035: <subdomain> ::= <label> | <subdomain> "." <label>
subdomain :: Parser String String
subdomain = do
-- First: read a label. This is bare minimum for a subdomain.
lab <- label
-- Second: the rest is optional. TODO
-- TODO
where
point_sub :: Parser String String
point_sub = do
point <- string "."
sub <- defer \_ -> subdomain
pure $ point <> sub
-- From RFC 1035: <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
label :: Parser String String
label = let_then_str_then_alpha
where
let_then_str_then_alpha :: Parser String String
let_then_str_then_alpha = do
l <- letter
s <- ldhstr
case last s of
Nothing -> pure $ CU.singleton l
Just last_char -> case runParser (CU.singleton last_char) alphaNum of
Left _ -> fail $ "Label is wrong: last char is '" <> (CU.singleton last_char) <> "' which isn't an alphanum"
Right _ -> if length s > 62 -- Remember: we already did read a letter (l).
then fail $ "Label is larger than expected (max 63 characters, current: " <> show (1 + length s) <> ")"
else pure $ CU.singleton l <> CU.fromCharArray (foldl (\acc x -> snoc acc x) [] s)
-- From RFC 1035: <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
ldhstr :: Parser String (Array Char)
ldhstr = many let_dig_hyp
-- From RFC 1035: <let-dig-hyp> ::= <let-dig> | "-"
-- Either a Letter, Digital or an Hyphenation character.
let_dig_hyp :: Parser String Char
let_dig_hyp = let_dig <|> char '-' -- TODO: push error
-- From RFC 1035: <let-dig> ::= <letter> | <digit>
let_dig :: Parser String Char
let_dig = alphaNum
-- | Converting a single letter parser to a String parser.
char_to_string :: Parser String Char -> Parser String String
char_to_string p = do
character <- p
pure $ CU.singleton character
-- Not used currently.
hyp_then_string :: Parser String String
hyp_then_string = do
a <- char_to_string let_dig_hyp
b <- ldhstr
pure $ a <> b