{- 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 ( UserID (..) , GroupID (..) , RepoID (..) , ProjID (..) , Username (..) , PasswordHash (..) , RealName (..) , EmailAddress (..) , GroupName (..) , RepoName (..) , ProjectName (..) , User (..) , Group (..) , IrcChannel (..) , Repository (..) , Project (..) , Vervis () , runVervis , saveState , createUser , 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 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 data VervisEnv = VervisEnv { veName :: Text , veDir :: FilePath , veSave :: VervisState -> Vervis () } data VervisState = VervisState { vsUsers :: HashMap UserID User , vsGroups :: HashMap GroupID Group , vsProjects :: HashMap (Either UserID GroupID) (HashMap ProjID Project) , vsNextUser :: UserID , vsNextGroup :: GroupID , vsNextProject :: ProjID } deriving Generic instance ToJSON VervisState instance FromJSON VervisState newtype Vervis a = Vervis { unVervis :: RWST VervisEnv () VervisState IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO) ------------------------------------------------------------------------------- -- 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" ------------------------------------------------------------------------------- -- Monad ------------------------------------------------------------------------------- -- | Fetch the value of the environment. ask :: Vervis (VervisEnv) ask = Vervis RWS.ask -- | Retrieve a function of the current environment. asks :: (VervisEnv -> a) -> Vervis a asks = Vervis . RWS.asks -- | Fetch the current value of the state within the monad. get :: Vervis (VervisState) get = Vervis RWS.get -- | Get a specific component of the state, using a projection function -- supplied. gets :: (VervisState -> a) -> Vervis a gets = Vervis . RWS.gets -- | @'put' s@ sets the state within the monad to @s@. put :: VervisState -> Vervis () put = Vervis . RWS.put -- | @'modify' f@ is an action that updates the state to the result of -- applying @f@ to the current state. modify :: (VervisState -> VervisState) -> Vervis () modify = Vervis . RWS.modify ------------------------------------------------------------------------------- -- Operations ------------------------------------------------------------------------------- -- 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 save <- mkSaveState (3 :: Second) file let venv = VervisEnv { veName = name , veDir = dir , veSave = liftIO . save } (a, _s) <- runVervis' venv vstate comp return a 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 ------------------------------------------------------------------------------- -- Git Utils ------------------------------------------------------------------------------- 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)