Merge branch 'release-0.1.0.1' into production

.gitignore

@@ -13,7 +13,9 @@ yesod-devel/
 *.chs.h
 codex.tags
 hscope.out
-/migrations
+*.tix
+.hpc/
+TAGS
 
 # Intellij IDEA:
 .idea

Application.hs

@@ -37,7 +37,7 @@ import           System.Posix.Env.ByteString
 import           Yesod.Core.Types                     (loggerSet, Logger (Logger))
 import           Yesod.Default.Config
 import           Yesod.Default.Handlers
-import           Yesod.Default.Main
+import           Yesod.Default.Main hiding (LogFunc)
 
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
@@ -54,6 +54,7 @@ import Handler.Notification
 import Handler.PostLogin
 import Handler.Privacy
 import Handler.Project
+import Handler.Project.Signup
 import Handler.ProjectBlog
 import Handler.RepoFeed
 import Handler.ResetPassword
@@ -69,7 +70,7 @@ import Handler.Wiki.Comment
 
 import Widgets.Navbar
 
-runSql :: MonadSqlPersist m => Text -> m ()
+runSql :: MonadIO m => Text -> ReaderT SqlBackend m ()
 runSql = flip rawExecute [] -- TODO quasiquoter?
 
 version :: (Text, Text)
@@ -154,12 +155,10 @@ makeFoundation conf = do
     -- Perform database migration using our application's logging settings.
     case appEnv conf of
         Testing -> withEnv "PGDATABASE" "template1" (applyEnv $ persistConfig foundation) >>= \ dbconf' -> do
-                let runDBNoTransaction (SqlPersistT r) = runReaderT r
-
                 options <- maybe [] L.words <$> lookupEnv "SNOWDRIFT_TESTING_OPTIONS"
 
                 unless (elem "nodrop" options) $ do
