Update to d-h 1.15.1

README.org

@@ -4,8 +4,7 @@
 #+options: h:0 num:nil toc:nil
 
 ** TODO List
-- [ ] Room availability
-- [ ] Write example configuration
+  - [ ] Write example configuration
 
 ** Setup
 

app/Commands.hs

@@ -25,15 +25,16 @@ import           Data.Time                      ( addUTCTime
 import           Discord                        ( DiscordHandler
                                                 , restCall
                                                 )
-import           Discord.Interactions           ( ApplicationCommandOptionValue(..)
-                                                , ApplicationCommandOptions(..)
+import           Discord.Interactions           ( OptionValue(..)
+                                                , Options(..)
                                                 , Choice(..)
                                                 , CreateApplicationCommand(..)
-                                                , InteractionDataApplicationCommandOptionValue(..)
-                                                , InteractionDataApplicationCommandOptions(..)
+                                                , OptionDataValue(..)
+                                                , OptionsData(..)
                                                 , InteractionResponse
                                                 , MemberOrUser(..)
-                                                , createApplicationCommandChatInput
+                                                , LocalizedText(..)
+                                                , createChatInput
                                                 , interactionResponseBasic
                                                 )
 import           Discord.Requests               ( ChannelRequest(..)
@@ -45,6 +46,8 @@ import           Discord.Types                  ( ChannelId
                                                 , Snowflake
                                                 , UTCTime
                                                 , User(..)
+                                                , RoleId(..)
+                                                , DiscordId,
                                                 )
 import           UnliftIO                       ( withRunInIO )
 
@@ -52,42 +55,46 @@ groupNames :: Config -> [T.Text]
 groupNames Config {..} = map fst $ Map.toList configGroups
 
 pingCommand :: Maybe CreateApplicationCommand
-pingCommand = createApplicationCommandChatInput "ping" "pong"
+pingCommand = createChatInput "ping" "pong"
 
 pingResponse :: Config -> IO InteractionResponse
 pingResponse _ = return $ interactionResponseBasic "Pong"
 
 edtCommand :: Config -> Maybe CreateApplicationCommand
 edtCommand c =
-  createApplicationCommandChatInput "edt" "Gets the planning for a group"
+  createChatInput "edt" "Gets the planning for a group"
     >>= \cac -> return $ cac
-          { createApplicationCommandOptions =
-            Just $ ApplicationCommandOptionsValues
-              [ ApplicationCommandOptionValueString
+          { createOptions =
+            Just $ OptionsValues
+              [ OptionValueString
                 "group"
+                Nothing
                 "The group for which the planning is requested"
+                Nothing
                 True
-                (Right $ map (\x -> Choice x x) $ groupNames c)
-              , ApplicationCommandOptionValueString
+                (Right $ map (\x -> Choice x Nothing x) $ groupNames c)
+                Nothing Nothing
+              , OptionValueString
                 "day"
-                (          "The day(s) for which the planning is requested "
-                `T.append` "(today, tomorrow, week or DD/MM/YYYY)"
-                )
+                Nothing
+                "The day(s) for which the planning is requested (today, tomorrow, week or DD/MM/YYYY)"
+                Nothing
                 False
                 (Left False)
+                Nothing Nothing
               ]
           }
 
-parseOpt :: InteractionDataApplicationCommandOptionValue -> (T.Text, T.Text)
-parseOpt InteractionDataApplicationCommandOptionValueString { interactionDataApplicationCommandOptionValueName = name, interactionDataApplicationCommandOptionValueStringValue = Right val, ..}
+parseOpt :: OptionDataValue -> (T.Text, T.Text)
+parseOpt OptionDataValueString { optionDataValueName = name, optionDataValueString = Right val, ..}
   = (name, val)
 parseOpt _ = ("INVALID Option", "INVALID type")
 
 edtResponse
   :: Config
-  -> Maybe InteractionDataApplicationCommandOptions
+  -> Maybe OptionsData
   -> IO InteractionResponse
-edtResponse conf@Config {..} (Just (InteractionDataApplicationCommandOptionsValues opts))
+edtResponse conf@Config {..} (Just (OptionsDataValues opts))
   = do
     planning <- getEdt conf parsedOpts
     return $ interactionResponseBasic planning
@@ -99,34 +106,28 @@ edtResponse _ _ = return $ interactionResponseBasic
 
 remindCommand :: Maybe CreateApplicationCommand
 remindCommand =
-  createApplicationCommandChatInput "remind" "reminds you of something later on"
+  createChatInput "remind" "reminds you of something later on"
     >>= \cac -> return $ cac
-          { createApplicationCommandOptions =
-            Just $ ApplicationCommandOptionsValues
-              [ ApplicationCommandOptionValueString "delay"
-                                                    "delay"
-                                                    True
-                                                    (Left False)
-              , ApplicationCommandOptionValueString "message"
-                                                    "message"
-                                                    True
-                                                    (Left False)
+          { createOptions =
+            Just $ OptionsValues
+            [ OptionValueString "delay" Nothing "delay" Nothing True (Left False) Nothing Nothing
+              , OptionValueString "message" Nothing "message" Nothing True (Left False) Nothing Nothing
               ]
           }
 
 remindResponse
-  :: Maybe InteractionDataApplicationCommandOptions
+  :: Maybe OptionsData
   -> EventSystem
-  -> ChannelId
+  -> Discord.Types.ChannelId
   -> MemberOrUser
   -> DiscordHandler InteractionResponse
-remindResponse (Just (InteractionDataApplicationCommandOptionsValues opts)) evts ch mou
+remindResponse (Just (OptionsDataValues opts)) evts ch mou
   = do
     let
       userid = case mou of
-        MemberOrUser (Left GuildMember { memberUser = Just User { userId = uid } })
+        MemberOrUser (Left Discord.Types.GuildMember { memberUser = Just Discord.Types.User { userId = uid } })
           -> uid
-        MemberOrUser (Right User { userId = uid }) -> uid
+        MemberOrUser (Right Discord.Types.User { userId = uid }) -> uid
         _ -> error "Couldnt get user id"
     let d = delay'
     now <- liftIO getCurrentTime
@@ -166,30 +167,31 @@ remindResponse _ _ _ _ =
 
 groupCommand :: Config -> Maybe CreateApplicationCommand
 groupCommand c =
-  createApplicationCommandChatInput "group" "grab your group" >>= \cac ->
+  createChatInput "group" "grab your group" >>= \cac ->
     return $ cac
-      { createApplicationCommandOptions = Just $ ApplicationCommandOptionsValues
-        [ ApplicationCommandOptionValueString
-            "group"
-            "Your group"
+      { createOptions = Just $ OptionsValues
+        [ OptionValueString
+            "group" Nothing
+            "Your group" Nothing
             True
-            (Right $ map (\x -> Choice x x) $ groupNames c)
+            (Right $ map (\x -> Choice x Nothing x) $ groupNames c)
+            Nothing Nothing
         ]
       }
 
 groupResponse
   :: Config
   -> MemberOrUser
-  -> GuildId
-  -> Maybe InteractionDataApplicationCommandOptions
+  -> Discord.Types.GuildId
+  -> Maybe OptionsData
   -> DiscordHandler InteractionResponse
-groupResponse c mou gid (Just (InteractionDataApplicationCommandOptionsValues opts))
+groupResponse c mou gid (Just (OptionsDataValues opts))
   = do
     let
       uid = case mou of
-        MemberOrUser (Left GuildMember { memberUser = Just User { userId = uid } })
+        MemberOrUser (Left Discord.Types.GuildMember { memberUser = Just Discord.Types.User { userId = uid } })
           -> uid
-        MemberOrUser (Right User { userId = uid }) -> uid
+        MemberOrUser (Right Discord.Types.User { userId = uid }) -> uid
         _ -> -1
     let rid =
           groupRole
@@ -213,7 +215,7 @@ groupResponse _ _ _ _ =
         "the group command has mandatory params, yet you managed not to give any, WOW"
 
 helpCommand :: Maybe CreateApplicationCommand
-helpCommand = createApplicationCommandChatInput "help" "help"
+helpCommand = createChatInput "help" "help"
 
 helpResponse :: IO InteractionResponse
 helpResponse =

app/Commands/Reminds.hs

@@ -22,11 +22,15 @@ import           Discord                        ( DiscordHandler
 import           Discord.Interactions           ( )
 import           Discord.Requests               ( ChannelRequest(CreateMessage)
                                                 )
-import           Discord.Types                  ( Snowflake(..) )
+import           Discord.Types                  ( Snowflake(..)
+                                                , DiscordId(..)
+                                                , ChannelId(..)
+                                                , UserId(..)
+                                                )
 
 data Remind = Remind
-    { rmdUser     :: Snowflake
-    , rmdChannel  :: Snowflake
+    { rmdUser     :: UserId
+    , rmdChannel  :: ChannelId
     , rmdMessage  :: T.Text
     , rmdDatetime :: UTCTime
     }
@@ -69,8 +73,8 @@ registerRemind Remind {..} = do
         conn
         "INSERT INTO reminds(user, channel, message, dt)\
     \VALUES (?,?,?,?)"
-        [ DB.toSql rmdUser
-        , DB.toSql rmdChannel
+        [ DB.toSql $ unId rmdUser
+        , DB.toSql $ unId rmdChannel
         , DB.toSql rmdMessage
         , DB.toSql rmdDatetime
         ]

app/Conf.hs

@@ -31,28 +31,33 @@ import           Data.Scientific                ( Scientific
 import           Data.Word                      ( Word64 )
 
 data Group = Group
-    { groupChannel :: D.Snowflake
-    , groupRole    :: D.Snowflake
+    { groupChannel :: D.ChannelId
+    , groupRole    :: D.RoleId
     , groupAde     :: T.Text
     }
     deriving (Show, Eq, Read)
 
 hmToGroup :: H.HashMap T.Text Value -> Group
 hmToGroup hm = Group
-    { groupChannel = scitosno
+    { groupChannel = fromInteger
+                     . fromRight (error "Cant read that as an int")
+                     . floatingOrInteger
                      . valueNum "channel"
                      . errorRequired "channel"
                      $ H.lookup "channel" hm
-    , groupRole = scitosno . valueNum "role" . errorRequired "role" $ H.lookup
-                      "role"
-                      hm
-    , groupAde = valueText "edturl" . errorRequired "edturl" $ H.lookup
-                     "edturl"
-                     hm
+    , groupRole = fromInteger
+                  . fromRight (error "Cant read that as an int")
+                  . floatingOrInteger
+                  . valueNum "role"
+                  . errorRequired "role"
+                  $ H.lookup "role" hm
+    , groupAde = valueText "edturl"
+                 . errorRequired "edturl"
+                 $ H.lookup "edturl" hm
     }
 
 data Config = Config
-    { configServer          :: D.Snowflake
+    { configServer          :: D.GuildId
     , configGroups          :: Map.Map T.Text Group
     , configAutoEDTCronDay  :: T.Text
     , configAutoEDTCronWeek :: T.Text
@@ -72,8 +77,12 @@ ymlToConf v = Config { configServer          = server
                      , configAutoEDTCronWeek = autoEdtCronWeek
                      }
   where
-    server'      = errorRequired "server" $ H.lookup "server" v
-    server       = scitosno $ valueNum "server" server'
+    server       = fromInteger
+                  . fromRight (error "Cant read that as an int")
+                  . floatingOrInteger
+                  . valueNum "server"
+                  . errorRequired "server"
+                  $ H.lookup "server" v
     groups       = parseGroups groupsObject
     groupsObject = H.lookup "groups" v
     parseGroups (Just (Object o)) =
@@ -107,9 +116,3 @@ valueNum :: [Char] -> Value -> Scientific
 valueNum _    (Number n) = n
 valueNum name _          = error $ name ++ " should be an integer"
 
-scitosno :: Scientific -> D.Snowflake
-scitosno =
-    D.Snowflake
-        . (fromInteger :: Integer -> Word64)
-        . fromRight (error "Cant read that as an int")
-        . floatingOrInteger

app/Main.hs

@@ -47,7 +47,7 @@ import           Discord                        ( DiscordHandler
                                                 , sendCommand
                                                 )
 import           Discord.Interactions           ( Interaction(..)
-                                                , InteractionDataApplicationCommand(..)
+                                                , ApplicationCommandData(..)
                                                 , interactionResponseBasic
                                                 )
 import qualified Discord.Requests              as R
@@ -71,7 +71,7 @@ main = do
   conf        <- readConfig "./conf.yaml"
   eventSystem <- E.initEventSystem
 
-  err         <- runDiscord $ def
+  err         <- Discord.runDiscord $ Discord.def
     { discordToken   = tok
     , discordOnStart = onDiscordStart conf eventSystem
     , discordOnEnd   = liftIO $ putStrLn "Ended"
@@ -80,10 +80,10 @@ main = do
     }
   TIO.putStrLn err
 
-onDiscordStart :: Config -> E.EventSystem -> DiscordHandler ()
+onDiscordStart :: Config -> E.EventSystem -> Discord.DiscordHandler ()
 onDiscordStart conf@Config {..} eventSystem = do
   let activity :: Activity
-      activity = def { activityName = "Doing stuff"
+      activity = Discord.def { activityName = "Doing stuff"
                      , activityType = ActivityTypeGame
                      , activityUrl  = Nothing
                      }
@@ -93,7 +93,7 @@ onDiscordStart conf@Config {..} eventSystem = do
                               , updateStatusOptsNewStatus = UpdateStatusOnline
                               , updateStatusOptsAFK       = False
                               }
-  sendCommand (UpdateStatus opts)
+  Discord.sendCommand (UpdateStatus opts)
 
   let glist = Map.toList configGroups
 
@@ -122,8 +122,8 @@ onDiscordStart conf@Config {..} eventSystem = do
       liftIO $ print [u, c, m, d]
       scheduleRemind
         eventSystem
-        Remind { rmdUser     = Snowflake $ DB.fromSql u
-               , rmdChannel  = Snowflake $ DB.fromSql c
+        Remind { rmdUser     = fromInteger $ DB.fromSql u
+               , rmdChannel  = fromInteger $ DB.fromSql c
                , rmdMessage  = DB.fromSql m
                , rmdDatetime = DB.fromSql d
                }
@@ -131,13 +131,13 @@ onDiscordStart conf@Config {..} eventSystem = do
     reminds
   liftIO $ putStrLn "Started"
 
-onDiscordEvent :: Config -> E.EventSystem -> Event -> DiscordHandler ()
+onDiscordEvent :: Config -> E.EventSystem -> Event -> Discord.DiscordHandler ()
 onDiscordEvent conf@Config {..} eventSystem (Ready _ _ _ _ _ _ (PartialApplication i _))
   = do
     mapM_
       (maybe
         (return ())
-        (void . restCall . R.CreateGuildApplicationCommand i configServer)
+        (void . Discord.restCall . R.CreateGuildApplicationCommand i configServer)
       )
       [ pingCommand
       , edtCommand conf
@@ -146,10 +146,10 @@ onDiscordEvent conf@Config {..} eventSystem (Ready _ _ _ _ _ _ (PartialApplicati
       , helpCommand
       ]
 
-onDiscordEvent conf@Config {..} eventSystem (InteractionCreate InteractionApplicationCommand { interactionDataApplicationCommand = InteractionDataApplicationCommandChatInput { interactionDataApplicationCommandName = name, interactionDataApplicationCommandOptions = opts, ..}, interactionChannelId = Just channel, interactionGuildId = Just guild, interactionUser = user, ..})
+onDiscordEvent conf@Config {..} eventSystem (InteractionCreate InteractionApplicationCommand { applicationCommandData = ApplicationCommandDataChatInput { applicationCommandDataName = name, optionsData = opts, ..}, interactionChannelId = Just channel, interactionGuildId = Just guild, interactionUser = user, ..})
   = do
     response <- responseIO
-    void $ restCall
+    void $ Discord.restCall
       (R.CreateInteractionResponse interactionId interactionToken response)
  where
   responseIO = case name of
@@ -162,7 +162,7 @@ onDiscordEvent conf@Config {..} eventSystem (InteractionCreate InteractionApplic
       return $ interactionResponseBasic $ "Unhandled Command: " `T.append` name
 onDiscordEvent _ _ _ = return ()
 
-pushgroupedt :: Config -> T.Text -> [(T.Text, Group)] -> DiscordHandler ()
+pushgroupedt :: Config -> T.Text -> [(T.Text, Group)] -> Discord.DiscordHandler ()
 pushgroupedt conf@Config {..} day glist = do
   mapM_
     (\(gn, Group { groupChannel = gc }) -> do
@@ -175,7 +175,7 @@ pushgroupedt conf@Config {..} day glist = do
         <> T.pack (show gc)
         <> ":\n"
         <> edt
-      restCall $ R.CreateMessage gc edt
+      Discord.restCall $ R.CreateMessage gc edt
       return ()
     )
     glist

stack.yaml

@@ -7,12 +7,9 @@ extra-deps:
   - emoji-0.1.0.2
   - iCalendar-0.4.0.5
   - mime-0.4.0.2
-  - discord-haskell-1.12.5
   - control-event-1.3
   - HDBC-sqlite3-2.3.3.1
-## My fork of discord-haskell to PR bug fixes and have them before merge
-#  - github: Annwan/discord-haskell
-#    commit: <insert pactch commit>
-# discord-haskell repo when there is a bug in hackage
-#  - github: aquarial/discord-haskell
-#    commit: <insert master commit>
+  - discord-haskell-1.15.1
+# discord-haskell repo when there is features/bug fixes not in hackage
+#  - github: discord-haskell/discord-haskell
+#    commit: <insert commit here>