module Network.Anticiv.Masks where
import Control.Monad
import Control.Monad.State
import Data.Char
import Data.List
import Data.Chatty.Atoms
import Data.Chatty.Hetero
import Network.Anticiv.Monad
import System.Chatty.Misc
class MatchMask mm l | mm -> l where
matchmask :: forall m. MonadAnticiv m => mm -> StateT String m (Maybe l)
verbosemask :: mm -> String
data CatchString = Remaining | RemString | QuotString | ServerHost
data CatchUser = ChannelUser | UserMask
data CatchInt = CatchInt
data Token = Token String | CIToken String | CIString String
newtype Optional a = Optional a
newtype Which a = Which [a]
instance Tuplify Token Token where
tuplify = id
instance MatchMask String Nil where
matchmask t = do
ss <- get
if take (length t) ss == t
then modify (drop $ length t) >> return (Just Nil)
else return Nothing
verbosemask t = "the case sensitive string \""++t++"\""
instance MatchMask Token Nil where
matchmask (Token t) = do
ss <- liftM (takeUntil isSpace . dropWhile isSpace) get
if ss == t
then modify (drop (length ss) . dropWhile isSpace) >> return (Just Nil)
else return Nothing
matchmask (CIToken t) = do
ss <- liftM (takeUntil isSpace . dropWhile isSpace) get
if ss `strEq` t
then modify (drop (length ss) . dropWhile isSpace) >> return (Just Nil)
else return Nothing
matchmask (CIString t) = do
ss <- get
if take (length t) ss `strEq` t
then modify (drop $ length t) >> return (Just Nil)
else return Nothing
verbosemask (Token t) = "the case sensitive token \""++t++"\""
verbosemask (CIToken t) = "the case insensitive token \""++t++"\""
verbosemask (CIString t) = "the case insenstive string \""++t++"\""
takeUntil = takeWhile . (not.)
nickfirstchars = ['A'..'Z'] ++ ['a'..'z'] ++ "_\\`|^"
nicknextchars = nickfirstchars ++ ['0'..'9']
namefirstchars = "~_-" ++ ['A'..'Z'] ++ ['a'..'z']
namenextchars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_-"
hostfirstchars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_-:"
hostnextchars = hostfirstchars ++ "./"
strEq a b = map toLower a == map toLower b
instance MatchMask CatchInt (Cons Int Nil) where
matchmask CatchInt = do
ss <- gets (takeWhile isDigit . dropWhile isSpace)
if null ss
then return Nothing
else do
modify (dropWhile isDigit . dropWhile isSpace)
return $ Just (read ss :-: Nil)
verbosemask CatchInt = "integer"
instance MatchMask CatchString (Cons String Nil) where
matchmask Remaining = do
ss <- get
put []
return $ Just (ss :-: Nil)
matchmask RemString = do
ss <- liftM (dropWhile isSpace) get
if null ss then return Nothing
else if head ss == ':' then put [] >> return (Just (tail ss :-: Nil))
else return Nothing
matchmask QuotString = do
let catchquote [] = Nothing
catchquote ('\"':rs) = Just ("",rs)
catchquote ('\\':'\"':rs)
| Nothing <- catchquote rs = Nothing
| Just (as,rx) <- catchquote rs = Just ('\"':as, rx)
catchquote ('\\':'\\':rs)
| Nothing <- catchquote rs = Nothing
| Just (as,rx) <- catchquote rs = Just ('\\':as, rx)
catchquote (a:rs)
| Nothing <- catchquote rs = Nothing
| Just (as,rx) <- catchquote rs = Just (a:as, rx)
ss <- get
if null ss
then return Nothing
else if head ss /= '\"'
then return Nothing
else
case catchquote ss of
Nothing -> return Nothing
Just (as,rx) -> put rx >> return (Just (as :-: Nil))
matchmask ServerHost = do
ss <- gets (dropWhile isSpace)
if null ss
then return Nothing
else if head ss /= ':'
then return Nothing
else if null (tail ss)
then return Nothing
else if not (head (tail ss) `elem` hostfirstchars)
then return Nothing
else let ho = head (tail ss) : takeWhile (`elem` hostnextchars) (tail $ tail ss)
in modify (drop (length ho) . tail) >> return (Just (ho :-: Nil))
verbosemask Remaining = "free form content"
verbosemask RemString = "colon-introduced string to line end"
verbosemask QuotString = "quoted string"
verbosemask ServerHost = "server host mask starting with a colon"
simul a b k = do
a' <- lift $ a k
b' <- lift $ b k
return (a',b')
instance MatchMask CatchUser (Cons UserA Nil) where
matchmask UserMask = do
let consumeColon = do
ss <- gets (dropWhile isSpace)
if null ss
then return Nothing
else if head ss /= ':'
then return Nothing
else modify (tail . dropWhile isSpace) >> return (Just ())
consumeNick = do
ss <- get
if null ss
then return Nothing
else if not (head ss `elem` nickfirstchars)
then return Nothing
else let nm = head ss : takeWhile (`elem` nicknextchars) (tail ss)
in modify (drop $ length nm) >> return (Just nm)
consumeBang = do
ss <- get
if null ss
then return Nothing
else if head ss /= '!'
then return Nothing
else modify tail >> return (Just ())
consumeName = do
ss <- get
if null ss
then return Nothing
else if not (head ss `elem` namefirstchars)
then return Nothing
else let nm = head ss : takeWhile (`elem` namenextchars) (tail ss)
in modify (drop $ length nm) >> return (Just nm)
consumeAt = do
ss <- get
if null ss
then return Nothing
else if head ss /= '@'
then return Nothing
else modify tail >> return (Just ())
consumeHost = do
ss <- get
if null ss
then return Nothing
else if not (head ss `elem` hostfirstchars)
then return Nothing
else let ho = head ss : takeWhile (`elem` hostnextchars) (tail ss)
in modify (drop $ length ho) >> return (Just ho)
colon <- consumeColon
nick <- consumeNick
bang <- consumeBang
name <- consumeName
at <- consumeAt
host <- consumeHost
let u = do
colon
ni <- nick
bang
na <- name
at
ho <- host
return (User ni na ho 0)
case u of
Nothing -> return Nothing
Just u -> do
us <- lift $ bgets channelUsers
us' <- mapM (getAtom `simul` return) us
a <- lift $ case filter (strEq (userNick u) . userNick . fst) us' of
[] -> do
a <- newAtom
r <- mrandomR (1,40000)
putAtom a u{reauthId=r}
bmodify $ \b -> b{channelUsers=a:channelUsers b}
return a
((k,a):_) -> do
putAtom a u{reauthId=reauthId k}
return a
return (Just (a :-: Nil))
matchmask ChannelUser = do
ss <- liftM (dropWhile isSpace) get
if null ss
then return Nothing
else if not (head ss `elem` nickfirstchars)
then return Nothing
else let nm = head ss : takeWhile (`elem` nicknextchars) (tail ss)
in do
us <- lift $ bgets channelUsers
us' <- mapM (getAtom `simul` return) us
let ux = filter (strEq nm . userNick . fst) us'
if not $ null ux
then do
modify (drop (length nm) . dropWhile isSpace)
return (Just (snd (head ux) :-: Nil))
else return Nothing
verbosemask UserMask = "full user mask starting with a colon"
verbosemask ChannelUser = "a user nick present in this channel"
instance (MatchMask a ar, IntoMaybe ar am, Append am Nil am) => MatchMask (Optional a) am where
matchmask (Optional a) = do
matchmask a >>= \a -> case a of
Nothing -> return $ Just $ tnothing (undefined :: ar)
Just k -> return $ Just $ tjust k
verbosemask (Optional a) = "optionally [" ++ verbosemask a ++ "]"
firstSeq :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe (a,b))
firstSeq _ [] = return Nothing
firstSeq f (p:ps) = f p >>= \c -> case c of
Nothing -> firstSeq f ps
Just k -> return $ Just (p,k)
instance (MatchMask a r,Append (Cons a Nil) r ar) => MatchMask (Which a) ar where
matchmask (Which []) = return Nothing
matchmask (Which ps) = do
ss <- get
firstSeq matchmask ps >>= \c -> case c of
Nothing -> return Nothing
Just (k,r) -> return $ Just (tappend (k :-: Nil) r)
verbosemask (Which []) = "empty choice (you should blame the bot's or module's author)"
verbosemask (Which ps) = unwords $ intersperse "or" $ map verbosemask ps
instance MatchMask Nil Nil where
matchmask Nil = return $ Just Nil
verbosemask _ = "end of mask"
instance (MatchMask x r, MatchMask xs rs, Append r rs rx) => MatchMask (Cons x xs) rx where
matchmask (x :-: xs) = do
l1 <- matchmask x
case l1 of
Nothing -> return Nothing
Just l1 -> do
l2 <- matchmask xs
case l2 of
Nothing -> return Nothing
Just l2 -> return $ Just $ tappend l1 l2
verbosemask (x :-: xs) = verbosemask x ++ ", then " ++ verbosemask x
trymask :: (MatchMask m r,Tuplify r t) => m -> String -> Anticiv (Maybe t)
trymask m s = do
r <- runStateT (matchmask m) s
return $ case r of
(Nothing,_) -> Nothing
(Just a,[]) -> Just $ tuplify a
(Just a,_) -> Nothing
infixr 8 #->
(#->) :: (MatchMask m r, Tuplify r t) => m -> (t -> Anticiv ()) -> String -> Anticiv Bool
mm #-> f = \s -> do
b <- trymask mm s
case b of
Nothing -> return False
Just t -> f t >> return True
infixr 8 #->>
(#->>) :: (MatchMask m r, Tuplify r t) => m -> Anticiv () -> String -> Anticiv Bool
mm #->> f = mm #-> const f
infixr 7 #||
(#||) :: Monad m => m Bool -> m Bool -> m Bool
a #|| b = do
ax <- a
if ax
then return True
else b
infixr 7 .||
(.||) :: Monad m => (a -> m Bool) -> (a -> m Bool) -> (a -> m Bool)
a .|| b = \x -> a x #|| b x
infixl 6 &
(&) = flip ($)