-                    runStderrLoggingT $ runResourceT $ withPostgresqlConn (pgConnStr dbconf') $ runDBNoTransaction $ do
+                    runStderrLoggingT $ runResourceT $ withPostgresqlConn (pgConnStr dbconf') $ runReaderT $ do
                         liftIO $ putStrLn "dropping database..."
                         runSql "DROP DATABASE IF EXISTS snowdrift_test;"
                         liftIO $ putStrLn "creating database..."
@@ -172,7 +171,7 @@ makeFoundation conf = do
         runSqlPool migrateTriggers p
 
 
-    runLoggingT
+    void $ runLoggingT
         migration
         (messageLoggerSource foundation logger)
 
@@ -255,8 +254,8 @@ doMigration = do
     maybe (return ()) (\ newer_last_migration -> update $ flip set [ DatabaseVersionLastMigration =. val newer_last_migration ]) maybe_newer_last_migration
 
 
-migrateTriggers :: (MonadSqlPersist m, MonadBaseControl IO m, MonadThrow m) => m ()
-migrateTriggers = runResourceT $ do
+migrateTriggers :: MonadIO m => ReaderT SqlBackend m ()
+migrateTriggers = do
     runSql $ T.unlines
         [ "CREATE OR REPLACE FUNCTION log_role_event_trigger() RETURNS trigger AS $role_event$"
         , "    BEGIN"

Data/Filter.hs

@@ -12,7 +12,8 @@ import qualified Data.Set as S
 -- TODO: allow for building custom SQL queries based on filters
 
 data Filterable = Filterable
-    { hasTag :: Text -> Bool
+    { isClaimed :: Text -> Bool
+    , hasTag :: Text -> Bool
     , getNamedTs :: Text -> Set UTCTime
     , searchLiteral :: Text -> Bool
     }
@@ -44,10 +45,18 @@ notTermP = stripP $ (not.) <$> (notP *> termP) <|> termP
 
 termP :: Parser (Filterable -> Bool)
 termP = stripP $
-    tagP
+    claimedP
+    <|> unclaimedP
+    <|> tagP
     <|> timeConstraintP
     <|> "(" *> expressionP <* ")"
 
+claimedP :: Parser (Filterable -> Bool)
+claimedP = flip isClaimed <$> stripP "CLAIMED"
+
+unclaimedP :: Parser (Filterable -> Bool)
+unclaimedP = (\x y -> not $ isClaimed y x) <$> stripP "UNCLAIMED"
+
 timeConstraintP :: Parser (Filterable -> Bool)
 timeConstraintP =
     foldl1 (<|>) $ [before, after, between] <*> ["CREATED", "LAST UPDATED"]

Data/Order.hs

@@ -12,7 +12,8 @@ import qualified Data.Set as S
 -- import Data.Time
 
 data Orderable = Orderable
-    { hasTag :: Text -> Bool
+    { isClaimed :: Text -> Bool
+    , hasTag :: Text -> Bool
     , getNamedTs :: Text -> Set UTCTime
     , searchLiteral :: Text -> Bool
     }
@@ -57,11 +58,21 @@ expTermP = stripP $ foldl (c (**)) <$> termP <*> many (stripP "^" *> termP)
 
 termP :: Parser (Orderable -> Double)
 termP = stripP $
-    tagP
+    claimedP
+    <|> unclaimedP
+    <|> tagP
     <|> const <$> double
     <|> timeValueP
     <|> "(" *> expressionP <* ")"
 
+(<?$>) :: (Orderable -> a -> Bool) -> Parser a -> Parser (Orderable -> Double)
+f <?$> p = (\x y -> if f y x then 1 else 0) <$> p
+
+claimedP :: Parser (Orderable -> Double)
+claimedP = isClaimed <?$> stripP "CLAIMED"
+
+unclaimedP :: Parser (Orderable -> Double)
+unclaimedP = (\y x -> not $ isClaimed y x) <?$> stripP "UNCLAIMED"
 
 toTimeValue :: UTCTime -> Double
 toTimeValue = (/ 86400 {- seconds per day -}) . fromIntegral . (id :: Integer -> Integer) . round . diffUTCTime epoch
@@ -101,7 +112,5 @@ timeConstraintP =
 timeP :: Parser UTCTime
 timeP = fmap (`UTCTime` 0) $ stripP $ fromGregorian <$> (read <$> A.count 4 digit) <* "-" <*> (read <$> A.count 2 digit) <* "-" <*> (read <$> A.count 2 digit)
 
-
 tagP :: Parser (Orderable -> Double)
-tagP = (\ x y -> if hasTag y x then 1 else 0) <$> takeWhile1 (inClass "a-z-")
-
+tagP = hasTag <?$> takeWhile1 (inClass "a-z-")

Data/Text/PrettyHtml.hs

@@ -9,25 +9,27 @@ import Data.Attoparsec.Text
 import qualified Text.Blaze.Html5.Attributes as Attr
 import qualified Text.Blaze.Html5 as Html
 
-import Data.Either
-
 import Data.List as L
 import Data.String
 import Data.Text as T
 
 import Control.Applicative
 
-
 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 regroup = L.concatMap $ \(a, b) -> L.map Left a ++ [Right b | T.length b > 0]
-                splitUp = fmap (fmap T.concat . partitionEithers) . L.groupBy ((==) `on` isRight)
-                pieces = regroup . splitUp $ result
+            let pieces = L.foldr concatRights [] result
 
             fmap sequence_ $ forM pieces $ either renderPretty (return . toHtml)
 

Foundation.hs

@@ -23,7 +23,7 @@ import           Control.Monad.Writer.Strict        (WriterT, runWriterT)
 import qualified Data.ByteString.Lazy.Char8         as LB
 import           Data.Char                          (isSpace)
 import           Data.Int                           (Int64)
-import           Data.Maybe                         (mapMaybe)
+import           Data.Maybe                         (mapMaybe, fromMaybe)
 import           Data.Monoid
 import           Data.Time
 import           Data.Text                          as T
@@ -99,8 +99,8 @@ mkYesodData "App" $(parseRoutesFile "config/routes")
 
 type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
 
-licenseText :: LB.ByteString
-licenseText = E.encodeUtf8 $ renderJavascriptUrl (\ _ _ -> T.empty) [julius|
+licenseNotice :: LB.ByteString
+licenseNotice = E.encodeUtf8 $ renderJavascriptUrl (\ _ _ -> T.empty) [julius|
     /*
      @licstart  The following is the entire license notice for the JavaScript code in this page.
 
@@ -206,8 +206,8 @@ instance Yesod App where
         if LB.all isSpace content
          then return Nothing
          else
-            let license = either Left (Right . LB.append licenseText)
-             in addStaticContentExternal (license . minifym) base64md5 Settings.staticDir (StaticR . flip StaticRoute []) extension mime (LB.append licenseText content)
+            let license = either Left (Right . LB.append licenseNotice)
+             in addStaticContentExternal (license . minifym) base64md5 Settings.staticDir (StaticR . flip StaticRoute []) extension mime (LB.append licenseNotice content)
 
     -- Place Javascript at bottom of the body tag so the rest of the page loads first
     jsLoader _ = BottomOfBody
@@ -222,7 +222,7 @@ instance Yesod App where
 
 -- How to run database actions.
 instance YesodPersist App where
-    type YesodPersistBackend App = SqlPersistT
+    type YesodPersistBackend App = SqlBackend
     runDB = defaultRunDB persistConfig connPool
 
 instance YesodPersistRunner App where
@@ -230,7 +230,7 @@ instance YesodPersistRunner App where
 
 -- set which project in the site runs the site itself
 getSiteProject :: Handler (Entity Project)
-getSiteProject = maybe (error "No project has been defined as the owner of this website.") id <$>
+getSiteProject = fromMaybe (error "No project has been defined as the owner of this website.") <$>
     (getSiteProjectHandle >>= runYDB . getBy . UniqueProjectHandle)
 
 getSiteProjectHandle :: Handler Text
@@ -348,6 +348,7 @@ instance YesodAuth App where
 
         lift $ defaultLayout $(widgetFile "auth")
 
+instance YesodAuthPersist App
 
 createUser :: Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text
            -> Maybe Text -> Handler (Maybe UserId)
@@ -374,7 +375,7 @@ createUser ident passwd name email avatar nick = do
                 insertDefaultNotificationPrefs user_id
                 welcome_route <- getUrlRender
                             -- 'MonolingualWikiR' is deprecated.
-                            <*> (pure $ MonolingualWikiR "snowdrift" "welcome" [])
+                            <*> pure (MonolingualWikiR "snowdrift" "welcome" [])
                 let notif_text = Markdown $ T.unlines
                         [ "Thanks for registering!"
                         , "<br> Please read our [**welcome message**](" <>

Handler/Comment.hs

@@ -356,7 +356,7 @@ postCloseComment user@(Entity user_id _) comment_id comment make_comment_handler
             lookupPostMode >>= \case
                 Just PostMode -> do
                     runSDB $ do
-                        closing_id <- insert closing
+                        closing_id <- lift $ insert closing
                         tell [ECommentClosed closing_id closing]
 
                     return Nothing
@@ -396,13 +396,20 @@ postEditComment
         -> Entity Comment
         -> (CommentMods -> CommentHandlerInfo)
         -> Handler (Maybe (Widget, Widget))
-postEditComment user (Entity comment_id comment) make_comment_handler_info = do
+postEditComment user@(Entity user_id _) (Entity comment_id comment) make_comment_handler_info = do
     ((result, _), _) <- runFormPost (editCommentForm "" (commentLanguage comment))
     case result of
         FormSuccess (EditComment new_text new_language) -> lookupPostMode >>= \case
             Just PostMode -> do
-                runSYDB (editCommentDB comment_id new_text new_language)
-                alertSuccess "posted new edit"
+                let c = countMatches T.isPrefixOf "ticket:" $
+                            T.lines $ unMarkdown new_text
+                if c > 1
+                    then alertDanger $
+                        "each comment must contain at most one ticket; " <>
+                        "found " <> T.pack (show c)
+                    else do
+                        runSYDB (editCommentDB user_id comment_id new_text new_language)
+                        alertSuccess "posted new edit"
                 return Nothing
             _ -> do
                 (form, _) <- generateFormPost (editCommentForm new_text new_language)
@@ -499,7 +506,7 @@ postNewComment mparent_id (Entity user_id user) discussion_id make_permissions_m
                                                        then (Just now, Just user_id)
                                                        else (Nothing, Nothing)
                     comment = Entity
-                                (Key $ PersistInt64 0)
+                                (key $ PersistInt64 0)
                                 (Comment now approved_ts approved_by discussion_id mparent_id user_id contents depth visibility language)
 
                 max_depth <- getMaxDepthDefault 0
@@ -630,13 +637,13 @@ postRetractComment user comment_id comment make_comment_handler_info = do
         _ -> error "Error when submitting form."
 
 postUnclaimComment :: Entity User -> CommentId -> Comment -> (CommentMods -> CommentHandlerInfo) -> Handler (Maybe (Widget, Widget))
-postUnclaimComment user@(Entity user_id _) comment_id comment make_comment_handler_info = do
+postUnclaimComment user comment_id comment make_comment_handler_info = do
     ((result, _), _) <- runFormPost (claimCommentForm Nothing)
     case result of
         FormSuccess mnote -> do
             lookupPostMode >>= \case
                 Just PostMode -> do
-                    runSDB (userUnclaimCommentDB user_id comment_id mnote)
+                    runSDB (userUnclaimCommentDB comment_id mnote)
                     return Nothing
                 _ -> do
                     (form, _) <- generateFormPost (claimCommentForm (Just mnote))

Handler/HonorPledge.hs

@@ -19,4 +19,5 @@ postHonorPledgeR = do
             runDB $ establishUserDB user_id elig_time reason
             setMessage "Congratulations, you are now a fully established user!"
             redirect HomeR
+        --TODO: add "already established" error for that case
         _ -> error "You're not eligible for establishment."

Handler/Notification.hs

@@ -22,7 +22,7 @@ getNotificationsR = do
 whenNotifId :: DBConstraint m => Text -> (NotificationId -> m ()) -> m ()
 whenNotifId value action =
     F.forM_ (readMaybe $ T.unpack value :: Maybe Int) $ \notif_id ->
-        action $ Key $ toPersistValue notif_id
+        action $ key $ toPersistValue notif_id
 
 proxyNotifications :: RedirectUrl App route => Text -> Text
                    -> (UserId -> DB ()) -> (UserId -> DB ())

Handler/Project.hs

@@ -28,7 +28,6 @@ import Model.User
 import Model.Wiki
 import System.Locale (defaultTimeLocale)
 import View.Comment
-import View.PledgeButton
 import View.Project
 import View.SnowdriftEvent
 import Widgets.Preview
@@ -236,7 +235,7 @@ postProjectR project_handle = do
                             project_update <- insert $ ProjectUpdate now project_id viewer_id $ diffMarkdown (projectDescription project) description
                             last_update <- getBy $ UniqueProjectLastUpdate project_id
                             case last_update of
-                                Just (Entity key _) -> repsert key $ ProjectLastUpdate project_id project_update
+                                Just (Entity k _) -> repsert k $ ProjectLastUpdate project_id project_update
                                 Nothing -> void $ insert $ ProjectLastUpdate project_id project_update
 
                         update $ \ p -> do
@@ -273,7 +272,7 @@ postProjectR project_handle = do
             redirect $ ProjectR project_handle
 
 --------------------------------------------------------------------------------
--- /application
+-- /applications (List of submitted applications)
 
 getApplicationsR :: Text -> Handler Html
 getApplicationsR project_handle = do
@@ -293,6 +292,9 @@ getApplicationsR project_handle = do
         setTitle . toHtml $ projectName project <> " Volunteer Applications | Snowdrift.coop"
         $(widgetFile "applications")
 
+--------------------------------------------------------------------------------
+-- /application (Form for new application)
+
 getApplicationR :: Text -> VolunteerApplicationId -> Handler Html
 getApplicationR project_handle application_id = do
     viewer_id <- requireAuthId
@@ -312,20 +314,6 @@ getApplicationR project_handle application_id = do
         setTitle . toHtml $ projectName project <> " Volunteer Application - " <> userDisplayName user <> " | Snowdrift.coop"
         $(widgetFile "application")
 
---------------------------------------------------------------------------------
--- /button.png
-
-getProjectPledgeButtonR :: Text -> Handler TypedContent
-getProjectPledgeButtonR project_handle = do
-   pledges <- runYDB $ do
-        Entity project_id _project <- getBy404 $ UniqueProjectHandle project_handle
-        getProjectShares project_id
-
-   let png = overlayImage blankPledgeButton $
-        fillInPledgeCount (fromIntegral (length pledges))
-
-   respond "image/png" png
-
 --------------------------------------------------------------------------------
 -- /edit
 
@@ -507,6 +495,8 @@ getProjectFeedR project_handle = do
         provideRep $ atomFeed feed
         provideRep $ rssFeed feed
         provideRep $ defaultLayout $ do
+            setTitle . toHtml $
+                projectName project <> " - Feed | Snowdrift.coop"
             $(widgetFile "project_feed")
             toWidget $(cassiusFile "templates/comment.cassius")
 
@@ -641,10 +631,11 @@ getUpdateSharesR project_handle = do
     Entity project_id project <- runYDB $ getBy404 $ UniqueProjectHandle project_handle
 
     ((result, _), _) <- runFormGet $ pledgeForm project_id
-
+    let dangerRedirect msg = do
+            alertDanger msg
+            redirect $ ProjectR project_handle
     case result of
         FormSuccess (SharesPurchaseOrder new_user_shares) -> do
-            -- TODO - refuse negative
             user_id <- requireAuthId
 
             (confirm_form, _) <- generateFormPost $ projectConfirmSharesForm (Just new_user_shares)
@@ -689,9 +680,9 @@ getUpdateSharesR project_handle = do
                         setTitle . toHtml $ projectName project <> " - update pledge | Snowdrift.coop"
                         $(widgetFile "update_shares")
 
-        FormMissing -> defaultLayout [whamlet| form missing |]
-        FormFailure _ -> defaultLayout [whamlet| form failure |]
-
+        FormMissing -> dangerRedirect "Form missing."
+        FormFailure errors ->
+            dangerRedirect $ T.snoc (T.intercalate "; " errors) '.'
 
 postUpdateSharesR :: Text -> Handler Html
 postUpdateSharesR project_handle = do
@@ -700,8 +691,6 @@ postUpdateSharesR project_handle = do
 
     case result of
         FormSuccess (SharesPurchaseOrder shares) -> do
-            -- TODO - refuse negative
-
             if isConfirmed
                 then do
                     Just pledge_render_id <- fmap (read . T.unpack) <$> lookupSession pledgeRenderKey
@@ -1264,4 +1253,3 @@ postNewProjectDiscussionR project_handle = do
       (makeProjectCommentActionPermissionsMap (Just user) project_handle def) >>= \case
         Left comment_id -> redirect (ProjectCommentR project_handle comment_id)
         Right (widget, form) -> defaultLayout $ previewWidget form "post" (projectDiscussionPage project_handle widget)
-

Handler/Project/Signup.hs

+module Handler.Project.Signup where
+
+import Import
+
+import Model.License       (fetchLicensesDB)
+import View.Project.Signup (projectSignupForm)
+
+getProjectSignupR :: Handler Html
+getProjectSignupR = do
+    licenses <- runDB fetchLicensesDB
+    render   <- getUrlRender
+    (project_signup_form, _) <- generateFormPost $
+        projectSignupForm render licenses
+    defaultLayout $ do
+        setTitle "Project Sign Up | Snowdrift.coop"
+        $(widgetFile "project_signup")
+
+postProjectSignupR :: Handler Html
+postProjectSignupR = 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"
+            defaultLayout $(widgetFile "project_signup")
+        FormFailure _ -> do
+            alertDanger "Form failure"
+            defaultLayout $(widgetFile "project_signup")

Handler/ProjectBlog.hs

@@ -49,8 +49,8 @@ checkComment' muser_id project_handle post_name comment_id = do
     redirectIfRethreaded comment_id
 
     (project, blog_post, ecomment) <- runYDB $ do
-        project@(Entity project_id _)   <- getBy404 $ UniqueProjectHandle project_handle
-        Entity _ blog_post              <- getBy404 $ UniqueBlogPost project_id post_name
+        (project@(Entity project_id _), Entity _ blog_post) <-
+            fetchProjectBlogPostDB project_handle post_name
 
         let has_permission = exprCommentProjectPermissionFilter muser_id (val project_id)
 
@@ -174,7 +174,7 @@ requireRolesAny roles project_handle err_msg = do
 
 getProjectBlogR :: Text -> Handler Html
 getProjectBlogR project_handle = do
-    maybe_from <- fmap (Key . PersistInt64 . read . T.unpack) <$> lookupGetParam "from"
+    maybe_from <- fmap (key . PersistInt64 . read . T.unpack) <$> lookupGetParam "from"
     post_count <- fromMaybe 10 <$> fmap (read . T.unpack) <$> lookupGetParam "from"
     Entity project_id project <- runYDB $ getBy404 $ UniqueProjectHandle project_handle
 
@@ -219,29 +219,18 @@ postNewBlogPostR project_handle = do
     (viewer_id, Entity project_id _) <-
         requireRolesAny [Admin, TeamMember] project_handle "You do not have permission to post to this project's blog."
 
-    now <- liftIO getCurrentTime
-
     ((result, _), _) <- runFormPost $ projectBlogForm Nothing
 
     case result of
-        FormSuccess (title, handle, Markdown content) -> do
+        FormSuccess project_blog@ProjectBlog {..} -> do
             lookupPostMode >>= \case
                 Just PostMode -> do
-                    void $ runSDB $ postBlogPostDB title handle viewer_id project_id (Markdown content)
+                    void $ runSDB $ postBlogPostDB
+                        projectBlogTitle projectBlogHandle
+                        viewer_id project_id projectBlogContent
                     alertSuccess "posted"
                     redirect $ ProjectBlogR project_handle
-
-                _ -> do
-
-                    let (top_content', bottom_content') = break (== "***") $ T.lines content
-                        top_content = T.unlines top_content'
-                        bottom_content = if bottom_content' == [] then Nothing else Just (Markdown $ T.unlines bottom_content')
-                        blog_post = BlogPost now title handle viewer_id project_id (Key $ PersistInt64 0) (Markdown top_content) bottom_content
-
-                    (form, _) <- generateFormPost $ projectBlogForm $ Just (title, handle, Markdown content)
-
-                    defaultLayout $ previewWidget form "post" $ renderBlogPost project_handle blog_post
-
+                _ -> previewBlogPost viewer_id project_handle project_blog
         x -> do
             alertDanger $ T.pack $ show x
             redirect $ NewBlogPostR project_handle
@@ -252,16 +241,54 @@ postNewBlogPostR project_handle = do
 
 getBlogPostR :: Text -> Text -> Handler Html
 getBlogPostR project_handle blog_post_handle = do
-    (project, blog_post) <- runYDB $ do
-        Entity project_id project <- getBy404 $ UniqueProjectHandle project_handle
-        Entity _ blog_post <- getBy404 $ UniqueBlogPost project_id blog_post_handle
-
-        return (project, blog_post)
-
+    (Entity _ project, Entity _ blog_post) <-
+        runYDB $ fetchProjectBlogPostDB project_handle blog_post_handle
     defaultLayout $ do
         setTitle . toHtml $ projectName project <> " Blog - " <> blogPostTitle blog_post <> " | Snowdrift.coop"
 
-        renderBlogPost project_handle blog_post
+        renderBlogPost project_handle blog_post NotPreview
+
+
+--------------------------------------------------------------------------------
+-- /p/#Text/blog/#Text/edit
+
+checkEditBlogPostPermissions :: Text -> Handler UserId
+checkEditBlogPostPermissions project_handle = do
+    fst <$> requireRolesAny [Admin, TeamMember] project_handle
+        "only the admin or a team member can edit a blog post"
+
+getEditBlogPostR :: Text -> Text -> Handler Html
+getEditBlogPostR project_handle blog_post_handle = do
+    (Entity _ project, Entity _ BlogPost {..}) <-
+        runYDB $ fetchProjectBlogPostDB project_handle blog_post_handle
+    void $ checkEditBlogPostPermissions project_handle
+    (blog_form, enctype) <- generateFormPost $ projectBlogForm $
+        Just $ ProjectBlog blogPostTitle blog_post_handle $
+            concatContent blogPostTopContent blogPostBottomContent
+    defaultLayout $ do
+        setTitle $ toHtml $ projectName project <> " Blog - Edit | Snowdrift.coop"
+        $(widgetFile "edit_blog_post")
+
+postEditBlogPostR :: Text -> Text -> Handler Html
+postEditBlogPostR project_handle blog_post_handle = do
+    (_, Entity blog_post_id BlogPost {..}) <-
+        runYDB $ fetchProjectBlogPostDB project_handle blog_post_handle
+    viewer_id <- checkEditBlogPostPermissions project_handle
+    ((result, _), _) <- runFormPost $ projectBlogForm Nothing
+    case result of
+      FormSuccess project_blog@ProjectBlog {..} -> do
+          lookupPostMode >>= \case
+              Just PostMode -> do
+                  runDB $ updateBlogPostDB viewer_id blog_post_id project_blog
+                  alertSuccess "Blog post updated"
+                  redirect $ BlogPostR project_handle projectBlogHandle
+              _ -> previewBlogPost viewer_id project_handle project_blog
+      FormMissing -> do
+          alertDanger "No data provided"
+          redirect $ BlogPostR project_handle blog_post_handle
+      FormFailure errs -> do
+          alertDanger $ "Form failure: " <> (T.intercalate ", " errs)
+          redirect $ BlogPostR project_handle blog_post_handle
 
 --------------------------------------------------------------------------------
 -- /p/#Text/blog/#Text/c/#CommentId

Handler/RepoFeed.hs

@@ -18,7 +18,9 @@ import Data.Text.PrettyHtml
 
 import Prelude (head)
 
-import Data.Time (addUTCTime) 
+import Data.Time (addUTCTime, secondsToDiffTime, UTCTime(..), fromGregorian)
+import Data.Hourglass ( timeGetDate, dateYear, dateMonth, dateDay
+                      , timeGetTimeOfDay, todHour, todMin, todSec, toSeconds )
 import Data.List (sortBy)
 
 import Data.Tree (unfoldTreeM_BF, levels)
@@ -43,7 +45,6 @@ getRepoFeedR = do
         author = "Snowdrift.coop Team"
         description = "Commits to the Snowdrift.coop repository."
         lang = "en"
-        -- commitTime = toUTCTime . personTime . commitAuthor
         time = commitTime $ head commits
 
     entries <- forM commits $ \ commit -> do
@@ -53,9 +54,24 @@ getRepoFeedR = do
 
     newsFeed $ Feed title feed_url home_url author description lang time entries
 
+-- Remove as soon as it's available in hit:
+-- https://github.com/vincenthz/hit/pull/20
+gitTimeToUTC :: GitTime -> UTCTime
+gitTimeToUTC gt = UTCTime utcDay diffTime
+    where
+      date     = timeGetDate gt
+      year     = toInteger $ dateYear date
+      month    = succ $ fromEnum $ dateMonth date
+      day      = dateDay date
+      utcDay   = fromGregorian year month day
+      tod      = timeGetTimeOfDay gt
+      hours    = toInteger $ toSeconds $ todHour tod
+      minutes  = toInteger $ toSeconds $ todMin tod
+      seconds  = toInteger $ todSec tod
+      diffTime = secondsToDiffTime $ hours + minutes + seconds
 
 commitTime :: Commit -> UTCTime
-commitTime = toUTCTime . personTime . commitAuthor
+commitTime = gitTimeToUTC . personTime . commitAuthor
 
 getCommits :: Git -> Ref -> UTCTime -> IO [Commit]
 getCommits repo ref bound = do

Handler/User.hs

@@ -56,7 +56,7 @@ getUsersR = do
         userProjects :: Entity User -> Maybe (Map (Text, Text) (Set (Role)))
         userProjects u = M.lookup (entityKey u) allProjects
         getUserKey :: Entity User -> Text
-        getUserKey (Entity key _) = either (error . T.unpack) id . fromPersistValue . unKey $ key
+        getUserKey = either (error . T.unpack) id . fromPersistValue . toPersistValue . entityKey
 
     defaultLayout $ do
         setTitle "Users | Snowdrift.coop"
@@ -129,9 +129,19 @@ getUserR user_id = do
                     <> "you will not be able to receive email notifications."
 
     defaultLayout $ do
-        setTitle . toHtml $ "User Profile - " <> userDisplayName (Entity user_id user) <> " | Snowdrift.coop"
+        setTitle $ toHtml $ "User Profile - " <>
+            userDisplayName (Entity user_id user) <> " | Snowdrift.coop"
         renderUser mviewer_id user_id user projects_and_roles
 
+postUserR :: UserId -> Handler Html
+postUserR user_id = do
+    void $ checkEditUser user_id
+    memail <- runDB $ fetchUserEmail user_id
+    case memail of
+        Nothing    -> alertDanger "No email address is associated with your account."
+        Just email -> startEmailVerification user_id email
+    redirect $ UserR user_id
+
 --------------------------------------------------------------------------------
 -- /#UserId/balance
 
@@ -181,7 +191,8 @@ getUserBalanceR' user_id = do
     (add_funds_form, _) <- generateFormPost addTestCashForm
 
     defaultLayout $ do
-        setTitle . toHtml $ "User Balance - " <> userDisplayName (Entity user_id user) <> " | Snowdrift.coop"
+        setTitle $ toHtml $ "User Balance - " <>
+            userDisplayName (Entity user_id user) <> " | Snowdrift.coop"
         $(widgetFile "user_balance")
 
 postUserBalanceR :: UserId -> Handler Html
@@ -260,7 +271,8 @@ getUserDiscussionR' user_id get_root_comments = do
     (comment_form, _) <- generateFormPost commentNewTopicForm
 
     defaultLayout $ do
-        setTitle . toHtml $ userDisplayName (Entity user_id user) <> " User Discussion | Snowdrift.coop"
+        setTitle $ toHtml $ userDisplayName (Entity user_id user) <>
+            " User Discussion | Snowdrift.coop"
         $(widgetFile "user_discuss")
 
 --------------------------------------------------------------------------------
@@ -297,7 +309,7 @@ getUserChangePasswordR user_id = do
     user <- runYDB $ get404 user_id
     (form, enctype) <- generateFormPost changePasswordForm
     defaultLayout $ do
-        setTitle . toHtml $ "Change Passphrase - " <>
+        setTitle $ toHtml $ "Change Passphrase - " <>
             userDisplayName (Entity user_id user) <> " | Snowdrift.coop"
         $(widgetFile "change_password")
 
@@ -335,6 +347,70 @@ postUserChangePasswordR user_id = do
             alertDanger "Oops, failed to update the passphrase."
             defaultLayout $(widgetFile "change_password")
 
+--------------------------------------------------------------------------------