module Clckwrks.Bugs.Plugin where
import Clckwrks
import Clckwrks.Monad (ClckPluginsSt)
import Clckwrks.Plugin
import Clckwrks.Bugs.URL
import Clckwrks.Bugs.Acid
import Clckwrks.Bugs.PreProcess (bugsCmd)
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)
import System.FilePath ((</>))
import Web.Plugins.Core (Plugin(..), When(Always), addCleanup, addHandler, getConfig, getPluginRouteFn, initPlugin)
bugsHandler :: (BugsURL -> [(Text, Maybe Text)] -> Text)
-> BugsConfig
-> ClckPlugins
-> [Text]
-> ClckT ClckURL (ServerPartT IO) Response
bugsHandler showBugsURL bugsConfig plugins paths =
case parseSegments fromPathSegments paths of
(Left e) -> notFound $ toResponse (show e)
(Right u) ->
ClckT $ withRouteT flattenURL $ unClckT $ runBugsT bugsConfig $ routeBugs u
where
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 [] }
bugListLink = NamedLink { namedLinkTitle = "Bug List", namedLinkURL = showBugsURL BugList [] }
return ("Bugs", [submitLink, timelineLink, bugListLink])
bugsInit :: ClckPlugins
-> IO (Maybe Text)
bugsInit plugins =
do (Just bugsShowFn) <- getPluginRouteFn plugins (pluginName bugsPlugin)
(Just clckShowFn) <- getPluginRouteFn plugins (pluginName clckPlugin)
mTopDir <- clckTopDir <$> getConfig plugins
let basePath = maybe "_state" (\td -> td </> "_state") mTopDir
acid <- openLocalStateFrom (basePath </> "bugs") initialBugsState
addCleanup plugins Always (createCheckpointAndClose acid)
let bugsConfig = BugsConfig { bugsDirectory = "bugs-dir"
, bugsState = acid
, bugsClckURL = clckShowFn
}
addPreProc plugins (bugsCmd bugsShowFn)
addNavBarCallback plugins (navBarCallback acid bugsShowFn)
addHandler plugins (pluginName bugsPlugin) (bugsHandler bugsShowFn bugsConfig)
return Nothing
addBugsAdminMenu :: ClckT url IO ()
addBugsAdminMenu =
do p <- plugins <$> get
(Just showBugsURL) <- getPluginRouteFn p (pluginName bugsPlugin)
let editMilestonesURL = showBugsURL (BugsAdmin EditMilestones) []
addAdminMenu ("Bugs", [(Set.fromList [Administrator, Editor], "Edit Milestones", editMilestonesURL)])
bugsPlugin :: Plugin BugsURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt
bugsPlugin = Plugin
{ pluginName = "bugs"
, pluginInit = bugsInit
, pluginDepends = ["clck", "page"]
, pluginToPathInfo = toPathInfo
, pluginPostHook = addBugsAdminMenu
}
plugin :: ClckPlugins
-> Text
-> IO (Maybe Text)
plugin plugins baseURI =
initPlugin plugins baseURI bugsPlugin