Unsubscribe from emails (#253)

* Unsubscribe from emails

* Unsubscribe from emails

* Rephrase message

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

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
 

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

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

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)

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

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"
+                    ]
+            ]

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
 $$

src/Shared/Spec.purs

@@ -39,6 +39,12 @@ spec ∷
                                   , body ∷ RegisterLogin
                                   , response ∷ Ok
                                   }
+                    , unsubscribe ∷
+                            GET "/unsubscribe?email_id=<emailId>"
+                                  { guards ∷ Guards Nil
+                                  , query ∷ { emailId ∷ String }
+                                  , response ∷ Html
+                                  }
                     , login ∷
                             Routes "/login"
                                   { guards ∷ Guards ("checkAnonymous" : Nil)

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