By | fr33domlover |
At | 2016-01-23 |
Title | Add puppet system related state |
Description |
Edit file src/Main.hs 33188 → 33188
59 59 , bsSTree = empty
60 60 , bsMemos = ms
61 61 , bsUserOptions = userOpts
62 62 , bsKnownNicks = nicks
63 63 , bsLastMsgTime = M.empty
+ 64 , bsPuppet = M.empty
64 65 }
65 66 66 67 -- | Event detector specification
67 68 matchers =
68 69 [ matchPrefixedCommand
… … … … Edit file src/FunBot/Types.hs 33188 → 33188
204 204 }
205 205 206 206 -- | Per-channel settings
207 207 data ChanSettings = ChanSettings
208 208 { -- | Whether to display URL titles (the default is yes).
- 209 csSayTitles :: Bool
+ 209 csSayTitles :: Bool
210 210 -- | Whether to welcome new users when the channel is quiet.
- 211 , csWelcome :: Bool
+ 211 , csWelcome :: Bool
212 212 -- | Nicks to mention in the welcome message.
- 213 , csFolks :: [Nickname]
+ 213 , csFolks :: [Nickname]
214 214 -- | Email address for async discussions.
- 215 , csEmail :: Text
+ 215 , csEmail :: Text
216 216 -- | Generic key-value mapping intended to refer to URLs by short labels.
- 217 , csLocations :: HashMap LocationLabel Location
+ 217 , csLocations :: HashMap LocationLabel Location
+ 218 -- | Users who can ask the bot to send an arbitrary message in the
+ 219 -- channel. Can be useful but also dangerous, manage with care.
+ 220 , csPuppeteers :: HashSet Nickname
218 221 }
219 222 220 223 -- | User-modifiable bot behavior settings
221 224 data Settings = Settings
222 225 { -- | Maps a host label to Git repo space+name to annoucement details
… … … … 233 236 , stDevHosts :: HashMap DevHost DevHostLabel
234 237 -- | A generic key-value mapping intended to refer to URLs by short
235 238 -- labels. This is a global mapping, and there are also per-channel
236 239 -- mappings in 'ChanSettings'.
237 240 , stLocations :: HashMap LocationLabel Location
+ 241 -- | Users who can ask the bot to send an arbitrary message in an
+ 242 -- arbitrary channel. This gives a lot of power but is also dangerous,
+ 243 -- use with care. There are also per-channel puppeteers, see
+ 244 -- 'ChanSettings'.
+ 245 , stPuppeteers :: HashSet Nickname
238 246 }
239 247 240 248 -- | Alias for the settings option type
241 249 type SettingsOption = Option BotSession
242 250 … … … … 278 286 , bsUserOptions :: HashMap Nickname UserOptions
279 287 -- | Known nicks in channels
280 288 , bsKnownNicks :: HashMap Channel (HashSet Nickname)
281 289 -- | Time of last message per channel.
282 290 , bsLastMsgTime :: HashMap Channel UTCTime
+ 291 -- | Whether puppet mode is enabled for this channel, and by which user.
+ 292 , bsPuppet :: HashMap Channel (Maybe Nickname)
283 293 }
284 294 285 295 -- | Shortcut alias for bot session monad
286 296 type BotSession = Session BotEnv BotState
287 297 … … … … Edit file src/FunBot/Settings/Instances.hs 33188 → 33188
34 34 import Network.IRC.Fun.Bot.State
35 35 import Network.IRC.Fun.Types.Base (Nickname (..))
36 36 37 37 import qualified Data.CaseInsensitive as CI
38 38 import qualified Data.HashMap.Lazy as M
+ 39 import qualified Data.HashSet as S
39 40 import qualified Data.Text as T
40 41 41 42 instance MonadSettings BotSession Settings where
42 43 getSettings = getStateS bsSettings
43 44 … … … … 261 262 ]
262 263 263 264 instance FromJSON ChanSettings where
264 265 parseJSON (Object o) =
265 266 ChanSettings <$>
- 266 o .: "say-titles" <*>
- 267 o .: "welcome" <*>
- 268 (map Nickname <$> o .: "folks") <*>
- 269 o .: "email" <*>
- 270 (M.map Location <$> o .: "locations")
+ 267 o .: "say-titles" <*>
+ 268 o .: "welcome" <*>
+ 269 (map Nickname <$> o .: "folks") <*>
+ 270 o .: "email" <*>
+ 271 (M.map Location <$> o .: "locations") <*>
+ 272 (S.map Nickname <$> o .: "puppeteers")
271 273 parseJSON v = typeMismatch "ChanSettings" v
272 274 273 275 instance ToJSON ChanSettings where
- 274 toJSON (ChanSettings sayTitles welcome folks email locs) = object
+ 276 toJSON (ChanSettings sayTitles welcome folks email locs pts) = object
275 277 [ "say-titles" .= sayTitles
276 278 , "welcome" .= welcome
277 279 , "folks" .= map unNickname folks
278 280 , "email" .= email
279 281 , "locations" .= M.map unLocation locs
+ 282 , "puppeteers" .= S.map unNickname pts
280 283 ]
281 284 282 285 instance FromJSON Settings where
283 286 parseJSON (Object o) =
284 287 Settings <$>
285 288 o .: "repos" <*>
286 289 o .: "feeds" <*>
287 290 o .: "shortcuts" <*>
288 291 o .: "channels" <*>
289 292 (M.map DevHostLabel <$> o .: "dev-hosts") <*>
- 290 (M.map Location <$> o .: "locations")
+ 293 (M.map Location <$> o .: "locations") <*>
+ 294 (S.map Nickname <$> o .: "puppeteers")
291 295 parseJSON v = typeMismatch "Settings" v
292 296 293 297 instance ToJSON Settings where
- 294 toJSON (Settings repos feeds shortcuts channels hosts locs) = object
- 295 [ "repos" .= repos
- 296 , "feeds" .= feeds
- 297 , "shortcuts" .= shortcuts
- 298 , "channels" .= channels
- 299 , "dev-hosts" .= M.map unDevHostLabel hosts
- 300 , "locations" .= M.map unLocation locs
+ 298 toJSON (Settings repos feeds shortcuts channels hosts locs pts) = object
+ 299 [ "repos" .= repos
+ 300 , "feeds" .= feeds
+ 301 , "shortcuts" .= shortcuts
+ 302 , "channels" .= channels
+ 303 , "dev-hosts" .= M.map unDevHostLabel hosts
+ 304 , "locations" .= M.map unLocation locs
+ 305 , "puppeteers" .= S.map unNickname pts
301 306 ]
… … … … Edit file src/FunBot/Settings/Sections/Channels.hs 33188 → 33188
39 39 import Network.IRC.Fun.Bot.State
40 40 import Network.IRC.Fun.Types.Base (Channel (..), Nickname (..))
41 41 42 42 import qualified Data.CaseInsensitive as CI
43 43 import qualified Data.HashMap.Lazy as M
+ 44 import qualified Data.HashSet as S
44 45 import qualified Data.Sequence as Q
45 46 import qualified Data.Text as T
46 47 - 47 defChan = ChanSettings True False [] "(?)" M.empty
+ 48 defChan = ChanSettings True False [] "(?)" M.empty S.empty
48 49 49 50 locationOption chan l@(LocationLabel t) =
50 51 let defl = "(?)"
51 52 getl l sets = fromMaybe defl $ do
52 53 cs <- M.lookup chan $ stChannels sets
… … … … Edit file src/FunBot/Commands/Info.hs 33188 → 33188
227 227 \!delete-shortcut commands, and relevant settings."
228 228 )
229 229 , ( "locations"
230 230 , "TODO ask fr33domlover to write this!"
231 231 )
+ 232 , ( "puppet"
+ 233 , "TODO ask fr33domlover to write this!"
+ 234 )
232 235 ]
233 236 234 237 respondInfo
235 238 :: Maybe Channel
236 239 -> Nickname
… … … …