git.gnu.io has moved to IP address 209.51.188.249 -- please double check where you are logging in.

Commit 3969bb94 authored by Bryan Richter's avatar Bryan Richter

Merge branch 'release-0.1.3' into production

parents d02ed568 a7b0a8fe
This diff is collapsed.
......@@ -3,7 +3,7 @@ module Foundation where
import Model
import Model.Currency
import Model.Established.Internal (Established(..))
import Model.Notification.Internal (NotificationType(..), NotificationDelivery(..))
import Model.Notification.Internal (UserNotificationType(..), UserNotificationDelivery(..))
import Model.SnowdriftEvent.Internal
import Model.Language
import qualified Settings
......@@ -386,7 +386,6 @@ createUser ident passwd name email avatar nick = do
discussion_id <- insert (Discussion 0)
user <- maybe return setPassword passwd $ User ident email False (Just now) Nothing Nothing name account_id avatar Nothing Nothing nick langs now now EstUnestablished discussion_id
uid_maybe <- insertUnique user
Entity snowdrift_id _ <- getBy404 $ UniqueProjectHandle "snowdrift"
case uid_maybe of
Just user_id -> do
......@@ -408,9 +407,8 @@ createUser ident passwd name email avatar nick = do
welcome_route <>
"), and let us know any questions."
]
-- TODO: change snowdrift_id to the generated site-project id
-- TODO: This notification doesn't get sent to the event channel. Is that okay?
insert_ $ Notification now NotifWelcome user_id (Just snowdrift_id) notif_text False
insert_ $ UserNotification now NotifWelcome user_id notif_text False
return $ Just user_id
Nothing -> do
lift $ addAlert "danger" "Handle already in use."
......@@ -418,18 +416,16 @@ createUser ident passwd name email avatar nick = do
where
insertDefaultNotificationPrefs :: UserId -> DB ()
insertDefaultNotificationPrefs user_id =
void . insertMany $ uncurry (UserNotificationPref user_id Nothing) <$>
void . insertMany $ uncurry (UserNotificationPref user_id) <$>
-- 'NotifWelcome' is not set since it is delivered when a
-- user is created.
[ (NotifBalanceLow, NotifDeliverWebsite)
, (NotifBalanceLow, NotifDeliverEmail)
, (NotifUnapprovedComment, NotifDeliverEmail)
, (NotifRethreadedComment, NotifDeliverWebsite)
, (NotifReply, NotifDeliverEmail)
, (NotifEditConflict, NotifDeliverWebsite)
, (NotifFlag, NotifDeliverWebsite)
, (NotifFlag, NotifDeliverEmail)
, (NotifFlagRepost, NotifDeliverWebsite)
[ (NotifBalanceLow, UserNotifDeliverWebsiteAndEmail)
, (NotifUnapprovedComment, UserNotifDeliverEmail)
, (NotifRethreadedComment, UserNotifDeliverWebsite)
, (NotifReply, UserNotifDeliverEmail)
, (NotifEditConflict, UserNotifDeliverWebsite)
, (NotifFlag, UserNotifDeliverWebsiteAndEmail)
, (NotifFlagRepost, UserNotifDeliverWebsite)
]
instance YesodJquery App
......
This diff is collapsed.
......@@ -6,30 +6,71 @@ import Model.Notification
import Model.Project
import Model.User
import qualified Data.Foldable as F
import Data.List (sort)
import qualified Data.Text as T
import Widgets.Time
-- Merge two notification types together. This should only be used
-- for rendering.
data Notification
= UNotification UserNotificationId UserNotification
| PNotification ProjectNotificationId ProjectNotification
deriving Eq
instance Ord Notification where
-- The arguments of 'compare' are intentionally swapped, so the
-- newest notifications are listed first.
compare (UNotification _ un1) (UNotification _ un2)
= compare (userNotificationCreatedTs un2)
(userNotificationCreatedTs un1)
compare (UNotification _ un) (PNotification _ pn)
= compare (projectNotificationCreatedTs pn)
(userNotificationCreatedTs un)
compare (PNotification _ pn) (UNotification _ un)
= compare (userNotificationCreatedTs un)
(projectNotificationCreatedTs pn)
compare (PNotification _ pn1) (PNotification _ pn2)
= compare (projectNotificationCreatedTs pn2)
(projectNotificationCreatedTs pn1)
buildNotificationsList :: [Entity UserNotification]
-> [Entity ProjectNotification] -> [Notification]
buildNotificationsList uns pns =
sort $ ((\(Entity un_id un) -> UNotification un_id un) <$> uns)
<> ((\(Entity pn_id pn) -> PNotification pn_id pn) <$> pns)
getNotificationsR :: Handler Html
getNotificationsR = do
user_id <- requireAuthId
notifs <- runDB $ do
notifs <- runDB $ do
userReadNotificationsDB user_id
fetchUserNotificationsDB user_id
user_notifs <- fetchUserNotificationsDB user_id
project_notifs <- fetchProjectNotificationsDB user_id
return $ buildNotificationsList user_notifs project_notifs
defaultLayout $ do
snowdriftTitle "Notifications"
$(widgetFile "notifications")
whenNotifId :: DBConstraint m => Text -> (NotificationId -> m ()) -> m ()
whenNotifId :: (PersistEntity r, DBConstraint m)
=> Text -> (Key r -> m ()) -> m ()
whenNotifId value action =
F.forM_ (readMaybe $ T.unpack value :: Maybe Int) $ \notif_id ->
action $ key $ toPersistValue notif_id
whenUserNotifId :: DBConstraint m => Text -> (UserNotificationId -> m ()) -> m ()
whenUserNotifId = whenNotifId
whenProjectNotifId :: DBConstraint m => Text -> (ProjectNotificationId -> m ()) -> m ()
whenProjectNotifId = whenNotifId
proxyNotifications :: RedirectUrl App route => Text -> Text
-> (UserId -> DB ()) -> (UserId -> DB ())
-> (NotificationId -> DB ()) -> (NotificationId -> DB ())
-> (UserNotificationId -> DB ()) -> (UserNotificationId -> DB ())
-> (ProjectNotificationId -> DB ()) -> (ProjectNotificationId -> DB ())
-> route -> Handler Html
proxyNotifications value1 value2 action_all1 action_all2
action_notif1 action_notif2 route = do
action_user_notif1 action_user_notif2
action_project_notif1 action_project_notif2 route = do
user_id <- requireAuthId
req <- getRequest
let params = reqGetParams req
......@@ -40,27 +81,35 @@ proxyNotifications value1 value2 action_all1 action_all2
| value2 `elem` names -> action2
| otherwise -> return ()
forM_ params $ \(name, value) ->
if | name == "all" ->
runDB $ handleAction (action_all1 user_id)
(action_all2 user_id)
| name == "notification" ->
whenNotifId value $ \notif_id -> runDB $
handleAction (action_notif1 notif_id)
(action_notif2 notif_id)
| otherwise -> return ()
case name of
"all" ->
runDB $ handleAction (action_all1 user_id)
(action_all2 user_id)
"user_notification" ->
whenUserNotifId value $ \notif_id -> runDB $
handleAction (action_user_notif1 notif_id)
(action_user_notif2 notif_id)
"project_notification" ->
whenProjectNotifId value $ \notif_id -> runDB $
handleAction (action_project_notif1 notif_id)
(action_project_notif2 notif_id)
_ -> return ()
redirect route
getNotificationsProxyR :: Handler Html
getNotificationsProxyR =
proxyNotifications "archive" "delete"
archiveNotificationsDB deleteNotificationsDB
archiveNotificationDB deleteNotificationDB
archiveUserNotificationDB deleteUserNotificationDB
archiveProjectNotificationDB deleteProjectNotificationDB
NotificationsR
getArchivedNotificationsR :: Handler Html
getArchivedNotificationsR = do
user_id <- requireAuthId
notifs <- runDB (fetchUserArchivedNotificationsDB user_id)
notifs <- runDB $ buildNotificationsList
<$> fetchArchivedUserNotificationsDB user_id
<*> fetchArchivedProjectNotificationsDB user_id
defaultLayout $ do
snowdriftTitle "Archived Notifications"
$(widgetFile "archived_notifications")
......@@ -69,5 +118,6 @@ getArchivedNotificationsProxyR :: Handler Html
getArchivedNotificationsProxyR =
proxyNotifications "unarchive" "delete"
unarchiveNotificationsDB deleteArchivedNotificationsDB
unarchiveNotificationDB deleteNotificationDB
unarchiveUserNotificationDB deleteUserNotificationDB
unarchiveProjectNotificationDB deleteProjectNotificationDB
ArchivedNotificationsR
......@@ -38,9 +38,6 @@ getEventTicketClaimedR = redirectCommentEvent
getEventTicketUnclaimedR :: EventTicketUnclaimedId -> Handler ()
getEventTicketUnclaimedR = redirectCommentEvent (get404 >=> eventTicketUnclaimedClaim >>> get404) ticketOldClaimingTicket
getEventNotificationSentR :: EventNotificationSentId -> Handler ()
getEventNotificationSentR = error "no page associated with event type NotificationSent"
getEventWikiPageR :: EventWikiPageId -> Handler ()
getEventWikiPageR event_wiki_page_id = do
languages <- getLanguages
......
......@@ -8,7 +8,8 @@ import Handler.Discussion
import Handler.User.Comment
import Model.Currency
import Model.Comment.ActionPermissions
import Model.Notification.Internal (NotificationType (..))
import Model.Notification.Internal
(UserNotificationType (..), ProjectNotificationType (..))
import Model.Role
import Model.ResetPassword (deleteFromResetPassword)
import Model.Transaction
......@@ -609,7 +610,7 @@ getUserNotificationsR :: UserId -> Handler Html
getUserNotificationsR user_id = do
void $ checkEditUser user_id
user <- runYDB $ get404 user_id
let fetchNotifPref = runYDB . fetchUserNotificationPrefDB user_id Nothing
let fetchNotifPref = runYDB . fetchUserNotificationPrefDB user_id
mbal <- fetchNotifPref NotifBalanceLow
mucom <- fetchNotifPref NotifUnapprovedComment
mrcom <- fetchNotifPref NotifRethreadedComment
......@@ -635,8 +636,8 @@ postUserNotificationsR user_id = do
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
case result of
FormSuccess notif_pref -> do
forM_ (userNotificationPref notif_pref) $ \ (ntype, ndelivs) ->
runDB $ updateNotificationPrefDB user_id Nothing ntype ndelivs
forM_ (userNotificationPref notif_pref) $ \ (ntype, ndeliv) ->
runDB $ updateUserNotificationPrefDB user_id ntype ndeliv
alertSuccess "Successfully updated the notification preferences."
redirect $ UserR user_id
_ -> do
......@@ -676,7 +677,7 @@ getProjectNotificationsR user_id project_id = do
user <- runYDB $ get404 user_id
project <- runYDB $ get404 project_id
let fetchNotifPref =
runYDB . fetchUserNotificationPrefDB user_id (Just project_id)
runYDB . fetchProjectNotificationPrefDB user_id project_id
mwiki_page <- fetchNotifPref NotifWikiPage
mwiki_edit <- fetchNotifPref NotifWikiEdit
mblog_post <- fetchNotifPref NotifBlogPost
......@@ -700,9 +701,9 @@ postProjectNotificationsR user_id project_id = do
Nothing Nothing Nothing
case result of
FormSuccess notif_pref -> do
forM_ (projectNotificationPref notif_pref) $ \ (ntype, ndelivs) ->
runDB $ updateNotificationPrefDB
user_id (Just project_id) ntype ndelivs
forM_ (projectNotificationPref notif_pref) $ \ (ntype, ndeliv) ->
runDB $ updateProjectNotificationPrefDB
user_id project_id ntype ndeliv
alertSuccess "Successfully updated the notification preferences."
redirect (UserR user_id)
_ -> do
......
......@@ -234,10 +234,18 @@ postWikiR project_handle target_language target = do
, "[**Ticket created**](" <> render (WikiCommentR project_handle target_language target comment_id) <> ")"
]
sendPreferredNotificationDB last_editor NotifEditConflict
Nothing Nothing notif_text
sendPreferredNotificationDB user_id NotifEditConflict
Nothing Nothing notif_text
sendPreferredUserNotificationDB
(Just $ NotificationSender user_id)
(NotificationReceiver last_editor)
NotifEditConflict
Nothing
notif_text
sendPreferredUserNotificationDB
(Just $ NotificationSender last_editor)
(NotificationReceiver user_id)
NotifEditConflict
Nothing
notif_text
lift $ lift $ alertDanger "conflicting edits (ticket created, notification sent)"
......@@ -644,7 +652,6 @@ getMonolingualWikiR = redirectPolylingualWiki $ \case
-- These routes are higher in the tree - can't possibly have been generated by inserting the language
_ -> error "the impossible happened"
where
redirectSameParams url = do
params <- reqGetParams <$> getRequest
......
......@@ -11,7 +11,9 @@ import Model.Established.Internal (Established(..))
import Model.Language
import Model.License.Internal (LicenseName, LicenseType, LicenseProjectType, LicenseText, LicenseWebsite)
import Model.Markdown.Diff (MarkdownDiff)
import Model.Notification.Internal (NotificationType, NotificationDelivery)
import Model.Notification.Internal
( UserNotificationType, UserNotificationDelivery
, ProjectNotificationType, ProjectNotificationDelivery )
import Model.Permission.Internal (PermissionLevel)
import Model.Project.Signup
( ProjectSignupName, ProjectSignupWebsite, ProjectSignupHandle
......@@ -73,3 +75,6 @@ data ProjectSignupLicense = ProjectSignupLicense License
derivePersistField "ProjectSignupLicense"
deriving instance Show ProjectSignup
deriving instance Eq UserNotification
deriving instance Eq ProjectNotification
......@@ -77,7 +77,9 @@ import qualified Model.Comment.Internal as Internal
import Model.Comment.Sql
import Model.Discussion
import Model.Notification
import Model.User.Internal (sendPreferredNotificationDB)
import Model.User.Internal
( sendPreferredUserNotificationDB, NotificationSender (..)
, NotificationReceiver (..) )
import qualified Control.Monad.State as State
import Control.Monad.Writer.Strict (tell)
......@@ -240,7 +242,7 @@ approveCommentDB user_id comment_id comment = do
from $ \unc -> do
where_ (unc ^. UnapprovedCommentNotificationComment ==. val comment_id)
return (unc ^. UnapprovedCommentNotificationNotification)
deleteCascadeWhere [NotificationId P.<-. notif_ids]
deleteCascadeWhere [UserNotificationId P.<-. notif_ids]
insertApprovedCommentDB
:: UTCTime
......@@ -458,7 +460,12 @@ editCommentDB user_id comment_id text language = do
rendered_route <- lift $ makeCommentRouteDB langs comment_id >>= return . render . fromJust
let notif_text = Markdown $ "A comment you flagged has been edited and reposted to the site. You can view it [here](" <> rendered_route <> ")."
lift (deleteCascade comment_flagging_id) -- delete flagging and all flagging reasons with it.
sendPreferredNotificationDB commentFlaggingFlagger NotifFlagRepost Nothing Nothing notif_text
sendPreferredUserNotificationDB
(Just $ NotificationSender user_id)
(NotificationReceiver commentFlaggingFlagger)
NotifFlagRepost
Nothing
notif_text
where
updateComment = do
existent_tickets <- lift $ fetchTicketNamesDB comment_id
......@@ -503,7 +510,12 @@ flagCommentDB comment_id permalink_route flagger_id reasons message = do
, ""
, "[link to flagged comment](" <> permalink_route <> ")"
]
sendPreferredNotificationDB poster_id NotifFlag Nothing Nothing notif_text
sendPreferredUserNotificationDB
(Just $ NotificationSender flagger_id)
(NotificationReceiver poster_id)
NotifFlag
Nothing
notif_text
return True
-- | Post an new (approved) Comment.
......
module Model.Notification
( archiveNotificationDB
, sendNotificationDB
, sendNotificationDB_
, sendNotificationEmailDB
, unarchiveNotificationDB
( archiveUserNotificationDB
, archiveProjectNotificationDB
, sendUserNotificationDB
, sendProjectNotificationDB
, sendUserNotificationDB_
, sendProjectNotificationDB_
, sendUserNotificationEmailDB
, sendProjectNotificationEmailDB
, unarchiveUserNotificationDB
, unarchiveProjectNotificationDB
, module Model.Notification.Internal
) where
......@@ -14,39 +19,76 @@ import Model.Notification.Internal
import Control.Monad.Writer.Strict (tell)
import Data.Maybe (fromJust)
updateNotificationArchived :: Bool -> NotificationId -> DB ()
updateNotificationArchived bool notif_id =
updateNotificationArchived
:: ( MonadIO m, PersistField a, PersistField b
, PersistEntity val, PersistEntityBackend val ~ SqlBackend )
=> EntityField val a -> EntityField val b -> a -> b
-> SqlPersistT m ()
updateNotificationArchived notif_archived_con notif_id_con
notif_archived_val notif_id_val =
update $ \n -> do
set n [NotificationArchived =. val bool]
where_ (n ^. NotificationId ==. val notif_id)
set n [notif_archived_con =. val notif_archived_val]
where_ $ n ^. notif_id_con ==. val notif_id_val
-- | Archive a notification.
archiveNotificationDB :: NotificationId -> DB ()
archiveNotificationDB = updateNotificationArchived True
updateUserNotificationArchived :: Bool -> UserNotificationId -> DB ()
updateUserNotificationArchived =
updateNotificationArchived UserNotificationArchived UserNotificationId
unarchiveNotificationDB :: NotificationId -> DB ()
unarchiveNotificationDB = updateNotificationArchived False
updateProjectNotificationArchived :: Bool -> ProjectNotificationId -> DB ()
updateProjectNotificationArchived =
updateNotificationArchived ProjectNotificationArchived ProjectNotificationId
-- | Send a notification to a user.
sendNotificationDB :: NotificationType -> UserId -> Maybe ProjectId
-> Maybe CommentId -> Markdown -> SDB NotificationId
sendNotificationDB notif_type user_id mproject_id mcomment_id content = do
archiveUserNotificationDB :: UserNotificationId -> DB ()
archiveUserNotificationDB = updateUserNotificationArchived True
archiveProjectNotificationDB :: ProjectNotificationId -> DB ()
archiveProjectNotificationDB = updateProjectNotificationArchived True
unarchiveUserNotificationDB :: UserNotificationId -> DB ()
unarchiveUserNotificationDB = updateUserNotificationArchived False
unarchiveProjectNotificationDB :: ProjectNotificationId -> DB ()
unarchiveProjectNotificationDB = updateProjectNotificationArchived False
sendUserNotificationDB :: UserNotificationType -> UserId -> Maybe CommentId
-> Markdown -> SDB UserNotificationId
sendUserNotificationDB notif_type user_id mcomment_id content = do
now <- liftIO getCurrentTime
let notif = Notification now notif_type user_id mproject_id content False
let notif = UserNotification now notif_type user_id content False
notif_id <- lift (insert notif)
-- Record the fact that we send this notification, so we can
-- delete it when the comment is approved.
when (notif_type == NotifUnapprovedComment && isJust mcomment_id) $
lift $ insert_ $ UnapprovedCommentNotification (fromJust mcomment_id) notif_id
tell [ENotificationSent notif_id notif]
tell [EUserNotificationSent notif_id notif]
return notif_id
sendNotificationDB_ :: NotificationType -> UserId -> Maybe ProjectId
-> Maybe CommentId -> Markdown -> SDB ()
sendNotificationDB_ notif_type user_id mproject_id mcomment_id content = void $ sendNotificationDB notif_type user_id mproject_id mcomment_id content
sendProjectNotificationDB :: ProjectNotificationType -> UserId -> ProjectId
-> Markdown -> SDB ProjectNotificationId
sendProjectNotificationDB notif_type user_id project_id content = do
now <- liftIO getCurrentTime
let notif = ProjectNotification now notif_type user_id project_id content False
notif_id <- lift (insert notif)
tell [EProjectNotificationSent notif_id notif]
return notif_id
sendUserNotificationDB_ :: UserNotificationType -> UserId -> Maybe CommentId
-> Markdown -> SDB ()
sendUserNotificationDB_ notif_type user_id mcomment_id content =
void $ sendUserNotificationDB notif_type user_id mcomment_id content
sendProjectNotificationDB_ :: ProjectNotificationType -> UserId -> ProjectId
-> Markdown -> SDB ()
sendProjectNotificationDB_ notif_type user_id project_id content =
void $ sendProjectNotificationDB notif_type user_id project_id content
sendUserNotificationEmailDB :: UserNotificationType -> UserId -> Markdown -> DB ()
sendUserNotificationEmailDB notif_type user_id content = do
now <- liftIO getCurrentTime
insert_ $ UserNotificationEmail now notif_type user_id content
sendNotificationEmailDB :: NotificationType -> UserId -> Maybe ProjectId
-> Markdown -> DB ()
sendNotificationEmailDB notif_type user_id mproject_id content = do
sendProjectNotificationEmailDB :: ProjectNotificationType -> UserId -> ProjectId
-> Markdown -> DB ()
sendProjectNotificationEmailDB notif_type user_id project_id content = do
now <- liftIO getCurrentTime
insert_ $ NotificationEmail now notif_type user_id mproject_id content
insert_ $ ProjectNotificationEmail now notif_type user_id project_id content
......@@ -5,7 +5,7 @@ import Prelude
import Database.Persist.TH
import Data.Text (Text)
data NotificationType
data UserNotificationType
= NotifWelcome
-- User has become eligible for establishment.
| NotifEligEstablish
......@@ -29,8 +29,12 @@ data NotificationType
| NotifFlag
-- Flagged comment was reposted.
| NotifFlagRepost
deriving (Eq, Read, Show, Bounded, Enum)
derivePersistField "UserNotificationType"
data ProjectNotificationType
-- New wiki page.
| NotifWikiPage
= NotifWikiPage
| NotifWikiEdit
-- New blog post.
| NotifBlogPost
......@@ -38,30 +42,38 @@ data NotificationType
| NotifUpdatedPledge
| NotifDeletedPledge
deriving (Eq, Read, Show, Bounded, Enum)
derivePersistField "NotificationType"
derivePersistField "ProjectNotificationType"
showUserNotificationType :: UserNotificationType -> Text
showUserNotificationType NotifWelcome = "Snowdrift welcome message"
showUserNotificationType NotifEligEstablish = "You have become eligible for establishment"
showUserNotificationType NotifUnapprovedComment = "Unapproved comments"
showUserNotificationType NotifApprovedComment = "Approved comments"
showUserNotificationType NotifRethreadedComment = "Rethreaded comments"
showUserNotificationType NotifBalanceLow = "Balance low"
showUserNotificationType NotifReply = "Replies to my comments"
showUserNotificationType NotifEditConflict = "Edit conflict"
showUserNotificationType NotifFlag = "A comment of yours was flagged"
showUserNotificationType NotifFlagRepost = "A comment you flagged was edited and reposted"
showNotificationType :: NotificationType -> Text
showNotificationType NotifWelcome = "Snowdrift welcome message"
showNotificationType NotifEligEstablish = "You have become eligible for establishment"
showNotificationType NotifUnapprovedComment = "Unapproved comments"
showNotificationType NotifApprovedComment = "Approved comments"
showNotificationType NotifRethreadedComment = "Rethreaded comments"
showNotificationType NotifBalanceLow = "Balance low"
showNotificationType NotifReply = "Replies to my comments"
showNotificationType NotifEditConflict = "Edit conflict"
showNotificationType NotifFlag = "A comment of yours was flagged"
showNotificationType NotifFlagRepost = "A comment you flagged was edited and reposted"
showNotificationType NotifBlogPost = "New blog post"
showNotificationType NotifWikiEdit = "Wiki page was edited"
showNotificationType NotifWikiPage = "New wiki page"
showNotificationType NotifNewPledge = "New pledge"
showNotificationType NotifUpdatedPledge = "Pledge updated"
showNotificationType NotifDeletedPledge = "Pledge deleted"
showProjectNotificationType :: ProjectNotificationType -> Text
showProjectNotificationType NotifWikiEdit = "Wiki page was edited"
showProjectNotificationType NotifWikiPage = "New wiki page"
showProjectNotificationType NotifBlogPost = "New blog post"
showProjectNotificationType NotifNewPledge = "New pledge"
showProjectNotificationType NotifUpdatedPledge = "Pledge updated"
showProjectNotificationType NotifDeletedPledge = "Pledge deleted"
data NotificationDelivery
= NotifDeliverWebsite
| NotifDeliverEmail
-- XXX: Not supported by 'userNotificationsForm'.
-- | NotifDeliverEmailDigest
data UserNotificationDelivery
= UserNotifDeliverWebsite
| UserNotifDeliverEmail
| UserNotifDeliverWebsiteAndEmail
deriving (Read, Show, Eq)
derivePersistField "NotificationDelivery"
derivePersistField "UserNotificationDelivery"
data ProjectNotificationDelivery
= ProjectNotifDeliverWebsite
| ProjectNotifDeliverEmail
| ProjectNotifDeliverWebsiteAndEmail
deriving (Read, Show, Eq)
derivePersistField "ProjectNotificationDelivery"
......@@ -26,7 +26,8 @@ snowdriftEventTime (ECommentClosed _ CommentClosing{..}) = commen
snowdriftEventTime (ETicketClaimed (Left (_, TicketClaiming{..}))) = ticketClaimingTs
snowdriftEventTime (ETicketClaimed (Right (_, TicketOldClaiming{..}))) = ticketOldClaimingClaimTs
snowdriftEventTime (ETicketUnclaimed _ TicketOldClaiming{..}) = ticketOldClaimingReleasedTs
snowdriftEventTime (ENotificationSent _ Notification{..}) = notificationCreatedTs
snowdriftEventTime (EUserNotificationSent _ UserNotification{..}) = userNotificationCreatedTs
snowdriftEventTime (EProjectNotificationSent _ ProjectNotification{..}) = projectNotificationCreatedTs
snowdriftEventTime (EWikiEdit _ WikiEdit{..} _) = wikiEditTs
snowdriftEventTime (EWikiPage _ WikiPage{..} _) = wikiPageCreatedTs
snowdriftEventTime (EBlogPost _ BlogPost{..}) = blogPostTs
......@@ -220,4 +221,6 @@ snowdriftEventToFeedEntry _ _ _ _ _ _ _ (EDeletedPledge _ _ _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ _ _ (ECommentApproved _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ _ _ (ECommentPending _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ _ _ (ENotificationSent _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ _ _ (EUserNotificationSent _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ _ _ (EProjectNotificationSent _ _) = Nothing
......@@ -33,7 +33,9 @@ data SnowdriftEvent
-- Comment rethreaded.
| ECommentRethreaded RethreadId Rethread -- rethreaded-from-URL
| ENotificationSent NotificationId Notification
| EUserNotificationSent UserNotificationId UserNotification
| EProjectNotificationSent ProjectNotificationId ProjectNotification
-- New WikiEdit made.
| EWikiEdit WikiEditId WikiEdit WikiTarget
......
This diff is collapsed.
This diff is collapsed.
......@@ -20,7 +20,7 @@ createWikiPageDB language target project_id content permission_level user_id = d
now <- liftIO getCurrentTime
discussion_id <- lift createDiscussionDB
let wiki_page = WikiPage now project_id discussion_id permission_level
let wiki_page = WikiPage now user_id project_id discussion_id permission_level
wiki_page_id <- lift $ insert wiki_page
let wiki_target = WikiTarget wiki_page_id project_id target language
......
......@@ -43,35 +43,36 @@ Hop on #snowdrift at
Essential build instructions
----------------------------
Note: our code is mirrored at
[Gitorious](https://gitorious.org/snowdrift/snowdrift)
(which is FLO, licensed AGPL, but is shutting down soon and we haven't finalized
our move to another FLO service yet) and
[GitHub](https://github.com/snowdriftcoop/snowdrift)
(which is popular but proprietary).
**You really should read our full [guide to our code](GUIDE.md)
which has step-by-step instructions that even a true beginner can follow.**
It also contains links for learning Haskell, comments about development methods,
and more.
Our code is hosted at the fully free/libre/open site
[Git.GNU.io/snowdrift/snowdrift](https://git.gnu.io/snowdrift/snowdrift)
but for convenience and redundancy we also mirror at
[GitHub](https://github.com/snowdriftcoop/snowdrift),
a popular but proprietary platform.
**Our full [guide to our code](GUIDE.md) has precise setup details
and clarifications about technical items.
Beginners with minimal technical background can get set up by following our
[Beginners' Snowdrift Set Up](BEGINNERS.md) which can get anyone started for
making basic contributions along with links and info to help learn more about
the tools we use.
But for those experienced with Git, Haskell, PostgreSQL, and perhaps even Yesod,
here's quick and dirty minimal instructions to get started:
For advanced programmers experienced with Git, Haskell, PostgreSQL,
and perhaps even Yesod, here's quick and dirty minimal start instructions:
```
// Install any dependencies you don't have:
// GHC **7.8.x**, cabal, PostgreSQL, zlib1g-dev, libpq-dev, happy, alex
// GHC **7.8.x**, cabal, PostgreSQL, happy, alex, git
// update cabal, set PATH, etc. — see GUIDE.md for more detailed instructions
// Fork, clone and install
git clone [your remote address]
// your remote looks like git@gitorious.org:snowdrift/yourusername-snowdrift.git]
cd snowdrift
cabal sandbox init
cabal install --enable-tests -fdev
// Set up the database with our quick script.
// To understand what the script does or to run the commands manually, see GUIDE.md
// To understand the script does or to run the commands manually, see GUIDE.md
sdm init
// Launch the development site
......@@ -82,5 +83,5 @@ Snowdrift Development
// To rebuild after making changes run
cabal install -fdev
Read through GUIDE.md for thorough details about development, testing, and so on.
Read GUIDE.md for thorough details about development, testing, and so on.
```
name: Snowdrift
version: 0.1.2
license: OtherLicense
version: 0.1.3
license: AGPL-3
license-file: LICENSE
author: David L. L. Thomas
maintainer: Snowdrift.coop
......
This diff is collapsed.
This diff is collapsed.
......@@ -12,19 +12,17 @@ module View.User
, userNotificationsForm
) where
import Import hiding (UserNotificationPref)
import Import hiding (UserNotificationPref, ProjectNotificationPref)
import Model.Currency
import Model.Markdown
import Model.Notification (NotificationDelivery (..))
import Model.Notification (UserNotificationDelivery (..), ProjectNotificationDelivery (..))
import Model.Role
import Model.User
import Model.User.Internal
import Widgets.Markdown (snowdriftMarkdownField)
import Widgets.ProjectPledges
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as N
import qualified Data.Map as M
import qualified Data.Set as S
import Data.String (fromString)
......@@ -172,65 +170,75 @@ userNameWidget user_id = do
addTestCashForm :: Form Milray
addTestCashForm = renderBootstrap3 BootstrapBasicForm $ fromInteger . (10000 *) <$> areq' intField "Add (fake) money to your account (in whole dollars)" (Just 10)
-- 'selectFieldList' does not allow to work with 'NonEmpty'
-- lists, so we have to work around that.
req :: SomeMessage App -> Maybe (NonEmpty NotificationDelivery)
-> AForm (HandlerT App IO) (NonEmpty NotificationDelivery)
req s xs = N.fromList <$> areq' dropdown s (N.toList <$> xs)
req :: Eq a => [(Text, a)] -> SomeMessage App -> Maybe a
-> AForm (HandlerT App IO) a
req methods s xs = areq' (dropdown methods) s xs
opt :: SomeMessage App -> Maybe (NonEmpty NotificationDelivery)
-> AForm (HandlerT App IO) (Maybe (NonEmpty NotificationDelivery))
opt s xs = fmap N.fromList <$> aopt' dropdown s (Just <$> N.toList <$> xs)
opt :: Eq a => [(Text, a)] -> SomeMessage App -> Maybe a
-> AForm (HandlerT App IO) (Maybe a)
opt methods s xs = aopt' (dropdown methods) s (Just xs)
dropdown :: Field (HandlerT App IO) [NotificationDelivery]
dropdown = selectFieldList methods
dropdown :: Eq a => [(Text, a)] -> Field (HandlerT App IO) a
dropdown methods = selectFieldList methods
methods :: [(Text, [NotificationDelivery])]
methods =
userMethods :: [(Text, UserNotificationDelivery)]
userMethods =
-- XXX: Support 'NotifDeliverEmailDigest'.
[ ("website", [NotifDeliverWebsite])
, ("email", [NotifDeliverEmail])