Browse Source

simple file db

master
soupi 1 year ago
commit
0d05f69f3f
8 changed files with 370 additions and 0 deletions
  1. +114
    -0
      .gitignore
  2. +30
    -0
      LICENSE
  3. +6
    -0
      README.md
  4. +62
    -0
      package.yaml
  5. +37
    -0
      simple-file-db.cabal
  6. +103
    -0
      src/SimpleFileDb.hs
  7. +6
    -0
      stack.yaml
  8. +12
    -0
      stack.yaml.lock

+ 114
- 0
.gitignore View File

@@ -0,0 +1,114 @@
/dist/
/.cabal-sandbox/
/cabal.sandbox.config
/.stack-work/

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.

+ 6
- 0
README.md View File

@@ -0,0 +1,6 @@
# simple-file-db

A very very simple way to save data in a file and interact with it in a concurrent setting.

Note that this is not tolerant of async IO exceptions.
Use this for your toy projects if you'd like but don't trust it!

+ 62
- 0
package.yaml View File

@@ -0,0 +1,62 @@
name: simple-file-db
version: 0.1.0.0
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 GitLab at <https://gitlab.com/gilmi/simple-file-db#readme>

dependencies:
- base >= 4.7 && < 5
- relude
- filepath
- directory
- cereal
- stm
- mtl

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


+ 37
- 0
simple-file-db.cabal View File

@@ -0,0 +1,37 @@
cabal-version: 1.12

-- This file has been generated from package.yaml by hpack version 0.33.0.
--
-- see: https://github.com/sol/hpack
--
-- hash: 50cf4b5b3906b49299bc79335968aad19c4bbacab53a1948f806ce68437bf5de

name: simple-file-db
version: 0.1.0.0
description: Please see the README on GitLab at <https://gitlab.com/gilmi/simple-file-db#readme>
author: Gil Mizrahi
maintainer: gilmi@posteo.net
copyright: 2020 Gil Mizrahi
license: BSD3
license-file: LICENSE
build-type: Simple
extra-source-files:
README.md

library
exposed-modules:
SimpleFileDb
other-modules:
Paths_simple_file_db
hs-source-dirs:
src
default-extensions: NoImplicitPrelude BangPatterns ConstraintKinds DataKinds DeriveFunctor DeriveFoldable DeriveTraversable DeriveDataTypeable DeriveGeneric DeriveAnyClass EmptyDataDecls FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiWayIf MultiParamTypeClasses FunctionalDependencies TypeSynonymInstances PatternGuards PatternSynonyms RankNTypes RecordWildCards NamedFieldPuns ScopedTypeVariables TupleSections ViewPatterns TypeApplications OverloadedStrings QuasiQuotes
build-depends:
base >=4.7 && <5
, cereal
, directory
, filepath
, mtl
, relude
, stm
default-language: Haskell2010

+ 103
- 0
src/SimpleFileDb.hs View File

@@ -0,0 +1,103 @@
-- | Interact with the db file

module SimpleFileDb
( DBVar
, DB
, DBMessage(..)
, initializeDB
, dbWorker
, readDB
, writeDB
, modifyDB
, readDBIO
, writeDBIO
, modifyDBIO
)
where

import Relude

import Data.Functor
import System.Directory
import System.FilePath
import Control.Concurrent.STM (TBQueue, readTBQueue, writeTBQueue, newTBQueueIO)
import Control.Concurrent (forkIO)
import Data.Serialize

data DBMessage db
= Save db

data DBVar db
= DBVar
{ getDbVar :: TVar db
, getMsgQueue :: TBQueue (DBMessage db)
}

type DB db = (Serialize db)

-- Actions --

initializeDB
:: DB db => MonadIO m => FilePath -> db -> m (DBVar db)
initializeDB dbfile emptydb = do
liftIO $ createDirectoryIfMissing True (takeDirectory dbfile)
dbFileExists <- liftIO $ doesFileExist dbfile
if dbFileExists
then do
runReaderT loadStateIO dbfile >>= \case
Left err ->
error $ "Failed to load file.\n - " <> toText err
Right db -> do
mkDBVar dbfile db
else do
runReaderT (saveStateIO emptydb) dbfile
mkDBVar dbfile emptydb

mkDBVar :: DB db => MonadIO m => FilePath -> db -> m (DBVar db)
mkDBVar dbfile db = do
dbv <- liftIO $ newTVarIO db
dbq <- liftIO $ newTBQueueIO 100
let dbvar = DBVar dbv dbq
liftIO $ forkIO $ dbWorker dbfile dbvar
pure dbvar

getDbFilePath :: MonadReader FilePath m => m FilePath
getDbFilePath = ask

saveStateIO :: DB db => MonadIO m => MonadReader FilePath m => db -> m ()
saveStateIO x = do
dbfile <- getDbFilePath
writeFileBS dbfile $ encode x

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

dbWorker :: DB db => FilePath -> DBVar db -> IO ()
dbWorker cfg dbvar =
forever $ do
atomically (readTBQueue (getMsgQueue dbvar)) >>= \case
Save db ->
runReaderT (saveStateIO db) cfg

readDB :: DBVar db -> STM db
readDB dbVar = readTVar $ getDbVar dbVar

writeDB :: db -> DBVar db -> STM ()
writeDB db dbvar = do
writeTVar (getDbVar dbvar) db
writeTBQueue (getMsgQueue dbvar) (Save db)

modifyDB :: DB db => DBVar db -> (db -> db) -> STM ()
modifyDB dbvar f = flip writeDB dbvar . f =<< readDB dbvar

readDBIO :: DB db => MonadIO m => DBVar db -> m db
readDBIO = atomically . readDB

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

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


+ 6
- 0
stack.yaml View File

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

packages:
- .

extra-deps: []

+ 12
- 0
stack.yaml.lock View File

@@ -0,0 +1,12 @@
# 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: []
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