9 changed files with 642 additions and 587 deletions
-
4.gitignore
-
12README.org
-
405app/Commands.hs
-
250app/Commands/EDT.hs
-
78app/Commands/Reminds.hs
-
169app/Conf.hs
-
306app/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 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 |
|||
{ 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 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 |
|||
{ 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 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 v = Config |
|||
{ configServer = server |
|||
, configGroups = groups |
|||
, configAutoEDTCronDay = autoEdtCronDay |
|||
, configAutoEDTCronWeek = autoEdtCronWeek |
|||
} |
|||
ymlToConf v = Config { configServer = server |
|||
, configGroups = groups |
|||
, configAutoEDTCronDay = autoEdtCronDay |
|||
, configAutoEDTCronWeek = autoEdtCronWeek |
|||
} |
|||
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 |
|||
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" |
|||
autoEdtCronDay = |
|||
valueText "autoEdtCronDay" |
|||
$ fromMaybe "0 15 * * 0-4" |
|||
$ H.lookup "autoEdtCronDay" v |
|||
valueText "autoEdtCronDay" $ fromMaybe "0 15 * * 0-4" $ H.lookup |
|||
"autoEdtCronDay" |
|||
v |
|||
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 name = fromMaybe (error $ "required field: " ++ name) |
|||
errorRequired name = fromMaybe (error $ "required field: " ++ name) |
|||
valueText :: [Char] -> Value -> T.Text |
|||
valueText _ (String t) = t |
|||
valueText name _ = error $ name ++ " should be a string" |
|||
valueNum :: [Char] -> Value -> Scientific |
|||
valueNum _ (Number n) = n |
|||
valueNum name _ = error $ name ++ " should be an integer" |
|||
valueText _ (String t) = t |
|||
valueText name _ = error $ name ++ " should be a string" |
|||
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 |
|||
scitosno :: Scientific -> D.Snowflake |
|||
scitosno = |
|||
D.Snowflake |
|||
. (fromInteger :: Integer -> Word64) |
|||
. fromRight (error "Cant read that as an int") |
|||
. floatingOrInteger |
|||
Write
Preview
Loading…
Cancel
Save
Reference in new issue