From 3a2edcc49188901cf438a184060fde695e890d11 Mon Sep 17 00:00:00 2001 From: Eduardo Asafe Date: Sat, 22 Jun 2024 21:21:39 +0900 Subject: [PATCH] Unsubscribe from emails (#253) * Unsubscribe from emails * Unsubscribe from emails * Rephrase message --- src/Server/Database/UnsubscribeTokens.purs | 21 +++++++++ src/Server/Database/Users.purs | 10 +++-- src/Server/Handler.purs | 2 + src/Server/Unsubscribe/Action.purs | 46 +++++++++++++++++++ src/Server/Unsubscribe/Database.purs | 22 +++++++++ src/Server/Unsubscribe/Handler.purs | 15 +++++++ src/Server/Unsubscribe/Template.purs | 25 +++++++++++ src/Server/sql/index.sql | 8 ++++ src/Shared/Spec.purs | 6 +++ src/Shared/User.purs | 52 ++++++++++++++++++++++ 10 files changed, 204 insertions(+), 3 deletions(-) create mode 100644 src/Server/Database/UnsubscribeTokens.purs create mode 100644 src/Server/Unsubscribe/Action.purs create mode 100644 src/Server/Unsubscribe/Database.purs create mode 100644 src/Server/Unsubscribe/Handler.purs create mode 100644 src/Server/Unsubscribe/Template.purs diff --git a/src/Server/Database/UnsubscribeTokens.purs b/src/Server/Database/UnsubscribeTokens.purs new file mode 100644 index 00000000..aacc11cf --- /dev/null +++ b/src/Server/Database/UnsubscribeTokens.purs @@ -0,0 +1,21 @@ +module Server.Database.UnsubscribeTokens where + +import Droplet.Language +import Prelude +import Prim hiding (Constraint) +import Data.Tuple.Nested (type (/\)) + +import Server.Database.Users (UsersTable) +import Type.Proxy (Proxy(..)) + +type UnsubscribeTokens = + ( id ∷ Column Int (PrimaryKey /\ Identity) + , contents ∷ String + , unsubscriber ∷ Column Int (Constraint "unsubcribe_tokens_user" (ForeignKey "id" UsersTable)) + ) + +unsubscribeTokens ∷ Table "unsubscribe_tokens" UnsubscribeTokens +unsubscribeTokens = Table + +_unsubscriber ∷ Proxy "unsubscriber" +_unsubscriber = Proxy diff --git a/src/Server/Database/Users.purs b/src/Server/Database/Users.purs index 31e230c1..d8d3384b 100644 --- a/src/Server/Database/Users.purs +++ b/src/Server/Database/Users.purs @@ -2,8 +2,8 @@ module Server.Database.Users where import Droplet.Language import Prelude -import Server.Database.Fields -import Server.Effect +import Server.Database.Fields (_id, c) +import Server.Effect (BaseEffect, ServerEffect) import Data.Date (Date) import Data.DateTime (DateTime) @@ -15,7 +15,7 @@ import Server.Database as SD import Server.Database.Countries (CountriesTable) import Server.Database.Types (Checked) import Shared.Account (RegisterLoginUser) -import Shared.User (Gender, ProfileVisibility(..)) +import Shared.User (Gender, ProfileVisibility(..), ReceiveEmail) import Type.Proxy (Proxy(..)) type Users = @@ -29,6 +29,7 @@ type Users = , completed_tutorial ∷ Column Checked Default , description ∷ String , avatar ∷ Maybe String + , receive_email ∷ Column ReceiveEmail Default , gender ∷ Maybe Gender , country ∷ Column (Maybe Int) (ForeignKey "id" CountriesTable) , read_receipts ∷ Column Checked Default @@ -57,6 +58,9 @@ _headline = Proxy _joined ∷ Proxy "joined" _joined = Proxy +_receiveEmail ∷ Proxy "receive_email" +_receiveEmail = Proxy + _email ∷ Proxy "email" _email = Proxy diff --git a/src/Server/Handler.purs b/src/Server/Handler.purs index 805e5eaa..cdce1494 100644 --- a/src/Server/Handler.purs +++ b/src/Server/Handler.purs @@ -39,6 +39,7 @@ import Server.NotFound.Handler as SNH import Server.Profile.Handler as SPH import Server.Recover.Handler as SRH import Server.Settings.Handler as SSH +import Server.Unsubscribe.Handler as SUH import Shared.ResponseError (ResponseError(..)) import Shared.Routes (routes) @@ -47,6 +48,7 @@ handlers reading = { landing: runHtml reading SLH.landing , register: runJson reading SLH.register , temporary: runJson reading SLH.temporary + , unsubscribe: runHtml reading SUH.unsubscribe , im: { get: runHtml reading SIH.im , contacts: runJson reading SIH.contacts diff --git a/src/Server/Unsubscribe/Action.purs b/src/Server/Unsubscribe/Action.purs new file mode 100644 index 00000000..44bf5be3 --- /dev/null +++ b/src/Server/Unsubscribe/Action.purs @@ -0,0 +1,46 @@ +module Server.Unsubscribe.Action where + +import Debug +import Prelude +import Shared.Im.Types +import Shared.Privilege + +import Data.Array as DA +import Data.Array.NonEmpty as DAN +import Data.Either (Either(..)) +import Data.Maybe (Maybe(..)) +import Data.Maybe as DM +import Data.Nullable as DN +import Data.Set (Set) +import Data.Set as DST +import Data.String as DS +import Data.Tuple (Tuple(..)) +import Droplet.Driver (Pool) +import Run.Except as RE +import Server.AccountValidation as SA +import Server.Effect (BaseEffect, Configuration, ServerEffect) +import Server.Email as SE +import Server.File as SF +import Environment (production) +import Server.Im.Database as SID +import Server.Im.Database.Flat (FlatContactHistoryMessage, fromFlatContact, fromFlatMessage) +import Server.Im.Database.Flat as SIF +import Server.Im.Types (Payload) +import Server.Sanitize as SS +import Server.ThreeK as ST +import Server.Wheel as SW +import Shared.Markdown (Token(..)) +import Shared.Markdown as SM +import Shared.Resource (Media(..), ResourceType(..)) +import Shared.Resource as SP +import Shared.ResponseError (ResponseError(..)) +import Server.Unsubscribe.Database as SUD + +unsubscribe ∷ String → ServerEffect Boolean +unsubscribe token = do + maybeId ← SUD.fetchUnsubscriber token + case maybeId of + Nothing → pure false + Just id → do + SUD.unsubscribe id + pure true diff --git a/src/Server/Unsubscribe/Database.purs b/src/Server/Unsubscribe/Database.purs new file mode 100644 index 00000000..cdde91a8 --- /dev/null +++ b/src/Server/Unsubscribe/Database.purs @@ -0,0 +1,22 @@ +module Server.Unsubscribe.Database where + +import Droplet.Language +import Prelude hiding (not, join) +import Server.Database.UnsubscribeTokens +import Server.Database.Users + +import Data.Maybe (Maybe) +import Server.Database as SD +import Server.Database.Fields (_contents, _id) +import Server.Effect (ServerEffect) +import Shared.User (ReceiveEmail(..)) + +fetchUnsubscriber ∷ String → ServerEffect (Maybe Int) +fetchUnsubscriber token = do + row ← SD.single $ select _unsubscriber # from unsubscribeTokens # wher (_contents .=. token) + pure $ map _.unsubscriber row + +unsubscribe ∷ Int → ServerEffect Unit +unsubscribe id = do + SD.execute $ update users # set (_receiveEmail .=. NoEmails) # wher (_id .=. id) + SD.execute $ delete # from unsubscribeTokens # wher (_unsubscriber .=. id) \ No newline at end of file diff --git a/src/Server/Unsubscribe/Handler.purs b/src/Server/Unsubscribe/Handler.purs new file mode 100644 index 00000000..b0b60214 --- /dev/null +++ b/src/Server/Unsubscribe/Handler.purs @@ -0,0 +1,15 @@ +module Server.Unsubscribe.Handler where + +import Prelude +import Server.Effect (ServerEffect) + +import Server.NotFound.Template as SUN +import Server.Response as SR +import Server.Unsubscribe.Action as SUA +import Server.Unsubscribe.Template as SUT +import Shared.Html (Html) + +unsubscribe ∷ { query ∷ { emailId ∷ String } } → ServerEffect Html +unsubscribe { query: { emailId } } = do + unsubbed ← SUA.unsubscribe emailId + SR.serveTemplate $ if unsubbed then SUT.template else SUN.template diff --git a/src/Server/Unsubscribe/Template.purs b/src/Server/Unsubscribe/Template.purs new file mode 100644 index 00000000..d19e77ee --- /dev/null +++ b/src/Server/Unsubscribe/Template.purs @@ -0,0 +1,25 @@ +module Server.Unsubscribe.Template where + +import Prelude + +import Effect (Effect) +import Flame.Html.Attribute as HA +import Flame.Html.Element as HE +import Flame.Renderer.String as FRS +import Server.Template (externalDefaultParameters) +import Server.Template as ST + +template ∷ Effect String +template = do + contents ← ST.template externalDefaultParameters + { content = externalDefaultParameters.content <> content + , title = "MeroChat - Unsubscribe from Emails" + } + FRS.render contents + where + content = + [ HE.div (HA.class' "green-area green-box") + [ HE.h2 (HA.class' "ext-heading") "Email unsubscribed" + , HE.p_ "You have been unsubscribed. If you wish to subscribe again, log in and modify your emails settings" + ] + ] \ No newline at end of file diff --git a/src/Server/sql/index.sql b/src/Server/sql/index.sql index f933fc3d..1ab62a79 100644 --- a/src/Server/sql/index.sql +++ b/src/Server/sql/index.sql @@ -312,6 +312,14 @@ create table experiments added timestamptz not null default (utc_now()) ); +create table unsubscribe_tokens +( + id integer generated always as identity primary key, + unsubscriber integer not null, + contents text not null, + constraint unsubcribe_tokens_user foreign key (unsubscriber) references users(id) on delete cascade +); + create or replace function insert_history (sender_id int, recipient_id int) returns void as $$ diff --git a/src/Shared/Spec.purs b/src/Shared/Spec.purs index 8e56b842..584f878a 100644 --- a/src/Shared/Spec.purs +++ b/src/Shared/Spec.purs @@ -39,6 +39,12 @@ spec ∷ , body ∷ RegisterLogin , response ∷ Ok } + , unsubscribe ∷ + GET "/unsubscribe?email_id=" + { guards ∷ Guards Nil + , query ∷ { emailId ∷ String } + , response ∷ Html + } , login ∷ Routes "/login" { guards ∷ Guards ("checkAnonymous" : Nil) diff --git a/src/Shared/User.purs b/src/Shared/User.purs index e689960e..bf59ee1c 100644 --- a/src/Shared/User.purs +++ b/src/Shared/User.purs @@ -64,6 +64,8 @@ type IU = ) ) +data ReceiveEmail = AllEmails | UnreadMessageEmails | NoEmails + data Gender = Female | Male @@ -77,15 +79,22 @@ data ProfileVisibility | Nobody | TemporarilyBanned -- user is deleted when banned for good +derive instance Eq ReceiveEmail derive instance Eq ProfileVisibility derive instance Eq Gender +instance DecodeJson ReceiveEmail where + decodeJson = DADGR.genericDecodeJson + instance DecodeJson Gender where decodeJson = DADGR.genericDecodeJson instance DecodeJson ProfileVisibility where decodeJson = DADGR.genericDecodeJson +instance EncodeJson ReceiveEmail where + encodeJson = DAEGR.genericEncodeJson + instance EncodeJson Gender where encodeJson = DAEGR.genericEncodeJson @@ -105,21 +114,32 @@ instance Show ProfileVisibility where instance ReadForeign Gender where readImpl foreignGender = SU.fromJust <<< DSR.read <$> F.readString foreignGender +instance ReadForeign ReceiveEmail where + readImpl f = SU.fromJust <<< DE.toEnum <$> F.readInt f + instance ReadForeign ProfileVisibility where readImpl f = SU.fromJust <<< DE.toEnum <$> F.readInt f +derive instance Generic ReceiveEmail _ derive instance Generic Gender _ derive instance Generic ProfileVisibility _ instance WriteForeign Gender where writeImpl gender = F.unsafeToForeign $ show gender +instance WriteForeign ReceiveEmail where + writeImpl = F.unsafeToForeign <<< DE.fromEnum + instance WriteForeign ProfileVisibility where writeImpl = F.unsafeToForeign <<< DE.fromEnum +instance ToValue ReceiveEmail where + toValue = F.unsafeToForeign <<< DE.fromEnum + instance ToValue Gender where toValue = F.unsafeToForeign <<< DE.fromEnum +derive instance Ord ReceiveEmail derive instance Ord Gender derive instance Ord ProfileVisibility @@ -203,12 +223,44 @@ instance Enum ProfileVisibility where Nobody → Just Contacts TemporarilyBanned → Just Nobody +instance Bounded ReceiveEmail where + bottom = AllEmails + top = NoEmails + +instance BoundedEnum ReceiveEmail where + cardinality = Cardinality 1 + + fromEnum = case _ of + AllEmails → 0 + UnreadMessageEmails → 1 + NoEmails → 2 + + toEnum = case _ of + 0 → Just AllEmails + 1 → Just UnreadMessageEmails + 2 → Just NoEmails + _ → Nothing + +instance Enum ReceiveEmail where + succ = case _ of + AllEmails → Just UnreadMessageEmails + UnreadMessageEmails → Just NoEmails + NoEmails → Nothing + + pred = case _ of + AllEmails → Nothing + UnreadMessageEmails → Just AllEmails + NoEmails → Just UnreadMessageEmails + instance FromValue Gender where fromValue v = map (SU.fromJust <<< DE.toEnum) (DL.fromValue v ∷ Either String Int) instance FromValue ProfileVisibility where fromValue v = map (SU.fromJust <<< DE.toEnum) (DL.fromValue v ∷ Either String Int) +instance FromValue ReceiveEmail where + fromValue v = map (SU.fromJust <<< DE.toEnum) (DL.fromValue v ∷ Either String Int) + instance ToValue ProfileVisibility where toValue = F.unsafeToForeign <<< DE.fromEnum