clckwrks-plugin-bugs 0.3.4 → 0.5.1
raw patch · 7 files changed
+73/−34 lines, 7 filesdep +clckwrks-plugin-pagedep ~clckwrksdep ~happstack-authenticate
Dependencies added: clckwrks-plugin-page
Dependency ranges changed: clckwrks, happstack-authenticate
Files
- Clckwrks/Bugs/Page/EditBug.hs +18/−11
- Clckwrks/Bugs/Page/EditMilestones.hs +17/−10
- Clckwrks/Bugs/Page/SubmitBug.hs +14/−6
- Clckwrks/Bugs/Page/ViewBug.hs +4/−1
- Clckwrks/Bugs/Plugin.hs +15/−3
- Clckwrks/Bugs/Types.hs +1/−0
- clckwrks-plugin-bugs.cabal +4/−3
Clckwrks/Bugs/Page/EditBug.hs view
@@ -10,6 +10,7 @@ import Clckwrks.Bugs.Types import Clckwrks.Bugs.URL import Clckwrks.Bugs.Page.Template (template)+import Clckwrks.Page.Types (Markup(..), PreProcessor(..)) import Clckwrks.ProfileData.Acid (GetUserIdUsernames(..)) import Data.Monoid (mempty) import Data.Maybe (fromJust)@@ -40,7 +41,7 @@ template (fromString "Edit Bug Report") () <%> <h1>Edit Bug Report</h1>--- <% reform (form here) "sbr" updateReport Nothing (editBugForm users milestones bug) %>+ <% reform (form here) "sbr" updateReport Nothing (editBugForm users milestones bug) %> </%> where updateReport :: Bug -> BugsM Response@@ -55,7 +56,7 @@ editBugForm :: [(Maybe UserId, Text)] -> [Milestone] -> Bug -> BugsForm Bug editBugForm users milestones bug@Bug{..} =- (fieldset $ ol $+ (divHorizontal $ fieldset $ Bug <$> pure bugId <*> pure bugSubmittor <*> pure bugSubmitted@@ -65,31 +66,37 @@ <*> bugBodyForm bugBody <*> pure Set.empty <*> bugMilestoneForm bugMilestone- <* (li $ inputSubmit (pack "update")))- `setAttrs` ["class" := "bugs"]+ <* (divFormActions $ inputSubmit' (pack "update"))) where+ divFormActions = mapView (\xml -> [<div class="form-actions"><% xml %></div>])+ divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>])+ divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])+ divControls = mapView (\xml -> [<div class="controls"><% xml %></div>])+ inputSubmit' str = inputSubmit str `setAttrs` [("class":="btn")]+ label' str = (label str `setAttrs` [("class":="control-label")]) + bugStatusForm :: BugStatus -> BugsForm BugStatus bugStatusForm oldStatus =- (li $ label (pack "Status:")) ++> select [(s, show s) | s <- [minBound .. maxBound]] (== oldStatus)+ divControlGroup $ label' (pack "Status:") ++> (divControls $ select [(s, show s) | s <- [minBound .. maxBound]] (== oldStatus)) bugAssignedForm :: Maybe UserId -> BugsForm (Maybe UserId) bugAssignedForm mUid =- (li $ label (pack "Assigned:")) ++>- select users (== mUid)+ divControlGroup $ label' (pack "Assigned:") ++>+ (divControls $ select users (== mUid)) bugTitleForm :: Text -> BugsForm Text bugTitleForm oldTitle =- (li $ label (pack "Summary:")) ++> (inputText oldTitle `setAttrs` ["size" := "80"])+ divControlGroup $ label' (pack "Summary:") ++> (divControls $ inputText oldTitle `setAttrs` ["size" := "80", "class" := "input-xxlarge"]) bugBodyForm :: Markup -> BugsForm Markup bugBodyForm oldBody =- (li $ label (pack "Details:")) ++> ((\t -> Markup [HsColour, Markdown] t Untrusted) <$> textarea 80 20 (markup oldBody))+ divControlGroup $ label' (pack "Details:") ++> (divControls $ ((\t -> Markup [HsColour, Markdown] t Untrusted) <$> (textarea 80 20 (markup oldBody) `setAttrs` [("class" := "input-xxlarge")]))) bugMilestoneForm :: Maybe MilestoneId -> BugsForm (Maybe MilestoneId) bugMilestoneForm mMilestone =- (li $ label (pack "Milestone:")) ++>- select ((Nothing, pack "none") : [(Just $ milestoneId m, milestoneTitle m) | m <- milestones]) (== mMilestone)+ divControlGroup $ label' (pack "Milestone:") ++>+ (divControls $ select ((Nothing, pack "none") : [(Just $ milestoneId m, milestoneTitle m) | m <- milestones]) (== mMilestone)) impure :: (Monoid view, Monad m) => m a -> Form m input error view () a
Clckwrks/Bugs/Page/EditMilestones.hs view
@@ -31,15 +31,14 @@ do milestones <- query GetMilestones template (fromString "Edit Milestones") () <%>- <h1>Edit Milestones</h1> <% reform (form here) "em" updateMilestones Nothing (editMilestonesForm milestones) %> </%> where- updateMilestones :: ([Milestone], Bool, Bool) -> BugsM Response- updateMilestones (_milestones, False, True) =+ updateMilestones :: ([Milestone], (Bool, Bool)) -> BugsM Response+ updateMilestones (_milestones, (False, True)) = do _mid <- update $ NewMilestone seeOtherURL here- updateMilestones (milestones, True, False) =+ updateMilestones (milestones, (True, False)) = do update $ SetMilestones milestones seeOtherURL Timeline @@ -49,15 +48,23 @@ -- between the GET and POST requests. We need to use a different -- pattern where the POST processing does not depend on the -- [Milestone] parameter.-editMilestonesForm :: [Milestone] -> BugsForm ([Milestone], Bool, Bool)+editMilestonesForm :: [Milestone] -> BugsForm ([Milestone], (Bool, Bool)) editMilestonesForm milestones =- (fieldset $ ol $- (,,) <$> (sequenceA $ map editMilestoneForm milestones) <*> (isJust <$> inputSubmit (pack "update")) <*> (isJust <$> inputSubmit (pack "add new milestone"))- ) `setAttrs` ["class" := "bugs"]+ (divHorizontal $ fieldset $+ (,) <$> (sequenceA $ map editMilestoneForm milestones) <*> (divFormActions $ (,) <$> (isJust <$> inputSubmit' (pack "update")) <*> (isJust <$> inputSubmit' (pack "add new milestone")))+ ) where+ divFormActions = mapView (\xml -> [<div class="form-actions"><% xml %></div>])+ divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>])+ divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])+ divControls = mapView (\xml -> [<div class="controls"><% xml %></div>])+ label' str = (label str `setAttrs` [("class":="control-label")])+ inputSubmit' str = inputSubmit str `setAttrs` [("class":="btn")]+ editMilestoneForm ms@Milestone{..} =- li $ label ("#" ++ show (unMilestoneId milestoneId) ++" title:") ++>- ((\newTitle -> ms { milestoneTitle = newTitle }) <$> inputText milestoneTitle)+ divControlGroup $+ label' ("#" ++ show (unMilestoneId milestoneId) ++" title:") ++>+ (divControls ((\newTitle -> ms { milestoneTitle = newTitle }) <$> inputText milestoneTitle)) impure :: (Monoid view, Monad m) => m a -> Form m input error view () a impure ma =
Clckwrks/Bugs/Page/SubmitBug.hs view
@@ -9,6 +9,7 @@ import Clckwrks.Bugs.Types import Clckwrks.Bugs.URL import Clckwrks.Bugs.Page.Template (template)+import Clckwrks.Page.Types (Markup(..), PreProcessor(..)) import Data.String (fromString) import Data.Monoid (mempty) import Data.Maybe (fromJust)@@ -27,7 +28,7 @@ submitBug here = do template (fromString "Submit a Report") () <%>- <h1>Submit Report</h1>+ <h1>Submit Bug Report</h1> <% reform (form here) "sbr" addReport Nothing submitForm %> </%> where@@ -39,7 +40,7 @@ submitForm :: BugsForm Bug submitForm =- (fieldset $ ol $+ (divHorizontal $ fieldset $ Bug <$> pure (BugId 0) <*> submittorIdForm <*> nowForm@@ -49,9 +50,16 @@ <*> bugBodyForm <*> pure Set.empty <*> pure Nothing- <* (li $ inputSubmit (pack "submit"))- ) `setAttrs` ["class" := "bugs"]+ <* (divFormActions $ inputSubmit' (pack "submit"))+ ) where+ divFormActions = mapView (\xml -> [<div class="form-actions"><% xml %></div>])+ divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>])+ divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])+ divControls = mapView (\xml -> [<div class="controls"><% xml %></div>])+ inputSubmit' str = inputSubmit str `setAttrs` [("class":="btn")]+ label' str = (label str `setAttrs` [("class":="control-label")])+ submittorIdForm :: BugsForm UserId submittorIdForm = impure (fromJust <$> getUserId) @@ -60,11 +68,11 @@ bugTitleForm :: BugsForm Text bugTitleForm =- (li $ label (pack "Summary:")) ++> (inputText mempty `setAttrs` ["size" := "80"])+ divControlGroup (label' (pack "Summary:") ++> (divControls $ inputText mempty `setAttrs` ["size" := "80", "class" := "input-xxlarge"])) bugBodyForm :: BugsForm Markup bugBodyForm =- (li $ label (pack "Details:")) ++> ((\t -> Markup [HsColour, Markdown] t Untrusted) <$> textarea 80 20 mempty)+ divControlGroup (label' (pack "Details:") ++> (divControls $ (\t -> Markup [HsColour, Markdown] t Untrusted) <$> (textarea 80 20 mempty `setAttrs` [("class" := "input-xxlarge")]))) impure :: (Monoid view, Monad m) => m a -> Form m input error view () a
Clckwrks/Bugs/Page/ViewBug.hs view
@@ -8,6 +8,7 @@ import Clckwrks.Bugs.Types import Clckwrks.Bugs.URL import Clckwrks.Bugs.Page.Template (template)+import Clckwrks.Page.Monad (markupToContent) import Clckwrks.ProfileData.Acid import Data.Maybe (fromMaybe, maybe) import Data.Set (Set)@@ -35,8 +36,10 @@ Nothing -> return (pack "none") Just mid -> fromMaybe (pack $ show mid) <$> query (GetMilestoneTitle mid)+ bugBodyMarkup <- markupToContent bugBody template (fromString $ "Bug #" ++ (show $ unBugId bugId)) () <%>+ <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>@@ -44,7 +47,7 @@ <dt>Status:</dt> <dd><% show bugStatus %></dd> <dt>Milestone:</dt> <dd><% milestoneTxt %></dd> <dt>Title:</dt> <dd><% bugTitle %></dd>- <dt>Body:</dt> <dd><% bugBody %></dd>+ <dt>Body:</dt> <dd><% bugBodyMarkup %></dd> <% whenHasRole (Set.singleton Administrator) <a href=(BugsAdmin (EditBug bugId))>edit</a> %> </dl> </%>
Clckwrks/Bugs/Plugin.hs view
@@ -2,6 +2,7 @@ module Clckwrks.Bugs.Plugin where import Clckwrks+import Clckwrks.Monad (ClckPluginsSt) import Clckwrks.Plugin import Clckwrks.Bugs.URL import Clckwrks.Bugs.Acid@@ -9,7 +10,9 @@ import Clckwrks.Bugs.Monad import Clckwrks.Bugs.Route import Control.Monad.State (get)+import Data.Acid (AcidState) import Data.Acid.Local+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text.Lazy as TL import Data.Maybe (fromMaybe)@@ -30,6 +33,14 @@ flattenURL :: ((url' -> [(Text, Maybe Text)] -> Text) -> (BugsURL -> [(Text, Maybe Text)] -> Text)) flattenURL _ u p = showBugsURL u p +navBarCallback :: AcidState BugsState+ -> (BugsURL -> [(Text, Maybe Text)] -> Text)+ -> 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])+ bugsInit :: ClckPlugins -> IO (Maybe Text) bugsInit plugins =@@ -44,6 +55,7 @@ , bugsClckURL = clckShowFn } addPreProc plugins (bugsCmd bugsShowFn)+ addNavBarCallback plugins (navBarCallback acid bugsShowFn) addHandler plugins (pluginName bugsPlugin) (bugsHandler bugsShowFn bugsConfig) return Nothing @@ -52,14 +64,14 @@ do p <- plugins <$> get (Just showBugsURL) <- getPluginRouteFn p (pluginName bugsPlugin) let editMilestonesURL = showBugsURL (BugsAdmin EditMilestones) []- addAdminMenu ("Bugs", [("Edit Milestones", editMilestonesURL)])+ addAdminMenu ("Bugs", [(Set.fromList [Administrator, Editor], "Edit Milestones", editMilestonesURL)]) -bugsPlugin :: Plugin BugsURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig [TL.Text -> ClckT ClckURL IO TL.Text]+bugsPlugin :: Plugin BugsURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt bugsPlugin = Plugin { pluginName = "bugs" , pluginInit = bugsInit- , pluginDepends = []+ , pluginDepends = ["clck", "page"] , pluginToPathInfo = toPathInfo , pluginPostHook = addBugsAdminMenu }
Clckwrks/Bugs/Types.hs view
@@ -2,6 +2,7 @@ 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)
clckwrks-plugin-bugs.cabal view
@@ -1,5 +1,5 @@ Name: clckwrks-plugin-bugs-Version: 0.3.4+Version: 0.5.1 Synopsis: bug tracking plugin for clckwrks Homepage: http://clckwrks.com/ License: BSD3@@ -43,11 +43,12 @@ base < 5, acid-state >= 0.7, attoparsec == 0.10.*,- clckwrks >= 0.13 && < 0.15,+ clckwrks >= 0.16 && < 0.17,+ clckwrks-plugin-page == 0.1.*, containers >= 0.4 && < 0.6, directory >= 1.1 && < 1.3, filepath >= 1.2 && < 1.4,- happstack-authenticate == 0.9.*,+ happstack-authenticate == 0.10.*, happstack-server >= 7.0 && < 7.2, happstack-hsp == 7.1.*, hsp == 0.7.*,