Unverified Commit 9878c3b7 authored by Bryan Richter's avatar Bryan Richter

[merge] Reboot the site, removing non-MVP features

What remains is not perfect in any way, but is significantly easier to
reason about.

Some MVP features were removed as well. These are things that may come back
in much the same shape, but maybe not. Those things are primarily Events
and Notifications.
parents cfba538f 979bd1b6
......@@ -40,51 +40,36 @@ library
else
ghc-options: -Werror -Wall
-- exposed-modules {{{2
exposed-modules:
Alerts
Application
Avatar
Css
Data.Filter
Data.Order
Data.Text.PrettyHtml
Data.Tree.Extra
Dev
DeprecatedBootstrap
Foundation
Handler.BuildFeed
Handler.Comment
Handler.Common
Handler.Discussion
Handler.HonorPledge
Handler.Image
Handler.Invitation
Handler.JsLicenses
Handler.MarkdownTutorial
Handler.NewDesign
Handler.Notification
Handler.PostLogin
Handler.Project
Handler.ProjectBlog
Handler.ResetPassphrase
Handler.Simple
Handler.SnowdriftEvent
Handler.TH
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,84 +78,46 @@ library
Handler.Volunteer
Handler.Who
Handler.Widget
Handler.Wiki
Handler.Wiki.Comment
Import
Import.NoFoundation
Local.Esqueleto
Local.Github
Local.Ord
Mechanism
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
Model.License
Model.License.Internal
Model.Markdown
Model.Markdown.Diff
Model.Notification
Model.Notification.Internal
Model.Permission.Internal
Model.Project
Model.Project.Signup
Model.Project.Signup.Internal
Model.Project.Sql
Model.ResetPassphrase
Model.Role
Model.Settings
Model.Shares
Model.SnowdriftEvent
Model.SnowdriftEvent.Internal
Model.TH
Model.Tag
Model.Transaction
Model.User
Model.User.Internal
Model.User.Sql
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
Widgets.Preview
Widgets.Search
Widgets.Tag
Widgets.UserPledges
WrappedValues
-- other-modules {{{2
other-modules:
Migrations
Model.Comment.Internal
Model.Established.Internal
Model.Role.Internal
Model.Settings.Internal
......@@ -208,25 +155,20 @@ library
build-depends:
-- base bounds reflect a core dependency
base >= 4 && < 5
, async
, attoparsec
, authenticate
, blaze-builder
, blaze-html
, blaze-markup
, bytestring
, conduit
, containers
, data-default
, Diff
, directory
, errors
, esqueleto
, fast-logger
, file-embed
, github
, ghci-runner
, hit
, hjsmin
, hourglass
, http-conduit
......@@ -245,11 +187,8 @@ library
, persistent-template
, process
, random
, regex-tdfa
, resourcet
, semigroups
, shakespeare
, stm
, template-haskell
, temporary
, text
......@@ -258,7 +197,6 @@ library
, transformers
, wai-extra
, wai-logger
, warp
, yaml
-- extra caution for our primary dependency on Yesod
, yesod >= 1.4 && < 1.5
......@@ -288,133 +226,6 @@ executable Snowdrift
ghc-options: -threaded
-- executable SnowdriftProcessPayments {{{1
executable SnowdriftProcessPayments
if flag(library-only)
Buildable: False
if flag(dev)
ghc-options: -Wall -O0 -fobject-code
if flag(merge)
ghc-options: -Wall -Werror -O0 -fobject-code
default-language: Haskell2010
main-is: SnowdriftProcessPayments.hs
hs-source-dirs: app
build-depends: base
, blaze-builder
, bytestring
, fast-logger
, lifted-base
, monad-logger
, mtl
, persistent
, resourcet
, Snowdrift
, text
, time
, yesod
ghc-options: -threaded
default-extensions: TemplateHaskell
QuasiQuotes
OverloadedStrings
NoImplicitPrelude
MultiParamTypeClasses
TypeFamilies
GADTs
GeneralizedNewtypeDeriving
FlexibleContexts
EmptyDataDecls
NoMonomorphismRestriction
DeriveDataTypeable
ScopedTypeVariables
-- executable SnowdriftEmailDaemon {{{1
executable SnowdriftEmailDaemon
if flag(dev)
ghc-options: -Wall -O0 -fobject-code
if flag(merge)
ghc-options: -Wall -Werror -O0 -fobject-code
if flag(library-only)
Buildable: False
-- Building on Windows is broken. See
-- https://github.com/commercialhaskell/stack/issues/466
if os(windows)
Buildable: False
default-language: Haskell2010
hs-source-dirs: app
main-is: SnowdriftEmailDaemon.hs
-- build-depends {{{2
build-depends: base
, authenticate
, blaze-builder
, blaze-html
, blaze-markup
, bytestring
, containers
, cmdargs
, data-default
, Diff
, directory
, esqueleto
, email-validate
, fast-logger
, hjsmin
, hourglass
, http-conduit
, lens
, lifted-base
, mime-mail
, monad-logger
, mtl
, path-pieces
, persistent
, persistent-postgresql
, persistent-template
, random
, resourcet
, semigroups
, shakespeare
, Snowdrift
, stm
, template-haskell
, text
, time
, titlecase
, transformers
, yaml
, yesod
, yesod-auth
, yesod-auth-hashdb
, yesod-core
, yesod-form
, yesod-markdown
, yesod-static
-- default-extensions {{{2
default-extensions: BangPatterns
ConstraintKinds
DeriveDataTypeable
EmptyDataDecls
ExistentialQuantification
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
LambdaCase
MultiParamTypeClasses
MultiWayIf
NoImplicitPrelude
QuasiQuotes
OverloadedStrings
RankNTypes
RecordWildCards
ScopedTypeVariables
TemplateHaskell
TupleSections
TypeFamilies
ViewPatterns
-- executable sendmail-mock {{{1
executable sendmail-mock
if flag(dev)
......@@ -440,16 +251,11 @@ test-suite test
ghc-options: -Wall -O0 -fobject-code
other-modules:
BlogTest
CommentTest
DiscussionTest
NotifyTest
PPrint
TestHandler
TestImport
TimedYesodTest
UserTest
WikiTest
default-extensions: QuasiQuotes
TemplateHaskell
OverloadedStrings
......
This diff is collapsed.
import Import hiding (runDB, runSDB)
import Control.Monad.Logger
import Control.Monad.Trans.Resource
import Control.Monad.Writer
import Yesod.Default.Config
import qualified Database.Persist.Sql
import Settings
import qualified Mechanism as Mech
runDB :: (PersistConfig c, MonadBaseControl IO m, MonadIO m)
=> c
-> PersistConfigPool c
-> PersistConfigBackend c (ResourceT (LoggingT m)) a
-> m a
runDB dbconf poolconf sql =
runStdoutLoggingT $
runResourceT $ Database.Persist.Sql.runPool dbconf sql poolconf
runSDB :: (PersistConfig c, MonadBaseControl IO m, MonadIO m)
=> c
-> PersistConfigPool c
-> WriterT t (PersistConfigBackend c (ResourceT (LoggingT m))) b
-> m b
runSDB dbconf poolconf = fmap fst . runDB dbconf poolconf . runWriterT
main :: IO ()
main = do
conf <- fromArgs parseExtra
dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
Database.Persist.Sql.loadConfig >>= Database.Persist.Sql.applyEnv
pool_conf <-
Database.Persist.Sql.createPoolConfig (dbconf :: Settings.PersistConf)
now <- liftIO getCurrentTime
runSDB dbconf pool_conf $ do
projects <- lift $ Mech.projectsToPay now
lift $ mapM_ (Mech.payout now) projects
Mech.rebalanceAllPledges
stanzas:
- type: webapp
hosts:
- snowdrift.coop
exec: ../dist/bin/Snowdrift
args:
- production
env:
APPROOT: https://snowdrift.coop
PGDATABASE: snowdrift_production
PGUSER: snowdrift_production
PGHOST: localhost
forward-env:
- PGPASS
- type: background
exec: ../dist/bin/SnowdriftEmailDaemon
env:
PGDATABASE: snowdrift_production
PGUSER: snowdrift_production
PGHOST: localhost
forward-env:
- PGPASS
args:
- '--db=production'
- '--email=notifications@snowdrift.coop'
- type: background
exec: ../ops/manage-symlink
# Redirect the https version of www.
- type: redirect
hosts:
- www.snowdrift.coop
actions:
- host: snowdrift.coop
secure: true
extraFiles:
- ../migrations
# FIXME: templates shouldn't be needed.
- ../templates
# Apps for cron to run
- ../ops/run-process-payments
- ../dist/bin/SnowdriftProcessPayments
# Assuming you have an awscli profile named 'snowdrift' that refers to the
# Snowdrift account, the server to copy to can be acquired with:
# $ aws --profile snowdrift ec2 describe-instances --instance-ids i-81a6df28 --query 'Reservations[].Instances[].PublicDnsName'
copy-to: ec2-54-152-177-195.compute-1.amazonaws.com:/opt/keter/incoming
stanzas:
- type: webapp
hosts:
- snowdrift.coop
- dev.snowdrift.coop
exec: ../dist/bin/Snowdrift
args:
- production
env:
APPROOT: https://snowdrift.coop
PGDATABASE: snowdrift_production
APPROOT: https://dev.snowdrift.coop
PGDATABASE: sd_reboot
PGUSER: snowdrift_production
PGHOST: localhost
forward-env:
- PGPASS
- type: background
exec: ../dist/bin/SnowdriftEmailDaemon
env:
PGDATABASE: snowdrift_production
PGUSER: snowdrift_production
PGHOST: localhost
forward-env:
- PGPASS
args:
- '--db=production'
- '--email=notifications@snowdrift.coop'
- type: background
exec: ../ops/manage-symlink
# Redirect the https version of www.
- type: redirect
hosts:
- www.snowdrift.coop
actions:
- host: snowdrift.coop
secure: true
extraFiles:
- ../migrations
# FIXME: templates shouldn't be needed.
- ../templates
# Apps for cron to run
- ../ops/run-process-payments
- ../dist/bin/SnowdriftProcessPayments
# Assuming you have an awscli profile named 'snowdrift' that refers to the
# Snowdrift account, the server to copy to can be acquired with:
......
This diff is collapsed.
This diff is collapsed.
......@@ -12,6 +12,7 @@ set -e
opt_build=${BUILD:=true}
opt_deploy=${DEPLOY:=true}
opt_appname=${APPNAME:=SnowdriftReboot}
#
#
......@@ -56,11 +57,11 @@ main () {
fi
rm -rf static/tmp/*
hdr "Tarballing"
tar czf Snowdrift.keter ${contents[@]}
tar czf ${opt_appname}.keter ${contents[@]}
if $opt_deploy
then
hdr "Deploying"
scp Snowdrift.keter `sd-main-dns`:/opt/keter/incoming
scp ${opt_appname}.keter `sd-main-dns`:/opt/keter/incoming
else
hdr "Not deploying, as requested"
fi
......
module Alerts
( alertDanger
, alertInfo
, alertSuccess
, alertWarning
, getAlert
) where
import Prelude
import Control.Monad (liftM)
import Yesod
import Data.Text (Text)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import qualified Data.Text.Lazy as TL
alertKey :: Text
alertKey = "_MSG_ALERT"
addAlert :: MonadHandler m => Text -> Text -> m ()
addAlert level msg = do
render <- getUrlRenderParams
prev <- lookupSession alertKey
setSession alertKey $ maybe id mappend prev $ TL.toStrict $ renderHtml $
[hamlet|
<div .alert .alert-#{level}>
#{msg}
|] render
alertDanger, alertInfo, alertSuccess, alertWarning :: MonadHandler m => Text -> m ()
alertDanger = addAlert "danger"
alertInfo = addAlert "info"
alertSuccess = addAlert "success"
alertWarning = addAlert "warning"
getAlert :: MonadHandler m => m (Maybe Html)
getAlert = do
mmsg <- liftM (fmap preEscapedToMarkup) $ lookupSession alertKey
deleteSession alertKey
return mmsg
......@@ -9,8 +9,6 @@ module Application
import Import
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM (atomically, newTChanIO, tryReadTChan)
import Control.Monad.Logger (runLoggingT, runStderrLoggingT)
import Control.Monad.Reader
import Control.Monad.Trans.Resource
......@@ -33,34 +31,25 @@ import qualified Data.List as L
import qualified Database.Persist
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import SnowdriftEventHandler
import Version
import Migrations
import Widgets.Navbar
-- Handlers!
import Handler.BuildFeed
import Handler.Comment
import Handler.Common
import Handler.HonorPledge
import Handler.Image
import Handler.Invitation
import Handler.JsLicenses
import Handler.MarkdownTutorial
import Handler.NewDesign
import Handler.Notification
import Handler.PostLogin
import Handler.Project
import Handler.ProjectBlog
import Handler.ResetPassphrase
import Handler.Simple
import Handler.SnowdriftEvent
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?
......@@ -120,7 +109,6 @@ makeFoundation conf = do
loggerSet' <- newStdoutLoggerSet defaultBufSize
(getter, _) <- clockDateCacher
event_chan <- newTChanIO
let logger = Yesod.Core.Types.Logger loggerSet' getter
foundation = App
{ appNavbar = navbar
......@@ -130,8 +118,6 @@ makeFoundation conf = do
, appHttpManager = manager
, persistConfig = dbconf
, appLogger = logger
, appEventChan = event_chan
, appEventHandlers = snowdriftEventHandlers
}
-- Database setup
......@@ -171,8 +157,6 @@ makeFoundation conf = do
migration
(messageLoggerSource foundation logger)
forkEventHandler foundation
return foundation
-- for yesod devel
......@@ -183,19 +167,3 @@ getApplicationDev =
loader = Yesod.Default.Config.loadConfig (configSettings Development)
{ csParseExtra = parseExtra
}
--------------------------------------------------------------------------------
-- SnowdriftEvent handling
forkEventHandler :: App -> IO ()
forkEventHandler app@App{..} = void . forkIO . forever $ do
threadDelay 1000000 -- Sleep for one second in between runs.
handleNEvents 10 -- Handle up to 10 events per run.
where
handleNEvents :: Int -> IO ()
handleNEvents 0 = return ()
handleNEvents n = atomically (tryReadTChan appEventChan) >>= \case
Nothing -> return ()
Just event -> do
mapM_ (runDaemon app) (appEventHandlers appSettings <*> [event])
handleNEvents (n-1)
{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
module Data.Text.PrettyHtml (unlinesHtml, prettyHtml, prettyThings) where
import Import.NoFoundation
import Control.Applicative
import Data.Attoparsec.Text
import Data.List as L
import Data.String
import Data.Text as T
import qualified Text.Blaze.Html5.Attributes as Attr
import qualified Text.Blaze.Html5 as Html
unlinesHtml :: [Html] -> Html
unlinesHtml = sequence_ . L.intersperse Html.br
-- | Single step of a 'Data.List.foldr' to concatenate 'Right's in an 'Either'
-- and remove empty 'Right's.
concatRights :: Either a T.Text -> [Either a T.Text] -> [Either a T.Text]
concatRights (Right y) xs | T.null y = xs
concatRights (Right y) (Right x : xs) = Right (y `T.append` x) : xs
concatRights y xs = y : xs
prettyHtml :: (Monad m, HasGithubRepo (HandlerT site m)) => [Parser Pretty] -> Text -> HandlerT site m Html
prettyHtml filters text =
case parseOnly (many $ (Left <$> choice filters) <|> (Right . T.singleton <$> anyChar)) text of
Right result -> do
let pieces = L.foldr concatRights [] result
fmap sequence_ $ forM pieces $ either renderPretty (return . toHtml)
Left err -> error err
renderPretty :: (Monad m, HasGithubRepo (HandlerT site m)) => Pretty -> HandlerT site m Html
renderPretty pretty = case pretty of
RawHtml html -> return html
GithubTicket int -> do
maybe_github_repo_link <- getGithubRepo
let github_issue = toHtml $ "Github issue " ++ show int
return $ case maybe_github_repo_link of
Just github_repo_link -> Html.a github_issue Html.! Attr.href
(fromString $ "https://github.com/" ++ T.unpack github_repo_link ++ "/issues/" ++ show int)
Nothing -> github_issue
data Pretty = GithubTicket Int | RawHtml Html
githubTicketRef :: Parser Pretty
githubTicketRef = GithubTicket <$> (asciiCI "GH-" *> decimal)
prettyThings :: [Parser Pretty]
prettyThings = [githubTicketRef]
module Data.Tree.Extra where
import Prelude (Ordering, (.), map)
import Data.List (sortBy)
import Data.Tree (Forest, Tree(..))
sortTreeBy :: (Tree a -> Tree a -> Ordering) -> Tree a -> Tree a
sortTreeBy f (Node x xs) = Node x (sortForestBy f xs)
sortForestBy :: (Tree a -> Tree a -> Ordering) -> Forest a -> Forest a
sortForestBy f = sortBy f . map (sortTreeBy f)