EmailAddress.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wall #-}

{- | An email address: a local part, one \@ and a domain with at least one
dot, with no white space, that fits one line of a box of CASA Form 101-02.

The constructor is not exported (see "ReOC.Primitive.Text1"). An
@EmailAddress@ is built with the prism '_EmailAddress' or with
'emailAddressLiteral'.
-}
module ReOC.Primitive.EmailAddress (
  EmailAddress,
  _EmailAddress,
  emailAddressText,
  emailAddressLiteral,
) where

import Control.Lens (Prism', preview, prism')
import Data.Char (isSpace)
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as Text
import Language.Haskell.TH.Syntax (Code (..), Lift, Q, liftTyped)
import ReOC.Primitive.FormText (FormFont (..), _FormText)

{- $setup
>>> :set -XOverloadedStrings
>>> import Control.Lens ((^?))
>>> import qualified Data.Text as Text
-}

-- | An email address.
newtype EmailAddress
  = EmailAddress Text
  deriving (Eq, Ord, Show, Lift)

{- | An email address.

>>> "ops@example.com" ^? _EmailAddress
Just (EmailAddress "ops@example.com")

>>> "casa@localhost" ^? _EmailAddress
Nothing

>>> "a@b@c.net" ^? _EmailAddress
Nothing

>>> (Text.replicate 60 "w" <> "@example.net") ^? _EmailAddress
Nothing
-}
_EmailAddress :: Prism' Text EmailAddress
_EmailAddress =
  prism'
    emailAddressText
    ( \t ->
        case Text.splitOn "@" t of
          [local, domain]
            | not (Text.null local)
            , valid domain
            , not (Text.any isSpace t)
            , isJust (preview (_FormText @'Narrow @212 @1) t) ->
                Just (EmailAddress t)
          _ -> Nothing
    )
 where
  valid domain =
    let parts = Text.splitOn "." domain
     in length parts >= 2 && not (any Text.null parts)

-- | The text of an email address.
emailAddressText :: EmailAddress -> Text
emailAddressText (EmailAddress t) =
  t

{- | An @EmailAddress@ literal, checked when the program is compiled:

> $$(emailAddressLiteral "ops@example.com")
-}
emailAddressLiteral :: String -> Code Q EmailAddress
emailAddressLiteral s =
  maybe
    (Code (fail ("emailAddressLiteral: not an email address: " <> show s)))
    liftTyped
    (preview _EmailAddress (Text.pack s))