(#79) Implement !song command

HyperNerd.cabal

@@ -62,6 +62,7 @@ executable HyperNerd
   other-modules:       Bot
                      , Bot.BttvFfz
                      , Bot.CustomCommand
+                     , Bot.Dubtrack
                      , Bot.Links
                      , Bot.Log
                      , Bot.Periodic

src/Bot.hs

@@ -3,6 +3,7 @@ module Bot (Bot, bot, Event(..), Sender(..), TwitchStream(..)) where
 
 import           Bot.BttvFfz
 import           Bot.CustomCommand
+import           Bot.Dubtrack
 import           Bot.Log
 import           Bot.Periodic
 import           Bot.Poll
@@ -66,8 +67,13 @@ builtinCommands =
                                                         $ regexArgsCommand "([a-zA-Z0-9]+) ?(.*)"
                                                         $ pairArgsCommand
                                                         $ updateCustomCommand builtinCommands))
+               , ("song", ("Print currently playing song", noArgsCommand currentSongCommand))
                ]
 
+noArgsCommand :: CommandHandler () -> CommandHandler a
+noArgsCommand commandHandler sender _ =
+    commandHandler sender ()
+
 authorizeCommand :: [T.Text] -> CommandHandler a -> CommandHandler a
 authorizeCommand authorizedPeople commandHandler sender args =
     if senderName sender `elem` authorizedPeople

src/Bot/Dubtrack.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+module Bot.Dubtrack where
+
+import           Bot.Replies
+import           Command
+import           Data.Aeson
+import           Data.Aeson.Types
+import qualified Data.Text as T
+import           Effect
+import           Network.HTTP.Simple
+import           Text.Printf
+
+data SongType = SongTypeYoutube
+              | SongTypeSoundcloud
+                deriving Show
+
+instance FromJSON SongType where
+    parseJSON (String "youtube") = return SongTypeYoutube
+    parseJSON (String "soundcloud") = return SongTypeSoundcloud
+    parseJSON invalid = typeMismatch "SongType" invalid
+
+data Song = Song { songId :: T.Text
+                 , songType :: SongType
+                 , songFkId :: T.Text
+                 , songName :: T.Text
+                 } deriving Show
+
+instance FromJSON Song where
+    parseJSON (Object v) = Song
+        <$> v .: "songid"
+        <*> v .: "type"
+        <*> v .: "fkid"
+        <*> v .: "name"
+    parseJSON invalid = typeMismatch "Song" invalid
+
+newtype Room = Room { roomCurrentSong :: Maybe Song } deriving Show
+
+instance FromJSON Room where
+    parseJSON (Object v) = Room <$> v .: "currentSong"
+    parseJSON invalid = typeMismatch "Room" invalid
+
+data DubtrackResponse a =
+    DubtrackResponse { drCode :: Int
+                     , drMessage :: T.Text
+                     , drData :: a
+                     }
+
+instance FromJSON a => FromJSON (DubtrackResponse a) where
+    parseJSON (Object v) = DubtrackResponse
+        <$> v .: "code"
+        <*> v .: "message"
+        <*> v .: "data"
+    parseJSON invalid = typeMismatch "DubtrackResponse" invalid
+
+songLink :: Song -> T.Text
+songLink song@(songType -> SongTypeYoutube) =
+    T.pack $ printf "https://www.youtube.com/watch?v=%s" $ songFkId song
+-- TODO(#220): Soundcloud links are not supported yet
+songLink (songType -> SongTypeSoundcloud) =
+    "Soundcloud links are not supported yet"
+songLink _ = error "This should never happen Kappa"
+
+currentSongCommand :: CommandHandler ()
+currentSongCommand sender _ =
+    -- TODO(#221): Dubtrack room is hardcode
+    do request <- parseRequest "https://api.dubtrack.fm/room/tsoding"
+       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 $ T.pack $ printf "%s: %s" (songName song) (songLink song))
+                   (roomCurrentSong $ drData dubtrackResponse)