Progress to acid-state

aggreact.cabal

@@ -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

package.yaml

@@ -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

src/Aggreact/Comments.hs

@@ -1,11 +1,13 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveAnyClass       #-}
-{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveDataTypeable   #-}
-{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveGeneric        #-}
-{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleContexts     #-}
-{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE Strict                     #-}
+{-# LANGUAGE StandaloneDeriving   #-}
-{-# LANGUAGE TypeSynonymInstances       #-}
+{-# LANGUAGE Strict               #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 {- |
 Module      : Aggreact.Comments
@@ -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
+type Comments = IxSet.IxSet Comment
-newtype CommentTable v = IxSet (Comment v)
 
 -- 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
+  , 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 =
     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 =

src/Persist.hs

@@ -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")

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")
-

stack.yaml

@@ -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