Target.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/>.
 -}

module Network.Irc.Messages.Internal.Tokens.Target
    ( target
    , msgtarget
    , msgto
    , channel
    , servername
    , host
    , nickname
    )
where

import Data.Char (isAsciiUpper)
import Data.Text (Text, pack)
import Network.Irc.Messages.Internal.Tokens.Other
import Network.Irc.Messages.Internal.Tokens.Wildcards
import Network.Irc.Messages.Internal.Types
import Network.Irc.Types
import Text.Regex.Applicative

target :: Regex Target
target = NickTarget <$> nickname <|> ServerTarget <$> servername

msgtarget :: Regex [MessageTarget]
msgtarget = (:) <$> msgto <*> many (sym ',' *> msgto)

msgto :: Regex MessageTarget
msgto = ChannelTarget <$> channel
    <|> uhs <$> user
            <*> optional (sym '%' *> host) <* sym '@'
            <*> servername
    <|> uh <$> user <* sym '%'
           <*> host
    <|> MaskTarget <$> targetmask
    <|> nn <$> nickname
    <|> nuh <$> nickname <* sym '!'
            <*> user <* sym '@'
            <*> host
    where
    uhs u h s = UserTarget Nothing  (Just (UserAddress u h))        (Just s)
    uh  u h   = UserTarget Nothing  (Just (UserAddress u (Just h))) Nothing
    nn  n     = UserTarget (Just n) Nothing                      Nothing
    nuh n u h = UserTarget (Just n) (Just (UserAddress u (Just h))) Nothing

channel :: Regex Channel
channel =
    Channel . pack . snd <$>
    withMatched
    ( (sym '#' <|> sym '+' <|> sym '!' <* channelid <|> sym '&') <*
      chanstring                                                 <*
      optional (sym ':' <* chanstring)
    )

servername :: Regex Hostname
servername = hostname

host :: Regex Host
host =
    HostByAddr  <$> hostaddr
    <|>
    HostByName  <$> hostname
    <|>
    HostCloak   <$> hostcloak

hostname :: Regex Hostname
hostname =
    Hostname . pack . snd <$>
    withMatched (shortname <* many (sym '.' <* shortname))

shortname :: Regex String
shortname =
    snd <$> withMatched
        ( (letter <|> digit) <*
          optional (many (letter <|> digit <|> sym '-') <* (letter <|> digit))
        )

hostaddr :: Regex Address
hostaddr = IPv4 <$> ip4addr <|> IPv6 <$> ip6addr

ip4addr :: Regex Text
ip4addr = pack . snd <$> withMatched (s <* p <* s <* p <* s <* p <* s)
    where
    d = digit
    s = snd <$> withMatched (d  <|>  d <* d  <|>  d <* d <* d)
    p = sym '.'

ip6addr :: Regex Text
ip6addr = pack . snd <$> withMatched (full <|> short <|> v4)
    where
    h = some hexdigit'
    c = sym ':'
    s = h <* many (c <* h)
    full = h <* c <* h <* c <*
           h <* c <* h <* c <*
           h <* c <* h <* c <*
           h <* c <* h
    short = optional s *> string "::" <* optional s
    v4 = string "0:0:0:0:0:" <*
         (string "0" <|> string "FFFF") <*
         sym ':' <*
         ip4addr

hostcloak :: Regex Text
hostcloak =
    pack <$> some (letter <|> digit <|> special <|> psym (`elem` ".-/"))

nickname :: Regex Nickname
nickname =
    Nickname . pack <$>
    ( (:)                                             <$>
      (letter <|> special)                            <*>
      many (letter <|> digit <|> special <|> sym '-')
    )

targetmask :: Regex TargetMask
targetmask = ServerMask <$> (sym '$' *> mask)
         <|> HostMask   <$> (sym '#' *> mask)

chanstring :: Regex String
chanstring = many $ psym (`notElem` "\0\a\r\n ,:")

channelid :: Regex String
channelid = snd <$> withMatched (c *> c *> c *> c *> c)
    where
    c = psym isAsciiUpper <|> digit