X-Git-Url: https://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=harbl%2Fsrc%2FNetwork%2FDNS%2FRBL%2FDomain%2FLdhStr.hs;fp=harbl%2Fsrc%2FNetwork%2FDNS%2FRBL%2FDomain%2FLdhStr.hs;h=28deb1fdee70a1847658c9f547293ddd3dfdbae4;hb=4dd314687c806419fac1fc88c96df6541e1dff4b;hp=0000000000000000000000000000000000000000;hpb=7decace098b98d7f19b7af43e9d0c641f445640f;p=dead%2Fharbl.git diff --git a/harbl/src/Network/DNS/RBL/Domain/LdhStr.hs b/harbl/src/Network/DNS/RBL/Domain/LdhStr.hs new file mode 100644 index 0000000..28deb1f --- /dev/null +++ b/harbl/src/Network/DNS/RBL/Domain/LdhStr.hs @@ -0,0 +1,212 @@ +-- | 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)