From 5cef08de36de5aec58e44db0acec80fc63700957 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Thu, 22 May 2014 03:23:57 +0530 Subject: [PATCH] Added Auth handler --- .gitignore | 2 + Network/IRC/Handlers.hs | 3 +- Network/IRC/Handlers/Auth.hs | 80 ++++++++++++++++++++++++++++++ Network/IRC/Handlers/Auth/Types.hs | 17 +++++++ Network/IRC/Protocol.hs | 2 +- config.cfg.template | 2 +- hask-irc.cabal | 12 ++++- 7 files changed, 113 insertions(+), 5 deletions(-) create mode 100644 Network/IRC/Handlers/Auth.hs create mode 100644 Network/IRC/Handlers/Auth/Types.hs diff --git a/.gitignore b/.gitignore index 5d08e77..670b628 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,5 @@ config.cfg *sublime* logs stats +state +TODO diff --git a/Network/IRC/Handlers.hs b/Network/IRC/Handlers.hs index b9e225d..2d23179 100644 --- a/Network/IRC/Handlers.hs +++ b/Network/IRC/Handlers.hs @@ -7,6 +7,7 @@ module Network.IRC.Handlers (coreMsgHandlerNames, mkMsgHandler) where import qualified Network.IRC.Handlers.MessageLogger as L import qualified Network.IRC.Handlers.SongSearch as SS +import qualified Network.IRC.Handlers.Auth as A import ClassyPrelude import Control.Concurrent.Lifted (Chan) @@ -31,7 +32,7 @@ mkMsgHandler _ _ "pingpong" = do return . Just $ newMsgHandler { onMessage = pingPong state } 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 Just _ -> return acc Nothing -> h botConfig eventChan name diff --git a/Network/IRC/Handlers/Auth.hs b/Network/IRC/Handlers/Auth.hs new file mode 100644 index 0000000..f070b0e --- /dev/null +++ b/Network/IRC/Handlers/Auth.hs @@ -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 diff --git a/Network/IRC/Handlers/Auth/Types.hs b/Network/IRC/Handlers/Auth/Types.hs new file mode 100644 index 0000000..9a0c8df --- /dev/null +++ b/Network/IRC/Handlers/Auth/Types.hs @@ -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 ++ "]" diff --git a/Network/IRC/Protocol.hs b/Network/IRC/Protocol.hs index 7732c9a..97e28ea 100644 --- a/Network/IRC/Protocol.hs +++ b/Network/IRC/Protocol.hs @@ -60,6 +60,6 @@ lineFromCommand BotConfig { .. } command = case command of JoinCmd -> Just $ "JOIN " ++ channel QuitCmd -> Just "QUIT" ChannelMsgReply { .. } -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg - PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ botNick ++ " :" ++ rmsg + PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ userNick ++ " :" ++ rmsg NamesCmd -> Just $ "NAMES " ++ channel _ -> Nothing diff --git a/config.cfg.template b/config.cfg.template index 1f7cdcc..4c55da9 100644 --- a/config.cfg.template +++ b/config.cfg.template @@ -2,7 +2,7 @@ server = "irc.freenode.net" port = 6667 channel = "#testtesttest" nick = "haskman" -msghandlers = ["greeter", "welcomer", "songsearch"] +msghandlers = ["greeter", "welcomer", "songsearch", "auth"] songsearch { tinysong_apikey = "xxxyyyzzz" diff --git a/hask-irc.cabal b/hask-irc.cabal index 5017912..7d84628 100644 --- a/hask-irc.cabal +++ b/hask-irc.cabal @@ -69,7 +69,11 @@ library unix >=2.7, convertible >=1.1, 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, Network.IRC.Handlers, Network.IRC.Client @@ -108,7 +112,11 @@ executable hask-irc unix >=2.7, convertible >=1.1, 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. -- hs-source-dirs: