sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 16:14:51 +09:00
Code Issues Activity

Remove obsolete code and start using stack

Browse source
This commit is contained in:
fr33domlover 2016-02-12 11:01:53 +00:00
parent 1abfc11ffa
commit 0bfef83458
6 changed files with 51 additions and 291 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
_boring
View file

@ -45,16 +45,16 @@
# cabal intermediates # cabal intermediates
\.installed-pkg-config \.installed-pkg-config
\.setup-config \.setup-config
# standard cabal build dir # standard cabal and stack build dirs
^dist$ ^dist$
^dist/build(/|$) ^dist/build(/|$)
^dist/doc(/|$) ^dist/doc(/|$)
^dist/dist-sandbox ^dist/dist-sandbox
^dist/package\.conf\.inplace$ ^dist/package\.conf\.inplace$
^dist/setup-config$ ^dist/setup-config$
# cabal sandbox
^\.cabal-sandbox(/|$) ^\.cabal-sandbox(/|$)
^cabal\.sandbox\.config$ ^cabal\.sandbox\.config$
^.stack-work(/|$)
# autotools # autotools
(^|/)autom4te\.cache($|/) (^|/)autom4te\.cache($|/)
(^|/)config\.(log|status)$ (^|/)config\.(log|status)$

20
src/Vervis/Git.hs
View file

@ -18,11 +18,10 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
module Vervis.Git module Vervis.Git
( Server (..)--TODO remove this type later... ( subdirs
, subdirs
, lastChange , lastChange
, timeAgo , timeAgo
, timesAgo --, timesAgo
) )
where where
@ -30,7 +29,6 @@ import Control.Monad (join)
import Control.Monad.Fix (MonadFix) import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class import Control.Monad.IO.Class
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
@ -40,7 +38,6 @@ 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 Data.Time.Units import Data.Time.Units
@ -48,20 +45,19 @@ import GHC.Generics
import System.Directory.Tree hiding (name, file, err) import System.Directory.Tree hiding (name, file, err)
import System.FilePath ((</>)) import System.FilePath ((</>))
import System.Hourglass (dateCurrent) import System.Hourglass (dateCurrent)
import Vervis.Types
import qualified Control.Monad.Trans.RWS as RWS import qualified Control.Monad.Trans.RWS as RWS
import qualified Data.CaseInsensitive as CI 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
data Server = Server {-data Server = Server
{ serverName :: Text { serverName :: Text
, serverDir :: FilePath , serverDir :: FilePath
, serverUsers :: HashMap Int User , serverUsers :: HashMap Int User
, serverGroups :: HashMap Int Group , serverGroups :: HashMap Int Group
, serverRepos :: HashMap (Either Int Int) [Repository] , serverRepos :: HashMap (Either Int Int) [Repository]
} }-}
-- | Return the subdirs of a given dir -- | Return the subdirs of a given dir
subdirs :: FilePath -> IO [FilePath] subdirs :: FilePath -> IO [FilePath]
@ -127,7 +123,7 @@ timeAgo dt = do
(period, duration) = fromSec sec (period, duration) = fromSec sec
return $ showAgo period duration return $ showAgo period duration
repoPaths :: Server -> Either Int Int -> [Repository] -> [FilePath] {-repoPaths :: Server -> Either Int Int -> [Repository] -> [FilePath]
repoPaths server (Left uid) repos = repoPaths server (Left uid) repos =
case M.lookup uid $ serverUsers server of case M.lookup uid $ serverUsers server of
Nothing -> error "';..;'" Nothing -> error "';..;'"
@ -147,9 +143,9 @@ repoPaths server (Right gid) repos =
prefix = dir </> ns prefix = dir </> ns
repoNames = repoNames =
map (T.unpack . CI.original . unRepoName . repoName) repos map (T.unpack . CI.original . unRepoName . repoName) repos
in map (prefix </>) repoNames in map (prefix </>) repoNames-}
timesAgo :: Server -> IO [(Text, Text)] {-timesAgo :: Server -> IO [(Text, Text)]
timesAgo server = do timesAgo server = do
-- make list of file paths -- make list of file paths
let paths = uncurry $ repoPaths server let paths = uncurry $ repoPaths server
@ -160,4 +156,4 @@ timesAgo server = do
-- run timeAgo on each result -- run timeAgo on each result
agos <- traverse timeAgo times agos <- traverse timeAgo times
-- return -- return
return $ zip (map T.pack repos) (map T.pack agos) return $ zip (map T.pack repos) (map T.pack agos)-}

