Browse Source

using chronos

master
soupi 1 year ago
commit
a2366b1d45
8 changed files with 385 additions and 0 deletions
  1. +117
    -0
      .gitignore
  2. +30
    -0
      LICENSE
  3. +1
    -0
      README.md
  4. +44
    -0
      app/Main.hs
  5. +84
    -0
      package.yaml
  6. +74
    -0
      src/MyBot.hs
  7. +9
    -0
      stack.yaml
  8. +26
    -0
      stack.yaml.lock

+ 117
- 0
.gitignore View File

@@ -0,0 +1,117 @@
/dist/
/.cabal-sandbox/
/cabal.sandbox.config
/.stack-work/
output
*.cabal
run.sh

Created by https://www.gitignore.io/api/vim,emacs,osx,haskell

### Vim ###
# swap
[._]*.s[a-w][a-z]
[._]s[a-w][a-z]
# session
Session.vim
# temporary
.netrwhist
*~
# auto-generated tag files
tags


### Emacs ###
# -*- mode: gitignore; -*-
*~
\#*\#
/.emacs.desktop
/.emacs.desktop.lock
*.elc
auto-save-list
tramp
.\#*

# Org-mode
.org-id-locations
*_archive

# flymake-mode
*_flymake.*

# eshell files
/eshell/history
/eshell/lastdir

# elpa packages
/elpa/

# reftex files
*.rel

# AUCTeX auto folder
/auto/

# cask packages
.cask/
dist/

# Flycheck
flycheck_*.el

# server auth directory
/server/

# projectiles files
.projectile

### OSX ###
*.DS_Store
.AppleDouble
.LSOverride

# Icon must end with two \r
Icon


# Thumbnails
._*

# Files that might appear in the root of a volume
.DocumentRevisions-V100
.fseventsd
.Spotlight-V100
.TemporaryItems
.Trashes
.VolumeIcon.icns
.com.apple.timemachine.donotpresent

# Directories potentially created on remote AFP share
.AppleDB
.AppleDesktop
Network Trash Folder
Temporary Items
.apdisk


### Haskell ###
dist
dist-*
cabal-dev
*.o
*.hi
*.chi
*.chs.h
*.dyn_o
*.dyn_hi
.hpc
.hsenv
.cabal-sandbox/
cabal.sandbox.config
*.prof
*.aux
*.hp
*.eventlog
.stack-work/
cabal.project.local


+ 30
- 0
LICENSE View File

@@ -0,0 +1,30 @@
Copyright Gil Mizrahi (c) 2020

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.

* Neither the name of Author name here nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ 1
- 0
README.md View File

@@ -0,0 +1 @@
# mybot

+ 44
- 0
app/Main.hs View File

