PlayingWithParsers == HomeInterface
This commit is contained in:
parent
016f0e03c5
commit
1101ab70bd
@ -1,47 +1,31 @@
|
||||
-- | `App.HomeInterface` presents the website and its features.
|
||||
module App.HomeInterface where
|
||||
|
||||
import Prelude
|
||||
import Prelude (Unit, map, show, ($), (<>))
|
||||
import DomainParser as DomainParser
|
||||
|
||||
import Control.Alt ((<|>))
|
||||
import Control.Lazy (defer)
|
||||
import Data.Array (many, length, snoc, last)
|
||||
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 Data.Either (Either(..))
|
||||
-- import Data.Maybe (Maybe(..), maybe)
|
||||
-- import Data.Tuple (Tuple(..))
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Effect (Effect)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Parsing
|
||||
-- import Halogen.HTML.Events as HE
|
||||
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
|
||||
|
||||
type Input = Unit
|
||||
--type Action = Unit
|
||||
data Action = UpdateStuff String
|
||||
-- type State = Unit
|
||||
type State = { stuff :: String }
|
||||
|
||||
data Query a = DoNothing a
|
||||
type Output = Unit
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
type State = { stuff :: String }
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
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 = case _ of
|
||||
UpdateStuff val -> H.modify_ _ { stuff = val }
|
||||
|
||||
-- initialState :: forall input. input -> State
|
||||
-- initialState _ = unit
|
||||
|
||||
initialState :: forall input. input -> State
|
||||
initialState _ = { stuff: "" }
|
||||
|
||||
list_of_domains_to_test :: Array String
|
||||
list_of_domains_to_test
|
||||
= [ "ex.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--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"
|
||||
, "-x.net"
|
||||
, "truc-blah.example.com"
|
||||
, "te.s-t.net"
|
||||
, "example.com"
|
||||
]
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render state
|
||||
= HH.div_ $
|
||||
[ Bulma.hero_danger "A simple input" "Nothing much to see"
|
||||
= 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 $
|
||||
[ h1 "Examples of domain parsing in Purescript"
|
||||
] <> test_domains [ "ex.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--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"
|
||||
, "e-.net"
|
||||
, "-x.net"
|
||||
, "truc-blah.example.com"
|
||||
, "te.s-t.net"
|
||||
, "example.com"
|
||||
]
|
||||
[ Bulma.h1 "Examples of domain parsing in Purescript"
|
||||
] <> test_domains list_of_domains_to_test
|
||||
, Bulma.section_small [ render_stuff ]
|
||||
]
|
||||
where
|
||||
@ -86,11 +94,11 @@ render state
|
||||
render_stuff = Bulma.columns_ [ b [ title "stuff"
|
||||
, stuff_input
|
||||
]
|
||||
, b [ title "result"
|
||||
, p $ case runParser state.stuff parse_stuff of
|
||||
Left _ -> "NOT OKAY"
|
||||
Right _ -> "OKAY"
|
||||
]
|
||||
--, b [ title "result"
|
||||
-- , p $ case runParser state.stuff DomainParser.parse_stuff of
|
||||
-- Left _ -> "NOT OKAY"
|
||||
-- Right _ -> "OKAY"
|
||||
-- ]
|
||||
]
|
||||
|
||||
stuff_input
|
||||
@ -107,95 +115,57 @@ render state
|
||||
-- tests_on_domain :: String -> _
|
||||
tests_on_domain d
|
||||
= b [ Bulma.strong $ d <> " -> [ldhstr, label, subdomain, domain]"
|
||||
, p $ d <> " : ldhstr : " <> (show $ runParser d ldhstr)
|
||||
, p $ d <> " : label : " <> (show $ runParser d label)
|
||||
, p $ d <> " : subdomain : " <> (show $ runParser d subdomain)
|
||||
, p $ d <> " : domain : " <> (show $ runParser d domain)
|
||||
, p $ d <> " : ldhstr : " <> (show $ runParser d DomainParser.ldhstr)
|
||||
, p $ d <> " : label : " <> (show $ runParser d DomainParser.label)
|
||||
, p $ d <> " : subdomain : " <> (show $ runParser d DomainParser.subdomain)
|
||||
, p $ d <> " : domain : " <> (show $ runParser d DomainParser.domain)
|
||||
]
|
||||
|
||||
aye :: Parser String Char
|
||||
aye = defer \_ -> char 'a' *> aye
|
||||
render_description = Bulma.columns_ [ render_basics, render_no_expert ]
|
||||
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
|
||||
ayebee = do
|
||||
_ <- char 'a'
|
||||
b <- char 'b' <|> char 'B'
|
||||
pure (b == 'B')
|
||||
render_why_and_contact = Bulma.columns_ [ render_why, render_contact ]
|
||||
render_why
|
||||
= b [ title "Why?"
|
||||
, p "Because everyone should be able to have a place on the Internet."
|
||||
, 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
|
||||
parse_stuff = do
|
||||
void $ label
|
||||
void $ eof
|
||||
pure true
|
||||
|
||||
|
||||
|
||||
-- From RFC 1035: <domain> ::= <subdomain> | " "
|
||||
domain :: Parser String String
|
||||
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
|
||||
render_how_and_code = Bulma.columns_ [ render_how, render_code ]
|
||||
render_how
|
||||
= b [ title "How does this work?"
|
||||
, p "We pay for the domain names (netlib.re and codelib.re) and let you have a subdomain."
|
||||
, 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!"
|
||||
, p "The project is fully open-source (ISC licence)."
|
||||
, p "There are 3 parts: libipc, micro-services (authentication and dnsmanager) and this website."
|
||||
]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user