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/>. - <http://creativecommons.org/publicdomain/zero/1.0/>.
-} -}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
module Vervis module Vervis
( UserID (..) ( UserID (..)
@ -46,48 +48,103 @@ import Control.Monad (join)
import Control.Monad.Fix (MonadFix) import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.RWS (RWST (..)) import Control.Monad.Trans.RWS (RWST (..))
import Data.Aeson
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.Git import Data.Git
import Data.Git.Revision import Data.Git.Revision
import Data.Git.Repository import Data.Git.Repository
import Data.Hashable (Hashable)
import Data.HashMap.Lazy (HashMap) import Data.HashMap.Lazy (HashMap)
import Data.HashSet (HashSet) import Data.HashSet (HashSet)
import Data.Hourglass import Data.Hourglass
import Data.JsonState
import Data.Maybe (fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text (Text) 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.FilePath ((</>))
import System.Hourglass (dateCurrent) 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.HashMap.Lazy as M
import qualified Data.Text as T 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 } 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 } newtype Username = Username { unUsername :: CI Text }
deriving (FromJSON, ToJSON)
newtype PasswordHash = PasswordHash { unPasswordHash :: Text } newtype PasswordHash = PasswordHash { unPasswordHash :: Text }
deriving (FromJSON, ToJSON)
newtype RealName = RealName { unRealName :: Text } newtype RealName = RealName { unRealName :: Text } deriving (FromJSON, ToJSON)
data EmailAddress = EmailAddress data EmailAddress = EmailAddress
{ emailUser :: Text { emailUser :: Text
, emailHost :: Text , emailHost :: Text
} }
deriving Generic
instance FromJSON EmailAddress
instance ToJSON EmailAddress
newtype GroupName = GroupName { unGroupName :: CI Text } newtype GroupName = GroupName { unGroupName :: CI Text }
deriving (FromJSON, ToJSON)
newtype RepoName = RepoName { unRepoName :: CI Text } newtype RepoName = RepoName { unRepoName :: CI Text }
deriving (FromJSON, ToJSON, WrappedText)
newtype ProjectName = ProjectName { unProjectName :: CI Text } newtype ProjectName = ProjectName { unProjectName :: CI Text }
deriving (FromJSON, ToJSON, WrappedText)
data User = User data User = User
{ userName :: Username { userName :: Username
@ -95,27 +152,47 @@ data User = User
, userRealName :: RealName , userRealName :: RealName
, userEmail :: EmailAddress , userEmail :: EmailAddress
} }
deriving Generic
instance FromJSON User
instance ToJSON User
data Group = Group data Group = Group
{ groupName :: GroupName { groupName :: GroupName
, groupUsers :: HashSet UserID , groupUsers :: HashSet UserID
} }
deriving Generic
instance FromJSON Group
instance ToJSON Group
data IrcChannel = IrcChannel data IrcChannel = IrcChannel
{ chanNetwork :: Text { chanNetwork :: Text
, chanName :: Text , chanName :: Text
} }
deriving Generic
instance FromJSON IrcChannel
instance ToJSON IrcChannel
data Repository = Repository data Repository = Repository
{ repoName :: RepoName { repoName :: RepoName
, repoIRC :: Maybe IrcChannel , repoIRC :: Maybe IrcChannel
, repoML :: Maybe Text , repoML :: Maybe Text
} }
deriving Generic
instance ToJSON Repository
instance FromJSON Repository
data Project = Project data Project = Project
{ projName :: ProjectName { projName :: ProjectName
, projRepos :: HashMap RepoID Repository , projRepos :: HashMap RepoID Repository
} }
deriving Generic
instance ToJSON Project
instance FromJSON Project
data VervisEnv = VervisEnv data VervisEnv = VervisEnv
{ veName :: Text { veName :: Text
@ -127,6 +204,10 @@ data VervisState = VervisState
, vsGroups :: HashMap GroupID Group , vsGroups :: HashMap GroupID Group
, vsProjects :: HashMap (Either UserID GroupID) (HashMap ProjID Project) , 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 } newtype Vervis a = Vervis { unVervis :: RWST VervisEnv () VervisState IO a }
deriving (Functor, Applicative, Monad, MonadFix, MonadIO) deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
@ -141,19 +222,20 @@ runVervis' venv vstate computation = do
-- | Run a Vervis server computation. -- | Run a Vervis server computation.
runVervis runVervis
:: Text -- ^ Server name, e.g. @hub.vervis.org@ :: 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 -> FilePath -- ^ Path to the directory containing the namespace/repo tree
-> Vervis a -- ^ Computation to run -> Vervis a -- ^ Computation to run
-> IO a -> IO a
runVervis name dir comp = do 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 let venv = VervisEnv
{ veName = name { veName = name
, veDir = dir , veDir = dir
} }
vstate = VervisState
{ vsUsers = M.empty
, vsGroups = M.empty
, vsProjects = M.empty
}
(a, _s) <- runVervis' venv vstate comp (a, _s) <- runVervis' venv vstate comp
return a return a

View file

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