--- /dev/null
+-- | The 'LdhStr' type and a Parsec parser to parse one. We don't
+-- export its constructor because then you could do something dumb
+-- like stick a semicolon inside one.
+--
+-- These are defined in RFC1035, Section 2.3.1, \"Preferred name
+-- syntax\" <https://tools.ietf.org/html/rfc1035#section-2.3.1>:
+--
+-- <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
+--
+-- We export our constructors so that we can pattern match to find
+-- out whether or not we have a hyphen at the end of a label.
+--
+module Network.DNS.RBL.Domain.LdhStr (
+ LdhStr(..),
+ ldh_str,
+ ldh_str_length )
+where
+
+import Text.Parsec ( (<|>), try )
+import Text.Parsec.String ( Parser )
+
+import Network.DNS.RBL.Domain.LetDigHyp ( LetDigHyp, let_dig_hyp )
+import Network.DNS.RBL.Pretty ( Pretty(..) )
+import Network.DNS.RBL.Reversible ( Reversible(..) )
+
+
+-- | A string of letters, digits, and hyphens from the RFC1035 grammar:
+--
+-- <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
+--
+-- These are represented as either a single instance of a
+-- 'LetDigHyp', or a string of them (recursive).
+--
+-- ==== _Examples_
+--
+-- >>> import Text.Parsec ( parse )
+--
+-- We can create an 'LdhStrSingleLdh' from a single (let-dig-hyp)
+-- character:
+--
+-- >>> let (Right r) = parse let_dig_hyp "" "x"
+-- >>> LdhStrSingleLdh r
+-- LdhStrSingleLdh (LetDigHypLetDig (LetDigLetter (Letter 'x')))
+--
+-- >>> let (Right r) = parse let_dig_hyp "" "1"
+-- >>> LdhStrSingleLdh r
+-- LdhStrSingleLdh (LetDigHypLetDig (LetDigDigit (Digit '1')))
+--
+-- >>> let (Right r) = parse let_dig_hyp "" "-"
+-- >>> LdhStrSingleLdh r
+-- LdhStrSingleLdh (LetDigHypHyphen (Hyphen '-'))
+--
+-- We can create an 'LdhStrMultipleLdh' from multiple (let-dig-hyp)
+-- characters:
+--
+-- >>> let (Right r) = parse let_dig_hyp "" "x"
+-- >>> let (Right r2) = parse let_dig_hyp "" "-"
+-- >>> let (Right r3) = parse let_dig_hyp "" "1"
+-- >>> let rs = LdhStrMultipleLdh r2 (LdhStrSingleLdh r3)
+-- >>> pretty_print $ LdhStrMultipleLdh r rs
+-- x-1
+--
+data LdhStr =
+ LdhStrSingleLdh LetDigHyp |
+ LdhStrMultipleLdh LetDigHyp LdhStr
+ deriving (Eq, Show)
+
+
+-- | Pretty-printing for strings of letters, digits, and hyphens that
+-- we've already parsed. Just shows/prints the underlying characters
+-- (structural) recursively.
+--
+-- ==== _Examples_
+--
+-- >>> import Text.Parsec ( parse )
+--
+-- >>> let (Right r) = parse let_dig_hyp "" "x"
+-- >>> pretty_print $ LdhStrSingleLdh r
+-- x
+--
+-- >>> let (Right r) = parse let_dig_hyp "" "1"
+-- >>> pretty_print $ LdhStrSingleLdh r
+-- 1
+--
+-- >>> let (Right r) = parse let_dig_hyp "" "-"
+-- >>> pretty_print $ LdhStrSingleLdh r
+-- -
+--
+-- >>> let (Right r) = parse ldh_str "" "123"
+-- >>> pretty_print $ r
+-- 123
+--
+instance Pretty LdhStr where
+ pretty_show (LdhStrSingleLdh ldh) = pretty_show ldh
+ pretty_show (LdhStrMultipleLdh ldh s) = (pretty_show ldh) ++ (pretty_show s)
+
+
+instance Reversible LdhStr where
+ -- | Reverse the characters of the given 'LdhStr'. We are bordering
+ -- on redundancy here, since the implementation of this is exactly
+ -- the same as for 'Subdomain'. However, if we were to generalize
+ -- 'LdhStr' to e.g. @Str LetDigHyp@ and 'Subdomain' to @Str
+ -- Label@, then we would get some semantic weirdness, like the
+ -- fact that the length of a subdomain includes the \".\"
+ -- characters. So pretty much only 'backwards' would be
+ -- generalizable.
+ --
+ -- ==== _Examples_
+ --
+ -- >>> import Text.Parsec ( parse )
+ --
+ -- Standard usage:
+ --
+ -- >>> let (Right r) = parse ldh_str "" "x"
+ -- >>> pretty_print $ backwards r
+ -- x
+ --
+ -- >>> let (Right r) = parse ldh_str "" "com"
+ -- >>> pretty_print $ backwards r
+ -- moc
+ --
+ -- >>> let (Right r) = parse ldh_str "" "example-com"
+ -- >>> pretty_print $ backwards r
+ -- moc-elpmaxe
+ --
+ -- >>> let (Right r) = parse ldh_str "" "www-example-com"
+ -- >>> pretty_print $ backwards r
+ -- moc-elpmaxe-www
+ --
+
+ -- The easy case, reversing a one-character string.
+ backwards s@(LdhStrSingleLdh _) = s
+
+ -- For multiple-character strings, we have two cases. The first is
+ -- where we have exactly two characters, and we just need to swap them.
+ backwards (LdhStrMultipleLdh l (LdhStrSingleLdh m)) =
+ LdhStrMultipleLdh m (LdhStrSingleLdh l)
+
+ -- And now the hard case. We do this in terms of another function,
+ -- 'build'. The 'build' function works on two strings at a time: the
+ -- first one, @dst@, is the one we're building. We start with @l@ as
+ -- our @dst@, and then append characters to it on the left from
+ -- another string. What's that other string? Just @s@! If we peel
+ -- things off the left of @s@ and stick them to the left of @l@ and
+ -- do that until we can't anymore, we will have reversed the string.
+ backwards (LdhStrMultipleLdh l s) = build (LdhStrSingleLdh l) s
+ where
+ -- Build up the first LdhStr on the left by peeling off elements
+ -- of the second from the left.
+ build :: LdhStr -> LdhStr -> LdhStr
+ build dst (LdhStrSingleLdh final) = LdhStrMultipleLdh final dst
+ build dst (LdhStrMultipleLdh leading rest) =
+ build (LdhStrMultipleLdh leading dst) rest
+
+
+-- | Parse a string of letters, digits, and hyphens (an 'LdhStr').
+--
+-- ==== _Examples_
+--
+-- >>> import Text.Parsec ( parseTest )
+--
+-- Single letters, digits, and hyphens are parsed:
+--
+-- >>> parseTest ldh_str "a"
+-- LdhStrSingleLdh (LetDigHypLetDig (LetDigLetter (Letter 'a')))
+--
+-- >>> parseTest ldh_str "0"
+-- LdhStrSingleLdh (LetDigHypLetDig (LetDigDigit (Digit '0')))
+--
+-- >>> parseTest ldh_str "-"
+-- LdhStrSingleLdh (LetDigHypHyphen (Hyphen '-'))
+--
+-- As well as strings of them:
+--
+-- >>> import Text.Parsec ( parse )
+-- >>> pretty_print $ parse ldh_str "" "a0-b"
+-- a0-b
+--
+ldh_str :: Parser LdhStr
+ldh_str = try both <|> just_one
+ where
+ both :: Parser LdhStr
+ both = do
+ ldh1 <- let_dig_hyp
+ ldh_tail <- ldh_str
+ return $ LdhStrMultipleLdh ldh1 ldh_tail
+
+ just_one :: Parser LdhStr
+ just_one = fmap LdhStrSingleLdh let_dig_hyp
+
+
+
+
+-- | Compute the length of an 'LdhStr'. It will be at least one, since
+-- 'LdhStr's are non-empty. And if there's something other than the
+-- first character present, we simply recurse.
+--
+-- ==== _Examples_
+--
+-- >>> import Text.Parsec ( parse )
+--
+-- >>> let (Right r) = parse ldh_str "" "a"
+-- >>> ldh_str_length r
+-- 1
+--
+-- >>> let (Right r) = parse ldh_str "" "abc-def"
+-- >>> ldh_str_length r
+-- 7
+--
+ldh_str_length :: LdhStr -> Int
+ldh_str_length (LdhStrSingleLdh _) = 1
+ldh_str_length (LdhStrMultipleLdh _ t) = 1 + (ldh_str_length t)
projects / dead / harbl.git / blobdiff