Vervis/src/Vervis.hs

{- 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 GeneralizedNewtypeDeriving #-}

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.CaseInsensitive (CI)
import Data.Foldable (toList)
import Data.Git
import Data.Git.Revision
import Data.Git.Repository
import Data.HashMap.Lazy (HashMap)
import Data.HashSet (HashSet)
import Data.Hourglass
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text (Text)
import System.Directory.Tree hiding (name)
import System.FilePath ((</>))
import System.Hourglass (dateCurrent)

import qualified Data.CaseInsensitive as CI (original)
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T

newtype UserID = UserID { unUserID :: Int }

newtype GroupID = GroupID { unGroupID :: Int }

newtype RepoID = RepoID { unRepoID :: Int }

newtype ProjID = ProjID { unProjID :: Int }

newtype Username = Username { unUsername :: CI Text }

newtype PasswordHash = PasswordHash { unPasswordHash :: Text }

newtype RealName = RealName { unRealName :: Text }

data EmailAddress = EmailAddress
    { emailUser :: Text
    , emailHost :: Text
    }

newtype GroupName = GroupName { unGroupName :: CI Text }

newtype RepoName = RepoName { unRepoName :: CI Text }

newtype ProjectName = ProjectName { unProjectName :: CI Text }

data User = User
    { userName     :: Username
    , userPassHash :: Maybe PasswordHash -- to disable pass and use SSH only?
    , userRealName :: RealName
    , userEmail    :: EmailAddress
    }

data Group = Group
    { groupName  :: GroupName
    , groupUsers :: HashSet UserID
    }

data IrcChannel = IrcChannel
    { chanNetwork :: Text
    , chanName    :: Text
    }

data Repository = Repository
    { repoName :: RepoName
    , repoIRC  :: Maybe IrcChannel
    , repoML   :: Maybe Text
    }

data Project = Project
    { projName  :: ProjectName
    , projRepos :: HashMap RepoID Repository
    }

data VervisEnv = VervisEnv
    { veName :: Text
    , veDir  :: FilePath
    }

data VervisState = VervisState
    { vsUsers    :: HashMap UserID User
    , vsGroups   :: HashMap GroupID Group
    , vsProjects :: HashMap ProjID Project
    }

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 to the directory containing the namespace/repo tree
    -> Vervis a -- ^ Computation to run
    -> IO a
runVervis name dir comp = do
    let venv = VervisEnv
            { veName = name
            , veDir  = dir
            }
        vstate = VervisState
            { vsUsers    = M.empty
            , vsGroups   = M.empty
            , vsProjects = M.empty
            }
    (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)