Initial commit

.gitignore

@@ -0,0 +1,4 @@
+/save.yml
+/conf.yml
+/dist-newstyle/
+/haddocks/

README.md

@@ -0,0 +1 @@
+# ninapcar

ninapcar.cabal

@@ -0,0 +1,42 @@
+cabal-version:       2.2
+
+name:                ninapcar
+version:             0.1.0.0
+-- synopsis:
+-- description:
+homepage:            https://git.annwan.me/software/ninapcar
+license:             BSD-3-Clause
+author:              Annwan
+maintainer:          annwan@annwan.me
+copyright:           2026 Annwan
+category:            Web
+build-type:          Simple
+
+executable ninapcar
+  hs-source-dirs:      src
+  main-is:             Main.hs
+  default-language:    Haskell2010
+  build-depends:       base >= 4.7 && < 5
+                     , text >= 2.1 && < 3
+                     , yaml >= 0.11.11.2
+                     , data-default == 0.8.0.2
+                     , unliftio == 0.2.25.1
+                     , discord-haskell == 1.18.0
+                     , random == 1.3.1
+                     , regex == 1.1.0.2
+                     , regex-pcre == 0.95.0.1
+                     , attoparsec == 0.14.4
+  ghc-options:         -Wall
+                       -Wcompat
+                       -Widentities
+                       -Wincomplete-record-updates
+                       -Wincomplete-uni-patterns
+                       -Wmissing-export-lists
+                       -Wmissing-home-modules
+                       -Wpartial-fields
+                       -Wredundant-constraints
+  other-modules:     Dice
+
+source-repository head
+  type:     git
+  location: https://git.annwan.me/software/ninapcar

src/Dice.hs