@@ -0,0 +1,44 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-} -- One more extension.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-} -- To derive Show
{-# LANGUAGE TypeOperators #-}

module Main where

import Relude
import Options.Generic
import Chronos
import qualified Data.Attoparsec.Text as Atto

import MyBot

main :: IO ()
main = do
config <- unwrapRecord "My Bot"
case parseDatetime $ unHelpful $ date config of
Left err ->
error $ "Invalid date: " <> fromString err
Right date ->
reportTime date (unHelpful $ token config)

data Config w = Config
{ token :: Text <?> "Bot token"
, date :: Text <?> "Bot token"
}
deriving (Generic)

instance ParseRecord (Config Wrapped)
deriving instance Show (Config Unwrapped)


parseDatetime :: Text -> Either String Time
parseDatetime =
Atto.parseOnly $ do
date <- parser_Ymd (Just '-')
Atto.space
day <- parser_HMS (Just ':')
Atto.endOfInput
pure $ offsetDatetimeToTime $ OffsetDatetime (Datetime date day) (Offset 3)

+ 84
- 0
package.yaml View File

@@ -0,0 +1,84 @@
name: mybot
version: 0.1.0.0
github: "gilmi/mybot"
license: BSD3
author: "Gil Mizrahi"
maintainer: "gilmi@posteo.net"
copyright: "2020 Gil Mizrahi"

extra-source-files:
- README.md

# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web

# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/gilmi/mybot#readme>

dependencies:
- base >= 4.7 && < 5
- relude
- pretty-simple
- containers
- text
- string-interpolate
- chronos
- random
- deepseq
- stm
- async
- optparse-generic
- discord-haskell

library:
source-dirs: src
default-extensions:
- NoImplicitPrelude
- BangPatterns
- ConstraintKinds
- DataKinds
- DeriveFunctor
- DeriveFoldable
- DeriveTraversable
- DeriveDataTypeable
- DeriveGeneric
- DeriveAnyClass
- EmptyDataDecls
- FlexibleContexts
- FlexibleInstances
- KindSignatures
- LambdaCase
- MultiParamTypeClasses
- FunctionalDependencies
- TypeSynonymInstances
- PatternGuards
- PatternSynonyms
- RankNTypes
- RecordWildCards
- NamedFieldPuns
- ScopedTypeVariables
- TupleSections
- ViewPatterns
- TypeApplications
- OverloadedStrings
- QuasiQuotes


executables:
mybot-exe:
main: Main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- mybot
- relude
- optparse-generic
- chronos
- attoparsec


+ 74
- 0
src/MyBot.hs View File

@@ -0,0 +1,74 @@
module MyBot where

import Relude hiding (toLower, isPrefixOf)

import Control.Monad (when)
import qualified Data.Text as T
import Control.Concurrent

import Chronos


import Discord
import Discord.Types
import qualified Discord.Requests as R

reportTime :: Time -> Text -> IO ()
reportTime time token = do
userFacingError <-
runDiscord $ def
{ discordToken = token
, discordOnEvent = eventHandler time
, discordOnStart = do
putTextLn "Bot is running."
}
error userFacingError
exitFailure

eventHandler :: Time -> Event -> DiscordHandler ()
eventHandler time event =
case event of
MessageCreate m ->
when (not (fromBot m) && isWhen (messageText m)) $ do
restCall $ R.CreateReaction (messageChannel m, messageId m) "clock"
time <- runWhen time
void $ restCall $ R.CreateMessage (messageChannel m) time

_ -> pure ()

fromBot :: Message -> Bool
fromBot m = userIsBot (messageAuthor m)

isWhen :: Text -> Bool
isWhen = ("when"==) . sanitize

sanitize :: Text -> Text
sanitize = T.dropWhile (==' ') . T.toLower

runWhen :: MonadIO m => Time -> m Text
runWhen target = do
timeNow <- liftIO now
let
interval = timeIntervalBuilder timeNow target
pure $ encodeTimespan (SubsecondPrecisionFixed 0) $ width interval

printInterval :: Timespan -> Text
printInterval (Timespan t) =
let
inSeconds = t `div` 1000000000
seconds = inSeconds `mod` 60
inMinutes = inSeconds `div` 60
minutes = inMinutes `mod` 60
inHours = inMinutes `div` 60
hours = inHours `mod` 24
inDays = inHours `div` 24
days = inDays
txt = T.pack . show
(<+>) a b = a <> " " <> b
in
unwords
[ txt days <+> "days"
, txt hours <+> "hours"
, txt minutes <+> "minutes"
, txt seconds <+> "seconds"
]

+ 9
- 0
stack.yaml View File

@@ -0,0 +1,9 @@
resolver: lts-16.18

packages:
- .

extra-deps:
- discord-haskell-1.8.0@sha256:420515069c5be313dd31d16e9a4b163d2b3fdda18ba18e98cbb0b0536cbae136,3562
- emoji-0.1.0.2@sha256:d995572a5c7dcd28f98eb15c6e387a7b3bda1ac2477ab0d9dba8580d5d7b161f,1273


+ 26
- 0
stack.yaml.lock View File

@@ -0,0 +1,26 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/lock_files

packages:
- completed:
hackage: discord-haskell-1.8.0@sha256:420515069c5be313dd31d16e9a4b163d2b3fdda18ba18e98cbb0b0536cbae136,3562
pantry-tree:
size: 2108
sha256: 2d32f71b9d3e32f797ad6d614d748b491350ff0febb7e7bfc6f7fb595d752a0d
original:
hackage: discord-haskell-1.8.0@sha256:420515069c5be313dd31d16e9a4b163d2b3fdda18ba18e98cbb0b0536cbae136,3562
- completed:
hackage: emoji-0.1.0.2@sha256:d995572a5c7dcd28f98eb15c6e387a7b3bda1ac2477ab0d9dba8580d5d7b161f,1273
pantry-tree:
size: 437
sha256: dd9ea90a631342e5db0fc21331ade4d563a685e9125d5a3989eefa8e1b96c6c6
original:
hackage: emoji-0.1.0.2@sha256:d995572a5c7dcd28f98eb15c6e387a7b3bda1ac2477ab0d9dba8580d5d7b161f,1273
snapshots:
- completed:
size: 532172
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/18.yaml
sha256: 4f2a092c6f4869854e8d7435ab98ce5157c641022c3cbfc4c4614ff3db752e62
original: lts-16.18

Loading…
Cancel
Save