From 78fc24371a7cd1daec658d8b544567a2fa2b2840 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Sun, 20 Oct 2019 17:21:14 +0200 Subject: [PATCH 01/10] Begin w/ dubtrack --- src/Bot/Dubtrack.hs | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/src/Bot/Dubtrack.hs b/src/Bot/Dubtrack.hs index b4edc50..d45c7c5 100644 --- a/src/Bot/Dubtrack.hs +++ b/src/Bot/Dubtrack.hs @@ -63,6 +63,32 @@ songLink (songType -> SongTypeSoundcloud) = "Soundcloud links are not supported yet" songLink _ = error "This should never happen Kappa" +newtype RoomName = RoomName { unName :: T.Text} +instance IsEntity RoomName where + nameOfEntity Proxy = "RoomName" + toProperties = Map.fromList [ + ("name", PropertyText $ unName reply) + ] + fromProperties = fmap RoomName . extractProperty "name" + +getRoom :: Effect (Entity RoomName) +getRoom = + reply <- listToMaybe <$> selectEntities Proxy (Take 1 All) + case reply of + Just reply' -> return reply' + Nothing -> + createEntity Proxy $ RoomName "tsoding" + +setRoomName :: Reaction Message T.Text +setRoomName = + liftR + (\msg -> do + reply <- getRoom + void $ updateEntityById $ (\a -> a{unName=msg}) <$> reply) $ + cmapR (const "Updated room for dubtrack") $ Reaction replyMessage + + + -- TODO(#221): Dubtrack room is hardcode currentSongCommand :: Reaction Message () currentSongCommand = From e0db68fbc10cd23b73727e56101bde38b8ef19a5 Mon Sep 17 00:00:00 2001 From: "https://jappieklooster.nl" Date: Mon, 21 Oct 2019 22:01:03 +0200 Subject: [PATCH 02/10] Make dubtrack configurable as well --- src/Bot.hs | 1 + src/Bot/Dubtrack.hs | 44 +++++++++++++++++++++++++++++++------------- 2 files changed, 32 insertions(+), 13 deletions(-) diff --git a/src/Bot.hs b/src/Bot.hs index 45aadd3..239d5b6 100644 --- a/src/Bot.hs +++ b/src/Bot.hs @@ -485,6 +485,7 @@ builtinCommands = [ ("link", setNoTrustLinkReplyCommand) , ("command", setNoTrustCommandReplyCommand) ]) + , ("dubtrack", setDubtrack) ])) , ( "version" , mkBuiltinCommand diff --git a/src/Bot/Dubtrack.hs b/src/Bot/Dubtrack.hs index d45c7c5..2e59d3a 100644 --- a/src/Bot/Dubtrack.hs +++ b/src/Bot/Dubtrack.hs @@ -5,11 +5,17 @@ module Bot.Dubtrack where import Bot.Replies +import Control.Monad import Data.Aeson import Data.Aeson.Types +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Proxy as P import qualified Data.Text as T import Effect +import Entity import Network.HTTP.Simple +import Property import Reaction import Text.InterpolatedString.QM import Transport @@ -63,28 +69,28 @@ songLink (songType -> SongTypeSoundcloud) = "Soundcloud links are not supported yet" songLink _ = error "This should never happen Kappa" -newtype RoomName = RoomName { unName :: T.Text} +newtype RoomName = RoomName + { unName :: T.Text + } + instance IsEntity RoomName where - nameOfEntity Proxy = "RoomName" - toProperties = Map.fromList [ - ("name", PropertyText $ unName reply) - ] + nameOfEntity _ = "RoomName" + toProperties reply = Map.fromList [("name", PropertyText $ unName reply)] fromProperties = fmap RoomName . extractProperty "name" getRoom :: Effect (Entity RoomName) -getRoom = - reply <- listToMaybe <$> selectEntities Proxy (Take 1 All) +getRoom = do + reply <- listToMaybe <$> selectEntities (P.Proxy @RoomName) (Take 1 All) case reply of Just reply' -> return reply' - Nothing -> - createEntity Proxy $ RoomName "tsoding" - + Nothing -> createEntity P.Proxy $ RoomName "tsoding" + setRoomName :: Reaction Message T.Text setRoomName = liftR (\msg -> do - reply <- getRoom - void $ updateEntityById $ (\a -> a{unName=msg}) <$> reply) $ + reply <- getRoom + void $ updateEntityById $ (\a -> a {unName = msg}) <$> reply) $ cmapR (const "Updated room for dubtrack") $ Reaction replyMessage @@ -93,7 +99,11 @@ setRoomName = currentSongCommand :: Reaction Message () currentSongCommand = Reaction $ \Message {messageSender = sender} -> do - request <- parseRequest "https://api.dubtrack.fm/room/tsoding" + mahroom <- getRoom + request <- + parseRequest $ + "https://api.dubtrack.fm/room/" <> + T.unpack (unName $ entityPayload mahroom) response <- eitherDecode . getResponseBody <$> httpRequest request case response of Left message -> errorEff $ T.pack message @@ -103,3 +113,11 @@ currentSongCommand = (\song -> replyToSender sender [qms|❝{songName song}❞: {songLink song}|]) (roomCurrentSong $ drData dubtrackResponse) + +setDubtrack :: Reaction Message T.Text +setDubtrack = + liftR + (\msg -> do + reply <- getRoom + void $ updateEntityById $ fmap (\a -> a {unName = msg}) reply) $ + cmapR (const "Updated the dubtrack") $ Reaction replyMessage From 6f7074b2104aa1ed400ab15b61d01c642a71c53a Mon Sep 17 00:00:00 2001 From: "https://jappieklooster.nl" Date: Mon, 21 Oct 2019 22:01:36 +0200 Subject: [PATCH 03/10] Get rid of type application --- src/Bot/Dubtrack.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Bot/Dubtrack.hs b/src/Bot/Dubtrack.hs index 2e59d3a..0897bd9 100644 --- a/src/Bot/Dubtrack.hs +++ b/src/Bot/Dubtrack.hs @@ -80,7 +80,7 @@ instance IsEntity RoomName where getRoom :: Effect (Entity RoomName) getRoom = do - reply <- listToMaybe <$> selectEntities (P.Proxy @RoomName) (Take 1 All) + reply <- listToMaybe <$> selectEntities P.Proxy (Take 1 All) case reply of Just reply' -> return reply' Nothing -> createEntity P.Proxy $ RoomName "tsoding" From df9066cbaa18498ae8ec7c7fe26dd5a930930e2b Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Mon, 21 Oct 2019 22:40:20 +0200 Subject: [PATCH 04/10] Those newlines were part of formatting apparantly --- src/Bot/Dubtrack.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Bot/Dubtrack.hs b/src/Bot/Dubtrack.hs index 0897bd9..159654a 100644 --- a/src/Bot/Dubtrack.hs +++ b/src/Bot/Dubtrack.hs @@ -92,8 +92,6 @@ setRoomName = reply <- getRoom void $ updateEntityById $ (\a -> a {unName = msg}) <$> reply) $ cmapR (const "Updated room for dubtrack") $ Reaction replyMessage - - -- TODO(#221): Dubtrack room is hardcode currentSongCommand :: Reaction Message () From e764aa5f199da48169b5dc4cec3660f06ec5e3c4 Mon Sep 17 00:00:00 2001 From: "https://jappieklooster.nl" Date: Mon, 28 Oct 2019 21:13:51 +0100 Subject: [PATCH 05/10] Better name for dubtrack rooms in database --- src/Bot/Dubtrack.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Bot/Dubtrack.hs b/src/Bot/Dubtrack.hs index 159654a..e0631ca 100644 --- a/src/Bot/Dubtrack.hs +++ b/src/Bot/Dubtrack.hs @@ -74,7 +74,7 @@ newtype RoomName = RoomName } instance IsEntity RoomName where - nameOfEntity _ = "RoomName" + nameOfEntity _ = "DubtrackRoomName" toProperties reply = Map.fromList [("name", PropertyText $ unName reply)] fromProperties = fmap RoomName . extractProperty "name" From e790da7960c9bc9fdb3557b72b3a87bc1b355c3e Mon Sep 17 00:00:00 2001 From: "https://jappieklooster.nl" Date: Mon, 28 Oct 2019 21:17:00 +0100 Subject: [PATCH 06/10] Remove name cause it's weird for an entitiy --- src/Bot/Dubtrack.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Bot/Dubtrack.hs b/src/Bot/Dubtrack.hs index e0631ca..d1f4cf3 100644 --- a/src/Bot/Dubtrack.hs +++ b/src/Bot/Dubtrack.hs @@ -74,7 +74,7 @@ newtype RoomName = RoomName } instance IsEntity RoomName where - nameOfEntity _ = "DubtrackRoomName" + nameOfEntity _ = "DubtrackRoom" toProperties reply = Map.fromList [("name", PropertyText $ unName reply)] fromProperties = fmap RoomName . extractProperty "name" From 7bbf2b854d405dca1f4d36f5077152e6cf5f65fb Mon Sep 17 00:00:00 2001 From: "https://jappieklooster.nl" Date: Mon, 28 Oct 2019 21:30:19 +0100 Subject: [PATCH 07/10] Made an error appear if dubtrackroom not set --- src/Bot.hs | 2 +- src/Bot/Dubtrack.hs | 63 +++++++++++++++++++++------------------------ 2 files changed, 30 insertions(+), 35 deletions(-) diff --git a/src/Bot.hs b/src/Bot.hs index 239d5b6..ee23d0a 100644 --- a/src/Bot.hs +++ b/src/Bot.hs @@ -485,7 +485,7 @@ builtinCommands = [ ("link", setNoTrustLinkReplyCommand) , ("command", setNoTrustCommandReplyCommand) ]) - , ("dubtrack", setDubtrack) + , ("dubtrack", setDubtrackRoom) ])) , ( "version" , mkBuiltinCommand diff --git a/src/Bot/Dubtrack.hs b/src/Bot/Dubtrack.hs index d1f4cf3..6a3832c 100644 --- a/src/Bot/Dubtrack.hs +++ b/src/Bot/Dubtrack.hs @@ -78,44 +78,39 @@ instance IsEntity RoomName where toProperties reply = Map.fromList [("name", PropertyText $ unName reply)] fromProperties = fmap RoomName . extractProperty "name" -getRoom :: Effect (Entity RoomName) -getRoom = do - reply <- listToMaybe <$> selectEntities P.Proxy (Take 1 All) - case reply of - Just reply' -> return reply' - Nothing -> createEntity P.Proxy $ RoomName "tsoding" - -setRoomName :: Reaction Message T.Text -setRoomName = +getRoom :: Effect (Maybe (Entity RoomName)) +getRoom = + listToMaybe <$> selectEntities P.Proxy (Take 1 All) + +setDubtrackRoom :: Reaction Message T.Text +setDubtrackRoom = liftR (\msg -> do - reply <- getRoom - void $ updateEntityById $ (\a -> a {unName = msg}) <$> reply) $ - cmapR (const "Updated room for dubtrack") $ Reaction replyMessage + mayReply <- getRoom + case mayReply of + Just reply -> void $ updateEntityById $ (\a -> a {unName = msg}) <$> reply + Nothing -> void $ createEntity P.Proxy $ RoomName msg + ) $ cmapR (const "Updated room for dubtrack") $ Reaction replyMessage -- TODO(#221): Dubtrack room is hardcode currentSongCommand :: Reaction Message () currentSongCommand = Reaction $ \Message {messageSender = sender} -> do - mahroom <- getRoom - request <- - parseRequest $ - "https://api.dubtrack.fm/room/" <> - T.unpack (unName $ entityPayload mahroom) - response <- eitherDecode . getResponseBody <$> httpRequest request - case response of - Left message -> errorEff $ T.pack message - Right dubtrackResponse -> - maybe - (replyToSender sender "Nothing is playing right now") - (\song -> - replyToSender sender [qms|❝{songName song}❞: {songLink song}|]) - (roomCurrentSong $ drData dubtrackResponse) - -setDubtrack :: Reaction Message T.Text -setDubtrack = - liftR - (\msg -> do - reply <- getRoom - void $ updateEntityById $ fmap (\a -> a {unName = msg}) reply) $ - cmapR (const "Updated the dubtrack") $ Reaction replyMessage + mayRoom <- getRoom + case mayRoom of + Nothing -> replyToSender sender + "Dubtrack room not set, a mod can run '!config room name' to set it" + Just mahroom -> do + request <- + parseRequest $ + "https://api.dubtrack.fm/room/" <> + T.unpack (unName $ entityPayload mahroom) + response <- eitherDecode . getResponseBody <$> httpRequest request + case response of + Left message -> errorEff $ T.pack message + Right dubtrackResponse -> + maybe + (replyToSender sender "Nothing is playing right now") + (\song -> + replyToSender sender [qms|❝{songName song}❞: {songLink song}|]) + (roomCurrentSong $ drData dubtrackResponse) From 4b88b500692914fac7cbefd750341a91c324d9da Mon Sep 17 00:00:00 2001 From: "https://jappieklooster.nl" Date: Mon, 28 Oct 2019 21:38:51 +0100 Subject: [PATCH 08/10] Message that doesn't lie --- src/Bot/Dubtrack.hs | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/src/Bot/Dubtrack.hs b/src/Bot/Dubtrack.hs index 6a3832c..954f643 100644 --- a/src/Bot/Dubtrack.hs +++ b/src/Bot/Dubtrack.hs @@ -79,8 +79,7 @@ instance IsEntity RoomName where fromProperties = fmap RoomName . extractProperty "name" getRoom :: Effect (Maybe (Entity RoomName)) -getRoom = - listToMaybe <$> selectEntities P.Proxy (Take 1 All) +getRoom = listToMaybe <$> selectEntities P.Proxy (Take 1 All) setDubtrackRoom :: Reaction Message T.Text setDubtrackRoom = @@ -88,9 +87,10 @@ setDubtrackRoom = (\msg -> do mayReply <- getRoom case mayReply of - Just reply -> void $ updateEntityById $ (\a -> a {unName = msg}) <$> reply - Nothing -> void $ createEntity P.Proxy $ RoomName msg - ) $ cmapR (const "Updated room for dubtrack") $ Reaction replyMessage + Just reply -> + void $ updateEntityById $ (\a -> a {unName = msg}) <$> reply + Nothing -> void $ createEntity P.Proxy $ RoomName msg) $ + cmapR (const "Updated room for dubtrack") $ Reaction replyMessage -- TODO(#221): Dubtrack room is hardcode currentSongCommand :: Reaction Message () @@ -98,9 +98,11 @@ currentSongCommand = Reaction $ \Message {messageSender = sender} -> do mayRoom <- getRoom case mayRoom of - Nothing -> replyToSender sender - "Dubtrack room not set, a mod can run '!config room name' to set it" - Just mahroom -> do + Nothing -> + replyToSender + sender + "Dubtrack room not set, a mod can run '!config dubtrack $ROOM_NAME' to set it" + Just mahroom -> do request <- parseRequest $ "https://api.dubtrack.fm/room/" <> @@ -112,5 +114,5 @@ currentSongCommand = maybe (replyToSender sender "Nothing is playing right now") (\song -> - replyToSender sender [qms|❝{songName song}❞: {songLink song}|]) + replyToSender sender [qms|❝{songName song}❞: {songLink song}|]) (roomCurrentSong $ drData dubtrackResponse) From 45e90aa748969ec2de346b00f45f3d85bcdfc239 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Mon, 4 Nov 2019 18:00:27 +0100 Subject: [PATCH 09/10] Fix PR comments --- src/Bot/Dubtrack.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Bot/Dubtrack.hs b/src/Bot/Dubtrack.hs index 954f643..c4fec4d 100644 --- a/src/Bot/Dubtrack.hs +++ b/src/Bot/Dubtrack.hs @@ -69,16 +69,16 @@ songLink (songType -> SongTypeSoundcloud) = "Soundcloud links are not supported yet" songLink _ = error "This should never happen Kappa" -newtype RoomName = RoomName +newtype DubtrackRoom = DubtrackRoom { unName :: T.Text } -instance IsEntity RoomName where +instance IsEntity DubtrackRoom where nameOfEntity _ = "DubtrackRoom" toProperties reply = Map.fromList [("name", PropertyText $ unName reply)] - fromProperties = fmap RoomName . extractProperty "name" + fromProperties = fmap DubtrackRoom . extractProperty "name" -getRoom :: Effect (Maybe (Entity RoomName)) +getRoom :: Effect (Maybe (Entity DubtrackRoom)) getRoom = listToMaybe <$> selectEntities P.Proxy (Take 1 All) setDubtrackRoom :: Reaction Message T.Text @@ -89,10 +89,11 @@ setDubtrackRoom = case mayReply of Just reply -> void $ updateEntityById $ (\a -> a {unName = msg}) <$> reply - Nothing -> void $ createEntity P.Proxy $ RoomName msg) $ + Nothing -> void $ createEntity P.Proxy $ DubtrackRoom msg) $ cmapR (const "Updated room for dubtrack") $ Reaction replyMessage -- TODO(#221): Dubtrack room is hardcode +-- TODO: Rewrite in the Reaction api currentSongCommand :: Reaction Message () currentSongCommand = Reaction $ \Message {messageSender = sender} -> do @@ -101,7 +102,7 @@ currentSongCommand = Nothing -> replyToSender sender - "Dubtrack room not set, a mod can run '!config dubtrack $ROOM_NAME' to set it" + "Dubtrack room not set, a mod can run '!config dubtrack ' to set it" Just mahroom -> do request <- parseRequest $ From c10a24c2384071cd0ce9df36480df0f680f1e6c9 Mon Sep 17 00:00:00 2001 From: rexim Date: Thu, 7 Nov 2019 23:57:53 +0700 Subject: [PATCH 10/10] (#221) Rewrite currentSongCommand with Reaction API --- src/Bot/Dubtrack.hs | 36 ++++++++++++------------------------ 1 file changed, 12 insertions(+), 24 deletions(-) diff --git a/src/Bot/Dubtrack.hs b/src/Bot/Dubtrack.hs index c4fec4d..709cc9e 100644 --- a/src/Bot/Dubtrack.hs +++ b/src/Bot/Dubtrack.hs @@ -14,7 +14,6 @@ import qualified Data.Proxy as P import qualified Data.Text as T import Effect import Entity -import Network.HTTP.Simple import Property import Reaction import Text.InterpolatedString.QM @@ -92,28 +91,17 @@ setDubtrackRoom = Nothing -> void $ createEntity P.Proxy $ DubtrackRoom msg) $ cmapR (const "Updated room for dubtrack") $ Reaction replyMessage --- TODO(#221): Dubtrack room is hardcode --- TODO: Rewrite in the Reaction api currentSongCommand :: Reaction Message () currentSongCommand = - Reaction $ \Message {messageSender = sender} -> do - mayRoom <- getRoom - case mayRoom of - Nothing -> - replyToSender - sender - "Dubtrack room not set, a mod can run '!config dubtrack ' to set it" - Just mahroom -> do - request <- - parseRequest $ - "https://api.dubtrack.fm/room/" <> - T.unpack (unName $ entityPayload mahroom) - response <- eitherDecode . getResponseBody <$> httpRequest request - case response of - Left message -> errorEff $ T.pack message - Right dubtrackResponse -> - maybe - (replyToSender sender "Nothing is playing right now") - (\song -> - replyToSender sender [qms|❝{songName song}❞: {songLink song}|]) - (roomCurrentSong $ drData dubtrackResponse) + liftR (const getRoom) $ + replyOnNothing + [qms|Dubtrack room not set, a mod can run + '!config dubtrack ' to set it|] $ + cmapR (T.unpack . urlOfRoom . entityPayload) $ + jsonHttpRequestReaction $ + cmapR (roomCurrentSong . drData) $ + replyOnNothing "Nothing is playing right now" $ + cmapR (\song -> [qms|❝{songName song}❞: {songLink song}|]) $ + Reaction replyMessage + where + urlOfRoom = ("https://api.dubtrack.fm/room/" <>) . unName