@@ -0,0 +1,176 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-|
+Module      : Dice
+Description : Dice Rolling
+Maintainer  : Annwan <annwan@annwan.me>
+
+Internals of the dice roller module for the bot
+-}
+module Dice (DiceResult(..), DiceExpr(..), parseDiceExpr, compute) where
+
+import System.Random
+import Control.Applicative
+import Control.Monad
+import Data.List (sort)
+import qualified Data.Attoparsec.Text as P
+import Data.Text (Text, pack)
+
+-- | The result of a dice expression
+data DiceResult = DiceResult [(Bool, Integer)] Integer
+
+-- | A dice expression
+--
+--   Examples:
+--
+--   * @4@: @Constant 4@
+--   * @(3 + 3d6kh3)@: @'Sum' ('Constant' 3) ('DiceKeepHigh' 3 6 3)@
+--   * @(4d6 /^ 2)@: @'DivCeil' ('Dice' 4 6) ('Constant' 2)@
+--   * @(10d8kl8 /v (4d6 - 1))@: @'DivFloor' ('DiceKeepLow' 10 8 8) ('Sub' ('Dice' 4 6) ('Constant' 1)))@
+data DiceExpr = -- | An integer constant
+                Constant Integer
+              | -- | The sum of 2 expressions
+                Sum DiceExpr DiceExpr
+              | -- | The Product of 2 expressions
+                Product DiceExpr DiceExpr
+              | -- | Divide and round down
+                DivFloor DiceExpr DiceExpr
+              | -- | Divide and round up
+                DivCeil DiceExpr DiceExpr
+              | -- | Divide and round to nearest
+                DivRound DiceExpr DiceExpr
+              | -- | The difference of 2 expressions
+                Sub DiceExpr DiceExpr
+              | -- | A plain set of dice
+                Dice  Integer Integer
+              | -- | A set of dice where you keep the /n/ lowest
+                DiceKeepLow  Integer Integer Integer
+              | -- | A set of dice where you keep the /n/ highest
+                DiceKeepHigh Integer Integer Integer
+              deriving (Show, Read, Eq)
+
+-- | Compute the result of a dice expression
+--
+--   This function runs in IO due to random number generation.
+compute :: DiceExpr -> IO DiceResult
+compute (Constant v) = pure $ DiceResult [] v
+compute (Sum lhs rhs) = do
+    DiceResult ll lv <- compute lhs
+    DiceResult rl rv <- compute rhs
+    pure $ DiceResult (ll ++ rl) (lv + rv)
+compute (Product lhs rhs) = do
+    DiceResult ll lv <- compute lhs
+    DiceResult rl rv <- compute rhs
+    pure $ DiceResult (ll ++ rl) (lv * rv)
+compute (Sub lhs rhs) = do
+    DiceResult ll lv <- compute lhs
+    DiceResult rl rv <- compute rhs
+    pure $ DiceResult (ll ++ rl) (lv - rv)
+compute (DivFloor lhs rhs) = do
+    DiceResult ll lv <- compute lhs
+    DiceResult rl rv <- compute rhs
+    let (q, _) = quotRem lv rv
+    pure $ DiceResult (ll ++ rl) (q)
+compute (DivCeil lhs rhs) = do
+    DiceResult ll lv <- compute lhs
+    DiceResult rl rv <- compute rhs
+    let (q, r) = quotRem lv rv
+    pure $ DiceResult (ll ++ rl) (q + if r > 0 then 1 else 0)
+compute (DivRound lhs rhs) = do
+    DiceResult ll lv <- compute lhs
+    DiceResult rl rv <- compute rhs
+    let (q, r) = quotRem lv rv
+        (n, _) = quotRem rv 2
+    pure $ DiceResult (ll ++ rl) (q + if r > n then 1 else 0)
+compute (Dice count sides) = do
+    rRaw <- replicateM (fromInteger count) $ randomRIO (1, sides)
+    let r = map (True,) rRaw
+    pure $ DiceResult r $ sum rRaw
+compute (DiceKeepLow count sides keep) = do
+    rRaw <- replicateM (fromInteger count) $ randomRIO (1, sides)
+    let rSorted = sort rRaw
+        rKept = take (fromInteger keep) rSorted
+        rLeft = drop (fromInteger keep) rSorted
+        res = sum rKept
+        rolls = map (True,) rKept ++ map (False,) rLeft
+    pure $ DiceResult rolls res
+compute (DiceKeepHigh count sides keep) = do
+    rRaw <- replicateM (fromInteger count) $ randomRIO (1, sides)
+    let rSorted = map negate . sort . map negate $ rRaw
+        rKept = take (fromInteger keep) rSorted
+        rLeft = drop (fromInteger keep) rSorted
+        res = sum rKept
+        rolls = map (True,) rKept ++ map (False,) rLeft
+    pure $ DiceResult rolls res
+
+-- | Parser for a constant litteral
+parserConstant :: P.Parser DiceExpr
+parserConstant = Constant <$> P.decimal
+
+-- | Parser for a dice litteral
+parserDice :: P.Parser DiceExpr
+parserDice = Dice <$> P.decimal
+                 <*> ("d" *> P.decimal)
+
+-- | Parser for a keep-high dice literal
+parserDiceKeepHigh :: P.Parser DiceExpr
+parserDiceKeepHigh = DiceKeepHigh <$> P.decimal
+                                 <*> ("d" *> P.decimal)
+                                 <*> ("kh" *> P.decimal)
+
+-- | Parser for a keep-low dice literal
+parserDiceKeepLow :: P.Parser DiceExpr
+parserDiceKeepLow = DiceKeepLow <$> P.decimal
+                                <*> ("d" *> P.decimal)
+                                <*> ("kl" *> P.decimal)
+
+-- | Parser for a sum
+parserSum :: P.Parser DiceExpr
+parserSum = Sum <$> ("(" *> parserDiceExpr) <*> (P.skipSpace *> "+" *> P.skipSpace *> parserDiceExpr) <* ")"
+
+-- | Parser for a product
+parserProduct :: P.Parser DiceExpr
+parserProduct = Product <$> ("(" *> parserDiceExpr) <*> (P.skipSpace *> "*" *> parserDiceExpr) <* ")"
+
+-- | Parser for a subtraction
+parserSub :: P.Parser DiceExpr
+parserSub = Sub <$> ("(" *> parserDiceExpr) <*> (P.skipSpace *> "*" *> P.skipSpace *> parserDiceExpr) <* ")"
+
+-- | Parser for a rounded division
+parserDivRound :: P.Parser DiceExpr
+parserDivRound = DivRound <$> ("(" *> parserDiceExpr) <*> (P.skipSpace *> "/" *> P.skipSpace *> parserDiceExpr) <* ")"
+
+
+-- | Parser for a high-rounding division
+parserDivCeil :: P.Parser DiceExpr
+parserDivCeil = DivCeil <$> ("(" *> parserDiceExpr) <*> (P.skipSpace *> "/^" *> P.skipSpace *> parserDiceExpr) <* ")"
+
+-- | Parser for a low-rounding division
+parserDivFloor :: P.Parser DiceExpr
+parserDivFloor = DivFloor <$> ("(" *> parserDiceExpr) <*> (P.skipSpace *> "/v" *> P.skipSpace *> parserDiceExpr) <* ")"
+
+-- | Parser for a dice expression
+parserDiceExpr :: P.Parser DiceExpr
+parserDiceExpr = allP
+    where allP = parserSum
+               <|> parserSub
+               <|> parserProduct
+               <|> parserDivRound
+               <|> parserDivFloor
+               <|> parserDivCeil
+               <|> parserDiceKeepHigh
+               <|> parserDiceKeepLow
+               <|> parserDice
+               <|> parserConstant
+
+-- | Parse a dice expression
+parseDiceExpr :: Text -> Either Text DiceExpr
+parseDiceExpr spec =
+    let res = P.parse parserDiceExpr spec
+    in case res of
+        P.Fail _ _ msg -> Left $ pack msg
+        P.Partial f -> case f "" of
+            P.Fail _ _ msg -> Left $ pack msg
+            P.Partial _ -> error "unreachable"
+            P.Done _ r -> Right r
+        P.Done _ r -> Right r

