src/Forward.hs

   1 -- | The 'Forward' data type, and functions that act thereon.
   2 --
   3 module Forward (
   4   Forward(..),
   5   address_domain,
   6   dropby_goto_domains,
   7   fwd,
   8   pretty_print,
   9   strings_to_forwards )
  10 where
  11
  12 import Data.String.Utils ( split, strip )
  13
  14 import DNS ( NormalDomain, normalize_string )
  15
  16 -- | Type synonym to make the signatures below a little more clear.
  17 --   WARNING: Also defined in the "Report" module.
  18 type Domain = String
  19
  20
  21 -- | A type-safe wrapper around an email address that's represented as
  22 --   a 'String'. This differs from a 'Goto' in that it should only
  23 --   appear on the left-hand-side of a alias -> goto relationship.
  24 --
  25 newtype Address = Address String deriving ( Eq, Show )
  26
  27
  28 -- | A type-safe wrapper around an email address that's represented as
  29 --   a 'String'. This differs from 'Address' in that 'Goto' addresses
  30 --   are the destinations of mail that is forwarded, rather than the
  31 --   source.
  32 newtype Goto = Goto String deriving ( Eq, Show )
  33
  34
  35 -- | A data type representing a "forward." That is, an email address
  36 --   whose mail is sent to some other address.
  37 --
  38 --   The 'Address' field represents the alias address, the address to
  39 --   which mail is sent. The 'Goto' field is the address to which the
  40 --   mail is forwarded.
  41 --
  42 data Forward =
  43   Forward Address Goto
  44   deriving ( Eq, Show )
  45
  46
  47 -- | Shortcut constructor for creating 'Forward' objects.
  48 --
  49 --   ==== __Examples__
  50 --
  51 --   >>> pretty_print $ fwd "user1@example.com" "user2@example.net"
  52 --   "user1@example.com -> user2@example.net"
  53 --
  54 fwd :: String -> String -> Forward
  55 fwd addr goto = Forward (Address addr) (Goto goto)
  56
  57
  58 -- | Pretty-print a 'Forward'.
  59 --
  60 --   ==== __Examples__
  61 --
  62 --   >>> pretty_print (fwd "a@example.com" "b@example.net")
  63 --   "a@example.com -> b@example.net"
  64 --
  65 pretty_print :: Forward -> String
  66 pretty_print ( Forward (Address addr) (Goto goto) ) =
  67   addr ++ " -> " ++ goto
  68
  69
  70
  71 -- | Convert a list of 'String's into a list of 'Forward's. The list
  72 --   of 'String's is assumed to have exactly two elements; the first
  73 --   being an address, and the second being a comma-separated list of
  74 --   gotos.
  75 --
  76 --   We return a list containing one 'Forward' for each (address,goto)
  77 --   pair.
  78 --
  79 --   ==== __Examples__
  80 --
  81 --   A single address, pointed to itself (common with PostfixAdmin):
  82 --
  83 --   >>> let addr = "a@b.test"
  84 --   >>> let gotos = "a@b.test"
  85 --   >>> strings_to_forwards [addr, gotos]
  86 --   [Forward (Address "a@b.test") (Goto "a@b.test")]
  87 --
  88 --   One address forwarded to two other addresses:
  89 --
  90 --   >>> let addr = "a@b.test"
  91 --   >>> let gotos = "a1@b.test,a2@b.test"
  92 --   >>> map pretty_print (strings_to_forwards [addr, gotos])
  93 --   ["a@b.test -> a1@b.test","a@b.test -> a2@b.test"]
  94 --
  95 --   An address that receives mail itself, but also forwards a copy to
  96 --   another address (also common in PostfixAdmin). We've also mangled
  97 --   the whitespace a little bit here:
  98 --
  99 --   >>> let addr = "a@b.test"
 100 --   >>> let gotos = "a@b.test   ,a2@b.test    "
 101 --   >>> map pretty_print (strings_to_forwards [addr, gotos])
 102 --   ["a@b.test -> a@b.test","a@b.test -> a2@b.test"]
 103 --
 104 --   And finally, a one-element list, which should return no forwards:
 105 --
 106 --   >>> let addr = "a@b.test"
 107 --   >>> strings_to_forwards [addr]
 108 --   []
 109 --
 110 strings_to_forwards :: [String] -> [Forward]
 111 strings_to_forwards (addr:gotos:_) =
 112   [Forward (Address addr) (Goto (strip g)) | g <- split "," gotos]
 113 strings_to_forwards _ = []
 114
 115
 116 -- | Find the domain of the 'Goto' associated with a 'Forward'. This
 117 --   returns the __domain of the goto address__, not the domain of the
 118 --   'Address' itself.
 119 --
 120 --   ==== __Examples__
 121 --
 122 --   A normal forward:
 123 --
 124 --   >>> let f = fwd "user1@example.com" "user2@example.net"
 125 --   >>> goto_domain f
 126 --   Just "example.net"
 127 --
 128 --   A forward to a subdomain:
 129 --
 130 --   >>> let f = fwd "user1@example.com" "user2@sub.example.net"
 131 --   >>> goto_domain f
 132 --   Just "sub.example.net"
 133 --
 134 --   A goto without an '@' character:
 135 --
 136 --   >>> let f = fwd "user1@example.com" "example.net"
 137 --   >>> goto_domain f
 138 --   Nothing
 139 --
 140 --   A goto with three '@' characters:
 141 --
 142 --   >>> let f = fwd "user1@example.com" "@example@.net@"
 143 --   >>> goto_domain f
 144 --   Nothing
 145 --
 146 goto_domain :: Forward -> Maybe Domain
 147 goto_domain (Forward _ (Goto goto)) = domain_part goto
 148
 149
 150 -- | Find the domain of the 'Address' associated with a 'Forward'. This
 151 --   returns the __domain of the address__, not the domain of the
 152 --   'Goto'.
 153 --
 154 --   ==== __Examples__
 155 --
 156 --   A normal forward:
 157 --
 158 --   >>> let f = fwd "user1@example.com" "user2@example.net"
 159 --   >>> address_domain f
 160 --   Just "example.com"
 161 --
 162 --   A forward to/from subdomains:
 163 --
 164 --   >>> let f = fwd "user1@sub.example.com" "user2@sub.example.net"
 165 --   >>> address_domain f
 166 --   Just "sub.example.com"
 167 --
 168 --   An address/goto without an '@' character:
 169 --
 170 --   >>> let f = fwd "example.com" "example.net"
 171 --   >>> address_domain f
 172 --   Nothing
 173 --
 174 --   An address/goto with three '@' characters:
 175 --
 176 --   >>> let f = fwd "@example@.com@" "@example@.net@"
 177 --   >>> address_domain f
 178 --   Nothing
 179 --
 180 address_domain :: Forward -> Maybe Domain
 181 address_domain (Forward (Address addr) _) = domain_part addr
 182
 183
 184 -- | Return the domain part of an email address (represented by a
 185 --   'String').
 186 --
 187 --   The way we determine the domain is simple: we take whatever
 188 --   appears after the first '@' character in the address. If there is
 189 --   no '@' symbol, or if there's more than one, then we don't know
 190 --   what the domain is, so we return 'Nothing' instead.
 191 --
 192 --   ==== __Examples__
 193 --
 194 --   A normal address:
 195 --
 196 --   >>> domain_part "user2@example.net"
 197 --   Just "example.net"
 198 --
 199 --   A subdomain:
 200 --
 201 --   >>> domain_part "user2@sub.example.net"
 202 --   Just "sub.example.net"
 203 --
 204 --   An address without an '@' character:
 205 --
 206 --   >>> domain_part "example.net"
 207 --   Nothing
 208 --
 209 --   An address with two '@' characters:
 210 --
 211 --   >>> domain_part "@example@.net@"
 212 --   Nothing
 213 --
 214 domain_part :: String -> Maybe Domain
 215 domain_part address =
 216   case parts of
 217     [_,domain] -> Just domain
 218     _          -> Nothing
 219   where
 220     parts = split "@" address
 221
 222
 223 -- | Given a list of 'NormalDomain's @domains@ and a list of 'Forward's
 224 --   @forwards@, filter out all elements of @forwards@ that have a
 225 --   goto domain in the list of @domains@.
 226 --
 227 --   ==== __Examples__
 228 --
 229 --   >>> let ds = map normalize_string ["example.com", "example.net"]
 230 --   >>> let f1 = fwd "a@example.com" "a@example.com"
 231 --   >>> let f2 = fwd "a@example.com" "a1@example.net"
 232 --   >>> let f3 = fwd "a@example.com" "a2@example.org"
 233 --   >>> map pretty_print (dropby_goto_domains ds [f1,f2,f3])
 234 --   ["a@example.com -> a2@example.org"]
 235 --
 236 dropby_goto_domains :: [NormalDomain] -> [Forward] -> [Forward]
 237 dropby_goto_domains normal_domains =
 238   filter (not . is_bad)
 239   where
 240     -- | A 'Forward' is bad if its goto domain appears in the list, or
 241     --   if we can't figure out its goto domain.
 242     --
 243     is_bad :: Forward -> Bool
 244     is_bad f =
 245       case (goto_domain f) of
 246         Nothing -> True -- Drop these, too.
 247         -- Nice, we can't compare unless we normalize @d@!
 248         Just d  -> (normalize_string d) `elem` normal_domains