aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--reaktor2.cabal2
-rw-r--r--src/Data/Text/Extended.hs12
-rw-r--r--src/Prelude/Extended.hs1
-rw-r--r--src/Reaktor.hs42
-rw-r--r--src/Reaktor/Internal.hs17
-rw-r--r--src/Reaktor/Nick.hs27
-rw-r--r--src/Reaktor/Parser.hs25
-rw-r--r--src/Reaktor/Plugins/Mention.hs6
-rw-r--r--src/Reaktor/Plugins/Register.hs22
-rw-r--r--src/Reaktor/Plugins/System.hs42
-rw-r--r--src/Reaktor/Plugins/System/Internal.hs9
11 files changed, 114 insertions, 91 deletions
diff --git a/reaktor2.cabal b/reaktor2.cabal
index aced473..d97cad9 100644
--- a/reaktor2.cabal
+++ b/reaktor2.cabal
@@ -1,5 +1,5 @@
name: reaktor2
-version: 0.1.1
+version: 0.1.2
license: MIT
author: tv <tv@krebsco.de>
maintainer: tv <tv@krebsco.de>
diff --git a/src/Data/Text/Extended.hs b/src/Data/Text/Extended.hs
new file mode 100644
index 0000000..70eef63
--- /dev/null
+++ b/src/Data/Text/Extended.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Data.Text.Extended
+ ( module Data.Text
+ , show
+ ) where
+
+import Data.Text
+import Prelude hiding (show)
+import qualified Prelude
+
+show :: Show a => a -> Text
+show = pack . Prelude.show
diff --git a/src/Prelude/Extended.hs b/src/Prelude/Extended.hs
index 69dc8c8..55bcfe2 100644
--- a/src/Prelude/Extended.hs
+++ b/src/Prelude/Extended.hs
@@ -7,5 +7,6 @@ import Data.ByteString.Char8.Extended as Export (ByteString)
import Data.Default as Export (Default,def)
import Data.HashMap.Lazy as Export (HashMap)
import Data.Maybe as Export (fromMaybe,isJust,isNothing)
+import Data.Text as Export (Text)
import Data.Vector as Export (Vector)
import Prelude as Export
diff --git a/src/Reaktor.hs b/src/Reaktor.hs
index 3f968ac..e35792f 100644
--- a/src/Reaktor.hs
+++ b/src/Reaktor.hs
@@ -10,10 +10,12 @@ module Reaktor
import Blessings
import Control.Concurrent.Extended
import Control.Exception
-import Data.Attoparsec.ByteString.Char8 (feed,parse)
-import Data.Attoparsec.ByteString.Char8 (IResult(Done,Fail,Partial))
+import Data.Attoparsec.Text (feed,parse)
+import Data.Attoparsec.Text (IResult(Done,Fail,Partial))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8.Extended as BS
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.Extended as T
import Data.Foldable (toList)
import Data.Time.Clock.System
import Data.Time.Format
@@ -92,11 +94,11 @@ run Config{..} getPlugins =
putStrLn ""
-logger :: System.IO.Handle -> IO (Blessings ByteString) -> IO ()
+logger :: System.IO.Handle -> IO (Blessings Text) -> IO ()
logger h takeLog = forever $ do
s <- takeLog
let s' = if lastChar s == '\n' then s else s <> Plain "\n"
- System.IO.hPutStr h $ pp $ fmap BS.unpack s'
+ System.IO.hPutStr h $ pp $ fmap T.unpack s'
pinger :: (Message -> IO ()) -> IO ()
pinger aSend = forever $ do
@@ -109,15 +111,19 @@ receiver :: Actions -> (Message -> IO ()) -> IO (Maybe ByteString) -> IO ()
receiver Actions{..} putInMsg sockRecv =
receive ""
where
+ decode :: ByteString -> Text
+ decode = T.decodeUtf8With (\_err _c -> Just '?')
+
+ receive :: Text -> IO ()
receive "" =
sockRecv >>= \case
Nothing -> logErr "EOL"
- Just buf -> receive buf
+ Just buf -> receive (decode buf)
receive buf =
go (parse Parser.message buf)
where
- go :: IResult ByteString Message -> IO ()
+ go :: IResult Text Message -> IO ()
go = \case
Done rest msg -> do
logMsg msg
@@ -126,11 +132,11 @@ receiver Actions{..} putInMsg sockRecv =
p@(Partial _) ->
sockRecv >>= \case
- Nothing -> logErr ("EOF with partial " <> Plain (BS.show p))
- Just msg -> go (feed p msg)
+ Nothing -> logErr ("EOF with partial " <> Plain (T.show p))
+ Just buf' -> go (feed p (decode buf'))
f@(Fail _i _errorContexts _errMessage) ->
- logErr ("failed to parse message: " <> Plain (BS.show f))
+ logErr ("failed to parse message: " <> Plain (T.show f))
logErr s = aLog $ SGR [31,1] ("! receive: " <> s)
@@ -144,7 +150,7 @@ receiver Actions{..} putInMsg sockRecv =
sender :: IO Message -> (ByteString -> IO ()) -> IO ()
sender takeOutMsg sockSend =
- forever $ takeOutMsg >>= sockSend . formatMessage
+ forever $ takeOutMsg >>= sockSend . T.encodeUtf8 . formatMessage
splitter :: [Message -> IO ()] -> IO Message -> IO ()
splitter plugins takeInMsg =
@@ -161,24 +167,24 @@ logMsgFilter = \case
Just (Message p "PRIVMSG" ["NickServ",xs'])
where
check = elem cmd ["IDENTIFY","REGAIN"] && length ws > 2
- ws = BS.words xs
+ ws = T.words xs
(cmd:ws') = ws
(nick:_) = ws'
- xs' = BS.unwords [cmd, nick, "<password>"]
+ xs' = T.unwords [cmd, nick, "<password>"]
msg -> Just msg
-privmsg :: ByteString -> [ByteString] -> Message
+privmsg :: Text -> [Text] -> Message
privmsg msgtarget xs =
- Message Nothing "PRIVMSG" (msgtarget:BS.intercalate " " xs:[])
+ Message Nothing "PRIVMSG" (msgtarget:T.intercalate " " xs:[])
-lastChar :: Blessings ByteString -> Char
-lastChar = BS.last . last . toList
+lastChar :: Blessings Text -> Char
+lastChar = T.last . last . toList
-prefixTimestamp :: Blessings ByteString -> IO (Blessings ByteString)
+prefixTimestamp :: Blessings Text -> IO (Blessings Text)
prefixTimestamp s = do
- t <- SGR [38,5,239] . Plain . BS.pack <$> getTimestamp
+ t <- SGR [38,5,239] . Plain . T.pack <$> getTimestamp
return (t <> " " <> s)
stripSGR :: Blessings a -> Blessings a
diff --git a/src/Reaktor/Internal.hs b/src/Reaktor/Internal.hs
index 48a3f24..e52a347 100644
--- a/src/Reaktor/Internal.hs
+++ b/src/Reaktor/Internal.hs
@@ -6,8 +6,8 @@ module Reaktor.Internal where
import Prelude.Extended
import Blessings
import Data.Aeson
+import qualified Data.Text as T
import Network.Socket as Exports (HostName,ServiceName)
-import qualified Data.ByteString.Char8.Extended as BS
import System.IO
@@ -15,10 +15,10 @@ data Actions = Actions
{ aIsSecure :: Bool
, aSend :: Message -> IO ()
- , aLog :: Blessings ByteString -> IO ()
+ , aLog :: Blessings Text -> IO ()
- , aSetNick :: ByteString -> IO ()
- , aGetNick :: IO ByteString
+ , aSetNick :: Text -> IO ()
+ , aGetNick :: IO Text
}
@@ -26,10 +26,11 @@ data Config = Config
{ cUseTLS :: Bool
, cHostName :: HostName
, cServiceName :: ServiceName
- , cNick :: Maybe ByteString
+ , cNick :: Maybe Text
, cLogHandle :: Handle
, cLogTime :: Bool
}
+ deriving Show
instance Default Config where
def = Config False "irc.r" "6667" Nothing stderr True
@@ -50,15 +51,15 @@ instance FromJSON Config where
tlsPort = "6697"
-data Message = Message (Maybe ByteString) ByteString [ByteString] | Start
+data Message = Message (Maybe Text) Text [Text] | Start
deriving Show
-formatMessage :: Message -> ByteString
+formatMessage :: Message -> Text
formatMessage = \case
Message mb_prefix cmd params ->
maybe "" ((":"<>) . (<>" ")) mb_prefix
<> cmd
- <> BS.concat (map (" "<>) (init params))
+ <> T.concat (map (" "<>) (init params))
<> if null params then "" else " :" <> last params
<> "\r\n"
x -> error ("cannot format " <> show x)
diff --git a/src/Reaktor/Nick.hs b/src/Reaktor/Nick.hs
index 591ea4b..76c98f7 100644
--- a/src/Reaktor/Nick.hs
+++ b/src/Reaktor/Nick.hs
@@ -1,30 +1,31 @@
module Reaktor.Nick where
-import Data.ByteString.Char8.Extended (ByteString)
-import qualified Data.ByteString.Char8.Extended as BS
-import Data.Char (chr)
-import Data.Char (isDigit)
-import System.Random (getStdRandom, randomR)
+import Data.Char (chr)
+import Data.Char (isDigit)
+import qualified Data.Text as T
+import qualified Data.Text.Read as T (decimal)
+import Prelude.Extended
+import System.Random (getStdRandom, randomR)
-getNext :: ByteString -> ByteString
+getNext :: Text -> Text
getNext nick_ = nick'
where
+ splitNick :: Text -> (Text, Int)
splitNick s =
- (prefix, maybe 0 fst (BS.readInt suffix))
+ (prefix, either (const 0) fst (T.decimal suffix))
where
- prefix = BS.take (BS.length s - BS.length suffix) s
- suffix = BS.reverse . BS.takeWhile isDigit . BS.reverse $ s
+ prefix = T.take (T.length s - T.length suffix) s
+ suffix = T.reverse . T.takeWhile isDigit . T.reverse $ s
(nickPrefix, nickSuffix) = splitNick nick_
- nick' = nickPrefix <> (BS.pack . show $ nickSuffix + 1)
+ nick' = nickPrefix <> (T.pack . show $ nickSuffix + 1)
-
-getRandom :: IO ByteString
+getRandom :: IO Text
getRandom = do
h_chr <- getRandomChar nickhead
t_len <- getStdRandom (randomR (4,8)) :: IO Int
t_str <- mapM (const $ getRandomChar nicktail) [1..t_len]
- return $ BS.pack (h_chr:t_str)
+ return $ T.pack (h_chr:t_str)
where
getRandomChar cs = (cs!!) <$> getStdRandom (randomR (0, length cs - 1))
diff --git a/src/Reaktor/Parser.hs b/src/Reaktor/Parser.hs
index 1b358fc..f226ad5 100644
--- a/src/Reaktor/Parser.hs
+++ b/src/Reaktor/Parser.hs
@@ -1,37 +1,36 @@
{-# LANGUAGE OverloadedStrings #-}
module Reaktor.Parser where
+import Prelude.Extended
import Control.Applicative
-import Data.ByteString (ByteString)
-import Data.Attoparsec.ByteString.Char8
---import qualified Data.ByteString.Char8.Extended as BS
-import qualified Data.ByteString.Char8 as BS
+import Data.Attoparsec.Text
import qualified Data.Char
+import qualified Data.Text.Extended as T
import Reaktor.Internal
-prefix :: Parser ByteString
-prefix = BS.pack <$> many (satisfy Data.Char.isAlphaNum <|>
+prefix :: Parser Text
+prefix = T.pack <$> many (satisfy Data.Char.isAlphaNum <|>
satisfy (flip elem (":.-@/!~[]\\`_^{|}" :: String)))
-command :: Parser ByteString
-command = BS.pack <$> many1 (satisfy Data.Char.isAlphaNum)
+command :: Parser Text
+command = T.pack <$> many1 (satisfy Data.Char.isAlphaNum)
nospcrlfcl :: Parser Char
nospcrlfcl =
satisfy (flip notElem ("\NUL\CR\LF :" :: String)) <?> "nospcrlfcl"
-middle :: Parser ByteString
+middle :: Parser Text
middle =
- BS.pack <$> ((:) <$> nospcrlfcl <*> many (char ':' <|> nospcrlfcl))
+ T.pack <$> ((:) <$> nospcrlfcl <*> many (char ':' <|> nospcrlfcl))
<?> "middle"
-trailing :: Parser ByteString
+trailing :: Parser Text
trailing =
- BS.pack <$> many (char ':' <|> char ' ' <|> nospcrlfcl)
+ T.pack <$> many (char ':' <|> char ' ' <|> nospcrlfcl)
<?> "trailing"
-params :: Parser [ByteString]
+params :: Parser [Text]
params = (do
a <- many (char ' ' *> middle)
b <- optional (char ' ' *> char ':' *> trailing)
diff --git a/src/Reaktor/Plugins/Mention.hs b/src/Reaktor/Plugins/Mention.hs
index 379bd38..b3cdbb8 100644
--- a/src/Reaktor/Plugins/Mention.hs
+++ b/src/Reaktor/Plugins/Mention.hs
@@ -4,8 +4,8 @@
module Reaktor.Plugins.Mention (new) where
import Prelude.Extended
-import qualified Data.ByteString.Char8.Extended as BS
import qualified Data.Char
+import qualified Data.Text as T
import Reaktor
@@ -19,5 +19,5 @@ new Actions{..} = do
_ -> return ()
where
isMention nick text =
- not (BS.isPrefixOf (nick <> ":") text) &&
- any (==nick) (BS.splitWith (not . Data.Char.isAlphaNum) text)
+ not (T.isPrefixOf (nick <> ":") text) &&
+ any (==nick) (T.split (not . Data.Char.isAlphaNum) text)
diff --git a/src/Reaktor/Plugins/Register.hs b/src/Reaktor/Plugins/Register.hs
index 0809006..ff420f0 100644
--- a/src/Reaktor/Plugins/Register.hs
+++ b/src/Reaktor/Plugins/Register.hs
@@ -7,15 +7,15 @@ module Reaktor.Plugins.Register where
import Blessings
import Prelude.Extended
import Data.Aeson
-import Data.ByteString.Char8.Extended (ByteString)
-import qualified Data.ByteString.Char8.Extended as BS
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
import qualified Reaktor.Nick as Nick
import Reaktor
import System.Environment (lookupEnv)
data ConfigNickServ = ConfigNickServ
{ cnsPassFile :: FilePath
- , cnsPrefix :: ByteString
+ , cnsPrefix :: Text
}
instance FromJSON ConfigNickServ where
parseJSON = \case
@@ -26,10 +26,10 @@ instance FromJSON ConfigNickServ where
_ -> undefined
data Config = Config
- { cNick :: Maybe ByteString
- , cUser :: Maybe ByteString
- , cReal :: ByteString
- , cChannels :: [ByteString]
+ { cNick :: Maybe Text
+ , cUser :: Maybe Text
+ , cReal :: Text
+ , cChannels :: [Text]
, cNickServ :: Maybe ConfigNickServ
}
instance Default Config where
@@ -54,18 +54,18 @@ new Config{..} Actions{..} = do
regain nick pass = do
aSend (privmsg "NickServ" ["REGAIN", nick, pass])
- channelsArg = BS.intercalate "," cChannels
+ channelsArg = T.intercalate "," cChannels
-- TODO make this similar to privmsg (i.e. don't aSend)
join = do
-- TODO JOIN only if not already joined
-- i.e. not during subsequent nick changes
- unless (BS.null channelsArg) $
+ unless (T.null channelsArg) $
aSend (Message Nothing "JOIN" [channelsArg])
start = do
nick <- maybe aGetNick pure cNick
user <-
- maybe (maybe nick BS.pack <$> lookupEnv "LOGNAME") pure cUser
+ maybe (maybe nick T.pack <$> lookupEnv "LOGNAME") pure cUser
aSetNick nick
aSend (Message Nothing "NICK" [nick])
aSend (Message Nothing "USER" [user, "*", "0", cReal])
@@ -103,7 +103,7 @@ new Config{..} Actions{..} = do
else do
-- TODO do not fail, but disable NicServ
- [pass] <- BS.lines <$> BS.readFile cnsPassFile
+ [pass] <- T.lines <$> T.readFile cnsPassFile
pure $ \case
Start -> start
Message (Just _self) "NICK" (newnick:[]) -> onNick newnick
diff --git a/src/Reaktor/Plugins/System.hs b/src/Reaktor/Plugins/System.hs
index 8154423..f31f640 100644
--- a/src/Reaktor/Plugins/System.hs
+++ b/src/Reaktor/Plugins/System.hs
@@ -9,11 +9,10 @@ import Blessings
import Control.Applicative
import Control.Concurrent (forkIO)
import Control.Exception
-import qualified Data.ByteString.Char8.Extended as BS
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString.Search as BS
import qualified Data.HashMap.Lazy as M
import qualified Data.List as L
+import qualified Data.Text.Extended as T
+import qualified Data.Text.IO as T
import qualified Data.Vector as V
import Prelude.Extended
import Reaktor
@@ -42,7 +41,7 @@ new config@Config{..} actions@Actions{..} = do
_ -> pure ()
-run1 :: Config -> Actions -> Hook -> ByteString -> ByteString -> ByteString -> IO ()
+run1 :: Config -> Actions -> Hook -> Text -> Text -> Text -> IO ()
run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do
nick <- aGetNick
@@ -56,16 +55,16 @@ run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do
Just pat ->
let
result = RE.scan patternRE text
- patternRE = RE.compile pat []
+ patternRE = RE.compile pat [RE.utf8]
in
if null result
then Nothing
else Just ""
Query ->
if
- | BS.isPrefixOf (nick <> ":") text ->
+ | T.isPrefixOf (nick <> ":") text ->
Just (nick <> ":")
- | BS.isPrefixOf "*:" text ->
+ | T.isPrefixOf "*:" text ->
Just "*:"
| isQuery ->
Just ""
@@ -73,7 +72,8 @@ run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do
Nothing
audience = if isQuery then from else msgtarget
- from = BS.takeWhile (/='!') prefix
+
+ from = T.takeWhile (/='!') prefix
-- TODO check if msgtarget is one of our channels?
-- what if our nick has changed?
@@ -82,14 +82,14 @@ run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do
case isActivated of
Just trigger -> do
let
- cmdline = BS.dropWhile (==' ') $ BS.drop (BS.length trigger) text
+ cmdline = T.dropWhile (==' ') $ T.drop (T.length trigger) text
resultPrefix = if isQuery then [] else [from <> ":"]
parseCommandLine' pat s =
if null result then [] else snd (head result)
where
result = RE.scan patternRE s
- patternRE = RE.compile pat []
+ patternRE = RE.compile pat [RE.utf8]
captures =
V.fromList $
@@ -102,7 +102,7 @@ run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do
name =
case hCommand of
Capture i -> fromMaybe "<unnamed>" (capture i)
- CaptureOr Command{..} -> BS.pack $ takeBaseName $ commandPath
+ CaptureOr Command{..} -> T.pack $ takeBaseName $ commandPath
command =
case hCommand of
@@ -110,7 +110,7 @@ run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do
CaptureOr c -> Just c
args =
- map (maybe "" BS.unpack)
+ map (maybe "" T.unpack)
$ L.dropWhileEnd isNothing
-- $ map getArgument hArguments
$ flip map hArguments
@@ -124,7 +124,7 @@ run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do
let
onExit code = do
- let s = BS.show code
+ let s = T.show code
(sig, col) =
if code == ExitSuccess
then (SGR [38,5,235] "* ", SGR [38,5,107])
@@ -133,8 +133,8 @@ run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do
onExcept :: SomeException -> IO ()
onExcept e = do
- let s0 = BS.show e
- s = BL.toStrict $ BS.replace (BS.pack commandPath) name s0
+ let s0 = T.show e
+ s = T.replace (T.pack commandPath) name s0
aLog $ SGR [38,5,235] "! "
<> SGR [31,1] (Plain $ name <> ": " <> s0)
aSend (privmsg audience (resultPrefix <> [s]))
@@ -144,8 +144,8 @@ run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do
onOutLine s = aSend (privmsg audience [s])
extraEnv =
- [ ("_prefix", BS.unpack prefix)
- , ("_from", BS.unpack from)
+ [ ("_prefix", T.unpack prefix)
+ , ("_from", T.unpack from)
]
env =
@@ -171,8 +171,8 @@ fork :: FilePath
-> Maybe FilePath
-> Maybe [(String, String)]
-> String
- -> (ByteString -> IO ())
- -> (ByteString -> IO ())
+ -> (Text -> IO ())
+ -> (Text -> IO ())
-> (ExitCode -> IO ())
-> IO ()
fork path args cwd env input onOutLine onErrLine onExit = do
@@ -196,7 +196,7 @@ fork path args cwd env input onOutLine onErrLine onExit = do
waitForProcess ph >>= onExit
-hWithLines :: Handle -> (ByteString -> IO ()) -> IO ()
+hWithLines :: Handle -> (Text -> IO ()) -> IO ()
hWithLines h f = do
hSetBuffering h LineBuffering
go `finally` hClose h
@@ -204,4 +204,4 @@ hWithLines h f = do
go =
hIsEOF h >>= \case
True -> return ()
- False -> BS.hGetLine h >>= f >> go
+ False -> T.hGetLine h >>= f >> go
diff --git a/src/Reaktor/Plugins/System/Internal.hs b/src/Reaktor/Plugins/System/Internal.hs
index ac707ae..9b1b8de 100644
--- a/src/Reaktor/Plugins/System/Internal.hs
+++ b/src/Reaktor/Plugins/System/Internal.hs
@@ -18,6 +18,7 @@ instance FromJSON a => FromJSON (CaptureOr a) where
-- TODO query means via direct privmsg and <nick>:
data Activate = Always | Match | Query
+ deriving Show
instance FromJSON Activate where
parseJSON = \case
@@ -28,8 +29,9 @@ instance FromJSON Activate where
data Config = Config
{ cWorkDir :: Maybe FilePath
- , cHooks :: HashMap ByteString [Hook]
+ , cHooks :: HashMap Text [Hook]
}
+ deriving Show
instance Default Config where
def = Config Nothing mempty
@@ -46,10 +48,11 @@ data Hook = Hook
{ hActivate :: Activate
, hPattern :: Maybe ByteString
, hCommand :: CaptureOr Command
- , hArguments :: [CaptureOr ByteString]
+ , hArguments :: [CaptureOr Text]
, hWorkDir :: Maybe FilePath
- , hCommands :: HashMap ByteString Command
+ , hCommands :: HashMap Text Command
}
+ deriving Show
instance FromJSON Hook where
parseJSON = \case
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 07:07:59 +0000