From fa3d2b52848fe3573714a9a6c3611555461c13bc Mon Sep 17 00:00:00 2001
From: Brian Ginsburg <7957636+bgins@users.noreply.github.com>
Date: Wed, 13 Jul 2022 14:22:08 -0700
Subject: [PATCH] Make email optional at registration (#619)

---
 .../Fission/CLI/Handler/User/Register.hs      |  2 +-
 .../Fission/User/Registration/Types.hs        | 22 +++++++++-----
 .../Fission/Web/Server/Handler/User/Create.hs | 29 ++++++++++++++-----
 .../Fission/Web/Server/Internal/Production.hs |  2 +-
 .../Fission/Web/Server/User/Creator.hs        | 12 ++++----
 .../Fission/Web/Server/User/Creator/Class.hs  |  4 +--
 6 files changed, 45 insertions(+), 26 deletions(-)

diff --git a/fission-cli/library/Fission/CLI/Handler/User/Register.hs b/fission-cli/library/Fission/CLI/Handler/User/Register.hs
index d3ec0f9ef..8ee6c7623 100644
--- a/fission-cli/library/Fission/CLI/Handler/User/Register.hs
+++ b/fission-cli/library/Fission/CLI/Handler/User/Register.hs
@@ -129,7 +129,7 @@ createAccount maybeUsername maybeEmail = do
   let
     form = Registration
       { username
-      , email
+      , email      = Just email
       , password   = Nothing
       , exchangePK = Just exchangePK
       }
diff --git a/fission-core/library/Fission/User/Registration/Types.hs b/fission-core/library/Fission/User/Registration/Types.hs
index 1359d5857..e54c185f7 100644
--- a/fission-core/library/Fission/User/Registration/Types.hs
+++ b/fission-core/library/Fission/User/Registration/Types.hs
@@ -14,7 +14,7 @@ import           Web.UCAN.Internal.Orphanage.RSA2048.Public ()
 
 data Registration = Registration
   { username   :: Username
-  , email      :: Email
+  , email      :: Maybe Email
   , password   :: Maybe Password
   , exchangePK :: Maybe RSA.PublicKey
   }
@@ -29,16 +29,22 @@ instance Arbitrary Registration where
     return Registration {..}
 
 instance ToJSON Registration where
-  toJSON Registration { username, email = Email email' } =
-    Object [ ("username", String $ textDisplay username)
-           , ("email",    String email')
-           ]
+  toJSON Registration { username, email = mayEmail } =
+    case mayEmail of
+      Just (Email email) ->
+        Object [ ("username", String $ textDisplay username)
+               , ("email",    String email)
+               ]
+
+      Nothing ->
+        Object [ ("username", String $ textDisplay username) ]
+
 
 instance FromJSON Registration where
   parseJSON = withObject "Registration" \obj -> do
     username   <- obj .:  "username"
     password   <- obj .:? "password"
-    email      <- obj .:  "email"
+    email      <- obj .:? "email"
     exchangePK <- obj .:? "exchangePK"
 
     return Registration {..}
@@ -54,11 +60,11 @@ instance ToSchema Registration where
            [ ("username", username')
            , ("email", email')
            ]
-      |> required .~ ["username", "email"]
+      |> required .~ ["username"]
       |> description ?~ "The information that a user needs to provide to login/register."
       |> example ?~ toJSON Registration
            { username   = "username"
-           , email      = "alice@example.com"
+           , email      = Just "alice@example.com"
            , password   = Nothing
            , exchangePK = Nothing
            }
diff --git a/fission-web-server/library/Fission/Web/Server/Handler/User/Create.hs b/fission-web-server/library/Fission/Web/Server/Handler/User/Create.hs
index 465b45f8d..6ec909102 100644
--- a/fission-web-server/library/Fission/Web/Server/Handler/User/Create.hs
+++ b/fission-web-server/library/Fission/Web/Server/Handler/User/Create.hs
@@ -45,12 +45,19 @@ withDID ::
   , Challenge.Creator m
   )
   => ServerT User.Create.WithDID m
-withDID User.Registration {username, email} (DID.Key publicKey) = do
+withDID User.Registration {username, email = mayEmail} (DID.Key publicKey) = do
   now       <- currentTime
-  userId    <- Web.Err.ensureM $ User.create username publicKey email now
+  userId    <- Web.Err.ensureM $ User.create username publicKey mayEmail now
   challenge <- Web.Err.ensureM $ Challenge.create userId
-  Web.Err.ensureM $ sendVerificationEmail (Recipient email username) challenge
-  return NoContent
+
+  case mayEmail of
+    Just email -> do
+      Web.Err.ensureM $ sendVerificationEmail (Recipient email username) challenge
+      return NoContent
+
+    Nothing ->
+      return NoContent
+
 
 withPassword ::
   ( MonadDNSLink      m
@@ -64,9 +71,15 @@ withPassword ::
 withPassword User.Registration {password = Nothing} =
   Web.Err.throw err422 { errBody = "Missing password" }
 
-withPassword User.Registration {username, password = Just pass, email} = do
+withPassword User.Registration {username, password = Just pass, email = mayEmail} = do
   now <- currentTime
-  userId <- Web.Err.ensureM $ User.createWithPassword username pass email now
+  userId <- Web.Err.ensureM $ User.createWithPassword username pass mayEmail now
   challenge <- Web.Err.ensureM $ Challenge.create userId
-  Web.Err.ensureM $ sendVerificationEmail (Recipient email username) challenge
-  return ()
+
+  case mayEmail of
+    Just email -> do
+      Web.Err.ensureM $ sendVerificationEmail (Recipient email username) challenge
+      return ()
+
+    Nothing ->
+      return ()
diff --git a/fission-web-server/library/Fission/Web/Server/Internal/Production.hs b/fission-web-server/library/Fission/Web/Server/Internal/Production.hs
index bbe43c248..ceeac760d 100644
--- a/fission-web-server/library/Fission/Web/Server/Internal/Production.hs
+++ b/fission-web-server/library/Fission/Web/Server/Internal/Production.hs
@@ -223,7 +223,7 @@ start middleware runner = do
     logInfo @Text "🙋 Ensuring default user is in DB"
     userId <- User.getByPublicKey serverPK >>= \case
       Just (Entity userId _) -> return userId
-      Nothing -> Web.Error.ensureM $ User.createDB "fission" serverPK "hello@fission.codes" now
+      Nothing -> Web.Error.ensureM $ User.createDB "fission" serverPK (Just "hello@fission.codes") now
 
     logInfo @Text "💽 Ensuring default data domain domains is in DB"
     Domain.getByDomainName userRootDomain >>= \case
diff --git a/fission-web-server/library/Fission/Web/Server/User/Creator.hs b/fission-web-server/library/Fission/Web/Server/User/Creator.hs
index b02fead39..f7fa35f1f 100644
--- a/fission-web-server/library/Fission/Web/Server/User/Creator.hs
+++ b/fission-web-server/library/Fission/Web/Server/User/Creator.hs
@@ -37,10 +37,10 @@ createDB ::
      MonadIO m
   => Username
   -> Key.Public
-  -> Email
+  -> Maybe Email
   -> UTCTime
   -> Transaction m (Either Errors' UserId)
-createDB username pk email now =
+createDB username pk mayEmail now =
   insertUnique user >>= \case
     Just userId -> return $ Right userId
     Nothing     -> determineConflict username (Just pk)
@@ -50,7 +50,7 @@ createDB username pk email now =
         { userPublicKey     = Just pk
         , userExchangeKeys  = Just []
         , userUsername      = username
-        , userEmail         = Just email
+        , userEmail         = mayEmail
         , userRole          = Regular
         , userActive        = True
         , userVerified      = False
@@ -66,10 +66,10 @@ createWithPasswordDB ::
      MonadIO m
   => Username
   -> Password
-  -> Email
+  -> Maybe Email
   -> UTCTime
   -> Transaction m (Either Errors' UserId)
-createWithPasswordDB username password email now =
+createWithPasswordDB username password mayEmail now =
   Password.hashPassword password >>= \case
     Left err ->
       return $ Error.openLeft err
@@ -79,7 +79,7 @@ createWithPasswordDB username password email now =
         { userPublicKey     = Nothing
         , userExchangeKeys  = Just []
         , userUsername      = username
-        , userEmail         = Just email
+        , userEmail         = mayEmail
         , userRole          = Regular
         , userActive        = True
         , userVerified      = False
diff --git a/fission-web-server/library/Fission/Web/Server/User/Creator/Class.hs b/fission-web-server/library/Fission/Web/Server/User/Creator/Class.hs
index 3ab81a93d..d140e3e65 100644
--- a/fission-web-server/library/Fission/Web/Server/User/Creator/Class.hs
+++ b/fission-web-server/library/Fission/Web/Server/User/Creator/Class.hs
@@ -56,14 +56,14 @@ class Heroku.AddOn.Creator m => Creator m where
   create ::
        Username
     -> Key.Public
-    -> Email
+    -> Maybe Email
     -> UTCTime
     -> m (Either Errors' UserId)
 
   createWithPassword ::
        Username
     -> Password
-    -> Email
+    -> Maybe Email
     -> UTCTime
     -> m (Either Errors' UserId)