Modes.hs

{- This file is part of irc-fun-messages.
 -
 - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- | This module handles user modes and channel modes.
module Network.IRC.Fun.Messages.Modes
    ( -- * User Modes
      umodeToLetter
    , umodeFromLetter
    , parseUserMode
      -- * Channel Modes
    , cmodeToLetter
    , cmodeFromLetter
    , parseChannelModeParams
    )
where

import Data.Either (isRight)
import Data.Maybe (fromMaybe)
import Data.List (nub, partition)
import Data.Tuple (swap)
import Network.IRC.Fun.Messages.Internal.Types
import Text.Regex.Applicative

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 c = 'a' <= c && c <= 'z'  ||  'A' <= c && c <= 'Z'

-- 1 to remove, 2 to add
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')

-- the one from the MODE irc message
parseUserMode :: String -> Maybe ([UserMode], [UserMode])
parseUserMode = match umode

--TODO add modes from https://freenode.net/using_the_network.shtml
-- freenode it the main target anyway...
-- also maybe add a system for server-specific non-standard flags
channelModeMap :: [(ChannelMode, Char, ChannelModeType)]
channelModeMap = --eIbq,k,flj,CFLMPQScgimnprstz -- o and v type B syntax-wise
    [ (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 _ []               = Nothing
lookupCLetter q ((m, l, t):rest) =
    if q == m
        then Just l
        else lookupCLetter q rest

--TODO make the bool=True mean we use the freenode override
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 _ []               = Nothing
lookupCMode c ((m, l, t):rest) = if c == l then Just m else lookupCMode c rest

--TODO make the bool=True mean we use the freenode override
cmodeFromLetter :: Char -> Bool -> ChannelMode
cmodeFromLetter c freenode =
    let m =
            if freenode
                then freenodeOverride ++ channelModeMap
                else channelModeMap
    in  fromMaybe (CModeOther c []) (lookupCMode c m)

-- the one from the MODE irc message
-- http://www.irc.org/tech_docs/005.html
{-
some rules:

A

B

C

suppose we are setting 'l', then:

l       : does nothing
+l      : does nothing
-l      : unsets the mode
l 1000  : sets mode, same as +l 1000
+l 1000 : sets mode
-l 1000 : unsets mode, the 1000 is ignored

D

-}
parseChannelModeParams :: [String]
                       -> Bool -- whether to use freenode override
                       -> Maybe
                       ( [ChannelMode] -- list additions and boolean sets
                       , [ChannelMode] -- list removals and boolean unsets
                       , [ChannelMode] -- setting changes (sets and unsets)
                       )
parseChannelModeParams l freenode =
    let l' = map f l
        -- Tag params, each is either a mode (e.g. +abc) or an arg (e.g. *!*@*)
        f s =
            case match section s of
                Just sect -> Right sect
                Nothing   -> Left s
        section = (,) <$> optional (True <$ sym '+' <|> False <$ sym '-')
                      <*> (nub <$> many (psym isAsciiLetter))
        -- Collect (sign, modes, [arg]) tuples into a list
        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
        -- Attach args to their modes by mode type
        --attach (
    in  Nothing