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

This commit is contained in:
fr33domlover 2016-02-02 12:14:21 +00:00
parent b44dc7b456
commit c8e5de868c
2 changed files with 104 additions and 19 deletions

View file

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

View file

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