diff --git a/src/Bot/CustomCommand.hs b/src/Bot/CustomCommand.hs index d4f85b1..b0fbcf9 100644 --- a/src/Bot/CustomCommand.hs +++ b/src/Bot/CustomCommand.hs @@ -8,11 +8,12 @@ module Bot.CustomCommand , updateCustomCommand , showCustomCommand , timesCustomCommand - , CustomCommand(..) ) where +import Bot.CustomCommandType import Bot.Expr import Bot.Flip +import Bot.Help import Bot.Replies import Command import Control.Monad @@ -32,38 +33,19 @@ import Reaction import Text.InterpolatedString.QM import Transport -data CustomCommand = CustomCommand - { customCommandName :: T.Text - , customCommandMessage :: T.Text - , customCommandTimes :: Int - } - -instance IsEntity CustomCommand where - nameOfEntity _ = "CustomCommand" - toProperties customCommand = - M.fromList - [ ("name", PropertyText $ customCommandName customCommand) - , ("message", PropertyText $ customCommandMessage customCommand) - , ("times", PropertyInt $ customCommandTimes customCommand) - ] - fromProperties properties = - CustomCommand <$> extractProperty "name" properties <*> - extractProperty "message" properties <*> - pure (fromMaybe 0 $ extractProperty "times" properties) - customCommandByName :: T.Text -> MaybeT Effect (Entity CustomCommand) customCommandByName name = MaybeT $ fmap listToMaybe $ selectEntities Proxy $ Filter (PropertyEquals "name" $ PropertyText name) All --- TODO(#815): CRUD custom command should update help page now they're listed there as well. addCustomCommand :: CommandTable -> Reaction Message (T.Text, T.Text) addCustomCommand builtinCommands = - Reaction $ \Message {messageSender = sender, messageContent = (name, message)} -> do - customCommand <- runMaybeT $ customCommandByName name - let builtinCommand = M.lookup name builtinCommands - case (customCommand, builtinCommand) of + Reaction $ \mesg@Message { messageSender = sender + , messageContent = (name, message) + } -> do + res <- refreshHelpAndUnpack builtinCommands (fst <$> mesg) + case res of (Just _, Nothing) -> replyToSender sender [qms|Command '{name}' already exists|] (Nothing, Just _) -> @@ -83,12 +65,21 @@ addCustomCommand builtinCommands = } replyToSender sender [qms|Added command '{name}'|] +refreshHelpAndUnpack :: + CommandTable + -> Message T.Text + -> Effect (Maybe (Entity CustomCommand), Maybe BuiltinCommand) +refreshHelpAndUnpack builtinCommands mesg@Message {messageContent = name} = do + runReaction refreshHelpGistId mesg + customCommand <- runMaybeT $ customCommandByName name + let builtinCommand = M.lookup name builtinCommands + pure (customCommand, builtinCommand) + deleteCustomCommand :: CommandTable -> Reaction Message T.Text deleteCustomCommand builtinCommands = - Reaction $ \Message {messageSender = sender, messageContent = name} -> do - customCommand <- runMaybeT $ customCommandByName name - let builtinCommand = M.lookup name builtinCommands - case (customCommand, builtinCommand) of + Reaction $ \mesg@Message {messageSender = sender, messageContent = name} -> do + res <- refreshHelpAndUnpack builtinCommands mesg + case res of (Just _, Nothing) -> do void $ deleteEntities (Proxy :: Proxy CustomCommand) $ @@ -155,10 +146,11 @@ timesCustomCommand builtinCommands = updateCustomCommand :: CommandTable -> Reaction Message (T.Text, T.Text) updateCustomCommand builtinCommands = - Reaction $ \Message {messageSender = sender, messageContent = (name, message)} -> do - customCommand <- runMaybeT $ customCommandByName name - let builtinCommand = M.lookup name builtinCommands - case (customCommand, builtinCommand) of + Reaction $ \mesg@Message { messageSender = sender + , messageContent = (name, message) + } -> do + res <- refreshHelpAndUnpack builtinCommands (fst <$> mesg) + case res of (Just cmd, Nothing) -> do void $ updateEntityById (replaceCustomCommandMessage message <$> cmd) replyToSender sender [qms|Command '{name}' has been updated|] diff --git a/src/Bot/CustomCommandType.hs b/src/Bot/CustomCommandType.hs new file mode 100644 index 0000000..ab9f540 --- /dev/null +++ b/src/Bot/CustomCommandType.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Moved out of CustomCommand to break dependency cycle: +-- Help depends on this type, but custom commands needs +-- to refresh Help and therefore also this type. +module Bot.CustomCommandType + ( CustomCommand(..) + ) where + +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import Entity +import Property + +data CustomCommand = CustomCommand + { customCommandName :: T.Text + , customCommandMessage :: T.Text + , customCommandTimes :: Int + } + +instance IsEntity CustomCommand where + nameOfEntity _ = "CustomCommand" + toProperties customCommand = + M.fromList + [ ("name", PropertyText $ customCommandName customCommand) + , ("message", PropertyText $ customCommandMessage customCommand) + , ("times", PropertyInt $ customCommandTimes customCommand) + ] + fromProperties properties = + CustomCommand <$> extractProperty "name" properties <*> + extractProperty "message" properties <*> + pure (fromMaybe 0 $ extractProperty "times" properties) diff --git a/src/Bot/Help.hs b/src/Bot/Help.hs index 36ab08b..1a54bfb 100644 --- a/src/Bot/Help.hs +++ b/src/Bot/Help.hs @@ -8,7 +8,7 @@ module Bot.Help , startRefreshHelpGistTimer ) where -import Bot.CustomCommand +import Bot.CustomCommandType import Bot.GitHub import Bot.Replies import Command diff --git a/src/Bot/Poll.hs b/src/Bot/Poll.hs index 568b2a0..36819bf 100644 --- a/src/Bot/Poll.hs +++ b/src/Bot/Poll.hs @@ -204,7 +204,7 @@ currentPollCommand = currentPoll :: Effect (Maybe (Entity Poll)) currentPoll = do currentTime <- now - fmap (listToMaybe . filter (isPollAlive currentTime)) $ + fmap (find (isPollAlive currentTime)) $ selectEntities Proxy $ Take 1 $ SortBy "startedAt" Desc All startPoll :: Sender -> [T.Text] -> Int -> Effect Int diff --git a/src/Schedule.hs b/src/Schedule.hs index 3de88f7..905e0eb 100644 --- a/src/Schedule.hs +++ b/src/Schedule.hs @@ -230,6 +230,5 @@ eventsFrom day schedule@Schedule { scheduleTimezone = timezone nextEvent :: Schedule -> UTCTime -> Either String Event nextEvent schedule timePoint = maybeToEither "No events found" $ - listToMaybe $ - filter ((> timePoint) . eventUTCTime (scheduleTimezone schedule)) $ + find ((> timePoint) . eventUTCTime (scheduleTimezone schedule)) $ eventsFrom (utctDay timePoint) schedule