Ugly, hacky, dirty, full-of-warnings basic JSON persistence
This commit is contained in:
parent
b44dc7b456
commit
c8e5de868c
2 changed files with 104 additions and 19 deletions
118
src/Vervis.hs
118
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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue