9 changed files with 642 additions and 587 deletions
-
2.gitignore
-
12README.org
-
405app/Commands.hs
-
250app/Commands/EDT.hs
-
78app/Commands/Reminds.hs
-
163app/Conf.hs
-
304app/Main.hs
-
4botiut.cabal
-
1stack.yaml
@ -0,0 +1,78 @@ |
|||||
|
{-# LANGUAGE MultiParamTypeClasses #-} |
||||
|
{-# LANGUAGE OverloadedStrings #-} |
||||
|
{-# LANGUAGE RecordWildCards #-} |
||||
|
|
||||
|
-- | Manages all about reminders |
||||
|
module Commands.Reminds where |
||||
|
|
||||
|
import Conf ( ) |
||||
|
import qualified Control.Event as E |
||||
|
import Control.Monad ( void ) |
||||
|
import Control.Monad.IO.Unlift ( MonadUnliftIO(withRunInIO) ) |
||||
|
import Data.Convertible ( ConvertResult |
||||
|
, Convertible(safeConvert) |
||||
|
) |
||||
|
import qualified Data.Text as T |
||||
|
import Data.Time ( UTCTime ) |
||||
|
import qualified Database.HDBC as DB |
||||
|
import qualified Database.HDBC.Sqlite3 as DB.SQ3 |
||||
|
import Discord ( DiscordHandler |
||||
|
, restCall |
||||
|
) |
||||
|
import Discord.Interactions ( ) |
||||
|
import Discord.Requests ( ChannelRequest(CreateMessage) |
||||
|
) |
||||
|
import Discord.Types ( Snowflake(..) ) |
||||
|
|
||||
|
data Remind = Remind |
||||
|
{ rmdUser :: Snowflake |
||||
|
, rmdChannel :: Snowflake |
||||
|
, rmdMessage :: T.Text |
||||
|
, rmdDatetime :: UTCTime |
||||
|
} |
||||
|
|
||||
|
instance Convertible Snowflake DB.SqlValue where |
||||
|
safeConvert (Snowflake v) = safeConvert v |
||||
|
|
||||
|
setupRemindDb :: IO () |
||||
|
setupRemindDb = do |
||||
|
conn <- DB.SQ3.connectSqlite3 "db.sqlite3" |
||||
|
DB.run |
||||
|
conn |
||||
|
"CREATE TABLE IF NOT EXISTS reminds\ |
||||
|
\(id INTEGER PRIMARY KEY AUTOINCREMENT UNIQUE NOT NULL,\ |
||||
|
\user INTEGER NOT NULL,\ |
||||
|
\channel INTEGER NOT NULL,\ |
||||
|
\message INTEGER NOT NULL,\ |
||||
|
\dt DATETIME);" |
||||
|
[] |
||||
|
DB.commit conn |
||||
|
DB.disconnect conn |
||||
|
|
||||
|
scheduleRemind :: E.EventSystem -> Remind -> DiscordHandler () |
||||
|
scheduleRemind ev Remind {..} = do |
||||
|
void $ withRunInIO $ \runInIo -> |
||||
|
E.addEvent ev rmdDatetime |
||||
|
$ void |
||||
|
$ runInIo |
||||
|
$ restCall |
||||
|
$ CreateMessage rmdChannel |
||||
|
$ "<@" |
||||
|
`T.append` T.pack (show rmdUser) |
||||
|
`T.append` "> **Reminder**\n" |
||||
|
`T.append` rmdMessage |
||||
|
|
||||
|
registerRemind :: Remind -> IO () |
||||
|
registerRemind Remind {..} = do |
||||
|
conn <- DB.SQ3.connectSqlite3 "db.sqlite3" |
||||
|
DB.run |
||||
|
conn |
||||
|
"INSERT INTO reminds(user, channel, message, dt)\ |
||||
|
\VALUES (?,?,?,?)" |
||||
|
[ DB.toSql rmdUser |
||||
|
, DB.toSql rmdChannel |
||||
|
, DB.toSql rmdMessage |
||||
|
, DB.toSql rmdDatetime |
||||
|
] |
||||
|
DB.commit conn |
||||
|
DB.disconnect conn |
||||
@ -1,106 +1,115 @@ |
|||||
{-# LANGUAGE OverloadedStrings #-} |
{-# LANGUAGE OverloadedStrings #-} |
||||
{-# LANGUAGE LambdaCase #-} |
{-# LANGUAGE LambdaCase #-} |
||||
|
|
||||
module Conf ( Group(..) , Config(..) , readConfig ) where |
|
||||
|
module Conf |
||||
|
( Group(..) |
||||
|
, Config(..) |
||||
|
, readConfig |
||||
|
) where |
||||
|
|
||||
import qualified Data.Text as T |
|
||||
import qualified Discord.Types as D |
|
||||
import Data.Yaml ( Object |
|
||||
, decodeFileThrow |
|
||||
, (.:) |
|
||||
, parseMaybe |
|
||||
, Parser |
|
||||
, withObject |
|
||||
, FromJSON |
|
||||
, Value (Object, Number, String) |
|
||||
, parseJSON |
|
||||
) |
|
||||
import qualified Data.HashMap.Strict as H |
|
||||
import qualified Data.Map.Strict as Map |
|
||||
import Data.Maybe (fromMaybe) |
|
||||
import Control.Monad (mzero) |
|
||||
|
import Control.Monad ( mzero ) |
||||
|
import qualified Data.HashMap.Strict as H |
||||
|
import qualified Data.Map.Strict as Map |
||||
|
import Data.Maybe ( fromMaybe ) |
||||
|
import qualified Data.Text as T |
||||
|
import Data.Yaml ( (.:) |
||||
|
, FromJSON |
||||
|
, Object |
||||
|
, Parser |
||||
|
, Value(Number, Object, String) |
||||
|
, decodeFileThrow |
||||
|
, parseJSON |
||||
|
, parseMaybe |
||||
|
, withObject |
||||
|
) |
||||
|
import qualified Discord.Types as D |
||||
|
|
||||
import Data.Word (Word64) |
|
||||
import Data.Scientific (Scientific, floatingOrInteger) |
|
||||
import Data.Either (fromRight) |
|
||||
|
import Data.Either ( fromRight ) |
||||
|
import Data.Scientific ( Scientific |
||||
|
, floatingOrInteger |
||||
|
) |
||||
|
import Data.Word ( Word64 ) |
||||
|
|
||||
data Group = Group |
data Group = Group |
||||
{ groupChannel :: D.Snowflake |
|
||||
, groupRole :: D.Snowflake |
|
||||
, groupAde :: T.Text |
|
||||
} |
|
||||
deriving (Show, Eq, Read) |
|
||||
|
{ groupChannel :: D.Snowflake |
||||
|
, groupRole :: D.Snowflake |
||||
|
, groupAde :: T.Text |
||||
|
} |
||||
|
deriving (Show, Eq, Read) |
||||
|
|
||||
hmToGroup :: H.HashMap T.Text Value -> Group |
hmToGroup :: H.HashMap T.Text Value -> Group |
||||
hmToGroup hm = Group |
hmToGroup hm = Group |
||||
{ groupChannel = scitosno |
|
||||
. 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 |
|
||||
} |
|
||||
|
{ groupChannel = scitosno |
||||
|
. 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 |
||||
|
} |
||||
|
|
||||
data Config = Config |
data Config = Config |
||||
{ configServer :: D.Snowflake |
|
||||
, configGroups :: Map.Map T.Text Group |
|
||||
, configAutoEDTCronDay :: T.Text |
|
||||
, configAutoEDTCronWeek :: T.Text |
|
||||
} |
|
||||
deriving (Show, Eq, Read) |
|
||||
|
{ configServer :: D.Snowflake |
||||
|
, configGroups :: Map.Map T.Text Group |
||||
|
, configAutoEDTCronDay :: T.Text |
||||
|
, configAutoEDTCronWeek :: T.Text |
||||
|
} |
||||
|
deriving (Show, Eq, Read) |
||||
|
|
||||
readConfig :: FilePath -> IO Config |
readConfig :: FilePath -> IO Config |
||||
readConfig fp = do |
readConfig fp = do |
||||
conf_yml <- decodeFileThrow fp :: IO Object |
|
||||
-- print conf_yml |
|
||||
return $ ymlToConf conf_yml |
|
||||
|
conf_yml <- decodeFileThrow fp :: IO Object |
||||
|
-- print conf_yml |
||||
|
return $ ymlToConf conf_yml |
||||
|
|
||||
ymlToConf :: Object -> Config |
ymlToConf :: Object -> Config |
||||
ymlToConf v = Config |
|
||||
{ configServer = server |
|
||||
, configGroups = groups |
|
||||
, configAutoEDTCronDay = autoEdtCronDay |
|
||||
, configAutoEDTCronWeek = autoEdtCronWeek |
|
||||
} |
|
||||
|
ymlToConf v = Config { configServer = server |
||||
|
, configGroups = groups |
||||
|
, configAutoEDTCronDay = autoEdtCronDay |
||||
|
, configAutoEDTCronWeek = autoEdtCronWeek |
||||
|
} |
||||
where |
where |
||||
server' = errorRequired "server" $ H.lookup "server" v |
|
||||
server = scitosno $ valueNum "server" server' |
|
||||
groups = parseGroups groupsObject |
|
||||
|
server' = errorRequired "server" $ H.lookup "server" v |
||||
|
server = scitosno $ valueNum "server" server' |
||||
|
groups = parseGroups groupsObject |
||||
groupsObject = H.lookup "groups" v |
groupsObject = H.lookup "groups" v |
||||
parseGroups (Just (Object o)) = let groupList' :: H.HashMap T.Text Group |
|
||||
groupList' = fmap ( hmToGroup |
|
||||
. (\case |
|
||||
Object u -> u |
|
||||
_ -> error "groups are objects") |
|
||||
) o |
|
||||
in Map.fromList $ H.toList groupList' |
|
||||
|
parseGroups (Just (Object o)) = |
||||
|
let groupList' :: H.HashMap T.Text Group |
||||
|
groupList' = fmap |
||||
|
( hmToGroup |
||||
|
. (\case |
||||
|
Object u -> u |
||||
|
_ -> error "groups are objects" |
||||
|
) |
||||
|
) |
||||
|
o |
||||
|
in Map.fromList $ H.toList groupList' |
||||
parseGroups _ = error "Wrong format for groups" |
parseGroups _ = error "Wrong format for groups" |
||||
autoEdtCronDay = |
autoEdtCronDay = |
||||
valueText "autoEdtCronDay" |
|
||||
$ fromMaybe "0 15 * * 0-4" |
|
||||
$ H.lookup "autoEdtCronDay" v |
|
||||
|
valueText "autoEdtCronDay" $ fromMaybe "0 15 * * 0-4" $ H.lookup |
||||
|
"autoEdtCronDay" |
||||
|
v |
||||
autoEdtCronWeek = |
autoEdtCronWeek = |
||||
valueText "autoEdtCronWeek" |
|
||||
$ fromMaybe "30 9 * * 0" |
|
||||
$ H.lookup "autoEdtCronWeek" v |
|
||||
|
valueText "autoEdtCronWeek" $ fromMaybe "30 9 * * 0" $ H.lookup |
||||
|
"autoEdtCronWeek" |
||||
|
v |
||||
|
|
||||
|
|
||||
errorRequired :: [Char] -> Maybe a -> a |
errorRequired :: [Char] -> Maybe a -> a |
||||
errorRequired name = fromMaybe (error $ "required field: " ++ name) |
|
||||
|
errorRequired name = fromMaybe (error $ "required field: " ++ name) |
||||
valueText :: [Char] -> Value -> T.Text |
valueText :: [Char] -> Value -> T.Text |
||||
valueText _ (String t) = t |
|
||||
valueText name _ = error $ name ++ " should be a string" |
|
||||
|
valueText _ (String t) = t |
||||
|
valueText name _ = error $ name ++ " should be a string" |
||||
valueNum :: [Char] -> Value -> Scientific |
valueNum :: [Char] -> Value -> Scientific |
||||
valueNum _ (Number n) = n |
|
||||
valueNum name _ = error $ name ++ " should be an integer" |
|
||||
|
valueNum _ (Number n) = n |
||||
|
valueNum name _ = error $ name ++ " should be an integer" |
||||
|
|
||||
scitosno :: Scientific -> D.Snowflake |
scitosno :: Scientific -> D.Snowflake |
||||
scitosno = D.Snowflake |
|
||||
. (fromInteger :: Integer -> Word64) |
|
||||
. fromRight (error "Cant read that as an int") |
|
||||
. floatingOrInteger |
|
||||
|
scitosno = |
||||
|
D.Snowflake |
||||
|
. (fromInteger :: Integer -> Word64) |
||||
|
. fromRight (error "Cant read that as an int") |
||||
|
. floatingOrInteger |
||||
Write
Preview
Loading…
Cancel
Save
Reference in new issue