From fe4d1e1afe99e8dfd56329adf40cf10bf82b9eb0 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 12 Dec 2018 07:46:30 +0000 Subject: [PATCH] Remove the src-old dir, no need for it anymore (since long time ago) --- src-old/Vervis/Monad.hs | 138 -------------------------------------- src-old/Vervis/Persist.hs | 107 ----------------------------- 2 files changed, 245 deletions(-) delete mode 100644 src-old/Vervis/Monad.hs delete mode 100644 src-old/Vervis/Persist.hs diff --git a/src-old/Vervis/Monad.hs b/src-old/Vervis/Monad.hs deleted file mode 100644 index 8e0800d..0000000 --- a/src-old/Vervis/Monad.hs +++ /dev/null @@ -1,138 +0,0 @@ -{- 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.Monad - ( VervisEnv (..) - , VervisState (..) - , Vervis () - , runVervis - , ask - , asks - , get - , gets - , put - , modify - ) -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 Vervis.Types - -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 - -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) - --- 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 - --- | 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 diff --git a/src-old/Vervis/Persist.hs b/src-old/Vervis/Persist.hs deleted file mode 100644 index 4a984b5..0000000 --- a/src-old/Vervis/Persist.hs +++ /dev/null @@ -1,107 +0,0 @@ -{- 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 EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Vervis.Persist - --( - --) -where - -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Resource (runResourceT) -import Control.Monad.Logger (runStderrLoggingT) -import Data.Text (Text) -import Data.Traversable (forM) -import Database.Esqueleto ((^.), (&&.), (==.)) -import Database.Persist hiding ((==.)) -import Database.Persist.Sqlite hiding ((==.)) -import Database.Persist.TH -import Vervis.Git -import Yesod hiding ((==.)) - -import qualified Data.Text as T -import qualified Database.Esqueleto as E - -getHomeR :: Handler Html -getHomeR = do - rows <- runDB $ do - repos <- E.select $ E.from $ \ (sharer, project, repo) -> do - E.where_ $ - project ^. ProjectSharer ==. sharer ^. SharerId &&. - repo ^. RepoProject ==. project ^. ProjectId - E.orderBy - [ E.asc $ sharer ^. SharerIdent - , E.asc $ project ^. ProjectIdent - , E.asc $ repo ^. RepoIdent - ] - return - ( sharer ^. SharerIdent - , project ^. ProjectIdent - , repo ^. RepoIdent - ) - liftIO $ forM repos $ \ (E.Value sharer, E.Value project, E.Value repo) -> do - let path = - T.unpack $ - T.intercalate "/" - [ "state2" - , sharer - , project - , repo - ] - dt <- lastChange path - ago <- timeAgo dt - return (sharer, project, repo, T.pack ago) - -mainView :: IO () -mainView = - runStderrLoggingT $ - withSqlitePool "test.db3" openConnectionCount $ - \ pool -> liftIO $ do - runResourceT $ flip runSqlPool pool $ do - runMigration migrateAll - - cindyId <- insert $ Sharer "cindy" Nothing - bobId <- insert $ Sharer "bob" Nothing - aliceId <- insert $ Sharer "alice" Nothing - - proj4Id <- insert $ Project "proj4" cindyId Nothing Nothing - proj2Id <- insert $ Project "proj2" aliceId Nothing Nothing - proj6Id <- insert $ Project "proj6" cindyId Nothing Nothing - proj3Id <- insert $ Project "proj3" bobId Nothing Nothing - proj5Id <- insert $ Project "proj5" cindyId Nothing Nothing - proj1Id <- insert $ Project "proj1" aliceId Nothing Nothing - - insert_ $ Repo "repo8" proj5Id Nothing Nothing - insert_ $ Repo "repo1" proj1Id Nothing Nothing - insert_ $ Repo "repo6" proj4Id Nothing Nothing - insert_ $ Repo "repo3" proj3Id Nothing Nothing - insert_ $ Repo "repo4" proj3Id Nothing Nothing - insert_ $ Repo "repo10" proj6Id Nothing Nothing - insert_ $ Repo "repo5" proj4Id Nothing Nothing - insert_ $ Repo "repo7" proj5Id Nothing Nothing - insert_ $ Repo "repo2" proj2Id Nothing Nothing - insert_ $ Repo "repo9" proj5Id Nothing Nothing - insert_ $ Repo "repo11" proj6Id Nothing Nothing - insert_ $ Repo "repo12" proj6Id Nothing Nothing - warp 3000 $ MainView pool