Remove obsolete code and start using stack
This commit is contained in:
fr33domlover
parent
1abfc11ffa
commit
0bfef83458
6 changed files with 51 additions and 291 deletions
4
_boring
4
_boring
|
|
@ -45,16 +45,16 @@
|
|||
# cabal intermediates
|
||||
\.installed-pkg-config
|
||||
\.setup-config
|
||||
# standard cabal build dir
|
||||
# standard cabal and stack build dirs
|
||||
^dist$
|
||||
^dist/build(/|$)
|
||||
^dist/doc(/|$)
|
||||
^dist/dist-sandbox
|
||||
^dist/package\.conf\.inplace$
|
||||
^dist/setup-config$
|
||||
# cabal sandbox
|
||||
^\.cabal-sandbox(/|$)
|
||||
^cabal\.sandbox\.config$
|
||||
^.stack-work(/|$)
|
||||
# autotools
|
||||
(^|/)autom4te\.cache($|/)
|
||||
(^|/)config\.(log|status)$
|
||||
|
|
|
|||
|
|
@ -18,11 +18,10 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module Vervis.Git
|
||||
( Server (..)--TODO remove this type later...
|
||||
, subdirs
|
||||
( subdirs
|
||||
, lastChange
|
||||
, timeAgo
|
||||
, timesAgo
|
||||
--, timesAgo
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -30,7 +29,6 @@ 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
|
||||
|
|
@ -40,7 +38,6 @@ 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
|
||||
|
|
@ -48,20 +45,19 @@ import GHC.Generics
|
|||
import System.Directory.Tree hiding (name, file, err)
|
||||
import System.FilePath ((</>))
|
||||
import System.Hourglass (dateCurrent)
|
||||
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
|
||||
|
||||
data Server = Server
|
||||
{-data Server = Server
|
||||
{ serverName :: Text
|
||||
, serverDir :: FilePath
|
||||
, serverUsers :: HashMap Int User
|
||||
, serverGroups :: HashMap Int Group
|
||||
, serverRepos :: HashMap (Either Int Int) [Repository]
|
||||
}
|
||||
}-}
|
||||
|
||||
-- | Return the subdirs of a given dir
|
||||
subdirs :: FilePath -> IO [FilePath]
|
||||
|
|
@ -127,7 +123,7 @@ timeAgo dt = do
|
|||
(period, duration) = fromSec sec
|
||||
return $ showAgo period duration
|
||||
|
||||
repoPaths :: Server -> Either Int Int -> [Repository] -> [FilePath]
|
||||
{-repoPaths :: Server -> Either Int Int -> [Repository] -> [FilePath]
|
||||
repoPaths server (Left uid) repos =
|
||||
case M.lookup uid $ serverUsers server of
|
||||
Nothing -> error "';..;'"
|
||||
|
|
@ -147,9 +143,9 @@ repoPaths server (Right gid) repos =
|
|||
prefix = dir </> ns
|
||||
repoNames =
|
||||
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
|
||||
-- make list of file paths
|
||||
let paths = uncurry $ repoPaths server
|
||||
|
|
@ -160,4 +156,4 @@ timesAgo server = do
|
|||
-- run timeAgo on each result
|
||||
agos <- traverse timeAgo times
|
||||
-- return
|
||||
return $ zip (map T.pack repos) (map T.pack agos)
|
||||
return $ zip (map T.pack repos) (map T.pack agos)-}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
38
stack.yaml
Normal 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
11
vervis.cabal
|
|
@ -28,20 +28,15 @@ source-repository head
|
|||
library
|
||||
exposed-modules: Vervis
|
||||
, Vervis.Git
|
||||
, Vervis.Monad
|
||||
, Vervis.Ops
|
||||
, Vervis.Persist
|
||||
, Vervis.Types
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: aeson
|
||||
, base >=4.8 && <5
|
||||
build-depends: base >=4.8 && <5
|
||||
, case-insensitive >=1
|
||||
, directory-tree >=0.12
|
||||
, esqueleto
|
||||
, filepath
|
||||
, hit >=0.6.3
|
||||
, json-state
|
||||
, hashable
|
||||
, hourglass
|
||||
, monad-logger
|
||||
|
|
@ -49,9 +44,9 @@ library
|
|||
, persistent-sqlite
|
||||
, persistent-template
|
||||
, resourcet
|
||||
, text >=1
|
||||
, text
|
||||
, time-units
|
||||
, transformers >=0.4.2
|
||||
, transformers
|
||||
, unordered-containers >=0.2.5
|
||||
, yesod
|
||||
, yesod-persistent
|
||||
|
|
|
|||
Loading…
Reference in a new issue