src/Main.hs

@@ -0,0 +1,246 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main (main) where
+
+import Control.Monad (forM_, void)
+import Data.Default
+import Data.List (find)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Yaml
+import Discord
+import Discord.Interactions
+import qualified Discord.Requests as R
+import Discord.Types
+import UnliftIO
+import Dice
+
+data Config = Config {token :: Text, server :: GuildId} deriving (Show, Eq)
+
+instance FromJSON Config where
+  parseJSON = withObject "Config" $ \v ->
+    Config
+      <$> v .: "token"
+      <*> v .: "server"
+
+data Project = Project
+  { rolls :: [Integer],
+    target :: Integer
+  }
+  deriving (Show, Read, Eq)
+
+instance FromJSON Project where
+  parseJSON = withObject "Project" $
+    \v ->
+      Project
+        <$> v .: "rolls"
+        <*> v .: "target"
+
+instance ToJSON Project where
+  toJSON (Project r t) = object ["rolls" .= r, "target" .= t]
+
+newtype State = State {projects :: [Project]} deriving (Show, Read, Eq)
+
+instance FromJSON State where
+  parseJSON = withObject "State" $ \v -> State <$> v .: "projects"
+
+instance ToJSON State where
+  toJSON (State p) = object ["projects" .= p]
+
+instance Default State where def = State []
+
+readSave :: IO State
+readSave = do
+  loaded :: Either ParseException State <- decodeFileEither "save.yml"
+  case loaded of
+    Left _ -> do
+      putStrLn "Couldn't parse save, using empty state"
+      pure def
+    Right s -> do
+      putStrLn "Save Loaded"
+      pure s
+
+readConfig :: IO Config
+readConfig = do
+  loaded :: Either ParseException Config <- decodeFileEither "conf.yml"
+  case loaded of
+    Left _ -> error "Couldn't read config"
+    Right c -> do
+      putStrLn "Loaded config"
+      pure c
+
+main :: IO ()
+main = do
+  config <- readConfig
+  stateContent <- readSave
+  state :: MVar State <- newMVar stateContent
+  t <-
+    runDiscord $
+      def
+        { discordToken = token config,
+          discordOnStart = liftIO $ putStrLn "ninapcar init done",
+          discordOnEvent = eventHandler config state,
+          discordOnEnd = do
+            s <- readMVar state
+            encodeFile "save.yml" s
+            putStrLn "done",
+          discordGatewayIntent = def {gatewayIntentMessageContent = False}
+        }
+  putStrLn (T.unpack t)
+
+eventHandler :: Config -> MVar State -> Event -> DiscordHandler ()
+eventHandler config state = \case
+  Ready _ _ _ _ _ _ (PartialApplication appId _) -> onReady config appId
+  InteractionCreate intr -> onInteractionCreate state intr
+  _ -> pure ()
+
+data SlashCommand = SlashCommand
+  { name :: Text,
+    registration :: Maybe CreateApplicationCommand,
+    handler :: MVar State -> Interaction -> Maybe OptionsData -> DiscordHandler ()
+  }
+
+ping :: SlashCommand
+ping =
+  SlashCommand
+    { name = "ping",
+      registration =
+         let create = createChatInput "ping" "check bot status"
+         in create,
+      handler = \_state intr _opts ->
+        void . restCall $
+          R.CreateInteractionResponse
+            (interactionId intr)
+            (interactionToken intr)
+            (interactionResponseBasic "pong")
+    }
+
+rollDice :: Text -> IO (Either Text DiceResult)
+rollDice s =
+    case parseDiceExpr s of
+    Left err -> pure $ Left err
+    Right expr -> Right <$> compute expr
+
+data RollOpts = RollOpts { spec :: Maybe Text, comment :: Maybe Text }
+
+roll :: SlashCommand
+roll =
+  SlashCommand
+    { name = "roll",
+      registration = reg,
+      handler = han
+    }
+  where
+    reg =
+      let create = createChatInput "roll" "roll a dice"
+       in case create of
+            Nothing -> Nothing
+            Just c@CreateApplicationCommandChatInput {} ->
+              Just $
+                c
+                  { createOptions =
+                      Just $
+                        OptionsValues
+                          [ OptionValueString
+                              { optionValueName = "dice"
+                              , optionValueLocalizedName = Nothing
+                              , optionValueDescription = "dice spec to roll"
+                              , optionValueLocalizedDescription = Nothing
+                              , optionValueRequired = True
+                              , optionValueStringChoices = Left False
+                              , optionValueStringMinLen = Nothing
+                              , optionValueStringMaxLen = Nothing
+                              }
+                          , OptionValueString
+                              { optionValueName = "comment"
+                              , optionValueLocalizedName = Nothing
+                              , optionValueDescription = "comment for the dice roll"
+                              , optionValueLocalizedDescription = Nothing
+                              , optionValueRequired = False
+                              , optionValueStringChoices = Left False
+                              , optionValueStringMinLen = Nothing
+                              , optionValueStringMaxLen = Nothing
+                              }
+                          ]
+                  }
+            _ -> Nothing
+    han _state intr = \case
+      Just (OptionsDataValues raw_opts) -> do
+          let opts = parse_opts (RollOpts Nothing Nothing) raw_opts
+              commentTxt :: Text
+              commentTxt = case comment opts of
+                Nothing -> ""
+                Just c -> c <> ": "
+          case spec opts of
+              Nothing -> interactionReplyError intr "something went wrong"
+              Just s -> do
+                res <- liftIO $ rollDice s
+                case res of
+                    Left err -> interactionReplyError intr $ "Error: " <> err
+                    Right r ->  void . restCall
+                        $ R.CreateInteractionResponse (interactionId intr) (interactionToken intr) (interactionResponseBasic $ commentTxt <> "(`" <> s <> "`) " <> showResult r)
+        where
+           parse_opts :: RollOpts -> [OptionDataValue] -> RollOpts
+           parse_opts old [] = old
+           parse_opts old ((OptionDataValueString {optionDataValueString= Right val, optionDataValueName= "dice"}):rest) =
+               parse_opts (old { spec = Just val }) rest
+           parse_opts old ((OptionDataValueString {optionDataValueString = Right val, optionDataValueName = "comment" }):rest) =
+               parse_opts (old { comment = Just val }) rest
+           parse_opts old (_:rest) = parse_opts old rest
+           showResult :: DiceResult -> Text
+           showResult (DiceResult rs final) =
+               "[ " <> (foldr (<>) "" . map showRoll $ rs) <> "] -> " <> T.show final
+           showRoll :: (Bool, Integer) -> Text
+           showRoll (True, i) = T.show i <> " "
+           showRoll (False, i) = "~~" <> T.show i <> "~~ "
+      _ -> interactionReplyError intr "Something went wrong"
+slashCommands :: [SlashCommand]
+slashCommands = [ping, roll]
+
+onReady :: Config -> ApplicationId -> DiscordHandler ()
+onReady config appId = do
+  liftIO $ putStrLn "Bot Ready!"
+  appCmdRegistrations <- mapM tryRegistering slashCommands
+
+  case sequence appCmdRegistrations of
+    Left err ->
+      liftIO $ putStrLn $ "[!] Failed to register some commands" ++ show err
+    Right cmds -> do
+      liftIO $ putStrLn $ "Registered " ++ show (length cmds) ++ " command(s)"
+
+      unregisterOutdatedCmds cmds
+  where
+    tryRegistering cmd = case registration cmd of
+      Just reg ->
+        restCall $
+          R.CreateGuildApplicationCommand appId (server config) reg
+      Nothing -> pure . Left $ RestCallErrorCode 0 "" ""
+
+    unregisterOutdatedCmds validCmds = do
+      registered <- restCall $ R.GetGuildApplicationCommands appId (server config)
+      case registered of
+        Left err -> liftIO $ putStrLn $ "Failed to get registerd commands" ++ show err
+        Right cmds ->
+          let validIds = map applicationCommandId validCmds
+              outdatedIds =
+                filter (`notElem` validIds)
+                  . map applicationCommandId
+                  $ cmds
+           in forM_ outdatedIds $
+                restCall . R.DeleteGuildApplicationCommand appId (server config)
+
+onInteractionCreate :: MVar State -> Interaction -> DiscordHandler ()
+onInteractionCreate state = \case
+  cmd@InteractionApplicationCommand
+    { applicationCommandData = input@ApplicationCommandDataChatInput {}
+    } ->
+      case find (\c -> applicationCommandDataName input == name c) slashCommands of
+        Just found -> handler found state cmd (optionsData input)
+        Nothing -> liftIO $ putStrLn $ "Unknown slash command: `" ++ show (applicationCommandDataName input) ++ "`"
+  _ -> pure ()
+
+interactionReplyError :: Interaction -> Text -> DiscordHandler ()
+interactionReplyError intr err = void. restCall $ R.CreateInteractionResponse (interactionId intr) (interactionToken intr) (interactionResponseBasic $ "[ERROR] " <> err)