fix conflicts with stateExport

.gitignore

@@ -16,5 +16,6 @@ users.json
 state
 log
 
+backupData.bin
 
 

reffit.cabal

@@ -41,6 +41,7 @@ Executable reffit
     aeson,
     lens-aeson,
     unordered-containers,
+    cereal,
     bytestring                >= 0.9.1   && < 0.11,
     heist                     >= 0.13    && < 0.14,
     snaplet-acid-state        >= 0.2.5   && < 0.3,

src/Reffit/AcidTypes.hs

@@ -41,10 +41,12 @@ import Snap (SnapletInit, Snaplet, Handler,
              addRoutes, nestSnaplet, serveSnaplet,
              defaultConfig, makeSnaplet,
              snapletValue, writeText, modify, gets)
+import Data.Serialize
 import Snap.Snaplet.AcidState (Update, Query, Acid, 
                                 HasAcid (getAcidStore),
                                 makeAcidic, update,
                                 query, acidInit)
+import Control.Lens
 
 data PersistentState = PersistentState {
     _documents  :: Map.Map DocumentId Document
@@ -55,26 +57,15 @@ data PersistentState = PersistentState {
 makeLenses ''PersistentState
 deriveSafeCopy 0 'base ''PersistentState
 
-{-
-data PersistentState0 = PersistentState0 {
-    _documents0  :: Map.Map DocumentId Document0
-  , _users0      :: Map.Map UserName User0
-  , _docClasses0 :: [DocClass]
-  , _fieldTags0  :: FieldTags
-  } deriving (Show, Generic, Typeable)
-makeLenses ''PersistentState0
-deriveSafeCopy 0 'base ''PersistentState0
-
-
-instance Migrate PersistentState where
-  type MigrateFrom PersistentState = PersistentState0
-  migrate (PersistentState0 d u c f) =
-    PersistentState (Map.map migrate d) (Map.map migrate u) c f 
--}
-
+instance Serialize PersistentState where
+
 queryAllDocs :: Query PersistentState (Map.Map DocumentId Document)
 queryAllDocs = asks _documents
 
+-- TODO - what's the right way here?  Can't be this
+updateAllDocs :: Map.Map DocumentId Document -> Update PersistentState ()
+updateAllDocs docMap = modify (over documents (const docMap ))
+
 -- TODO: addDocument, addComment, and addCritique all have
 -- the newId t = hash t <|> length docs <|> firstNotTaken...
 -- Factor this out.
@@ -109,7 +100,8 @@ addOComment user' pId comment = do
       where
         cId = head . filter (\k -> Map.notMember k (docOComments doc)) $
               (cHash:cInd:cAll)
-        cHash = abs . fromIntegral . hash $ T.unpack (ocText comment) ++ show (ocPostTime comment)
+        cHash = abs . fromIntegral . hash $ T.unpack (ocText comment) ++ 
+                show (ocPostTime comment)
         cInd  = fromIntegral . Map.size $ docOComments doc
         cAll = [0..]  
 
@@ -172,13 +164,6 @@ castOCommentVote :: User -> Bool -> DocumentId -> Document
                  -> UTCTime
                  -> Update PersistentState ()
 
-{-
-castCritiqueVote :: User -> Bool -> DocumentId -> Document
-                 -> CritiqueId -> Critique -> UpDownVote -> UTCTime
-                 -> Update PersistentState ()
-castCritiqueVote user isAnon dId doc cId critique voteVal t = undefined
--}
-
 castOCommentVote user isAnon dId doc cId comment voteVal t = do
   modify (over users $ \us' ->
            let vRecord = if isAnon then Nothing else Just voteVal
@@ -249,6 +234,10 @@ addCritique user' pId critique = do
 queryAllUsers :: Query PersistentState (Map.Map T.Text User)
 queryAllUsers = asks _users
 
+-- TODO : find right way here
+updateAllUsers :: Map.Map UserName User -> Update PersistentState ()
+updateAllUsers us = modify (over users (const us))
+
 -- TODO - how can I alert the caller that there's already
 -- a user by that name?
 -- There SHOULDN'T be, because addUser should only get called
@@ -294,13 +283,21 @@ pin user dId doPin t = do
 queryAllDocClasses :: Query PersistentState [DocClass]
 queryAllDocClasses = asks _docClasses
 
+-- TODO: right type, wrong combinator
+updateAllDocClasses :: [DocClass] -> Update PersistentState ()
+updateAllDocClasses classes = modify (over docClasses (const classes))
+
 addDocClass :: DocClass -> Update PersistentState ()
 addDocClass dc = do
   modify (over docClasses (dc:))
 
 queryAllFieldTags :: Query PersistentState FieldTags
 queryAllFieldTags = asks _fieldTags
 
+-- TODO: find appropriate combinator
+updateAllFieldTags :: FieldTags -> Update PersistentState ()
+updateAllFieldTags tags = modify (over fieldTags (const tags))
+
 addUserTag :: User -> TagPath -> Update PersistentState ()
 addUserTag user tp =
   modify (over users (Map.insert (userName user)
@@ -314,13 +311,14 @@ deleteUserTag user tp =
 addFieldTag :: TagPath -> Update PersistentState ()
 addFieldTag tp = modify (over fieldTags (insertTag tp))
 
-makeAcidic ''PersistentState ['addDocument,         'queryAllDocs
-                             , 'queryAllUsers,      'addUser
+makeAcidic ''PersistentState ['addDocument,         'queryAllDocs, 'updateAllDocs
+                             , 'queryAllUsers,      'addUser,      'updateAllUsers
                              , 'addUserTag,         'deleteUserTag
                              , 'userFollow,         'userUnfollow
                              , 'pin
-                             , 'queryAllDocClasses, 'addDocClass
-                             , 'queryAllFieldTags,  'addFieldTag
                              , 'addOComment,        'castOCommentVote
+                             , 'queryAllDocClasses, 'addDocClass, 'updateAllDocClasses
+                             , 'queryAllFieldTags,  'addFieldTag, 'updateAllFieldTags
                              , 'addSummary,         'addCritique
-                             , 'castSummaryVote,    'castCritiqueVote]
+                             , 'castSummaryVote,    'castCritiqueVote]
+

src/Reffit/Document.hs

@@ -9,7 +9,10 @@ import           Reffit.Types
 import           Reffit.FieldTag
 import           Reffit.OverviewComment
 
+import           Control.Applicative
 import qualified Data.Text as T
+import           Data.Serialize
+import           Data.Text
 import           Data.Time
 import           GHC.Generics
 import           Data.Typeable
@@ -39,6 +42,7 @@ data Document = Document { docUploader  :: Maybe UserName
                          } deriving (Show, Generic, Typeable)
 deriveSafeCopy 1 'extension ''Document 
 
+
 data Document0 = Document0 { docUploader0  :: Maybe UserName
                            , docId0        :: DocumentId
                            , docTitle0     :: T.Text
@@ -66,4 +70,13 @@ instance Migrate Document where
       sumToComm  (Summary sP sPr sVs sT) =
         OverviewComment sP sPr Nothing sVs sT
       critToComm (Critique cPr cp cDim cVal cReac cT) =
-        OverviewComment cp cPr (Just (cDim, cVal)) cReac cT
+        OverviewComment cp cPr (Just (cDim, cVal)) cReac cT
+
+instance Serialize Document where
+
+-- I can't write docSummarySplices here, because a view of the document summary
+-- depends on scores for the document.  So trying to render it brings in a
+-- dependency on Reffit.Scores, but Reffit.Scores depends on Reffit.Document.
+-- So PaperRoll is now Reffit.PaperRoll, a module for rendering lists of papers
+-- (and, if other modules need, for rendering a single paper-summary block)
+

src/Reffit/FieldTag.hs

@@ -2,15 +2,20 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveDataTypeable #-}
-
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module Reffit.FieldTag where
 
+import Reffit.Types
+
+import Control.Applicative
 import qualified Data.Text as T
 import qualified Data.List as L
 import Data.Tree
 import Data.String
-
+import Data.Serialize
+import GHC.Word
 import Heist
 import qualified Heist.Interpreted as I
 import Snap.Snaplet.Heist
@@ -56,6 +61,21 @@ tagHierarchy =
        ]
     ]
 
+{-  Supposedly, these instances overlap defaults in Data.Serialize?
+instance Serialize (Tree T.Text) where
+  put (Node x nodes) = do
+    put x 
+    put nodes
+  get = Node <$> get <*> get
+
+instance Serialize (Forest T.Text) where
+  put [] = put (0 :: Word8)
+  put (t:ts) = do 
+    put (1 :: Word8)
+    put t
+    put ts
+-}
+
 topLabels :: FieldTags -> [T.Text]
 topLabels fts = map (\(Node t _) -> t) fts
 

src/Reffit/OverviewComment.hs

@@ -6,23 +6,22 @@
 module Reffit.OverviewComment where
 
 import           Reffit.Types
-import           Reffit.FieldTag
-
+import           Data.Serialize
 import           Data.Text
 import           Data.Time
 import           GHC.Generics
 import           Data.Typeable
 import           Data.SafeCopy
-import qualified Data.Map as Map 
 
+data OverviewCommentType = Summary' | Praise | Criticism
+                         deriving (Eq, Show, Generic, Typeable)
+deriveSafeCopy 0 'base ''OverviewCommentType
 
 data QualityDim = Novelty | Rigor | Coolness
                 deriving (Eq, Show, Generic, Typeable)
 deriveSafeCopy 0 'base ''QualityDim
 
-data OverviewCommentType = Summary' | Praise | Criticism
-                         deriving (Eq, Show, Generic, Typeable)
-deriveSafeCopy 0 'base ''OverviewCommentType
+instance Serialize QualityDim where
 
 data OverviewComment = OverviewComment { ocPoster :: Maybe UserName
                                        , ocText   :: Text
@@ -34,6 +33,7 @@ data OverviewComment = OverviewComment { ocPoster :: Maybe UserName
                                        } deriving (Show, Generic)
 deriveSafeCopy 0 'base ''OverviewComment
 
+instance Serialize OverviewComment where
 
 data Summary = Summary { summaryPoster   :: Maybe UserName
                        , summaryProse    :: Text
@@ -42,6 +42,7 @@ data Summary = Summary { summaryPoster   :: Maybe UserName
                        } deriving (Show, Generic)
 deriveSafeCopy 0 'base ''Summary
 
+-- TODO: Are these covered by migrate?
 summToOComment :: Summary -> OverviewComment
 summToOComment (Summary un pr reacs t) = 
   OverviewComment un pr Nothing reacs t
@@ -50,6 +51,9 @@ critToOComment :: Critique -> OverviewComment
 critToOComment (Critique pr un qDim val reacs t) = 
   OverviewComment un pr (Just (qDim,val)) reacs t 
 
+instance Serialize Summary where
+
+
 data Critique = Critique { critiqueProse     :: Text
                          , critiquePoster    :: Maybe UserName
                          , critiqueDim       :: QualityDim
@@ -59,3 +63,4 @@ data Critique = Critique { critiqueProse     :: Text
                          } deriving (Show, Generic)
 deriveSafeCopy 0 'base ''Critique
 
+instance Serialize Critique where

src/Reffit/Types.hs

@@ -5,28 +5,45 @@
 
 module Reffit.Types where
 
+import           Control.Applicative
 import           Data.Text
 import qualified Data.Map as Map
 import           GHC.Int
 import           GHC.Generics
 import           Data.Typeable
-import           Reffit.FieldTag
 import           Data.Time.Clock
+import           Data.Serialize
+import           Data.Time
 import Data.SafeCopy (base, deriveSafeCopy)
 import qualified Data.Set as Set
 
 
+-- Orphan instances for types used all over
+instance Serialize UTCTime where
+  put (UTCTime day dayTime) = do
+    put (toModifiedJulianDay day)
+    put (toRational dayTime) 
+  get = UTCTime <$> (ModifiedJulianDay <$> get) <*> (fromRational <$> get)
+
+instance Serialize Text where
+  put = put . unpack
+  get = pack <$> get
+
 data DocClass = DocClass { docClassName :: Text
                          } deriving (Show, Generic, Typeable, Eq)
 deriveSafeCopy 0 'base ''DocClass
 
+
 type UserName          = Text
 type CritiqueId        = Int32
 type SummaryId         = Int32 
 type DocumentId        = Int32
 type OverviewCommentId = Int32
+
+instance Serialize DocClass where
 
 data UpDownVote = DownVote | UpVote
                 deriving (Show, Eq, Ord, Generic, Typeable)
 deriveSafeCopy 0 'base ''UpDownVote
 
+instance Serialize UpDownVote where

src/Reffit/User.hs

@@ -8,6 +8,7 @@ module Reffit.User where
 import           Reffit.Types
 import           Reffit.FieldTag
 
+import           Data.Serialize
 import qualified Data.Set as Set
 import           Data.Text
 import           Data.Time
@@ -23,6 +24,8 @@ data UserEvent = WroteOComment   DocumentId OverviewCommentId
                deriving (Show, Eq, Ord, Generic, Typeable)
 deriveSafeCopy 1 'extension ''UserEvent
 
+instance Serialize UserEvent where
+
 data User = User { userName       :: UserName 
                  , userEmail      :: Text
                  , userFollowing  :: Set.Set UserName
@@ -34,6 +37,7 @@ data User = User { userName       :: UserName
                  } deriving (Show, Eq, Ord, Generic,Typeable)
 deriveSafeCopy 0 'base ''User
 
+instance Serialize User where
 
 data UserEvent0 = WroteCritique0   DocumentId CritiqueId
                 | VotedOnCritique0 DocumentId CritiqueId (Maybe UpDownVote) UTCTime
@@ -45,6 +49,7 @@ data UserEvent0 = WroteCritique0   DocumentId CritiqueId
                 deriving (Show, Eq, Ord, Generic, Typeable)
 deriveSafeCopy 0 'base ''UserEvent0
 
+-- Is there a less boilerplate way to do this?
 instance Migrate UserEvent where
   type MigrateFrom UserEvent        = UserEvent0
   migrate (WroteCritique0 d c)       = WroteOComment d c
@@ -69,5 +74,9 @@ deriveSafeCopy 0 'base ''User0
 
 instance Migrate User where
   type MigrateFrom User = User0
+<<<<<<< HEAD
   migrate (User0 n e f fb h p t jt) = User n e f fb (Prelude.map migrate h) p t jt
+=======
+  migrate (User0 n e f fb h p t jt) = User n e f fb h p t jt
+>>>>>>> 7fc6b9f38b1bf312e6cd104a1609ec53a6ce8248
 -}