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
|
||||
--
|
||||
-- hash: 1045a6f370c70bdbb8d4127fd57ab0a6d22abf83a1c9ce43b2543665b731e255
|
||||
-- hash: 509d9cadd72adab87913aef5b043403f5fafe6e6fd1545c065f3fe98db5d18c2
|
||||
|
||||
name: aggreact
|
||||
version: 0.1.0.0
|
||||
|
@ -29,8 +29,6 @@ library
|
|||
exposed-modules:
|
||||
Aggreact
|
||||
Aggreact.Comments
|
||||
Persist
|
||||
Store
|
||||
other-modules:
|
||||
Paths_aggreact
|
||||
hs-source-dirs:
|
||||
|
@ -38,7 +36,8 @@ library
|
|||
default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables
|
||||
ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2
|
||||
build-depends:
|
||||
aeson
|
||||
acid-state
|
||||
, aeson
|
||||
, base >=4.8 && <5
|
||||
, cereal
|
||||
, cereal-text
|
||||
|
@ -46,11 +45,11 @@ library
|
|||
, containers
|
||||
, ixset
|
||||
, protolude
|
||||
, safecopy
|
||||
, servant
|
||||
, servant-server
|
||||
, text
|
||||
, time
|
||||
, versioning
|
||||
default-language: Haskell2010
|
||||
|
||||
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
|
||||
dependencies:
|
||||
- aeson
|
||||
- acid-state
|
||||
- cereal
|
||||
- cereal-text
|
||||
- cereal-time
|
||||
- containers
|
||||
- ixset
|
||||
- safecopy
|
||||
- servant
|
||||
- servant-server
|
||||
- text
|
||||
- time
|
||||
- versioning
|
||||
executables:
|
||||
aggreact:
|
||||
main: Main.hs
|
||||
|
|
|
@ -2,9 +2,11 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
{- |
|
||||
|
@ -25,15 +27,18 @@ module Aggreact.Comments
|
|||
Id (..)
|
||||
, Comment (..)
|
||||
, Comments
|
||||
, CommentTable (..)
|
||||
) where
|
||||
|
||||
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.Char (isAlphaNum)
|
||||
import Data.Data (Data (..))
|
||||
import qualified Data.IxSet as IxSet
|
||||
import Data.SafeCopy (base, deriveSafeCopy)
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.Serialize.Text ()
|
||||
import qualified Data.Text as Text
|
||||
|
@ -41,13 +46,10 @@ import Data.Time (UTCTime)
|
|||
import Data.Time.Clock.Serialize ()
|
||||
import Data.Typeable (Typeable)
|
||||
|
||||
import Versioning.Base
|
||||
|
||||
|
||||
-- * Comments
|
||||
|
||||
type Comments = CommentTable V0
|
||||
newtype CommentTable v = IxSet (Comment v)
|
||||
type Comments = IxSet.IxSet Comment
|
||||
|
||||
-- Orphan Instance for Serialize IxSet
|
||||
instance ( Serialize a
|
||||
|
@ -59,16 +61,21 @@ instance ( Serialize a
|
|||
|
||||
-- * 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 ToJSON 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 ToJSON 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)
|
||||
deriving instance FromJSON UserId
|
||||
deriving instance ToJSON UserId
|
||||
|
@ -81,32 +88,65 @@ deriving instance Serialize Content
|
|||
|
||||
newtype Term = Term Text deriving (Eq,Ord,Generic)
|
||||
|
||||
data Comment v =
|
||||
data Comment =
|
||||
Comment
|
||||
{ id :: Id
|
||||
, parent :: ParentId
|
||||
, root :: RootId
|
||||
, created :: UTCTime
|
||||
, content :: Content
|
||||
, userid :: Since V0 v UserId
|
||||
} deriving (Generic,Typeable)
|
||||
, userid :: UserId
|
||||
} deriving (Generic,Typeable,Eq,Ord)
|
||||
|
||||
deriving instance FromJSON (Comment V0)
|
||||
deriving instance ToJSON (Comment V0)
|
||||
deriving instance Serialize (Comment V0)
|
||||
deriving instance Data (Comment V0)
|
||||
instance IxSet.Indexable (Comment V0) where
|
||||
deriving instance FromJSON Comment
|
||||
deriving instance ToJSON Comment
|
||||
deriving instance Serialize Comment
|
||||
deriving instance Data Comment
|
||||
instance IxSet.Indexable Comment where
|
||||
empty =
|
||||
IxSet.ixSet
|
||||
[ IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy Id)
|
||||
, IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy ParentId)
|
||||
, IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy RootId)
|
||||
, IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy UserId)
|
||||
, IxSet.ixFun getTerms -- Ability to search content text
|
||||
]
|
||||
|
||||
getTerms :: Comment v -> [Term]
|
||||
getTerms :: Comment -> [Term]
|
||||
getTerms = fmap Term . Text.split (not . isAlphaNum) . unContent . content
|
||||
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
|
||||
|
||||
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)
|
||||
extra-deps:
|
||||
- ixset-1.1.1
|
||||
- versioning-0.3.0.1
|
||||
- syb-with-class-0.6.1.10
|
||||
- acid-state-0.14.3
|
||||
|
||||
|
||||
# Override default flag values for local packages and extra-deps
|
||||
|
|
Loading…
Reference in a new issue