clckwrks-plugin-bugs 0.6.7 → 0.7.1
raw patch · 12 files changed
+184/−51 lines, 12 files
Files
- Clckwrks/Bugs/Acid.hs +31/−4
- Clckwrks/Bugs/Page/BugList.hs +61/−0
- Clckwrks/Bugs/Page/EditBug.hs +10/−9
- Clckwrks/Bugs/Page/SubmitBug.hs +10/−9
- Clckwrks/Bugs/Page/Timeline.hs +1/−1
- Clckwrks/Bugs/Page/ViewBug.hs +3/−3
- Clckwrks/Bugs/Plugin.hs +3/−2
- Clckwrks/Bugs/PreProcess.hs +6/−1
- Clckwrks/Bugs/Route.hs +4/−0
- Clckwrks/Bugs/Types.hs +52/−21
- Clckwrks/Bugs/URL.hs +1/−0
- clckwrks-plugin-bugs.cabal +2/−1
Clckwrks/Bugs/Acid.hs view
@@ -5,7 +5,8 @@ import Control.Monad.Reader (ask) import Control.Monad.State (get, modify, put) import Data.Acid (Query, Update, makeAcidic)-import Data.IxSet (IxSet, Proxy(..), (@=), (@+), getOne, empty, toAscList, toList, fromList, updateIx)+import Data.Data (Data, Typeable)+import Data.IxSet (IxSet, Proxy(..), (@=), (@+), getOne, empty, toAscList, toDescList, toList, fromList, updateIx) import qualified Data.IxSet as IxSet import Data.Map (Map) import qualified Data.Map as Map@@ -13,7 +14,7 @@ import Data.SafeCopy (base, deriveSafeCopy, extension, Migrate(..)) import Data.Text (Text) import qualified Data.Text as Text-import Clckwrks.Bugs.Types (Bug(..), BugStatus(..), BugId(..), Milestone(..), MilestoneId(..), TargetDate(..))+import Clckwrks.Bugs.Types (Bug(..), BugMeta(..), BugStatus(..), BugId(..), Milestone(..), MilestoneId(..), TargetDate(..)) data BugsState_0 = BugsState_0 { nextBugId_0 :: BugId@@ -60,13 +61,38 @@ putBug :: Bug -> Update BugsState () putBug bug = do bs@BugsState{..} <- get- put $ bs { bugs = updateIx (bugId bug) bug bugs }+ put $ bs { bugs = updateIx (bugId $ bugMeta bug) bug bugs } allBugIds :: Query BugsState [BugId] allBugIds = do BugsState{..} <- ask- return $ map bugId (toList bugs)+ return $ map (bugId . bugMeta) (toList bugs) +data SortBugsBy+ = SortByBugId+{-+ | SortBySubmittor+ | SortByMilestone+ | SortByStatus+-}+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 0 'base ''SortBugsBy)++data SortOrder a+ = Asc a+ | Desc a+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 0 'base ''SortOrder)++allBugMeta :: SortOrder SortBugsBy -> Query BugsState [BugMeta]+allBugMeta sortOrder =+ do BugsState{..} <- ask+ case sortOrder of+ (Asc SortByBugId) ->+ return $ map bugMeta (toAscList (Proxy :: Proxy BugId) bugs)+ (Desc SortByBugId) ->+ return $ map bugMeta (toDescList (Proxy :: Proxy BugId) bugs)+ ------------------------------------------------------------------------------ -- Milestones ------------------------------------------------------------------------------@@ -131,6 +157,7 @@ , 'getBugById , 'putBug , 'allBugIds+ , 'allBugMeta , 'newMilestone , 'getMilestones , 'getMilestoneTitle
+ Clckwrks/Bugs/Page/BugList.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-}+module Clckwrks.Bugs.Page.BugList where++import Clckwrks+import Clckwrks.Bugs.Acid+import Clckwrks.Bugs.Monad+import Clckwrks.Bugs.Types+import Clckwrks.Bugs.URL+import Clckwrks.Bugs.Page.Template (template)+import Clckwrks.ProfileData.Acid (GetProfileData(..))+import qualified Data.IxSet as IxSet+import Data.List (find)+import Data.String (fromString)+import qualified Data.Text.Lazy as Text+import Numeric (showFFloat)+import HSP.XML+import HSP.XMLGenerator++bugList :: BugsM Response+bugList =+ template (fromString "Bug List") ()+ <%>+ <h1>Bug List</h1>+ <% bugListWidget %>+ </%>++bugListWidget :: XMLGenT BugsM XML+bugListWidget =+ do bugs <- query (AllBugMeta (Desc SortByBugId))+ <div class="bug-list">+ <table class="table">+ <thead>+ <tr>+ <th>#</th>+ <th>Title</th>+ <th>Status</th>+ <th>Assigned</th>+ </tr>+ </thead>+ <tbody>+ <% map showBugMeta bugs %>+ </tbody>+ </table>+ </div>++showBugMeta :: BugMeta -> XMLGenT BugsM XML+showBugMeta BugMeta{..} =+ <tr [Text.pack "class" := (if (bugStatus == New) || (bugStatus == Accepted) then (Text.pack "bug-summary-open") else (Text.pack "bug-summary-closed"))] >+ <td><a href=(ViewBug bugId)><% bugId %></a></td>+ <td><% bugTitle %></td>+ <td><% show bugStatus %></td>+ <td><% case bugAssigned of+ Nothing -> <% () %>+ (Just u) -> do mpd <- query (GetProfileData u)+ case mpd of+ Nothing -> <% () %>+ (Just pd) -> <% username pd %>+ %>+ </td>+ </tr>
Clckwrks/Bugs/Page/EditBug.hs view
@@ -58,17 +58,18 @@ editBugForm :: [(Maybe UserId, Text)] -> [Milestone] -> Bug -> BugsForm Bug-editBugForm users milestones bug@Bug{..} =+editBugForm users milestones bug@(Bug bugMeta@BugMeta{..} bugBody) = (divHorizontal $ fieldset $- Bug <$> pure bugId- <*> pure bugSubmittor- <*> pure bugSubmitted- <*> bugStatusForm bugStatus- <*> bugAssignedForm bugAssigned- <*> bugTitleForm bugTitle+ Bug <$> (BugMeta <$> pure bugId+ <*> pure bugSubmitter+ <*> pure bugSubmitted+ <*> bugStatusForm bugStatus+ <*> bugAssignedForm bugAssigned+ <*> bugTitleForm bugTitle+ <*> pure Set.empty+ <*> bugMilestoneForm bugMilestone+ ) <*> bugBodyForm bugBody- <*> pure Set.empty- <*> bugMilestoneForm bugMilestone <* (divFormActions $ inputSubmit' (T.pack "update"))) where divFormActions = mapView (\xml -> [<div class="form-actions"><% xml %></div>])
Clckwrks/Bugs/Page/SubmitBug.hs view
@@ -37,21 +37,22 @@ addReport :: Bug -> BugsM Response addReport bug = do ident <- update GenBugId- update $ PutBug (bug { bugId = ident })+ update $ PutBug (bug { bugMeta = (bugMeta bug) { bugId = ident } }) seeOtherURL (ViewBug ident) submitForm :: BugsForm Bug submitForm = (divHorizontal $ fieldset $- Bug <$> pure (BugId 0)- <*> submittorIdForm- <*> nowForm- <*> pure New- <*> pure Nothing- <*> bugTitleForm+ Bug <$> (BugMeta <$> pure (BugId 0)+ <*> submittorIdForm+ <*> nowForm+ <*> pure New+ <*> pure Nothing+ <*> bugTitleForm+ <*> pure Set.empty+ <*> pure Nothing+ ) <*> bugBodyForm- <*> pure Set.empty- <*> pure Nothing <* (divFormActions $ inputSubmit' (pack "submit")) ) where
Clckwrks/Bugs/Page/Timeline.hs view
@@ -55,7 +55,7 @@ </%> showBugSummary :: Bug -> XMLGenT BugsM XML-showBugSummary Bug{..} =+showBugSummary (Bug BugMeta{..} bugBody) = <tr [Text.pack "class" := (if (bugStatus == New) || (bugStatus == Accepted) then (Text.pack "bug-summary-open") else (Text.pack "bug-summary-closed"))] > <td><a href=(ViewBug bugId)><% bugId %></a></td> <td><% bugTitle %></td>
Clckwrks/Bugs/Page/ViewBug.hs view
@@ -31,8 +31,8 @@ (Just bug) -> bugHtml bug bugHtml :: Bug -> BugsM Response-bugHtml Bug{..} =- do submittor <- query (GetUsername bugSubmittor)+bugHtml (Bug BugMeta{..} bugBody) =+ do submitter <- query (GetUsername bugSubmitter) milestoneTxt <- case bugMilestone of Nothing -> return (pack "none")@@ -44,7 +44,7 @@ <h1>View Bug</h1> <dl id="view-bug"> <dt>Bug #:</dt> <dd><% show $ unBugId bugId %></dd>- <dt>Submitted By:</dt><dd><% fromMaybe (pack "Anonymous") submittor %></dd>+ <dt>Submitted By:</dt><dd><% fromMaybe (pack "Anonymous") submitter %></dd> <dt>Submitted:</dt> <dd><% bugSubmitted %></dd> <dt>Status:</dt> <dd><% show bugStatus %></dd> <dt>Milestone:</dt> <dd><% milestoneTxt %></dd>
Clckwrks/Bugs/Plugin.hs view
@@ -38,8 +38,9 @@ -> ClckT ClckURL IO (String, [NamedLink]) navBarCallback acidBugsState showBugsURL = do let submitLink = NamedLink { namedLinkTitle = "Submit Bug", namedLinkURL = showBugsURL SubmitBug [] }- timelineLink = NamedLink { namedLinkTitle = "Timeline", namedLinkURL = showBugsURL Timeline [] }- return ("Bugs", [submitLink, timelineLink])+ timelineLink = NamedLink { namedLinkTitle = "Timeline", namedLinkURL = showBugsURL Timeline [] }+ bugListLink = NamedLink { namedLinkTitle = "Bug List", namedLinkURL = showBugsURL BugList [] }+ return ("Bugs", [submitLink, timelineLink, bugListLink]) bugsInit :: ClckPlugins -> IO (Maybe Text)
Clckwrks/Bugs/PreProcess.hs view
@@ -24,6 +24,7 @@ data BugsCmd = ShowBug BugId | ShowTimeline+ | BugListLink parseAttr :: Text -> Parser () parseAttr name =@@ -46,8 +47,9 @@ -} parseCmd :: Parser BugsCmd parseCmd =- choice [ parseAttr (pack "id") *> (ShowBug . BugId <$> decimal)+ choice [ parseAttr (pack "id") *> (ShowBug . BugId <$> decimal) , asciiCI (pack "timeline") *> pure ShowTimeline+ , asciiCI (pack "list-link") *> pure BugListLink ] bugsCmd :: (Functor m, Monad m) =>@@ -63,6 +65,9 @@ applyCmd bugsShowURL (ShowBug bid) = do html <- unXMLGenT $ <a href=(bugsShowURL (ViewBug bid) [])>#<% show $ unBugId bid %></a>+ return $ mconcat $ map B.fromLazyText $ TL.lines $ renderAsHTML html+applyCmd bugsShowURL BugListLink =+ do html <- unXMLGenT $ <a href=(bugsShowURL BugList [])>Bug List</a> return $ mconcat $ map B.fromLazyText $ TL.lines $ renderAsHTML html {- applyCmd bugsShowURL ShowTimeline =
Clckwrks/Bugs/Route.hs view
@@ -6,6 +6,7 @@ import Clckwrks (Role(..), requiresRole_) import Clckwrks.Bugs.Monad (BugsM, BugsConfig(..)) import Clckwrks.Bugs.URL (BugsURL(..), BugsAdminURL(..))+import Clckwrks.Bugs.Page.BugList (bugList) import Clckwrks.Bugs.Page.EditBug (editBug) import Clckwrks.Bugs.Page.EditMilestones (editMilestones) import Clckwrks.Bugs.Page.SubmitBug (submitBug)@@ -30,6 +31,7 @@ BugsAdmin {} -> requiresRole (Set.singleton Administrator) url BugsData {} -> return url Timeline {} -> return url+ BugList {} -> return url routeBugs :: BugsURL -> BugsM Response@@ -46,6 +48,8 @@ else serveFile (guessContentTypeM mimeTypes) (bugsDir </> "data" </> fp'') Timeline -> timeline+ BugList ->+ bugList BugsAdmin (EditBug bid) -> editBug url bid BugsAdmin EditMilestones ->
Clckwrks/Bugs/Types.hs view
@@ -1,16 +1,16 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell, TypeFamilies #-} module Clckwrks.Bugs.Types where import Clckwrks import Clckwrks.Page.Types (Markup(..), PreProcessor(..))-import Data.Data (Data, Typeable)-import Data.IxSet (Indexable(..), ixSet, ixFun)-import Data.Maybe (maybeToList)-import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)-import Data.Text (Text)-import Data.Time (UTCTime)-import Data.Set (Set)-import Web.Routes (PathInfo(..))+import Data.Data (Data, Typeable)+import Data.IxSet (Indexable(..), ixSet, ixFun)+import Data.Maybe (maybeToList)+import Data.SafeCopy (SafeCopy, Migrate(..), base, deriveSafeCopy, extension)+import Data.Text (Text)+import Data.Time (UTCTime)+import Data.Set (Set)+import Web.Routes (PathInfo(..)) newtype BugId = BugId { unBugId :: Integer } deriving (Eq, Ord, Read, Show, Data, Typeable, SafeCopy, PathInfo)@@ -49,21 +49,52 @@ $(deriveSafeCopy 0 'base ''BugStatus) -data Bug- = Bug { bugId :: BugId- , bugSubmittor :: UserId- , bugSubmitted :: UTCTime- , bugStatus :: BugStatus- , bugAssigned :: Maybe UserId- , bugTitle :: Text- , bugBody :: Markup- , bugTags :: Set BugTag- , bugMilestone :: Maybe MilestoneId- }+data Bug_0+ = Bug_0 { bugId_0 :: BugId+ , bugSubmittor_0 :: UserId+ , bugSubmitted_0 :: UTCTime+ , bugStatus_0 :: BugStatus+ , bugAssigned_0 :: Maybe UserId+ , bugTitle_0 :: Text+ , bugBody_0 :: Markup+ , bugTags_0 :: Set BugTag+ , bugMilestone_0 :: Maybe MilestoneId+ } deriving (Eq, Ord, Read, Show, Data, Typeable)-$(deriveSafeCopy 0 'base ''Bug)+$(deriveSafeCopy 0 'base ''Bug_0) +data BugMeta = BugMeta+ { bugId :: BugId+ , bugSubmitter :: UserId+ , bugSubmitted :: UTCTime+ , bugStatus :: BugStatus+ , bugAssigned :: Maybe UserId+ , bugTitle :: Text+ , bugTags :: Set BugTag+ , bugMilestone :: Maybe MilestoneId+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 0 'base ''BugMeta)++data Bug = Bug+ { bugMeta :: BugMeta+ , bugBody :: Markup+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(deriveSafeCopy 1 'extension ''Bug)++instance Migrate Bug where+ type MigrateFrom Bug = Bug_0+ migrate (Bug_0 id sub subd stat assi titl bdy tags mile) =+ Bug (BugMeta id sub subd stat assi titl tags mile) bdy+ instance Indexable Bug where+ empty = ixSet [ ixFun ((:[]) . bugId . bugMeta)+ , ixFun (maybeToList . bugMilestone . bugMeta)+ , ixFun ((:[]) . bugStatus . bugMeta)+ ]++instance Indexable BugMeta where empty = ixSet [ ixFun ((:[]) . bugId) , ixFun (maybeToList . bugMilestone) , ixFun ((:[]) . bugStatus)
Clckwrks/Bugs/URL.hs view
@@ -18,5 +18,6 @@ | BugsAdmin BugsAdminURL | BugsData FilePath | Timeline+ | BugList deriving (Eq, Ord, Read, Show, Data, Typeable) $(derivePathInfo ''BugsURL)
clckwrks-plugin-bugs.cabal view
@@ -1,5 +1,5 @@ Name: clckwrks-plugin-bugs-Version: 0.6.7+Version: 0.7.1 Synopsis: bug tracking plugin for clckwrks Homepage: http://clckwrks.com/ License: BSD3@@ -27,6 +27,7 @@ Clckwrks.Bugs.Acid Clckwrks.Bugs.Monad Clckwrks.Bugs.Plugin+ Clckwrks.Bugs.Page.BugList Clckwrks.Bugs.Page.EditBug Clckwrks.Bugs.Page.EditMilestones Clckwrks.Bugs.Page.Template