mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-07 21:06:46 +09:00
127 lines
4 KiB
Haskell
127 lines
4 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2016, 2018 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.GitOld
|
|
( lastChange
|
|
--, timeAgo
|
|
--, timeAgo'
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Control.Monad (join)
|
|
-- import Control.Monad.Fix (MonadFix)
|
|
-- import Control.Monad.IO.Class
|
|
-- 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.Git.Types (GitTime (..))
|
|
-- import Data.Hashable (Hashable)
|
|
-- import Data.HashMap.Lazy (HashMap)
|
|
-- import Data.HashSet (HashSet)
|
|
import Data.Hourglass
|
|
import Data.Maybe (fromMaybe{-, mapMaybe-})
|
|
-- import Data.Monoid ((<>))
|
|
-- 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
|
|
|
|
-- | Return the subdirs of a given dir
|
|
{-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
|
|
_ -> []-}
|
|
|
|
-- | Determine the time of the last commit in a given git branch
|
|
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
|
|
|
|
-- | Determine the time of the last commit in any branch for a given repo
|
|
lastChange :: FilePath -> IO (Maybe Elapsed)
|
|
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 elapseds = map gitTimeUTC times
|
|
return $ if null elapseds
|
|
then Nothing
|
|
else Just $ maximum elapseds
|
|
|
|
{-
|
|
showPeriod :: Period -> Text
|
|
showPeriod (Period 0 0 d) = T.pack (show d) <> " days"
|
|
showPeriod (Period 0 m _) = T.pack (show m) <> " months"
|
|
showPeriod (Period y _ _) = T.pack (show y) <> " years"
|
|
|
|
showDuration :: Duration -> Text
|
|
showDuration (Duration (Hours h) (Minutes m) (Seconds s) _) =
|
|
case (h, m, s) of
|
|
(0, 0, 0) -> "now"
|
|
(0, 0, _) -> T.pack (show s) <> " seconds"
|
|
(0, _, _) -> T.pack (show m) <> " minutes"
|
|
_ -> T.pack (show h) <> " hours"
|
|
|
|
showAgo :: Period -> Duration -> Text
|
|
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 Text
|
|
timeAgo dt = do
|
|
now <- dateCurrent
|
|
return $ timeAgo' now dt
|
|
|
|
timeAgo' :: DateTime -> DateTime -> Text
|
|
timeAgo' now dt =
|
|
let sec = timeDiff now dt
|
|
(period, duration) = fromSec sec
|
|
in showAgo period duration
|
|
-}
|