tools/ubot-plugins/hs-echo/app/Main.hs
author sheepluva
Tue, 22 Jun 2021 22:13:55 +0200
changeset 15824 d5c37e78ab83
parent 15816 7598960819a1
permissions -rw-r--r--
hedgewars-engine (rust): fix "protocol_version" -> "hedgewars_engine_protocol_version" That function/symbol was renamed in ef2fc0210362
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
15816
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
     1
{-# LANGUAGE OverloadedStrings #-}
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
     2
module Main where
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
     3
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
     4
import Text.Megaparsec (Parsec, parseMaybe)
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
     5
import Text.URI
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
     6
import System.Environment (getEnv)
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
     7
import Data.Text (Text, pack, unpack)
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
     8
import Data.Maybe
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
     9
import Control.Monad (when)
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    10
import Network.AMQP
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    11
import qualified Data.ByteString.Lazy.Char8 as BL
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    12
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    13
assert :: String -> Bool -> a -> a
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    14
assert message False x = error message
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    15
assert _ _ x = x
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    16
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    17
unRpack = unpack . unRText
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    18
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    19
main :: IO ()
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    20
main = do
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    21
    amqpUri <- getEnv "AMQP_URL"
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    22
    let uri = fromJust $ parseMaybe (parser :: Parsec Int Text URI) $ pack amqpUri
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    23
    when (uriScheme uri /= mkScheme "amqp") $ error "AMQP_URL environment variable scheme should be amqp"
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    24
    let Right (Authority (Just (UserInfo username (Just password))) rHost maybePort) = uriAuthority uri
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    25
 
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    26
    conn <- openConnection' (unRpack rHost) (fromInteger . toInteger $ fromMaybe 5672 maybePort) "/" (unRText username) (unRText password)
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    27
    chan <- openChannel conn
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    28
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    29
    (queueName, messageCount, consumerCount) <- declareQueue chan newQueue
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    30
    bindQueue chan queueName "irc" "cmd.echo.hedgewars"
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    31
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    32
    -- subscribe to the queue
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    33
    consumeMsgs chan queueName Ack (myCallback chan)
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    34
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    35
    getLine -- wait for keypress
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    36
    closeConnection conn
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    37
    putStrLn "connection closed"
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    38
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    39
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    40
myCallback :: Channel -> (Message,Envelope) -> IO ()
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    41
myCallback chan (msg, env) = do
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    42
    let message = BL.tail . BL.dropWhile (/= '\n') $ msgBody msg
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    43
    putStrLn $ "received message: " ++ (BL.unpack $ message)
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    44
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    45
    publishMsg chan "irc" "say.hedgewars"
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    46
        newMsg {msgBody = message}
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    47
7598960819a1 Add sample ubot plugin written in haskell
unc0rr
parents:
diff changeset
    48
    ackEnv env