Browse Source

remove DB in favor of simple-file-db

master
soupi 11 months ago
parent
commit
0843b6620b
7 changed files with 33 additions and 101 deletions
  1. +1
    -0
      package.yaml
  2. +0
    -74
      src/DB.hs
  3. +3
    -3
      src/Logi.hs
  4. +8
    -11
      src/Sephibot.hs
  5. +8
    -13
      src/Types.hs
  6. +2
    -0
      stack.yaml
  7. +11
    -0
      stack.yaml.lock

+ 1
- 0
package.yaml View File

@@ -37,6 +37,7 @@ dependencies:
- optparse-generic
- discord-haskell
- logi
- simple-file-db

library:
source-dirs: src


+ 0
- 74
src/DB.hs View File

@@ -1,76 +0,0 @@

module DB where

import Relude

import Data.Functor
import Data.Time
import System.Directory
import System.FilePath
import qualified Data.Text as T
import qualified Data.Map as M
import Control.Concurrent.STM (TBQueue, readTBQueue, writeTBQueue)
import Data.Serialize

import Types


initializeDB :: MonadIO m => MonadReader Config m => m DB
initializeDB = do
dbFilePath <- getDbFilePath
liftIO $ createDirectoryIfMissing True (takeDirectory dbFilePath)
dbFileExists <- liftIO $ doesFileExist dbFilePath
if dbFileExists
then do
loadStateIO >>= \case
Left err ->
error $ "Failed to load file.\n - " <> toText err
Right db ->
pure db
else do
saveStateIO defaultDB
pure defaultDB

getDbFilePath :: MonadReader Config m => m FilePath
getDbFilePath =
asks dbFilePath

saveStateIO :: MonadIO m => MonadReader Config m => DB -> m ()
saveStateIO mystate = do
dbfile <- getDbFilePath
writeFileBS dbfile $ encode mystate

loadStateIO :: MonadIO m => MonadReader Config m => m (Either String DB)
loadStateIO = do
dbfile <- getDbFilePath
decode <$> readFileBS dbfile

dbWorker :: Config -> TBQueue DBMessage -> IO ()
dbWorker cfg queue =
forever $ do
atomically (readTBQueue queue) >>= \case
Save db ->
runReaderT (saveStateIO db) cfg

readDB :: MyState -> STM DB
readDB MyState{_dbVar} = readTVar $ unsafeGetDbVar _dbVar

writeDB :: DB -> MyState -> STM ()
writeDB db mystate = do
writeTVar (unsafeGetDbVar $ _dbVar mystate) db
writeTBQueue (_dbMsgQueue mystate) (Save db)

modifyDB :: MyState -> (DB -> DB) -> STM ()
modifyDB mystate f = flip writeDB mystate . f =<< readDB mystate

readDBIO :: MonadIO m => MyState -> m DB
readDBIO = atomically . readDB

writeDBIO :: MonadIO m => DB -> MyState -> m ()
writeDBIO db = atomically . writeDB db

modifyDBIO :: MonadIO m => MyState -> (DB -> DB) -> m ()
modifyDBIO mystate f = atomically $ modifyDB mystate f


+ 3
- 3
src/Logi.hs View File

@@ -16,12 +16,12 @@ import Discord.Types

import Language.Logi
import Types
import DB
import SimpleFileDb

