X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fharbl.git;a=blobdiff_plain;f=harbl%2Fsrc%2FNetwork%2FDNS%2FRBL%2FDomain%2FLabel.hs;fp=harbl%2Fsrc%2FNetwork%2FDNS%2FRBL%2FDomain%2FLabel.hs;h=fb98cd8f5f83f0345eb50ccc64d550e3865be06f;hp=0000000000000000000000000000000000000000;hb=5c8702f0be60474482c587ba353e01ddf24f79cc;hpb=014dacb6ef0e93d0e67ebb154c397e999431469f

diff --git a/harbl/src/Network/DNS/RBL/Domain/Label.hs b/harbl/src/Network/DNS/RBL/Domain/Label.hs
new file mode 100644
index 0000000..fb98cd8
--- /dev/null
+++ b/harbl/src/Network/DNS/RBL/Domain/Label.hs
@@ -0,0 +1,145 @@
+-- | This module contains the 'Letter' type and a Parsec parser to
+--   parse one. We don't export its constructor because then you could
+--   do something dumb like stick a period inside one.
+--
+--   These are defined in RFC1035, Section 2.3.1, \"Preferred name
+--   syntax\" <https://tools.ietf.org/html/rfc1035#section-2.3.1>:
+--
+--     <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
+--
+--   However, we allow the slightly more general syntax from RFC1123,
+--   Section 2.1 <https://tools.ietf.org/html/rfc1123#section-2.1>:
+--
+--     The syntax of a legal Internet host name was specified in RFC-952
+--     [DNS:4].  One aspect of host name syntax is hereby changed: the
+--     restriction on the first character is relaxed to allow either a
+--     letter or a digit.  Host software MUST support this more liberal
+--     syntax.
+--
+module Network.DNS.RBL.Domain.Label (
+  Label,
+  label )
+where
+
+import Text.Parsec ( optionMaybe )
+import Text.Parsec.String ( Parser )
+
+import Network.DNS.RBL.Domain.LdhStrLetDig (
+  LdhStrLetDig,
+  ldh_str_let_dig,
+  ldh_str_let_dig_length )
+import Network.DNS.RBL.Domain.LetDig ( LetDig, let_dig )
+import Network.DNS.RBL.Pretty ( Pretty(..) )
+
+-- | The label type from the RFC1035 and RFC1123 grammars.
+--
+--   ==== _Examples_
+--
+--   >>> import Text.Parsec ( parse )
+--
+--   >>> let (Right r)  = parse let_dig "" "x"
+--   >>> r
+--   LetDigLetter (Letter 'x')
+--   >>> Label r Nothing
+--   Label (LetDigLetter (Letter 'x')) Nothing
+--
+data Label = Label LetDig (Maybe LdhStrLetDig)
+  deriving (Eq, Show)
+
+-- | Pretty-print a 'Label'. Should give you back a string that can be
+--   parsed as a 'Label'.
+--
+--   ==== _Examples_
+--
+--   >>> import Text.Parsec ( parse )
+--
+--   >>> let (Right r) = parse label "" "www"
+--   >>> pretty_print r
+--   www
+--
+--   >>> let (Right r) = parse label "" "example"
+--   >>> pretty_print r
+--   example
+--
+--   >>> let (Right r) = parse label "" "com"
+--   >>> pretty_print r
+--   com
+--
+instance Pretty Label where
+  pretty_show (Label l Nothing) = pretty_show l
+  pretty_show (Label l (Just s)) = (pretty_show l) ++ (pretty_show s)
+
+
+-- | The maximum number of characters (octets, really) allowed in a
+--   label. Quoting Section 2.3.1, \"Preferred name syntax\", of
+--   RFC1035:
+--
+--     The labels must follow the rules for ARPANET host names.  They
+--     must start with a letter, end with a letter or digit, and have
+--     as interior characters only letters, digits, and hyphen.  There
+--     are also some restrictions on the length.  Labels must be 63
+--     characters or less.
+--
+label_max_length :: Int
+label_max_length = 63
+
+
+-- | Parse a 'Label'.
+--
+--   In addition to the grammar, there's another restriction on
+--   labels: their length must be 'label_max_length' characters or
+--   less. We check this only after we have successfully parsed a
+--   label.
+--
+--   ==== _Examples_
+--
+--   >>> import Text.Parsec ( parse, parseTest )
+--
+--   Make sure we can parse a single character:
+--
+--   >>> parseTest label "a"
+--   Label (LetDigLetter (Letter 'a')) Nothing
+--
+--   And longer strings:
+--
+--   >>> pretty_print $ parse label "" "abc-def"
+--   abc-def
+--
+--   But not anything ending in a hyphen:
+--
+--   >>> parseTest label "abc-"
+--   parse error at (line 1, column 5):
+--   label cannot end with a hyphen
+--
+--   Or anything over 'label_max_length' characters:
+--
+--   >>> parseTest label (['a'..'z'] ++ ['a'..'z'] ++ ['a'..'z'])
+--   parse error at (line 1, column 79):
+--   labels must be 63 or fewer characters
+--
+--   However, /exactly/ 'label_max_length' characters is acceptable:
+--
+--   >>> pretty_print $ parse label "" (replicate label_max_length 'x')
+--   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+--
+--   Ensure that a label can begin with a digit:
+--
+--   >>> pretty_print $ parse label "" "3com"
+--   3com
+--
+label :: Parser Label
+label = do
+  l <- let_dig -- Guaranteed to be there
+  maybe_s <- optionMaybe ldh_str_let_dig -- Might not be there
+  case maybe_s of
+    -- It can only be one character long, from the letter...
+    Nothing -> return $ Label l maybe_s
+
+    -- The letter gives us one character, so we check that the rest is
+    -- less than (label_max_length - 1) characters long. But in the
+    -- error message we need to report label_max_length.
+    Just s  -> if (ldh_str_let_dig_length s) <= (label_max_length - 1)
+              then return $ Label l maybe_s
+              else fail $ "labels must be " ++
+                          (show label_max_length) ++
+                          " or fewer characters"