Ugly, hacky, dirty, full-of-warnings basic JSON persistence

src/Vervis.hs

@@ -13,7 +13,9 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveGeneric #-}
 
 module Vervis
     ( UserID (..)
@@ -46,48 +48,103 @@ import Control.Monad (join)
 import Control.Monad.Fix (MonadFix)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.RWS (RWST (..))
+import Data.Aeson
 import Data.CaseInsensitive (CI)
 import Data.Foldable (toList)
 import Data.Git
 import Data.Git.Revision
 import Data.Git.Repository
+import Data.Hashable (Hashable)
 import Data.HashMap.Lazy (HashMap)
 import Data.HashSet (HashSet)
 import Data.Hourglass
+import Data.JsonState
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Text (Text)
-import System.Directory.Tree hiding (name)
+import GHC.Generics
+import System.Directory.Tree hiding (name, file, err)
 import System.FilePath ((</>))
 import System.Hourglass (dateCurrent)
 
-import qualified Data.CaseInsensitive as CI (original)
+import qualified Data.CaseInsensitive as CI
 import qualified Data.HashMap.Lazy as M
 import qualified Data.Text as T
 
+instance (CI.FoldCase a, FromJSON a) => FromJSON (CI a) where
+    parseJSON v = CI.mk <$> parseJSON v
+
+instance ToJSON a => ToJSON (CI a) where
+    toJSON = toJSON . CI.original
+
+class WrappedText a where
+    toText   :: a -> Text
+    fromText :: Text -> a
+
+instance WrappedText Text where
+    toText   = id
+    fromText = id
+
+instance (WrappedText a, CI.FoldCase a) => WrappedText (CI a) where
+    toText   = toText . CI.original
+    fromText = CI.mk . fromText
+
+instance WrappedText Int where
+    toText   = T.pack . show
+    fromText = read . T.unpack
+
+mapFst :: (a -> c) -> [(a, b)] -> [(c, b)]
+mapFst f = map $ \ (x, y) -> (f x, y)
+
+instance (Eq k, Hashable k, WrappedText k, FromJSON v) => FromJSON (HashMap k v) where
+    parseJSON v = M.fromList . mapFst fromText . M.toList <$> parseJSON v
+
+instance (WrappedText k, ToJSON v) => ToJSON (HashMap k v) where
+    toJSON = toJSON . M.fromList . mapFst toText . M.toList
+
+instance (WrappedText a, WrappedText b) => WrappedText (Either a b) where
+    toText (Left x) = 'l' `T.cons` toText x
+    toText (Right y) = 'r' `T.cons` toText y
+    fromText t =
+        case T.uncons t of
+            Nothing       -> error "blank JSON field name???"
+            Just ('l', r) -> Left $ fromText r
+            Just ('r', r) -> Right $ fromText r
+            _             -> error "what is dis ting"
+
 newtype UserID = UserID { unUserID :: Int }
+    deriving (Eq, Hashable, FromJSON, ToJSON, WrappedText)
 
-newtype GroupID = GroupID { unGroupID :: Int }
+newtype GroupID = GroupID { unGroupID :: Int } deriving (Eq, Hashable, WrappedText)
 
-newtype RepoID = RepoID { unRepoID :: Int }
+newtype RepoID = RepoID { unRepoID :: Int } deriving (Eq, Hashable, WrappedText)
 
-newtype ProjID = ProjID { unProjID :: Int }
+newtype ProjID = ProjID { unProjID :: Int } deriving (Eq, Hashable, WrappedText)
 
 newtype Username = Username { unUsername :: CI Text }
+    deriving (FromJSON, ToJSON)
 
 newtype PasswordHash = PasswordHash { unPasswordHash :: Text }
+    deriving (FromJSON, ToJSON)
 
-newtype RealName = RealName { unRealName :: Text }
+newtype RealName = RealName { unRealName :: Text } deriving (FromJSON, ToJSON)
 
 data EmailAddress = EmailAddress
     { emailUser :: Text
     , emailHost :: Text
     }
+    deriving Generic
+
+instance FromJSON EmailAddress
+instance ToJSON EmailAddress
 
 newtype GroupName = GroupName { unGroupName :: CI Text }
+    deriving (FromJSON, ToJSON)
 
 newtype RepoName = RepoName { unRepoName :: CI Text }
+    deriving (FromJSON, ToJSON, WrappedText)
 
 newtype ProjectName = ProjectName { unProjectName :: CI Text }
+    deriving (FromJSON, ToJSON, WrappedText)
 
 data User = User
     { userName     :: Username
@@ -95,27 +152,47 @@ data User = User
     , userRealName :: RealName
     , userEmail    :: EmailAddress
     }
+    deriving Generic
+
+instance FromJSON User
+instance ToJSON User
 
 data Group = Group
     { groupName  :: GroupName
     , groupUsers :: HashSet UserID
     }
+    deriving Generic
+
+instance FromJSON Group
+instance ToJSON Group
 
 data IrcChannel = IrcChannel
     { chanNetwork :: Text
     , chanName    :: Text
     }
+    deriving Generic
+
+instance FromJSON IrcChannel
+instance ToJSON IrcChannel
 
 data Repository = Repository
     { repoName :: RepoName
     , repoIRC  :: Maybe IrcChannel
     , repoML   :: Maybe Text
     }
+    deriving Generic
+
+instance ToJSON Repository
+instance FromJSON Repository
 
 data Project = Project
     { projName  :: ProjectName
     , projRepos :: HashMap RepoID Repository
     }
+    deriving Generic
+
+instance ToJSON Project
+instance FromJSON Project
 
 data VervisEnv = VervisEnv
     { veName :: Text
@@ -127,6 +204,10 @@ data VervisState = VervisState
     , vsGroups   :: HashMap GroupID Group
     , vsProjects :: HashMap (Either UserID GroupID) (HashMap ProjID Project)
     }
+    deriving Generic
+
+instance ToJSON VervisState
+instance FromJSON VervisState
 
 newtype Vervis a = Vervis { unVervis :: RWST VervisEnv () VervisState IO a }
     deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
@@ -141,21 +222,22 @@ runVervis' venv vstate computation = do
 -- | Run a Vervis server computation.
 runVervis
     :: Text     -- ^ Server name, e.g. @hub.vervis.org@
+    -> FilePath -- ^ Path of database file, which is really JSON currently
     -> FilePath -- ^ Path to the directory containing the namespace/repo tree
     -> Vervis a -- ^ Computation to run
     -> IO a
-runVervis name dir comp = do
-    let venv = VervisEnv
-            { veName = name
-            , veDir  = dir
-            }
-        vstate = VervisState
-            { vsUsers    = M.empty
-            , vsGroups   = M.empty
-            , vsProjects = M.empty
-            }
-    (a, _s) <- runVervis' venv vstate comp
-    return a
+runVervis name file dir comp = do
+    result <- loadState file
+    case result of
+        Left (False, err) -> error $ "Loading JSON state failed: " ++ err
+        Left (True, err)  -> error $ "Parsing JSON state failed: " ++ err
+        Right vstate -> do
+            let venv = VervisEnv
+                    { veName = name
+                    , veDir  = dir
+                    }
+            (a, _s) <- runVervis' venv vstate comp
+            return a
 
 data Server = Server
     { serverName   :: Text

vervis.cabal

@@ -29,11 +29,14 @@ library
   exposed-modules:     Vervis
   -- other-modules:       
   -- other-extensions:    
-  build-depends:       base                 >=4.8   && <5
+  build-depends:       aeson
+                     , base                 >=4.8   && <5
                      , case-insensitive     >=1
                      , directory-tree       >=0.12
                      , filepath
                      , hit                  >=0.6.3
+                     , json-state
+                     , hashable
                      , hourglass
                      , text                 >=1
                      , transformers         >=0.4.2