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

Remove Wiki, Discussions, Comments, Blogs

parent ac6e6df9
......@@ -52,9 +52,7 @@ library
DeprecatedBootstrap
Foundation
Handler.BuildFeed
Handler.Comment
Handler.Common
Handler.Discussion
Handler.HonorPledge
Handler.Image
Handler.Invitation
......@@ -72,19 +70,15 @@ library
Handler.User
Handler.User.Balance
Handler.User.ChangePassphrase
Handler.User.Comment
Handler.User.ConfirmDelete
Handler.User.Delete
Handler.User.Discussion
Handler.User.Edit
Handler.User.EstEligible
Handler.User.NewDiscussion
Handler.User.Notifications
Handler.User.Pledges
Handler.User.ProjectNotifications
Handler.User.ResetPassphrase
Handler.User.SelectProject
Handler.User.Tickets
Handler.User.User
Handler.User.Users
Handler.User.Utils
......@@ -93,8 +87,6 @@ library
Handler.Volunteer
Handler.Who
Handler.Widget
Handler.Wiki
Handler.Wiki.Comment
Import
Import.NoFoundation
Local.Esqueleto
......@@ -104,16 +96,8 @@ library
Model
Model.Application
Model.Blog
Model.Comment
Model.Comment.ActionPermissions
Model.Comment.HandlerInfo
Model.Comment.Mods
Model.Comment.Routes
Model.Comment.Sql
Model.Count
Model.Currency
Model.Discussion
Model.Discussion.TH
Model.Issue
Model.Language
Model.Language.TH
......@@ -143,21 +127,17 @@ library
Model.Utils
Model.ViewType
Model.Volunteer
Model.Wiki
Model.Wiki.Sql
Settings
Settings.Development
Settings.StaticFiles
SnowdriftEventHandler
Version
View.Comment
View.Project
View.Project.Signup
View.ResetPassphrase
View.SnowdriftEvent
View.Time
View.User
View.Wiki
Widgets.Doc
Widgets.Markdown
Widgets.Navbar
......@@ -170,7 +150,6 @@ library
-- other-modules {{{2
other-modules:
Migrations
Model.Comment.Internal
Model.Established.Internal
Model.Role.Internal
Model.Settings.Internal
......
This diff is collapsed.
......@@ -32,11 +32,9 @@ User
-- ^ The last time the user visited /notifications
readApplications UTCTime default=now()
established Established default='EstUnestablished'
discussion DiscussionId default=nextval('discussion_id_seq'::regclass)
UniqueUser ident
UniqueUserAccount account
UniqueUserDiscussion discussion
deriving Show Typeable
......@@ -108,23 +106,6 @@ ViewTime
UniqueViewTimeUserProjectType user project type
-- A viewing of a single comment. The existence of this of a row here indicates
-- the comment has been viewed by the user; the absence indicates it hasnt.
ViewComment
user UserId
comment CommentId
UniqueViewComment user comment
-- A viewing of a single wiki page edit. The existence of this of a row here
-- indicates the edit has been viewed by the user; the absence indicates it
-- hasnt.
ViewWikiEdit
user UserId
edit WikiEditId
UniqueViewWikiEdit user edit
License
name LicenseName
type LicenseType
......@@ -144,13 +125,11 @@ Project
shareValue Milray
lastPayday PaydayId Maybe
githubRepo Text Maybe
discussion DiscussionId default=nextval('discussion_id_seq'::regclass)
public Bool default=true
logo Text Maybe
UniqueProjectAccount account
UniqueProjectHandle handle
UniqueProjectDiscussion discussion
deriving Eq Show
......@@ -175,21 +154,6 @@ ProjectSignup
deriving Show
BlogPost
ts UTCTime
title Text
handle Text
user UserId
project ProjectId
discussion DiscussionId
topContent Markdown
bottomContent Markdown Maybe
UniqueBlogPost project handle
UniqueBlogPostDiscussion discussion
deriving Show
ProjectUserRole
project ProjectId
user UserId
......@@ -302,137 +266,6 @@ ProjectNotificationEmail
UniqueProjectNotificationEmail createdTs type to project
-- A many-to-one relationship linking notifications sent to moderators about an
-- unapproved comment. When the comment is approved, all such notifications are
-- deleted automatically (as they are no longer relevant) - this table allows
-- us to keep track of which notifications to delete.
UnapprovedCommentNotification
comment CommentId
notification UserNotificationId
WikiPage
createdTs UTCTime default=now()
user UserId
project ProjectId
discussion DiscussionId
permissionLevel PermissionLevel
UniqueWikiPageDiscussion discussion
deriving Eq
WikiTarget
page WikiPageId
project ProjectId
target Text
language Language
UniqueWikiTarget project language target
WikiEdit
ts UTCTime
user UserId
page WikiPageId
language Language
content Markdown
comment Text Maybe
deriving Eq
WikiLastEdit
page WikiPageId
edit WikiEditId
language Language
UniqueWikiLastEdit page language
WikiTranslation
edit WikiEditId
source WikiEditId
complete Bool
Discussion
nothing Int64
Comment
createdTs UTCTime
-- "Unestablished" users may still make comments, but they must be approved
-- by a moderator. "Established" users' comments are marked as approved by
-- themselves (though this does not mean they are a moderator).
approvedTs UTCTime Maybe
approvedBy UserId Maybe
discussion DiscussionId
parent CommentId Maybe
user UserId
text Markdown
depth Int
visibility Visibility default='VisPublic'
language Language
deriving Eq Show
-- A comment has zero or more ancestors: its parent, grandparent, great
-- grandparent, etc.
CommentAncestor
comment CommentId
ancestor CommentId
UniqueCommentAncestor comment ancestor
deriving Show
-- A comment-closed relation.
CommentClosing
ts UTCTime
closedBy UserId
reason Markdown
comment CommentId
UniqueCommentClosing comment
-- A comment-retracted relation.
CommentRetracting
ts UTCTime
reason Markdown
comment CommentId
UniqueCommentRetracting comment
-- A flagging event, with one or more reason stored in CommentFlaggingReason.
CommentFlagging
ts UTCTime
flagger UserId
comment CommentId
message Markdown Maybe -- Optional message provided by the flagger.
-- Only one flagging can exist for a comment at any given time.
UniqueCommentFlagging comment
-- A reason associated with a comment flagging. One-to-many relation.
CommentFlaggingReason
flagging CommentFlaggingId
reason FlagReason
UniqueCommentFlaggingReason flagging reason
-- A rethread event. Moderators may move comment threads around as they wish.
Rethread
ts UTCTime -- Timestamp.
moderator UserId -- The moderator that rethreaded.
oldComment CommentId -- The old comment that was rethreaded.
newComment CommentId
reason Text -- The reason for rethreading.
-- An individual comment-rethread relation.
CommentRethread
rethread RethreadId
oldComment CommentId
newComment CommentId
Tag
name Text
UniqueTag name
......@@ -443,52 +276,11 @@ ProjectTag
UniqueProjectTag project tag
CommentTag
comment CommentId
tag TagId
user UserId
count Int default=1
UniqueCommentTag comment tag user
DeprecatedTag
project ProjectId
tag TagId
reason Text
-- A Comment can have at most one Ticket (i.e. the comment can be marked as a
-- ticket)
Ticket
createdTs UTCTime
updatedTs UTCTime
name Text
comment CommentId
UniqueTicket comment
deriving Eq Ord
TicketClaiming
ts UTCTime
user UserId
ticket CommentId
note Text Maybe
UniqueTicketClaiming ticket
deriving Show
TicketOldClaiming
claimTs UTCTime
user UserId
ticket CommentId
note Text Maybe
releaseNote Text Maybe
releasedTs UTCTime
deriving Show
Build
bootTime UTCTime
base Text
......@@ -524,17 +316,6 @@ RoleEvent
project ProjectId
added Bool
Doc
name Text
currentVersion WikiEditId
UniqueDocName name
DocEvent
ts UTCTime
doc DocId
blessedVersion WikiEditId
DatabaseVersion
lastMigration Int
......@@ -555,34 +336,6 @@ SharesPledged
-- Snowdrift events. These are all combined into a single sum time in
-- Model.SnowdriftEvent.
-- An approved comment.
EventCommentPosted
ts UTCTime
comment CommentId
-- An unapproved comment.
EventCommentPending
ts UTCTime
comment CommentId
EventCommentRethreaded
ts UTCTime
rethread RethreadId
-- An approved comment.
EventCommentClosing
ts UTCTime
commentClosing CommentClosingId
EventTicketClaimed
ts UTCTime
claim TicketClaimingId Maybe
oldClaim TicketOldClaimingId Maybe
EventTicketUnclaimed
ts UTCTime
claim TicketOldClaimingId
EventUserNotificationSent
ts UTCTime
notification UserNotificationId
......@@ -591,16 +344,6 @@ EventProjectNotificationSent
ts UTCTime
notification ProjectNotificationId
-- Wiki page created event.
EventWikiPage
ts UTCTime
wikiPage WikiPageId
-- Wiki edit made event.
EventWikiEdit
ts UTCTime
wikiEdit WikiEditId
EventNewPledge
ts UTCTime
sharesPledged SharesPledgedId
......@@ -616,10 +359,6 @@ EventDeletedPledge
project ProjectId
shares Int64
EventBlogPost
ts UTCTime
post BlogPostId
Image
ts UTCTime
uploader UserId
......@@ -638,10 +377,3 @@ UnnamedImage
origin Text Maybe
format ContentType
data ByteString
WatchedSubthread
ts UTCTime
user UserId
root CommentId
deriving Eq Ord
This diff is collapsed.
......@@ -40,7 +40,6 @@ import Widgets.Navbar
-- Handlers!
import Handler.BuildFeed
import Handler.Comment
import Handler.Common
import Handler.HonorPledge
import Handler.Image
......@@ -51,7 +50,6 @@ import Handler.NewDesign
import Handler.Notification
import Handler.PostLogin
import Handler.Project
import Handler.ProjectBlog
import Handler.ResetPassphrase
import Handler.Simple
import Handler.SnowdriftEvent
......@@ -59,8 +57,6 @@ import Handler.User
import Handler.Volunteer
import Handler.Who
import Handler.Widget
import Handler.Wiki
import Handler.Wiki.Comment
runSql :: MonadIO m => Text -> ReaderT SqlBackend m ()
runSql = flip rawExecute [] -- TODO quasiquoter?
......
......@@ -274,16 +274,20 @@ data NewEmail = NewEmail
, neAddr :: Text
}
createUser :: Text -> Maybe Text -> Maybe Text -> Maybe NewEmail -> Maybe Text
-> Maybe Text -> Handler (Maybe UserId)
createUser :: Text
-> Maybe Text
-> Maybe Text
-> Maybe NewEmail
-> Maybe Text
-> Maybe Text
-> Handler (Maybe UserId)
createUser ident passph name newEmail avatar nick = do
langs <- mapMaybe (readMaybe . T.unpack) <$> languages
now <- liftIO getCurrentTime
handle (\DBException -> return Nothing) $ runYDB $ do
account_id <- insert (Account 0)
discussion_id <- insert (Discussion 0)
-- we use "passphrase" usually, but setPassword is a Yesod import
user <- maybe return setPassword passph $ newUser langs now account_id discussion_id
user <- maybe return setPassword passph $ newUser langs now account_id
uid_maybe <- insertUnique user
case uid_maybe of
Just user_id -> do
......@@ -297,9 +301,7 @@ createUser ident passph name newEmail avatar nick = do
--
insertDefaultNotificationPrefs user_id
welcome_route <- getUrlRender
-- 'MonolingualWikiR' is deprecated.
<*> pure (MonolingualWikiR "snowdrift" "welcome" [])
let welcome_route = "#"
let notif_text = Markdown $ T.unlines
[ "Thanks for registering!"
, "<br> Please read our [**welcome message**](" <>
......@@ -313,7 +315,7 @@ createUser ident passph name newEmail avatar nick = do
lift $ addAlert "danger" "Handle already in use."
throwIO DBException
where
newUser langs now account_id discussion_id =
newUser langs now account_id =
User { userIdent = ident
, userEmail = (neAddr <$> newEmail)
, userEmail_verified = (maybe False neVerified newEmail)
......@@ -330,7 +332,6 @@ createUser ident passph name newEmail avatar nick = do
, userReadNotifications = now
, userReadApplications = now
, userEstablished = EstUnestablished
, userDiscussion = discussion_id
}
insertDefaultNotificationPrefs :: UserId -> DB ()
......
......@@ -3,7 +3,6 @@ module Handler.Discussion where
import Import
import Model.Comment.Sql
import Model.Discussion
-- | Given a callback that takes a "root comment getter", call the callback with the appropriate
-- "root comment getter", by looking for a "state=open" or "state=closed" GET param.
......
......@@ -17,7 +17,6 @@ import Handler.Notification
import Handler.TH
import Handler.User.Utils (startEmailVerification)
import Handler.Utils
import Model.License (fetchLicensesDB)
import Model.Project
( fetchPublicProjectsDB
, projectNameWidget
......@@ -31,7 +30,6 @@ import Model.User
, userDisplayName
, userReadNotificationsDB
)
import View.Project.Signup (projectSignupForm)
import View.Time (renderTime)
import View.User (renderUser, createUserForm)
......@@ -65,8 +63,6 @@ projectNav handle =
<h3>Subpages
<ul>
<li><a href=@{PUpdatesR handle}>Updates
<li><a href=@{WikiPagesR handle}>Wiki</a> (links to pre-alpha)
<li><a href=@{ProjectDiscussionR handle}>Discussion</a> (links to pre-alpha)
<li><a href=@{PTransactionsR handle}>Transactions
|]
......@@ -115,38 +111,6 @@ getUEditR = do
-- #### NEEDS REVIEW. COPIED FROM EXISTING PAGES.
--
-- | Where projects actually sign up.
--
-- As opposed to getPSignupR, where they learn about signing up. This page
-- will not be advertised during alpha.
getPSignupFormR :: Handler Html
getPSignupFormR = do
licenses <- runDB fetchLicensesDB
render <- getUrlRender
(project_signup_form, _) <- generateFormPost $
projectSignupForm render licenses
$(widget "project-signup-form" "Project Sign Up")
postPSignupFormR :: Handler Html
postPSignupFormR = do
licenses <- runDB fetchLicensesDB
render <- getUrlRender
((result, project_signup_form), _) <- runFormPost $
projectSignupForm render licenses
case result of
FormSuccess res -> do
runDB $ insert_ res
alertSuccess "Application submitted"
redirect HomeR
FormMissing -> do
alertDanger "No data provided"
$(widget "project-signup-form" "Project Sign Up")
FormFailure _ -> do
alertDanger "Form failure"
$(widget "project-signup-form" "Project Sign Up")
-- | Projects list.
getProjectsR :: Handler Html
getProjectsR = do
......
module Handler.Notification where
import Import hiding (delete)
import Data.List (sort)
import qualified Data.Foldable as F
import qualified Data.Text as T
import Model.Notification
import Model.User
-- 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)
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 ())
-> (UserNotificationId -> DB ()) -> (UserNotificationId -> DB ())
-> (ProjectNotificationId -> DB ()) -> (ProjectNotificationId -> DB ())
-> route -> Handler Html
proxyNotifications value1 value2 action_all1 action_all2
action_user_notif1 action_user_notif2
action_project_notif1 action_project_notif2 route = do
user_id <- requireAuthId
req <- getRequest
let params = reqGetParams req
names = fst `map` params
handleAction :: DB () -> DB () -> DB ()
handleAction action1 action2 =
if | value1 `elem` names -> action1
| value2 `elem` names -> action2
| otherwise -> return ()
forM_ params $ \(name, value) ->
if value == "all"
then
runDB $ handleAction (action_all1 user_id)
(action_all2 user_id)
else
case name of
"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
archiveUserNotificationDB deleteUserNotificationDB
archiveProjectNotificationDB deleteProjectNotificationDB
UNotificationsR
getArchivedNotificationsProxyR :: Handler Html
getArchivedNotificationsProxyR =
proxyNotifications "unarchive" "delete"
unarchiveNotificationsDB deleteArchivedNotificationsDB
unarchiveUserNotificationDB deleteUserNotificationDB
unarchiveProjectNotificationDB deleteProjectNotificationDB
(UNotificationsR, [("state", "archived")])
This diff is collapsed.
......@@ -6,8 +6,6 @@ import Network.HTTP.Types.Status (movedPermanently301)
import Dev
import Handler.TH
import Handler.Utils
import Widgets.Doc
getIntroR,
getFloR,
......@@ -46,18 +44,9 @@ getTermsR,
getPrivacyR,
getTrademarksR
:: Handler Html
getTermsR = defaultLayoutNew "terms-of-use" $ do
snowdriftTitle "Terms of Use"
alphaRewriteNotice
renderDoc "Terms of Use"
getPrivacyR = defaultLayoutNew "privacy" $ do
snowdriftTitle "Privacy Policy"
alphaRewriteNotice
renderDoc "Privacy Policy"
getTrademarksR = defaultLayoutNew "trademarks" $ do
snowdriftTitle "Trademarks"
alphaRewriteNotice
renderDoc "Trademarks"
getTermsR = undefined
getPrivacyR = undefined
getTrademarksR = undefined
-- | Permanent redirects for legacy urls that may still be referenced
-- outside of the type-safe project
......
module Handler.SnowdriftEvent where
import Import
import Control.Applicative
import Handler.Comment
import Model.Project
import WrappedValues
redirectCommentEvent :: (a -> YDB b) -> (b -> CommentId) -> a -> HandlerT App IO ()
redirectCommentEvent get_object get_comment_from_object =
get_object
>>> runYDB
>>> fmap get_comment_from_object
>=> getCommentDirectLinkR
getEventCommentPostedR :: EventCommentPostedId -> Handler ()
getEventCommentPostedR = redirectCommentEvent get404 eventCommentPostedComment
getEventCommentPendingR :: EventCommentPendingId -> Handler ()
getEventCommentPendingR = redirectCommentEvent get404 eventCommentPendingComment
getEventCommentRethreadedR :: EventCommentRethreadedId -> Handler ()
getEventCommentRethreadedR = redirectCommentEvent (get404 >=> eventCommentRethreadedRethread >>> get404) rethreadNewComment
getEventCommentClosingR :: EventCommentClosingId -> Handler ()
getEventCommentClosingR = redirectCommentEvent (get404 >=> eventCommentClosingCommentClosing >>> get404) commentClosingComment
getEventTicketClaimedR :: EventTicketClaimedId -> Handler ()
getEventTicketClaimedR = redirectCommentEvent
( get404
>=> (eventTicketClaimedClaim &&& eventTicketClaimedOldClaim)
>>> (fmap Left *** fmap Right)
>>> uncurry (<|>)
>>> maybe (lift notFound) (either (fmap Left . get404) (fmap Right . get404))