module Network.Irc.Messages.Modes
(
umodeToLetter
, umodeFromLetter
, parseUserMode
, cmodeToLetter
, cmodeFromLetter
, parseChannelModeParams
)
where
import Data.Either (isRight)
import Data.Maybe (fromMaybe)
import Data.List (nub, partition)
import Data.Text (Text)
import Data.Tuple (swap)
import Network.Irc.Messages.Internal.Types
import Network.Irc.Types
import Text.Regex.Applicative
import qualified Data.Text as T
userModeMap :: [(UserMode, Char)]
userModeMap =
[ (UModeInvisible, 'i')
, (UModeCallerID, 'g')
, (UModeSeeWallops, 'w')
, (UModeDeaf, 'D')
, (UModeNoForwarding, 'Q')
, (UModeBlockUnidentified, 'R')
, (UModeConnectedViaSSL, 'Z')
, (UModeAway, 'a')
, (UModeRestricted, 'r')
, (UModeOperator, 'o')
, (UModeLocalOperator, 'O')
, (UModeSeeNotices, 's')
]
umodeToLetter :: UserMode -> Char
umodeToLetter (UModeOther c) = c
umodeToLetter um =
fromMaybe
(error "Implementation error: User mode not assigned a letter")
(lookup um userModeMap)
umodeFromLetter :: Char -> UserMode
umodeFromLetter c = fromMaybe (UModeOther c) (lookup c $ map swap userModeMap)
isAsciiLetter :: Char -> Bool
isAsciiLetter c = 'a' <= c && c <= 'z' || 'A' <= c && c <= 'Z'
umode :: Regex ([UserMode], [UserMode])
umode = mix <$> many section
where
section = (,) <$> (True <$ sym '+' <|> False <$ sym '-')
<*> (nub <$> many (psym isAsciiLetter))
mix l =
let (add, remove) = partition fst l
add' = nub $ concatMap snd add
remove' = nub $ concatMap snd remove
in (map umodeFromLetter remove', map umodeFromLetter add')
parseUserMode :: Text -> Maybe ([UserMode], [UserMode])
parseUserMode = match umode . T.unpack
channelModeMap :: [(ChannelMode, Char, ChannelModeType)]
channelModeMap =
[ (CModeCreator, 'O', ModeTypeMaybeSetting)
, (CModeOperator, 'o', ModeTypeSetting)
, (CModeVoice, 'v', ModeTypeSetting)
, (CModeAnonymous, 'a', ModeTypeFlag)
, (CModeInviteOnly, 'i', ModeTypeFlag)
, (CModeModerated, 'm', ModeTypeFlag)
, (CModeNoMessagesFromOutside, 'n', ModeTypeFlag)
, (CModeQuiet, 'q', ModeTypeFlag)
, (CModePrivate, 'p', ModeTypeFlag)
, (CModeSecret, 's', ModeTypeFlag)
, (CModeServerReop, 'r', ModeTypeFlag)
, (CModeTopicSettableByChannelOpOnly, 't', ModeTypeFlag)
, (CModeKey Nothing, 'k', ModeTypeFlag)
, (CModeUserLimit Nothing, 'l', ModeTypeMaybeSetting)
, (CModeBanMask Nothing, 'b', ModeTypeList)
, (CModeExceptionMask Nothing, 'e', ModeTypeList)
, (CModeInvitationMask Nothing, 'I', ModeTypeList)
]
freenodeOverride :: [(ChannelMode, Char, ChannelModeType)]
freenodeOverride =
[ (CModeFreenodeQuiet Nothing, 'q', ModeTypeSetting)
]
lookupCLetter
:: ChannelMode
-> [(ChannelMode, Char, ChannelModeType)]
-> Maybe Char
lookupCLetter _ [] = Nothing
lookupCLetter q ((m, l, _t):rest) =
if q == m
then Just l
else lookupCLetter q rest
cmodeToLetter :: ChannelMode -> Bool -> Char
cmodeToLetter (CModeOther c _) _ = c
cmodeToLetter cm freenode =
let m =
if freenode
then freenodeOverride ++ channelModeMap
else channelModeMap
in fromMaybe
(error "Implementation error: Channel mode not assigned a letter")
(lookupCLetter cm m)
lookupCMode
:: Char
-> [(ChannelMode, Char, ChannelModeType)]
-> Maybe ChannelMode
lookupCMode _ [] = Nothing
lookupCMode c ((m, l, _):rest) = if c == l then Just m else lookupCMode c rest
cmodeFromLetter :: Char -> Bool -> ChannelMode
cmodeFromLetter c freenode =
let m =
if freenode
then freenodeOverride ++ channelModeMap
else channelModeMap
in fromMaybe (CModeOther c []) (lookupCMode c m)
parseChannelModeParams :: [Text]
-> Bool
-> Maybe
( [ChannelMode]
, [ChannelMode]
, [ChannelMode]
)
parseChannelModeParams l _freenode =
let _l' = map f l
f t =
case match section $ T.unpack t of
Just sect -> Right sect
Nothing -> Left t
section = (,) <$> optional (True <$ sym '+' <|> False <$ sym '-')
<*> (nub <$> many (psym isAsciiLetter))
_parts [] = Just []
_parts (Left _ : _) = Nothing
_parts (Right (sign, letters) : ss) =
let (args, next) = break isRight ss
in case _parts next of
Nothing -> Nothing
Just pn -> Just $ (sign, letters, args) : pn
in Nothing