Progress to acid-state
This commit is contained in:
parent
7d689e9d33
commit
0c32b46e49
7 changed files with 70 additions and 162 deletions
|
@ -2,7 +2,7 @@
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 1045a6f370c70bdbb8d4127fd57ab0a6d22abf83a1c9ce43b2543665b731e255
|
-- hash: 509d9cadd72adab87913aef5b043403f5fafe6e6fd1545c065f3fe98db5d18c2
|
||||||
|
|
||||||
name: aggreact
|
name: aggreact
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
@ -29,8 +29,6 @@ library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Aggreact
|
Aggreact
|
||||||
Aggreact.Comments
|
Aggreact.Comments
|
||||||
Persist
|
|
||||||
Store
|
|
||||||
other-modules:
|
other-modules:
|
||||||
Paths_aggreact
|
Paths_aggreact
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
|
@ -38,7 +36,8 @@ library
|
||||||
default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables
|
default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables
|
||||||
ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2
|
ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2
|
||||||
build-depends:
|
build-depends:
|
||||||
aeson
|
acid-state
|
||||||
|
, aeson
|
||||||
, base >=4.8 && <5
|
, base >=4.8 && <5
|
||||||
, cereal
|
, cereal
|
||||||
, cereal-text
|
, cereal-text
|
||||||
|
@ -46,11 +45,11 @@ library
|
||||||
, containers
|
, containers
|
||||||
, ixset
|
, ixset
|
||||||
, protolude
|
, protolude
|
||||||
|
, safecopy
|
||||||
, servant
|
, servant
|
||||||
, servant-server
|
, servant-server
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
, versioning
|
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
executable aggreact
|
executable aggreact
|
||||||
|
|
BIN
dist-newstyle/cache/config
vendored
BIN
dist-newstyle/cache/config
vendored
Binary file not shown.
|
@ -28,16 +28,17 @@ library:
|
||||||
source-dirs: src
|
source-dirs: src
|
||||||
dependencies:
|
dependencies:
|
||||||
- aeson
|
- aeson
|
||||||
|
- acid-state
|
||||||
- cereal
|
- cereal
|
||||||
- cereal-text
|
- cereal-text
|
||||||
- cereal-time
|
- cereal-time
|
||||||
- containers
|
- containers
|
||||||
- ixset
|
- ixset
|
||||||
|
- safecopy
|
||||||
- servant
|
- servant
|
||||||
- servant-server
|
- servant-server
|
||||||
- text
|
- text
|
||||||
- time
|
- time
|
||||||
- versioning
|
|
||||||
executables:
|
executables:
|
||||||
aggreact:
|
aggreact:
|
||||||
main: Main.hs
|
main: Main.hs
|
||||||
|
|
|
@ -2,9 +2,11 @@
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE Strict #-}
|
{-# LANGUAGE Strict #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
|
|
||||||
{- |
|
{- |
|
||||||
|
@ -25,15 +27,18 @@ module Aggreact.Comments
|
||||||
Id (..)
|
Id (..)
|
||||||
, Comment (..)
|
, Comment (..)
|
||||||
, Comments
|
, Comments
|
||||||
, CommentTable (..)
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Protolude hiding (get, put)
|
import Protolude hiding (get, put)
|
||||||
|
|
||||||
|
import Data.Acid (AcidState, Query, Update,
|
||||||
|
makeAcidic, openLocalState)
|
||||||
|
import Data.Acid.Advanced (query', update')
|
||||||
import Data.Aeson (FromJSON, ToJSON)
|
import Data.Aeson (FromJSON, ToJSON)
|
||||||
import Data.Char (isAlphaNum)
|
import Data.Char (isAlphaNum)
|
||||||
import Data.Data (Data (..))
|
import Data.Data (Data (..))
|
||||||
import qualified Data.IxSet as IxSet
|
import qualified Data.IxSet as IxSet
|
||||||
|
import Data.SafeCopy (base, deriveSafeCopy)
|
||||||
import Data.Serialize (Serialize (..))
|
import Data.Serialize (Serialize (..))
|
||||||
import Data.Serialize.Text ()
|
import Data.Serialize.Text ()
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
|
@ -41,13 +46,10 @@ import Data.Time (UTCTime)
|
||||||
import Data.Time.Clock.Serialize ()
|
import Data.Time.Clock.Serialize ()
|
||||||
import Data.Typeable (Typeable)
|
import Data.Typeable (Typeable)
|
||||||
|
|
||||||
import Versioning.Base
|
|
||||||
|
|
||||||
|
|
||||||
-- * Comments
|
-- * Comments
|
||||||
|
|
||||||
type Comments = CommentTable V0
|
type Comments = IxSet.IxSet Comment
|
||||||
newtype CommentTable v = IxSet (Comment v)
|
|
||||||
|
|
||||||
-- Orphan Instance for Serialize IxSet
|
-- Orphan Instance for Serialize IxSet
|
||||||
instance ( Serialize a
|
instance ( Serialize a
|
||||||
|
@ -59,16 +61,21 @@ instance ( Serialize a
|
||||||
|
|
||||||
-- * Comment
|
-- * Comment
|
||||||
|
|
||||||
newtype Id = Id Int64 deriving (Eq,Ord,Generic,Data)
|
newtype Id = Id Text deriving (Eq,Ord,Generic,Data)
|
||||||
deriving instance FromJSON Id
|
deriving instance FromJSON Id
|
||||||
deriving instance ToJSON Id
|
deriving instance ToJSON Id
|
||||||
deriving instance Serialize Id
|
deriving instance Serialize Id
|
||||||
|
|
||||||
newtype ParentId = ParentId Int64 deriving (Eq,Ord,Generic,Data)
|
newtype ParentId = ParentId Text deriving (Eq,Ord,Generic,Data)
|
||||||
deriving instance FromJSON ParentId
|
deriving instance FromJSON ParentId
|
||||||
deriving instance ToJSON ParentId
|
deriving instance ToJSON ParentId
|
||||||
deriving instance Serialize ParentId
|
deriving instance Serialize ParentId
|
||||||
|
|
||||||
|
newtype RootId = RootId Text deriving (Eq,Ord,Generic,Data)
|
||||||
|
deriving instance FromJSON RootId
|
||||||
|
deriving instance ToJSON RootId
|
||||||
|
deriving instance Serialize RootId
|
||||||
|
|
||||||
newtype UserId = UserId Text deriving (Eq,Ord,Generic,Data)
|
newtype UserId = UserId Text deriving (Eq,Ord,Generic,Data)
|
||||||
deriving instance FromJSON UserId
|
deriving instance FromJSON UserId
|
||||||
deriving instance ToJSON UserId
|
deriving instance ToJSON UserId
|
||||||
|
@ -81,32 +88,65 @@ deriving instance Serialize Content
|
||||||
|
|
||||||
newtype Term = Term Text deriving (Eq,Ord,Generic)
|
newtype Term = Term Text deriving (Eq,Ord,Generic)
|
||||||
|
|
||||||
data Comment v =
|
data Comment =
|
||||||
Comment
|
Comment
|
||||||
{ id :: Id
|
{ id :: Id
|
||||||
, parent :: ParentId
|
, parent :: ParentId
|
||||||
|
, root :: RootId
|
||||||
, created :: UTCTime
|
, created :: UTCTime
|
||||||
, content :: Content
|
, content :: Content
|
||||||
, userid :: Since V0 v UserId
|
, userid :: UserId
|
||||||
} deriving (Generic,Typeable)
|
} deriving (Generic,Typeable,Eq,Ord)
|
||||||
|
|
||||||
deriving instance FromJSON (Comment V0)
|
deriving instance FromJSON Comment
|
||||||
deriving instance ToJSON (Comment V0)
|
deriving instance ToJSON Comment
|
||||||
deriving instance Serialize (Comment V0)
|
deriving instance Serialize Comment
|
||||||
deriving instance Data (Comment V0)
|
deriving instance Data Comment
|
||||||
instance IxSet.Indexable (Comment V0) where
|
instance IxSet.Indexable Comment where
|
||||||
empty =
|
empty =
|
||||||
IxSet.ixSet
|
IxSet.ixSet
|
||||||
[ IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy Id)
|
[ IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy Id)
|
||||||
, IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy ParentId)
|
, IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy ParentId)
|
||||||
|
, IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy RootId)
|
||||||
, IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy UserId)
|
, IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy UserId)
|
||||||
, IxSet.ixFun getTerms -- Ability to search content text
|
, IxSet.ixFun getTerms -- Ability to search content text
|
||||||
]
|
]
|
||||||
|
|
||||||
getTerms :: Comment v -> [Term]
|
getTerms :: Comment -> [Term]
|
||||||
getTerms = fmap Term . Text.split (not . isAlphaNum) . unContent . content
|
getTerms = fmap Term . Text.split (not . isAlphaNum) . unContent . content
|
||||||
where unContent (Content x) = x
|
where unContent (Content x) = x
|
||||||
|
|
||||||
|
$(deriveSafeCopy 0 'base ''Id)
|
||||||
|
$(deriveSafeCopy 0 'base ''ParentId)
|
||||||
|
$(deriveSafeCopy 0 'base ''RootId)
|
||||||
|
$(deriveSafeCopy 0 'base ''Content)
|
||||||
|
$(deriveSafeCopy 0 'base ''UserId)
|
||||||
|
$(deriveSafeCopy 0 'base ''Comment)
|
||||||
|
|
||||||
|
initialComments :: Comments
|
||||||
|
initialComments = IxSet.empty
|
||||||
|
|
||||||
|
createComment :: Comment -> Update Comments ()
|
||||||
|
createComment = modify . IxSet.insert
|
||||||
|
|
||||||
|
updateComment :: Comment -> Update Comments ()
|
||||||
|
updateComment comment = modify (IxSet.updateIx (id comment) comment)
|
||||||
|
|
||||||
|
commentById :: Id -> Query Comments (Maybe Comment)
|
||||||
|
commentById cid = do
|
||||||
|
comments <- ask
|
||||||
|
return (IxSet.getOne (comments IxSet.@= cid))
|
||||||
|
|
||||||
|
commentsByParentId :: ParentId -> Query Comments [Comment]
|
||||||
|
commentsByParentId pid = do
|
||||||
|
comments <- ask
|
||||||
|
return (IxSet.toList (comments IxSet.@= pid))
|
||||||
|
|
||||||
|
commentsByRootId :: RootId -> Query Comments [Comment]
|
||||||
|
commentsByRootId rid = do
|
||||||
|
comments <- ask
|
||||||
|
return (IxSet.toList (comments IxSet.@= rid))
|
||||||
|
|
||||||
-- * Root
|
-- * Root
|
||||||
|
|
||||||
newtype Root =
|
newtype Root =
|
||||||
|
|
|
@ -1,84 +0,0 @@
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
{-|
|
|
||||||
module : Persist
|
|
||||||
Description : Persistence Lib
|
|
||||||
License : ISC
|
|
||||||
Maintainer : yann.esposito@gmail.com
|
|
||||||
|
|
||||||
This module handle persistence of state when the state is small:
|
|
||||||
|
|
||||||
- can be kept into memory
|
|
||||||
- equality between different state is fast enough
|
|
||||||
- serialization of the state to a file is fast enough
|
|
||||||
|
|
||||||
This is the case for many small applications.
|
|
||||||
The thread safety is handled with @TVar@ so it is oriented toward safety
|
|
||||||
and absolutely not toward efficiency.
|
|
||||||
|
|
||||||
For a more efficient persistence, you should really look toward an real DB.
|
|
||||||
|
|
||||||
-}
|
|
||||||
module Persist
|
|
||||||
( periodicallySave
|
|
||||||
, save )
|
|
||||||
where
|
|
||||||
|
|
||||||
import Protolude
|
|
||||||
|
|
||||||
import Control.Concurrent.STM.TVar (TVar)
|
|
||||||
import qualified Control.Concurrent.STM.TVar as TVar
|
|
||||||
import Data.Serialize
|
|
||||||
import System.AtomicWrite.Writer.ByteString
|
|
||||||
import qualified Versioning.Base as V
|
|
||||||
|
|
||||||
-- | save a in a reference in a file each when it changes with at most every
|
|
||||||
-- `nbSec` seconds Won't save when first called. Please use `save` if you want
|
|
||||||
-- to save before change.
|
|
||||||
periodicallySave :: (Serialize a, Eq a)
|
|
||||||
=> FilePath
|
|
||||||
-> Double
|
|
||||||
-> TVar a
|
|
||||||
-> IO ()
|
|
||||||
periodicallySave fp nbSec ref = do
|
|
||||||
currentValue <- TVar.readTVarIO ref
|
|
||||||
oldRef <- TVar.newTVarIO currentValue
|
|
||||||
periodicallySave' fp nbSec oldRef ref
|
|
||||||
|
|
||||||
periodicallySave' :: (Serialize a, Eq a)
|
|
||||||
=> FilePath
|
|
||||||
-> Double
|
|
||||||
-> TVar a
|
|
||||||
-> TVar a
|
|
||||||
-> IO ()
|
|
||||||
periodicallySave' fp nbSec oldref ref = void . async . forever $ do
|
|
||||||
oldValue <- TVar.readTVarIO oldref
|
|
||||||
value <- TVar.readTVarIO ref
|
|
||||||
when (value /= oldValue) $ do
|
|
||||||
putText "State changed!"
|
|
||||||
save fp value
|
|
||||||
atomically (TVar.writeTVar oldref value)
|
|
||||||
threadDelay (ceiling (nbSec * 1000000))
|
|
||||||
|
|
||||||
-- | Save a value in a file atomically (using mv)
|
|
||||||
save :: (Serialize a)
|
|
||||||
=> FilePath
|
|
||||||
-> a
|
|
||||||
-> IO ()
|
|
||||||
save fp value = do
|
|
||||||
putText $ "Saving state in " <> toS fp
|
|
||||||
atomicWriteFile fp (encode value)
|
|
||||||
|
|
||||||
(*->) = flip $
|
|
||||||
(*=>) = flip fmap
|
|
||||||
|
|
||||||
load :: FilePath -> v -> IO (Either Text (v a))
|
|
||||||
load dbFile v = do
|
|
||||||
dbFileExists <- doesFileExist dbFile
|
|
||||||
db <- if dbFileExists
|
|
||||||
then do
|
|
||||||
fileContent <- BS.readFile dbFile
|
|
||||||
decode fileContent *=> V.upgrade v
|
|
||||||
else
|
|
||||||
return (dbFile <> " doesn't exists")
|
|
48
src/Store.hs
48
src/Store.hs
|
@ -1,48 +0,0 @@
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# LANGUAGE Strict #-}
|
|
||||||
|
|
||||||
{- |
|
|
||||||
Module : Store
|
|
||||||
Description : Example of a library file.
|
|
||||||
Copyright : (c) 2018, Yann Esposito
|
|
||||||
License : ISC
|
|
||||||
Maintainer : yann.esposito@gmail.com
|
|
||||||
Stability : experimental
|
|
||||||
Portability : POSIX
|
|
||||||
|
|
||||||
This module handle persistence of state when the state is small:
|
|
||||||
|
|
||||||
- can be kept into memory
|
|
||||||
- equality between different state is fast enough
|
|
||||||
- serialization of the state to a file is fast enough
|
|
||||||
|
|
||||||
This is the case for many small applications.
|
|
||||||
The thread safety is handled with @TVar@ so it is oriented toward safety
|
|
||||||
and absolutely not toward efficiency.
|
|
||||||
|
|
||||||
For a more efficient persistence, you should really look toward an real DB.
|
|
||||||
|
|
||||||
-}
|
|
||||||
module Store
|
|
||||||
(
|
|
||||||
-- * Exported Functions
|
|
||||||
inc
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Protolude
|
|
||||||
|
|
||||||
import qualified Versioning.Base as V
|
|
||||||
import qualified Versioning.JSON as VJSON
|
|
||||||
|
|
||||||
load :: FilePath -> v -> IO (Either Text (v a))
|
|
||||||
load dbFile v = do
|
|
||||||
dbFileExists <- doesFileExist dbFile
|
|
||||||
db <- if dbFileExists
|
|
||||||
then do
|
|
||||||
fileContent <- BS.readFile dbFile
|
|
||||||
VJSON.fromJsonAnyVersionEither fileContent `fmap` \x -> V.upgrade latestVersion x
|
|
||||||
else
|
|
||||||
return (dbFile <> " doesn't exists")
|
|
||||||
|
|
|
@ -40,8 +40,8 @@ packages:
|
||||||
# (e.g., acme-missiles-0.3)
|
# (e.g., acme-missiles-0.3)
|
||||||
extra-deps:
|
extra-deps:
|
||||||
- ixset-1.1.1
|
- ixset-1.1.1
|
||||||
- versioning-0.3.0.1
|
|
||||||
- syb-with-class-0.6.1.10
|
- syb-with-class-0.6.1.10
|
||||||
|
- acid-state-0.14.3
|
||||||
|
|
||||||
|
|
||||||
# Override default flag values for local packages and extra-deps
|
# Override default flag values for local packages and extra-deps
|
||||||
|
|
Loading…
Reference in a new issue