Merge pull request #816 from tsoding/611

(#611) Keep track of how many times a video was suggested

Author: rexim

src/Bot.hs

@@ -505,6 +505,11 @@ builtinCommands =
           ( "Asciify Twitch, BTTV or FFZ emote"
           , $githubLinkLocationStr
           , nonEmptyRoles asciifyReaction))
+    , ( "fridaycount"
+      , mkBuiltinCommand
+          ( "Check how many times a particular video was submitted"
+          , $githubLinkLocationStr
+          , nonEmptyRoles fridayCountCommand))
     ]
 
 nextStreamCommand :: Reaction Message a

src/Bot/Friday.hs

@@ -12,6 +12,7 @@ module Bot.Friday
   , videoQueueCommand
   , startRefreshFridayGistTimer
   , ytLinkId
+  , fridayCountCommand
   ) where
 
 import Bot.GitHub
@@ -98,15 +99,16 @@ instance IsEntity FridayState where
 containsYtLink :: T.Text -> Bool
 containsYtLink = isJust . ytLinkId
 
+ytLinkRegexp :: T.Text
+ytLinkRegexp =
+  "https?:\\/\\/(www\\.)?youtu(be\\.com\\/watch\\?v=|\\.be\\/)([a-zA-Z0-9_-]+)"
+
 ytLinkId :: T.Text -> Maybe T.Text
 ytLinkId text =
   (\case
      [_, _, ytId] -> return ytId
      _ -> Nothing) =<<
-  rightToMaybe
-    (regexParseArgs
-       "https?:\\/\\/(www\\.)?youtu(be\\.com\\/watch\\?v=|\\.be\\/)([a-zA-Z0-9_-]+)"
-       text)
+  rightToMaybe (regexParseArgs ytLinkRegexp text)
 
 fridayCommand :: Reaction Message T.Text
 fridayCommand =
@@ -116,13 +118,31 @@ fridayCommand =
   liftR
     (\msg -> do
        markGistUnfresh
-       createEntity Proxy .
+       void $
+         createEntity Proxy .
          FridayVideo
            (messageContent msg)
            (senderName $ messageSender msg)
            Nothing =<<
-         now) $
-  cmapR (const "Added to the suggestions") $ Reaction replyMessage
+         now
+       return $ messageContent msg) $
+  cmapR ytLinkId $
+  maybeReaction
+    (Reaction $
+     const $
+     logMsg
+       [qms|Could not check friday video
+            duplicates because there is no YouTube
+            id in the message.|]) $
+  liftR
+    (\ytId ->
+       selectEntities (Proxy :: Proxy FridayVideo) $
+       Filter (PropertyTextLike "name" ("%" <> ytId <> "%")) All) $
+  cmapR
+    (\dups ->
+       [qms|Added to the suggested video.
+            This video was suggested {length dups} times|]) $
+  Reaction replyMessage
 
 unwatchedVideos :: Effect [Entity FridayVideo]
 unwatchedVideos =
@@ -302,3 +322,14 @@ videoQueueCommand =
         liftR updateEntityById $
         cmapR (const "Freshness invalidated 👌") $ Reaction replyMessage)
     ]
+
+fridayCountCommand :: Reaction Message T.Text
+fridayCountCommand =
+  cmapR ytLinkId $
+  replyOnNothing "Please submit a YouTube link" $
+  liftR
+    (\ytId ->
+       selectEntities (Proxy :: Proxy FridayVideo) $
+       Filter (PropertyTextLike "name" ("%" <> ytId <> "%")) All) $
+  cmapR (\dups -> [qms|This video was suggested {length dups} times|]) $
+  Reaction replyMessage

src/Effect.hs

@@ -48,6 +48,8 @@ data Condition
   | PropertyGreater T.Text
                     Property
   | PropertyMissing T.Text
+  | PropertyTextLike T.Text
+                     T.Text
   | ConditionAnd [Condition]
   deriving (Show)
 

src/Sqlite/Compiler.hs

@@ -45,6 +45,7 @@ compileCondition _ (E.ConditionAnd _) = undefined
 compileCondition _ (E.PropertyGreater _ _) = undefined
 -- TODO(#756): E.PropertyMissing is not interpreted in Sqlite.Compiler.compileCondition
 compileCondition _ (E.PropertyMissing _) = undefined
+compileCondition _ (E.PropertyTextLike _ _) = undefined
 
 -- TODO(#253): compileCteChain doesn't optimize common patterns like Sqlite.EntityPersistence.selectEntityIds
 compileCteChain :: T.Text -> E.Selector -> (Int, NamedQuery)

src/Sqlite/EntityPersistence.hs

@@ -427,6 +427,19 @@ selectEntityIds conn name (SortBy propertyName1 Asc (Filter (PropertyGreater pro
       ]
   where
     propertyName = propertyName1
+selectEntityIds conn name (Filter (PropertyTextLike propertyName propertyPattern) All) =
+  map fromOnly <$>
+  queryNamed
+    conn
+    [r|select entityId from EntityProperty
+       where entityName = :entityName and
+             propertyName = :propertyName and
+             propertyText like :propertyPattern
+       group by entityId; |]
+    [ ":entityName" := name
+    , ":propertyName" := propertyName
+    , ":propertyPattern" := propertyPattern
+    ]
 selectEntityIds _ _ selector =
   error ("Unsupported selector combination " ++ show selector)