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

Commit d9182204 authored by David L. L. Thomas's avatar David L. L. Thomas

Feed of git commits (current branch) at /dev/repo

parent ba77bd5f
......@@ -42,6 +42,7 @@ import Handler.UserBalance
import Handler.UserPledges
import Handler.Wiki
import Handler.Tickets
import Handler.RepoFeed
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
......
{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
module Data.Text.PrettyHtml (unlinesHtml, prettyHtml, prettyThings) where
import Import
import Data.Attoparsec.Text
import qualified Text.Blaze.Html5.Attributes as Attr
import qualified Text.Blaze.Html5 as Html
import Data.Either
import Data.Function (on)
import Data.List as L
import Data.String
import Data.Text as T
import Control.Applicative
isRight :: Either a b -> Bool
isRight (Right _) = True
isRight _ = False
unlinesHtml :: [Html] -> Html
unlinesHtml = sequence_ . L.intersperse Html.br
prettyHtml :: HasGithubRepo (GHandler sub master) => [Parser Pretty] -> Text -> GHandler sub master Html
prettyHtml filters text = do
case parseOnly (many $ (Left <$> choice filters) <|> (Right . T.singleton <$> anyChar)) text of
Right result -> do
let pieces = L.concatMap (\(a, b) -> L.map Left a ++ if T.length b > 0 then [Right b] else []) $ fmap (fmap T.concat) $ fmap partitionEithers $ L.groupBy ((==) `on` isRight) result
fmap sequence_ $ forM pieces $ either renderPretty (return . toHtml)
Left err -> error err
renderPretty :: HasGithubRepo (GHandler sub master) => Pretty -> GHandler sub master 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]
{-# LANGUAGE FlexibleInstances #-}
module Foundation where
import Prelude
......@@ -207,6 +208,7 @@ instance Yesod App where
isAuthorized PrivacyR _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
isAuthorized RepoFeedR _ = return Authorized
isAuthorized (AuthR _) _ = return Authorized
isAuthorized (InvitationR _) _ = return Authorized
......@@ -333,6 +335,11 @@ instance YesodAuth App where
instance YesodJquery App
class HasGithubRepo a where
getGithubRepo :: a (Maybe Text)
instance HasGithubRepo (GHandler App App) where
getGithubRepo = extraGithubRepo . appExtra . settings <$> getYesod
-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
......
......@@ -20,8 +20,6 @@ import Widgets.Markdown
import Database.Esqueleto
import Database.Persist.GenericSql.Raw
import Control.Monad (forM, forM_)
import Yesod.Markdown
lookupGetParamDefault :: Read a => Text -> a -> Handler a
......
module Handler.RepoFeed where
import Import
import Data.Text.Encoding
import Yesod.Feed
import Data.Git.Storage
import Data.Git.Named
import Data.Git.Repository
import Data.Git.Types
import Data.Git.Ref
import qualified Data.Text as T
import Data.Text.PrettyHtml
import Prelude (head)
import Data.Time (addUTCTime)
import Data.List (sortBy)
import Data.Tree (unfoldTreeM_BF, levels)
import Data.Function (on)
getRepoFeedR :: HasGithubRepo Handler => Handler RepAtomRss
getRepoFeedR = do
now <- liftIO getCurrentTime
let bound = addUTCTime (-2000000) now
(commits, branch) <- liftIO $ do
repo <- openRepo ".git"
RefLink (RefBranch branch) <- readRefFile ".git" RefHead
RefDirect ref <- readRefFile ".git" (RefBranch branch)
commits <- getCommits repo ref bound
return (commits, branch)
let title = T.pack $ "Snowdrift Commits (" ++ branch ++ ")"
feed_url = RepoFeedR
home_url = HomeR
author = "Snowdrift Team"
desc = "Commits to the Snowdrift repository."
lang = "en"
-- commitTime = toUTCTime . personTime . commitAuthor
time = commitTime $ head commits
entries <- forM commits $ \ commit -> do
let ls = T.lines $ decodeUtf8 $ commitMessage commit
html <- unlinesHtml <$> mapM (prettyHtml prettyThings) ls
return $ FeedEntry (ProjectR "snowdrift") (commitTime commit) (fromMaybe "empty commit message" $ listToMaybe ls) html
newsFeed $ Feed title feed_url home_url author desc lang time entries
commitTime :: Commit -> UTCTime
commitTime = toUTCTime . personTime . commitAuthor
getCommits :: Git -> Ref -> UTCTime -> IO [Commit]
getCommits repo ref bound = do
tree <- flip unfoldTreeM_BF ref $ \ ref' -> do
commit <- getCommit repo ref'
return $ if commitTime commit < bound
then (commit, [])
else (commit, commitParents commit)
return $ sortBy (flip compare `on` commitTime) $ filter (\ a -> length (commitParents a) <= 1) $ concat $ levels tree
......@@ -22,7 +22,6 @@ import qualified Data.Map as M
import Data.Tree
import Control.Monad
import Control.Arrow ((&&&))
import Database.Persist.Store
......@@ -33,10 +32,9 @@ getWikiR :: Text -> Handler RepHtml
getWikiR target = do
Entity _ user <- requireAuth
(Entity _ page, Entity _ _) <- runDB $ do
Entity _ page <- runDB $ do
page_entity <- getBy404 $ UniqueWikiTarget target
last_edit_entity <- getBy404 $ UniqueWikiLastEdit $ entityKey page_entity
return (page_entity, last_edit_entity)
return page_entity
when (userRole user < wikiPageCanView page) $ permissionDenied "You do not have sufficient privileges to view this page."
......
......@@ -23,7 +23,7 @@ import Data.Maybe as Import (fromMaybe, listToMaybe, mapMayb
import Data.Int as Import (Int64)
import Control.Monad as Import (when, void)
import Control.Monad as Import
import Data.Time.Clock as Import (UTCTime, diffUTCTime, getCurrentTime)
import Data.Time.Units
......
......@@ -63,7 +63,8 @@ widgetFile = (if development then widgetFileReload
data Extra = Extra
{ extraCopyright :: Text
, extraSourceRepo :: Text -- ^ Google Analytics
, extraSourceRepo :: Text
, extraGithubRepo :: Maybe Text
, extraAnalytics :: Maybe Text -- ^ Google Analytics
} deriving Show
......@@ -71,4 +72,5 @@ parseExtra :: DefaultEnv -> Object -> Parser Extra
parseExtra _ o = Extra
<$> o .: "copyright"
<*> o .: "source"
<*> o .:? "githubrepo"
<*> o .:? "analytics"
......@@ -57,10 +57,12 @@ library
Handler.UserPledges
Handler.Wiki
Handler.Tickets
Handler.RepoFeed
Widgets.Markdown
Widgets.Sidebar
Widgets.Time
Widgets.ProjectPledges
Data.Text.PrettyHtml
other-modules: Model.Role.Internal
......@@ -92,6 +94,7 @@ library
, yesod-form >= 1.2 && < 1.3
, yesod-routes
, yesod-persistent
, yesod-newsfeed >= 1.1 && < 1.2
, clientsession >= 0.8 && < 0.9
, bytestring >= 0.9 && < 0.11
, text >= 0.11 && < 0.12
......@@ -130,6 +133,7 @@ library
, attoparsec
, old-locale
, resourcet
, hit >= 0.5 && < 1.0
executable Snowdrift
......
......@@ -4,8 +4,6 @@ import Settings
import Application
import Yesod.Default.Config
import Control.Monad
import Database.Persist.Store
import Database.Persist.GenericSql
......
......@@ -53,3 +53,4 @@
/newcomments WikiNewCommentsR GET
/newedits WikiNewEditsR GET
/t TicketsR GET
/dev/repo RepoFeedR GET
......@@ -4,6 +4,7 @@ Default: &defaults
approot: "http://localhost:3000"
copyright: "2013 Snowdrift.coop"
source: "https://gitorious.org/snowdrift/snowdrift"
githubrepo: "dlthomas/snowdrift"
#analytics: UA-YOURCODE
Development:
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment