-- | 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\" : -- -- ::= | -- -- 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: -- -- ::= | -- -- 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)