runCode :: MonadIO m => MyState -> GuildId -> FilePath -> Code -> m (Maybe [Code])
runCode mystate gid name (Code code) =
liftIO $ timeout (2_000_000) $ atomically $ do
db <- readDB mystate
db <- readDB (mystate ^. dbVar)
randseed <- readTVar (mystate ^. randomSeed)
let
initialKnowledge = maybe defaultKnowledge id $ M.lookup gid (db ^. logiKnowledge)
@@ -29,7 +29,7 @@ runCode mystate gid name (Code code) =
Left err ->
pure [Code $ "Error: " <> ppErr err]
Right (results, Ctx knowledge randseed') -> do
modifyDB mystate $ over logiKnowledge $ M.insert gid knowledge
modifyDB (mystate ^. dbVar) $ over logiKnowledge $ M.insert gid knowledge
writeTVar (mystate ^. randomSeed) randseed'
pure $ map (Code . ppToText . ppResults) results



+ 8
- 11
src/Sephibot.hs View File

@@ -1,13 +1,12 @@
module Sephibot where

import Relude hiding (isPrefixOf)
import Control.Lens
import Control.Lens hiding (mapping)

import qualified Data.Text as T
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Concurrent
import Control.Concurrent.STM (newTBQueueIO)

import Data.Time
import System.Random
@@ -19,16 +18,14 @@ import qualified Discord.Requests as R
import When
import Types
import Logi
import DB
import SimpleFileDb

reportTime :: Text -> FilePath -> IO ()
reportTime token (Config -> cfg) = do
dbvar <- fmap DBVar . newTVarIO =<< runReaderT initializeDB cfg
msgQueue <- newTBQueueIO 100
void $ forkIO $ dbWorker cfg msgQueue
reportTime token dbfile = do
dbvar <- initializeDB dbfile defaultDB
stdgenVar <- newTVarIO =<< getStdGen
let
mystate = MyState dbvar msgQueue stdgenVar
mystate = MyState dbvar stdgenVar
userFacingError <-
runDiscord $ def
{ discordToken = token
@@ -107,7 +104,7 @@ handleMessage mystate message = do

| Just runWhen <- M.lookup txt whenToFormatter -> do
reactClock message
dates <- _targetDates <$> readDBIO mystate
dates <- _targetDates <$> readDBIO (mystate ^. dbVar)
case (`M.lookup` dates) =<< messageGuild message of
Nothing ->
sendMsg message "Date not set. Use the `:set-date` command to set a new date."
@@ -156,7 +153,7 @@ handleMessage mystate message = do
reminders :: GuildId -> MyState -> DiscordHandler ()
reminders gid mystate = do
now <- liftIO getCurrentTime
dates <- _targetDates <$> readDBIO mystate
dates <- _targetDates <$> readDBIO (mystate ^. dbVar)

let
uniques = S.toList . S.fromList
@@ -179,7 +176,7 @@ reminders gid mystate = do

setDate :: MonadIO m => MyState -> GuildId -> Maybe (ChannelId, UTCTime) -> m ()
setDate mystate ids mtime =
modifyDBIO mystate $
modifyDBIO (mystate ^. dbVar) $
over targetDates $
case mtime of
Nothing ->


+ 8
- 13
src/Types.hs View File

@@ -12,6 +12,7 @@ import Control.Concurrent.STM (TBQueue)
import Data.Time
import System.Random
import Language.Logi
import SimpleFileDb

---
instance Serialize Day where
@@ -28,33 +29,27 @@ instance Serialize Snowflake where
get = Snowflake <$> get
---

data DBMessage
= Save DB

newtype DBVar = DBVar { unsafeGetDbVar :: TVar DB }

data DB
= DB
data MyDB
= MyDB
{ _targetDates :: M.Map GuildId (ChannelId, UTCTime)
, _logiKnowledge :: M.Map GuildId Knowledge
}
deriving Generic

instance Serialize DB
instance Serialize MyDB

data MyState
= MyState
{ _dbVar :: DBVar
, _dbMsgQueue :: TBQueue DBMessage
{ _dbVar :: DBVar MyDB
, _randomSeed :: TVar StdGen
}
deriving Generic

makeLenses ''DB
makeLenses ''MyDB
makeLenses ''MyState

defaultDB :: DB
defaultDB = DB mempty mempty
defaultDB :: MyDB
defaultDB = MyDB mempty mempty

data Config
= Config


+ 2
- 0
stack.yaml View File

@@ -11,3 +11,5 @@ packages:
extra-deps:
- discord-haskell-1.8.0@sha256:420515069c5be313dd31d16e9a4b163d2b3fdda18ba18e98cbb0b0536cbae136,3562
- emoji-0.1.0.2@sha256:d995572a5c7dcd28f98eb15c6e387a7b3bda1ac2477ab0d9dba8580d5d7b161f,1273
- git: https://gitlab.com/gilmi/simple-file-db.git
commit: 0d05f69f3f677642dea41bcf1660db5a8e727bc7

+ 11
- 0
stack.yaml.lock View File

@@ -18,6 +18,17 @@ packages:
sha256: dd9ea90a631342e5db0fc21331ade4d563a685e9125d5a3989eefa8e1b96c6c6
original:
hackage: emoji-0.1.0.2@sha256:d995572a5c7dcd28f98eb15c6e387a7b3bda1ac2477ab0d9dba8580d5d7b161f,1273
- completed:
name: simple-file-db
version: 0.1.0.0
git: https://gitlab.com/gilmi/simple-file-db.git
pantry-tree:
size: 428
sha256: 741373768c894daf8f5224a8d09f0b76c8c550aa672699015692917b438d2dab
commit: 0d05f69f3f677642dea41bcf1660db5a8e727bc7
original:
git: https://gitlab.com/gilmi/simple-file-db.git
commit: 0d05f69f3f677642dea41bcf1660db5a8e727bc7
snapshots:
- completed:
size: 532172


Loading…
Cancel
Save