Vervis/src/Vervis.hs

345 lines
10 KiB
Haskell
Raw Normal View History

{- 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
( UserID (..)
, GroupID (..)
, RepoID (..)
, ProjID (..)
, Username (..)
, PasswordHash (..)
, RealName (..)
, EmailAddress (..)
, GroupName (..)
, RepoName (..)
, ProjectName (..)
, User (..)
, Group (..)
, IrcChannel (..)
, Repository (..)
, Project (..)
, Vervis ()
, runVervis
, Server (..)--TODO remove this type later...
, subdirs
, lastChange
, timeAgo
, timesAgo
)
where
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 GHC.Generics
import System.Directory.Tree hiding (name, file, err)
import System.FilePath ((</>))
import System.Hourglass (dateCurrent)
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 } deriving (Eq, Hashable, WrappedText)
newtype RepoID = RepoID { unRepoID :: Int } deriving (Eq, Hashable, WrappedText)
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 } 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
data VervisEnv = VervisEnv
{ veName :: Text
, veDir :: FilePath
}
data VervisState = VervisState
{ vsUsers :: HashMap UserID User
, vsGroups :: HashMap GroupID Group
2016-02-01 15:28:12 +01:00
, 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)
-- internal func, wrap with API func which hides env and state details
runVervis' :: VervisEnv -> VervisState -> Vervis a -> IO (a, VervisState)
runVervis' venv vstate computation = do
let rwst = unVervis computation
(a, s, _) <- runRWST rwst venv vstate
return (a, s)
-- | 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 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
, serverDir :: FilePath
, serverUsers :: HashMap Int User
, serverGroups :: HashMap Int Group
, serverRepos :: HashMap (Either Int Int) [Repository]
}
subdirs :: FilePath -> IO [FilePath]
subdirs dir = do
_base :/ tree <- buildL dir
return $ case tree of
Dir _ cs ->
let dirName (Dir n _) = Just n
dirName _ = Nothing
in mapMaybe dirName cs
_ -> []
lastBranchChange :: Git -> String -> IO GitTime
lastBranchChange git branch = do
mref <- resolveRevision git $ Revision branch []
mco <- traverse (getCommitMaybe git) mref
let mtime = fmap (personTime . commitCommitter) (join mco)
return $ fromMaybe (error "mtime is Nothing") mtime
lastChange :: FilePath -> IO DateTime
lastChange path = withRepo (fromString path) $ \ git -> do
--TODO add a better intro to json-state, the docs are bad there
names <- branchList git
times <- traverse (lastBranchChange git) $ map refNameRaw $ toList names
let datetimes = map timeConvert times
return $ maximum datetimes
showPeriod :: Period -> String
showPeriod (Period 0 0 d) = show d ++ " days"
showPeriod (Period 0 m _) = show m ++ " months"
showPeriod (Period y _ _) = show y ++ " years"
showDuration :: Duration -> String
showDuration (Duration (Hours h) (Minutes m) (Seconds s) _) =
case (h, m, s) of
(0, 0, 0) -> "now"
(0, 0, _) -> show s ++ " seconds"
(0, _, _) -> show m ++ " minutes"
_ -> show h ++ " hours"
showAgo :: Period -> Duration -> String
showAgo (Period 0 0 0) d = showDuration d
showAgo p _ = showPeriod p
fromSec :: Seconds -> (Period, Duration)
fromSec sec =
let d = 3600 * 24
m = 30 * d
y = 365 * d
fs (Seconds n) = fromIntegral n
(years, yrest) = sec `divMod` Seconds y
(months, mrest) = yrest `divMod` Seconds m
(days, drest) = mrest `divMod` Seconds d
in (Period (fs years) (fs months) (fs days), fst $ fromSeconds drest)
timeAgo :: DateTime -> IO String
timeAgo dt = do
now <- dateCurrent
let sec = timeDiff now dt
(period, duration) = fromSec sec
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 $ unUsername $ userName user
prefix = dir </> ns
repoNames =
map (T.unpack . CI.original . unRepoName . 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 $ unGroupName $ groupName group
prefix = dir </> ns
repoNames =
map (T.unpack . CI.original . unRepoName . 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)