69
src/Vervis/Ops.hs
View file

@ -1,69 +0,0 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
module Vervis.Ops
( saveState
, createUser
)
where
import Control.Monad (join)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class
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 Data.Time.Units
import GHC.Generics
import System.Directory.Tree hiding (name, file, err)
import System.FilePath ((</>))
import System.Hourglass (dateCurrent)
import Vervis.Monad
import Vervis.Types
import qualified Control.Monad.Trans.RWS as RWS
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T
saveState :: Vervis ()
saveState = do
save <- asks veSave
vstate <- get
save vstate
createUser :: User -> Vervis ()
createUser user = do
vstate <- get
let users = vsUsers vstate
next = vsNextUser vstate
users' = M.insert next user users
next' = UserID $ unUserID next + 1
put vstate { vsUsers = users', vsNextUser = next' }
saveState

200
src/Vervis/Types.hs
View file

@ -1,200 +0,0 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
module Vervis.Types
( UserID (..)
, GroupID (..)
, RepoID (..)
, ProjID (..)
, Username (..)
, PasswordHash (..)
, RealName (..)
, EmailAddress (..)
, GroupName (..)
, RepoName (..)
, ProjectName (..)
, User (..)
, Group (..)
, IrcChannel (..)
, Repository (..)
, Project (..)
)
where
import Control.Monad (join)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class
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 Data.Time.Units
import GHC.Generics
import System.Directory.Tree hiding (name, file, err)
import System.FilePath ((</>))
import System.Hourglass (dateCurrent)
import qualified Control.Monad.Trans.RWS as RWS
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T
-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------
newtype UserID = UserID { unUserID :: Int }
deriving (Eq, Hashable, FromJSON, ToJSON, WrappedText)
newtype GroupID = GroupID { unGroupID :: Int }
deriving (Eq, Hashable, FromJSON, ToJSON, WrappedText)
newtype RepoID = RepoID { unRepoID :: Int } deriving (Eq, Hashable, WrappedText)
newtype ProjID = ProjID { unProjID :: Int }
deriving (Eq, Hashable, FromJSON, ToJSON, WrappedText)
newtype Username = Username { unUsername :: CI Text }
deriving (FromJSON, ToJSON)
newtype PasswordHash = PasswordHash { unPasswordHash :: Text }
deriving (FromJSON, ToJSON)
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
, userPassHash :: Maybe PasswordHash -- to disable pass and use SSH only?
, 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
-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------
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"

38
stack.yaml Normal file
View file

@ -0,0 +1,38 @@
# For more information, see:
# http://docs.haskellstack.org/en/stable/yaml_configuration.html
# Specifies the GHC version and set of packages available (e.g., lts-3.5,
# nightly-2015-09-21, ghc-7.10.2)
resolver: lts-5.1
# Local packages, usually specified by relative directory name
packages:
- '.'
# Packages to be pulled from upstream that are not in the resolver (e.g.,
# acme-missiles-0.3)
extra-deps: []
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: >= 1.0.0
# Override the architecture used by stack
# arch: i386
# arch: x86_64
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

11
vervis.cabal
View file

@ -28,20 +28,15 @@ source-repository head
library library
exposed-modules: Vervis exposed-modules: Vervis
, Vervis.Git , Vervis.Git
, Vervis.Monad
, Vervis.Ops
, Vervis.Persist , Vervis.Persist
, Vervis.Types
-- other-modules: -- other-modules:
-- other-extensions: -- other-extensions:
build-depends: aeson build-depends: base >=4.8 && <5
, base >=4.8 && <5
, case-insensitive >=1 , case-insensitive >=1
, directory-tree >=0.12 , directory-tree >=0.12
, esqueleto , esqueleto
, filepath , filepath
, hit >=0.6.3 , hit >=0.6.3
, json-state
, hashable , hashable
, hourglass , hourglass
, monad-logger , monad-logger
@ -49,9 +44,9 @@ library
, persistent-sqlite , persistent-sqlite
, persistent-template , persistent-template
, resourcet , resourcet
, text >=1 , text
, time-units , time-units
, transformers >=0.4.2 , transformers
, unordered-containers >=0.2.5 , unordered-containers >=0.2.5
, yesod , yesod
, yesod-persistent , yesod-persistent