202 lines
6.9 KiB
Plaintext
202 lines
6.9 KiB
Plaintext
-- | `App.HomeInterface` presents the website and its features.
|
|
module App.HomeInterface where
|
|
|
|
import Prelude
|
|
|
|
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 Effect.Aff.Class (class MonadAff)
|
|
import Effect (Effect)
|
|
import Halogen as H
|
|
import Halogen.HTML as HH
|
|
-- 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
|
|
data Action = UpdateStuff 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
|
|
{ initialState
|
|
, render
|
|
, eval: H.mkEval $ H.defaultEval
|
|
{ handleAction = handleAction
|
|
}
|
|
}
|
|
|
|
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 _ = { stuff: "" }
|
|
|
|
render :: forall m. State -> H.ComponentHTML Action () m
|
|
render state
|
|
= HH.div_ $
|
|
[ 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.section_small [ render_stuff ]
|
|
]
|
|
where
|
|
-- Some helpers.
|
|
title = Bulma.h3
|
|
p = Bulma.p
|
|
b x = Bulma.column_ [ Bulma.box x ]
|
|
|
|
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"
|
|
]
|
|
]
|
|
|
|
stuff_input
|
|
= Bulma.box_input "stuff" "stuff" "stuff"
|
|
UpdateStuff
|
|
state.stuff
|
|
true
|
|
should_be_disabled
|
|
should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))
|
|
|
|
-- test_domains :: Array String -> _
|
|
test_domains doms = map tests_on_domain doms
|
|
|
|
-- 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)
|
|
]
|
|
|
|
aye :: Parser String Char
|
|
aye = defer \_ -> char 'a' *> aye
|
|
|
|
ayebee :: Parser String Boolean
|
|
ayebee = do
|
|
_ <- char 'a'
|
|
b <- char 'b' <|> char 'B'
|
|
pure (b == 'B')
|
|
|
|
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
|