diff --git a/src/Vervis.hs b/src/Vervis.hs index fda0d59..860c52d 100644 --- a/src/Vervis.hs +++ b/src/Vervis.hs @@ -13,7 +13,9 @@ - . -} +{-# 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 diff --git a/vervis.cabal b/vervis.cabal index 816b637..28b547f 100644 --- a/vervis.cabal +++ b/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