Added Auth handler
parent
cb40b9c4d3
commit
5cef08de36
|
@ -7,3 +7,5 @@ config.cfg
|
||||||
*sublime*
|
*sublime*
|
||||||
logs
|
logs
|
||||||
stats
|
stats
|
||||||
|
state
|
||||||
|
TODO
|
||||||
|
|
|
@ -7,6 +7,7 @@ module Network.IRC.Handlers (coreMsgHandlerNames, mkMsgHandler) where
|
||||||
|
|
||||||
import qualified Network.IRC.Handlers.MessageLogger as L
|
import qualified Network.IRC.Handlers.MessageLogger as L
|
||||||
import qualified Network.IRC.Handlers.SongSearch as SS
|
import qualified Network.IRC.Handlers.SongSearch as SS
|
||||||
|
import qualified Network.IRC.Handlers.Auth as A
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
import Control.Concurrent.Lifted (Chan)
|
import Control.Concurrent.Lifted (Chan)
|
||||||
|
@ -31,7 +32,7 @@ mkMsgHandler _ _ "pingpong" = do
|
||||||
return . Just $ newMsgHandler { onMessage = pingPong state }
|
return . Just $ newMsgHandler { onMessage = pingPong state }
|
||||||
|
|
||||||
mkMsgHandler botConfig eventChan name =
|
mkMsgHandler botConfig eventChan name =
|
||||||
flip (`foldM` Nothing) [L.mkMsgHandler, SS.mkMsgHandler] $ \acc h ->
|
flip (`foldM` Nothing) [L.mkMsgHandler, SS.mkMsgHandler, A.mkMsgHandler] $ \acc h ->
|
||||||
case acc of
|
case acc of
|
||||||
Just _ -> return acc
|
Just _ -> return acc
|
||||||
Nothing -> h botConfig eventChan name
|
Nothing -> h botConfig eventChan name
|
||||||
|
|
|
@ -0,0 +1,80 @@
|
||||||
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
|
module Network.IRC.Handlers.Auth (mkMsgHandler) where
|
||||||
|
|
||||||
|
import qualified Data.UUID as U
|
||||||
|
import qualified Data.UUID.V4 as U
|
||||||
|
|
||||||
|
import ClassyPrelude
|
||||||
|
import Control.Concurrent.Lifted (Chan)
|
||||||
|
import Control.Monad.Reader (asks)
|
||||||
|
import Control.Monad.State (get, put)
|
||||||
|
import Data.Acid (AcidState, Query, Update, makeAcidic, openLocalState)
|
||||||
|
import Data.Acid.Advanced (query', update')
|
||||||
|
import Data.Acid.Local (createCheckpointAndClose)
|
||||||
|
import Data.SafeCopy (base, deriveSafeCopy)
|
||||||
|
|
||||||
|
import Network.IRC.Handlers.Auth.Types
|
||||||
|
import Network.IRC.Types
|
||||||
|
|
||||||
|
emptyAuth :: Auth
|
||||||
|
emptyAuth = Auth mempty
|
||||||
|
|
||||||
|
$(deriveSafeCopy 0 'base ''Auth)
|
||||||
|
|
||||||
|
getToken :: Nick -> Query Auth (Maybe Token)
|
||||||
|
getToken user = lookup user <$> asks auth
|
||||||
|
|
||||||
|
saveToken :: Nick -> Token -> Update Auth ()
|
||||||
|
saveToken user token = get >>= put . Auth . insertMap user token . auth
|
||||||
|
|
||||||
|
deleteToken :: Nick -> Update Auth ()
|
||||||
|
deleteToken user = get >>= put . Auth . deleteMap user . auth
|
||||||
|
|
||||||
|
$(makeAcidic ''Auth ['getToken, 'saveToken, 'deleteToken])
|
||||||
|
|
||||||
|
issueToken :: AcidState Auth -> Nick -> IO Token
|
||||||
|
issueToken acid user = do
|
||||||
|
mt <- query' acid (GetToken user)
|
||||||
|
case mt of
|
||||||
|
Just t -> return t
|
||||||
|
Nothing -> do
|
||||||
|
token <- map (pack . U.toString) U.nextRandom
|
||||||
|
update' acid (SaveToken user token)
|
||||||
|
return token
|
||||||
|
|
||||||
|
authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message -> m (Maybe Command)
|
||||||
|
authMessage state PrivMsg { .. }
|
||||||
|
| "token" `isPrefixOf` msg = liftIO $ do
|
||||||
|
acid <- readIORef state
|
||||||
|
token <- issueToken acid (userNick user)
|
||||||
|
return . Just $ PrivMsgReply user token
|
||||||
|
authMessage _ _ = return Nothing
|
||||||
|
|
||||||
|
stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m ()
|
||||||
|
stopAuth state = liftIO $ readIORef state >>= createCheckpointAndClose
|
||||||
|
|
||||||
|
authEvent :: MonadMsgHandler m => IORef (AcidState Auth) -> SomeEvent -> m EventResponse
|
||||||
|
authEvent state event = case fromEvent event of
|
||||||
|
Just (AuthEvent user token reply, _) -> liftIO $ do
|
||||||
|
acid <- readIORef state
|
||||||
|
mt <- query' acid (GetToken user)
|
||||||
|
case mt of
|
||||||
|
Just t -> putMVar reply (t == token)
|
||||||
|
Nothing -> putMVar reply False
|
||||||
|
return RespNothing
|
||||||
|
_ -> return RespNothing
|
||||||
|
|
||||||
|
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
|
||||||
|
mkMsgHandler _ _ "auth" = do
|
||||||
|
state <- liftIO (openLocalState emptyAuth >>= newIORef)
|
||||||
|
return . Just $ newMsgHandler { onMessage = authMessage state
|
||||||
|
, onEvent = authEvent state
|
||||||
|
, onStop = stopAuth state }
|
||||||
|
mkMsgHandler _ _ _ = return Nothing
|
|
@ -0,0 +1,17 @@
|
||||||
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
|
module Network.IRC.Handlers.Auth.Types where
|
||||||
|
|
||||||
|
import ClassyPrelude
|
||||||
|
import Data.Data (Data)
|
||||||
|
|
||||||
|
import Network.IRC.Types hiding (user)
|
||||||
|
|
||||||
|
type Token = Text
|
||||||
|
newtype Auth = Auth { auth :: Map Nick Token } deriving (Eq, Show, Data, Typeable)
|
||||||
|
|
||||||
|
data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Typeable)
|
||||||
|
instance Event AuthEvent
|
||||||
|
instance Show AuthEvent where
|
||||||
|
show (AuthEvent user token _) = "AuthEvent[" ++ unpack user ++ ", " ++ unpack token ++ "]"
|
|
@ -60,6 +60,6 @@ lineFromCommand BotConfig { .. } command = case command of
|
||||||
JoinCmd -> Just $ "JOIN " ++ channel
|
JoinCmd -> Just $ "JOIN " ++ channel
|
||||||
QuitCmd -> Just "QUIT"
|
QuitCmd -> Just "QUIT"
|
||||||
ChannelMsgReply { .. } -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg
|
ChannelMsgReply { .. } -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg
|
||||||
PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ botNick ++ " :" ++ rmsg
|
PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ userNick ++ " :" ++ rmsg
|
||||||
NamesCmd -> Just $ "NAMES " ++ channel
|
NamesCmd -> Just $ "NAMES " ++ channel
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
|
@ -2,7 +2,7 @@ server = "irc.freenode.net"
|
||||||
port = 6667
|
port = 6667
|
||||||
channel = "#testtesttest"
|
channel = "#testtesttest"
|
||||||
nick = "haskman"
|
nick = "haskman"
|
||||||
msghandlers = ["greeter", "welcomer", "songsearch"]
|
msghandlers = ["greeter", "welcomer", "songsearch", "auth"]
|
||||||
|
|
||||||
songsearch {
|
songsearch {
|
||||||
tinysong_apikey = "xxxyyyzzz"
|
tinysong_apikey = "xxxyyyzzz"
|
||||||
|
|
|
@ -69,7 +69,11 @@ library
|
||||||
unix >=2.7,
|
unix >=2.7,
|
||||||
convertible >=1.1,
|
convertible >=1.1,
|
||||||
hslogger >=1.2.4,
|
hslogger >=1.2.4,
|
||||||
hslogger-template >=2.0
|
hslogger-template >=2.0,
|
||||||
|
ixset >=1.0,
|
||||||
|
acid-state >=0.12,
|
||||||
|
safecopy >=0.8,
|
||||||
|
uuid >=1.3
|
||||||
|
|
||||||
exposed-modules: Network.IRC.Types, Network.IRC.Protocol,
|
exposed-modules: Network.IRC.Types, Network.IRC.Protocol,
|
||||||
Network.IRC.Handlers, Network.IRC.Client
|
Network.IRC.Handlers, Network.IRC.Client
|
||||||
|
@ -108,7 +112,11 @@ executable hask-irc
|
||||||
unix >=2.7,
|
unix >=2.7,
|
||||||
convertible >=1.1,
|
convertible >=1.1,
|
||||||
hslogger >=1.2.4,
|
hslogger >=1.2.4,
|
||||||
hslogger-template >=2.0
|
hslogger-template >=2.0,
|
||||||
|
ixset >=1.0,
|
||||||
|
acid-state >=0.12,
|
||||||
|
safecopy >=0.8,
|
||||||
|
uuid >=1.3
|
||||||
|
|
||||||
-- Directories containing source files.
|
-- Directories containing source files.
|
||||||
-- hs-source-dirs:
|
-- hs-source-dirs:
|
||||||
|
|
Loading…
Reference in New Issue