Remove Issues

parent cba24e70
......@@ -91,7 +91,6 @@ library
Model.Count
Model.Currency
Model.Discussion.TH
Model.Issue
Model.Language
Model.Language.TH
Model.License
......
{-# LANGUAGE Rank2Types #-}
module Model.Issue where
import Import
import Data.Filter
import Data.Order
import Numeric (readHex)
import Text.Printf
import Widgets.Tag (pickForegroundColor)
import qualified Data.Set as S
import qualified Data.Text as T
import qualified GitHub.Data.Issues as GH
-- An Issue abstracts a Snowdrift ticket, Github issue, etc.
class Issue a where
issueWidget :: a -> Widget
issueFilterable :: a -> Filterable
issueOrderable :: a -> Orderable
-- Existentially quantified Issue.
newtype SomeIssue =
SomeIssue { unSomeIssue :: forall b. (forall a. Issue a => a -> b) -> b }
mkSomeIssue :: Issue a => a -> SomeIssue
mkSomeIssue issue = SomeIssue (\k -> k issue)
instance Issue SomeIssue where
issueWidget (SomeIssue k) = k issueWidget
issueFilterable (SomeIssue k) = k issueFilterable
issueOrderable (SomeIssue k) = k issueOrderable
instance Issue GH.Issue where
issueWidget github_issue =
[whamlet|
<tr>
<td>
$maybe url <- GH.issueHtmlUrl github_issue
<a href=#{url}>
GH-#{GH.issueNumber github_issue}
$nothing
GH-#{GH.issueNumber github_issue}
<td>
#{GH.issueTitle github_issue}
<td>
$forall tag <- GH.issueLabels github_issue
^{githubIssueTagWidget tag}
|]
where
githubIssueTagWidget :: GH.IssueLabel -> Widget
githubIssueTagWidget tag = do
[whamlet|
<!--
in-line styles are necessary unless we figure out getting
GitHub labelColors generally and make separate classes
for each color. We can't make cassius for each issue.
That would have lots of redundancy and the differing
colors for the same CSS class will conflict.
-->
<form .tag
style="background-color:##{GH.labelColor tag}; color:##{fg $ GH.labelColor tag}">
#{GH.labelName tag}
|]
-- TODO: Use Text tools and not String ones with ugly un/pack
-- e.g. use 'formatting' package instead of printf
fg :: Text -> String
fg = printf "%06x"
. pickForegroundColor
. maybe 0 fst
. listToMaybe
. readHex
. T.unpack
issueFilterable = mkFromGithubIssue Filterable
issueOrderable = mkFromGithubIssue Orderable
mkFromGithubIssue
:: ((Text -> Bool)
-> (Text -> Bool)
-> (Text -> Set UTCTime)
-> (Text -> Bool)
-> t)
-> GH.Issue
-> t
mkFromGithubIssue c i = c is_claimed has_tag get_named_ts search_literal
where
has_issue_assignee = isJust $ GH.issueAssignee i
is_claimed "CLAIMED" = has_issue_assignee
-- | inverted in 'Data.Filter' and 'Data.Order'
is_claimed "UNCLAIMED" = has_issue_assignee
is_claimed cmd = error $ "Unrecognized command " <> T.unpack cmd
has_tag t = t `elem` fmap GH.labelName (GH.issueLabels i)
get_named_ts "CREATED" = S.singleton $ GH.issueCreatedAt i
get_named_ts "LAST UPDATED" = S.singleton $ GH.issueUpdatedAt i
get_named_ts name = error $ "Unrecognized time name " ++ T.unpack name
search_literal str =
not (null $ T.breakOnAll str $ GH.issueTitle i)
|| fromMaybe False (null . T.breakOnAll str <$> GH.issueBody i)
......@@ -7,7 +7,6 @@ module Model.Project
, fetchProjectTeamMembersDB
, fetchProjectVolunteerApplicationsDB
, fetchProjectPledgesDB
, getGithubIssues
, projectNameWidget
, summarizeProject
-- * Balancing/deactivating pledges
......@@ -15,9 +14,7 @@ module Model.Project
import Import
import Control.Concurrent.Async (Async, async, wait)
import Control.Monad.Trans.Resource (MonadThrow)
import qualified Data.Text as T
import Model.Count
import WrappedValues
......@@ -58,29 +55,6 @@ fetchProjectDB project_id =
where_ $ p ^. ProjectId ==. val project_id
return p
getGithubIssues :: Project -> Handler [GH.Issue]
getGithubIssues project =
getGithubIssues'
>>= liftIO . wait
>>= either (\_ -> alertDanger eMsg >> return [])
return
where
eMsg = "failed to fetch GitHub tickets\n"
getIssues (account, repo) =
fmap (fmap toList) $ GH.issuesForRepo account repo []
getGithubIssues' :: Handler (Async (Either GH.Error [GH.Issue]))
getGithubIssues' = liftIO . async $
maybe (return $ Right []) getIssues parsedProjectGithubRepo
parsedProjectGithubRepo :: Maybe (GH.Name GH.Owner, GH.Name GH.Repo)
parsedProjectGithubRepo =
fmap
( (GH.mkOwnerName *** GH.mkRepoName)
. second (T.drop 1)
. T.break (== '/')
)
(projectGithubRepo project)
summarizeProject :: Entity Project
-> ProjectSummary
summarizeProject project =
......
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