We are no longer offering accounts on this server. Consider https://gitlab.freedesktop.org/ as a place to host projects.

Project.hs 4.58 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
module View.Project where

import Import

import           Model.Currency
import           Model.Markdown
import           Model.Project
import           Model.Shares
import           Model.Role
import           Widgets.Markdown

import qualified Data.Text       as T
import           Data.Time.Clock
import           Yesod.Markdown

renderProject :: Maybe ProjectId -> Project -> [Int64] -> Maybe (Entity Pledge) -> WidgetT App IO ()
renderProject maybe_project_id project pledges pledge = do
    let share_value = projectShareValue project
        users = fromIntegral $ length pledges
        shares = sum pledges
        project_value = share_value $* fromIntegral shares
        description = markdownWidget (projectHandle project) $ projectDescription project

        maybe_shares = pledgeShares . entityVal <$> pledge

    now <- liftIO getCurrentTime

    amounts <- case projectLastPayday project of
        Nothing -> return Nothing
        Just last_payday -> handlerToWidget $ runDB $ do
            -- This assumes there were transactions associated with the last payday
            [Value (Just last) :: Value (Maybe Rational)] <-
                select $
                from $ \ transaction -> do
                where_ $
                    transaction ^. TransactionPayday ==. val (Just last_payday) &&.
                    transaction ^. TransactionCredit ==. val (Just $ projectAccount project)
                return $ sum_ $ transaction ^. TransactionAmount

            [Value (Just year) :: Value (Maybe Rational)] <-
                select $
                from $ \ (transaction `InnerJoin` payday) -> do
                where_ $
                    payday ^. PaydayDate >. val (addUTCTime (-365 * 24 * 60 * 60) now) &&.
                    transaction ^. TransactionCredit ==. val (Just $ projectAccount project)
                on_ $ transaction ^. TransactionPayday ==. just (payday ^. PaydayId)
                return $ sum_ $ transaction ^. TransactionAmount

            [Value (Just total) :: Value (Maybe Rational)] <-
                select $
                from $ \ transaction -> do
                where_ $ transaction ^. TransactionCredit ==. val (Just $ projectAccount project)
                return $ sum_ $ transaction ^. TransactionAmount

            return $ Just (Milray $ round last, Milray $ round year, Milray $ round total)


    ((_, update_shares), _) <- handlerToWidget $ generateFormGet $ maybe previewPledgeForm pledgeForm maybe_project_id

    $(widgetFile "project")

renderBlogPost :: Text -> ProjectBlog -> WidgetT App IO ()
renderBlogPost project_handle blog_post = do
    let (Markdown top_content) = projectBlogTopContent blog_post
65
        (Markdown bottom_content) = maybe (Markdown "") ("***\n" <>) $ projectBlogBottomContent blog_post
66 67
        title = projectBlogTitle blog_post
        content = markdownWidget project_handle $ Markdown $ T.snoc top_content '\n' <> bottom_content
68

69 70 71 72 73 74 75 76 77 78
    $(widgetFile "blog_post")

editProjectForm :: Maybe (Project, [Text]) -> Form UpdateProject
editProjectForm project =
    renderBootstrap3 $ UpdateProject
        <$> areq' textField "Project Name" (projectName . fst <$> project)
        <*> areq' snowdriftMarkdownField "Description" (projectDescription . fst <$> project)
        <*> (maybe [] (map T.strip . T.splitOn ",") <$> aopt' textField "Tags" (Just . T.intercalate ", " . snd <$> project))
        <*> aopt' textField "Github Repository" (projectGithubRepo . fst <$> project)

79 80 81 82 83 84 85 86 87
projectBlogForm :: Maybe (Text, Text, Markdown) -> Form (UTCTime -> UserId -> ProjectId -> DiscussionId -> ProjectBlog)
projectBlogForm defaults = renderBootstrap3 $
    let getTitle (title, _, _) = title
        getHandle (_, handle, _) = handle
        getContent (_, _, content) = content
     in mkBlog
        <$> areq' textField "Post Title" (getTitle <$> defaults)
        <*> areq' textField "Post Handle" (getHandle <$> defaults)
        <*> areq' snowdriftMarkdownField "Content" (getContent <$> defaults)
88
  where
89 90 91 92 93 94
    mkBlog :: Text -> Text -> Markdown -> (UTCTime -> UserId -> ProjectId -> DiscussionId -> ProjectBlog)
    mkBlog title handle (Markdown content) now user_id project_id discussion_id =
        let (top_content, bottom_content) = break (== "***") $ T.lines content
         in ProjectBlog now title handle user_id project_id
                discussion_id (Markdown $ T.unlines top_content)
                (if null bottom_content then Nothing else Just $ Markdown $ T.unlines bottom_content)
95 96 97 98 99

inviteForm :: Form (Text, Role)
inviteForm = renderBootstrap3 $ (,)
    <$> areq' textField "About this invitation:" Nothing
    <*> areq roleField "Type of Invite:" (Just TeamMember)