2014-05-22 03:23:57 +05:30
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
|
2014-06-07 00:50:27 +05:30
|
|
|
module Network.IRC.Handlers.Auth (authMsgHandlerMaker) where
|
2014-05-22 03:23:57 +05:30
|
|
|
|
2014-05-25 01:09:31 +05:30
|
|
|
import qualified Data.UUID as U
|
2014-05-22 03:23:57 +05:30
|
|
|
import qualified Data.UUID.V4 as U
|
|
|
|
|
|
|
|
import ClassyPrelude
|
2014-06-01 23:14:19 +05:30
|
|
|
import Control.Monad.Reader (asks)
|
|
|
|
import Control.Monad.State (get, put)
|
|
|
|
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
|
|
|
|
openLocalState, createArchive)
|
|
|
|
import Data.Acid.Local (createCheckpointAndClose)
|
2014-05-22 03:23:57 +05:30
|
|
|
|
|
|
|
import Network.IRC.Handlers.Auth.Types
|
|
|
|
import Network.IRC.Types
|
2014-05-23 12:21:38 +05:30
|
|
|
import Network.IRC.Util
|
2014-05-22 03:23:57 +05:30
|
|
|
|
2014-05-22 20:59:02 +05:30
|
|
|
-- database
|
2014-05-22 03:23:57 +05:30
|
|
|
|
|
|
|
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
|
2014-05-22 20:59:02 +05:30
|
|
|
mt <- query acid (GetToken user)
|
2014-05-22 03:23:57 +05:30
|
|
|
case mt of
|
|
|
|
Just t -> return t
|
|
|
|
Nothing -> do
|
|
|
|
token <- map (pack . U.toString) U.nextRandom
|
2014-05-22 20:59:02 +05:30
|
|
|
update acid (SaveToken user token)
|
2014-05-22 03:23:57 +05:30
|
|
|
return token
|
|
|
|
|
2014-05-22 20:59:02 +05:30
|
|
|
-- handler
|
|
|
|
|
2014-06-08 04:26:50 +05:30
|
|
|
authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> FullMessage -> m [Command]
|
|
|
|
authMessage state FullMessage { .. }
|
|
|
|
| Just (PrivMsg user msg) <- fromMessage message
|
|
|
|
, "token" `isPrefixOf` msg =
|
|
|
|
map (singleton . toCommand . PrivMsgReply user) . io $ readIORef state >>= flip issueToken (userNick user)
|
2014-06-01 06:48:24 +05:30
|
|
|
authMessage _ _ = return []
|
2014-05-22 03:23:57 +05:30
|
|
|
|
|
|
|
stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m ()
|
2014-05-23 12:21:38 +05:30
|
|
|
stopAuth state = io $ do
|
2014-05-22 20:59:02 +05:30
|
|
|
acid <- readIORef state
|
|
|
|
createArchive acid
|
|
|
|
createCheckpointAndClose acid
|
2014-05-22 03:23:57 +05:30
|
|
|
|
2014-06-08 04:26:50 +05:30
|
|
|
authEvent :: MonadMsgHandler m => IORef (AcidState Auth) -> Event -> m EventResponse
|
2014-05-22 03:23:57 +05:30
|
|
|
authEvent state event = case fromEvent event of
|
2014-05-23 12:21:38 +05:30
|
|
|
Just (AuthEvent user token reply, _) -> io $ do
|
2014-05-22 03:23:57 +05:30
|
|
|
acid <- readIORef state
|
2014-05-22 20:59:02 +05:30
|
|
|
mt <- query acid (GetToken user)
|
2014-05-22 03:23:57 +05:30
|
|
|
case mt of
|
|
|
|
Just t -> putMVar reply (t == token)
|
|
|
|
Nothing -> putMVar reply False
|
|
|
|
return RespNothing
|
2014-05-22 20:59:02 +05:30
|
|
|
_ -> return RespNothing
|
2014-05-22 03:23:57 +05:30
|
|
|
|
2014-06-07 00:50:27 +05:30
|
|
|
authMsgHandlerMaker :: MsgHandlerMaker
|
|
|
|
authMsgHandlerMaker = MsgHandlerMaker "auth" go
|
2014-05-22 20:59:02 +05:30
|
|
|
where
|
2014-06-02 00:26:41 +05:30
|
|
|
helpMsg botNick = "Send a PM to get a new auth token. /msg " ++ nickToText botNick ++ " token"
|
|
|
|
|
|
|
|
go BotConfig { .. } _ "auth" = do
|
|
|
|
state <- io $ openLocalState emptyAuth >>= newIORef
|
|
|
|
return . Just $ newMsgHandler { onMessage = authMessage state
|
|
|
|
, onEvent = authEvent state
|
|
|
|
, onStop = stopAuth state
|
|
|
|
, onHelp = return $ singletonMap "token" (helpMsg botNick) }
|
|
|
|
go _ _ _ = return Nothing
|