From 0bfef8345883145496bdd97d532db44efe73dd8a Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Fri, 12 Feb 2016 11:01:53 +0000 Subject: [PATCH] Remove obsolete code and start using stack --- _boring | 4 +- src/Vervis/Git.hs | 20 ++--- src/Vervis/Ops.hs | 69 --------------- src/Vervis/Types.hs | 200 -------------------------------------------- stack.yaml | 38 +++++++++ vervis.cabal | 11 +-- 6 files changed, 51 insertions(+), 291 deletions(-) delete mode 100644 src/Vervis/Ops.hs delete mode 100644 src/Vervis/Types.hs create mode 100644 stack.yaml diff --git a/_boring b/_boring index f31ecec..a5a1481 100644 --- a/_boring +++ b/_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)$ diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index cb2f42b..bba9f4e 100644 --- a/src/Vervis/Git.hs +++ b/src/Vervis/Git.hs @@ -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)-} diff --git a/src/Vervis/Ops.hs b/src/Vervis/Ops.hs deleted file mode 100644 index c18cd60..0000000 --- a/src/Vervis/Ops.hs +++ /dev/null @@ -1,69 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016 by fr33domlover . - - - - ♡ 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 - - . - -} - -{-# 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 diff --git a/src/Vervis/Types.hs b/src/Vervis/Types.hs deleted file mode 100644 index bab26e7..0000000 --- a/src/Vervis/Types.hs +++ /dev/null @@ -1,200 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016 by fr33domlover . - - - - ♡ 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 - - . - -} - -{-# 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" diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..9c46655 --- /dev/null +++ b/stack.yaml @@ -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 diff --git a/vervis.cabal b/vervis.cabal index fba7a68..9bdb355 100644 --- a/vervis.cabal +++ b/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