Add a basic data model and determine change times from it
This commit is contained in:
parent
f51aa09159
commit
a953923a3e
2 changed files with 86 additions and 4 deletions
|
@ -14,22 +14,67 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Vervis
|
module Vervis
|
||||||
( subdirs
|
( User (..)
|
||||||
|
, Group (..)
|
||||||
|
, IrcChannel (..)
|
||||||
|
, Repository (..)
|
||||||
|
, Server (..)
|
||||||
|
, subdirs
|
||||||
, lastChange
|
, lastChange
|
||||||
, timeAgo
|
, timeAgo
|
||||||
|
, timesAgo
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad (join)
|
import Control.Monad (join)
|
||||||
|
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.HashMap.Lazy (HashMap)
|
||||||
import Data.Hourglass
|
import Data.Hourglass
|
||||||
import Data.Maybe (fromMaybe, mapMaybe)
|
import Data.Maybe (fromMaybe, mapMaybe)
|
||||||
|
import Data.Text (Text)
|
||||||
import System.Directory.Tree
|
import System.Directory.Tree
|
||||||
|
import System.FilePath ((</>))
|
||||||
import System.Hourglass (dateCurrent)
|
import System.Hourglass (dateCurrent)
|
||||||
|
|
||||||
|
import qualified Data.CaseInsensitive as CI (original)
|
||||||
|
import qualified Data.HashMap.Lazy as M
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
data User = User
|
||||||
|
{ userNick :: CI Text
|
||||||
|
, userPassHash :: Text
|
||||||
|
, userName :: Text
|
||||||
|
, userEmail :: Text
|
||||||
|
}
|
||||||
|
|
||||||
|
data Group = Group
|
||||||
|
{ groupName :: CI Text
|
||||||
|
, groupUsers :: [Int]
|
||||||
|
}
|
||||||
|
|
||||||
|
data IrcChannel = IrcChannel
|
||||||
|
{ chanNetwork :: Text
|
||||||
|
, chanName :: Text
|
||||||
|
}
|
||||||
|
|
||||||
|
data Repository = Repository
|
||||||
|
{ repoName :: CI Text
|
||||||
|
, repoIRC :: Maybe IrcChannel
|
||||||
|
, repoML :: Maybe Text
|
||||||
|
}
|
||||||
|
|
||||||
|
data Server = Server
|
||||||
|
{ serverName :: Text
|
||||||
|
, serverDir :: FilePath
|
||||||
|
, serverUsers :: HashMap Int User
|
||||||
|
, serverGroups :: HashMap Int Group
|
||||||
|
, serverRepos :: HashMap (Either Int Int) [Repository]
|
||||||
|
}
|
||||||
|
|
||||||
subdirs :: FilePath -> IO [FilePath]
|
subdirs :: FilePath -> IO [FilePath]
|
||||||
subdirs dir = do
|
subdirs dir = do
|
||||||
_base :/ tree <- buildL dir
|
_base :/ tree <- buildL dir
|
||||||
|
@ -90,3 +135,36 @@ timeAgo dt = do
|
||||||
let sec = timeDiff now dt
|
let sec = timeDiff now dt
|
||||||
(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 (Left uid) repos =
|
||||||
|
case M.lookup uid $ serverUsers server of
|
||||||
|
Nothing -> error "';..;'"
|
||||||
|
Just user ->
|
||||||
|
let dir = serverDir server
|
||||||
|
ns = T.unpack $ CI.original $ userNick user
|
||||||
|
prefix = dir </> ns
|
||||||
|
repoNames = map (T.unpack . CI.original . repoName) repos
|
||||||
|
in map (prefix </>) repoNames
|
||||||
|
repoPaths server (Right gid) repos =
|
||||||
|
case M.lookup gid $ serverGroups server of
|
||||||
|
Nothing -> error "';..;'"
|
||||||
|
Just group ->
|
||||||
|
let dir = serverDir server
|
||||||
|
ns = T.unpack $ CI.original $ groupName group
|
||||||
|
prefix = dir </> ns
|
||||||
|
repoNames = map (T.unpack . CI.original . repoName) repos
|
||||||
|
in map (prefix </>) repoNames
|
||||||
|
|
||||||
|
timesAgo :: Server -> IO [(Text, Text)]
|
||||||
|
timesAgo server = do
|
||||||
|
-- make list of file paths
|
||||||
|
let paths = uncurry $ repoPaths server
|
||||||
|
nsRepos = map paths $ M.toList $ serverRepos server
|
||||||
|
repos = concat nsRepos
|
||||||
|
-- run lastChange on each
|
||||||
|
times <- traverse lastChange repos
|
||||||
|
-- run timeAgo on each result
|
||||||
|
agos <- traverse timeAgo times
|
||||||
|
-- return
|
||||||
|
return $ zip (map T.pack repos) (map T.pack agos)
|
||||||
|
|
|
@ -30,9 +30,13 @@ library
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
build-depends: base >=4.8 && <5
|
build-depends: base >=4.8 && <5
|
||||||
|
, case-insensitive >=1
|
||||||
, directory-tree >=0.12
|
, directory-tree >=0.12
|
||||||
|
, filepath
|
||||||
, hit >=0.6.3
|
, hit >=0.6.3
|
||||||
, hourglass
|
, hourglass
|
||||||
|
, text >=1
|
||||||
|
, unordered-containers >=0.2.5
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
|
Loading…
Reference in a new issue