From 7857a8a9641d25840dab36f508eef7b5737d3248 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 16 Feb 2016 11:41:13 +0000 Subject: [PATCH] Make initial homepage with table and simple login --- config/models | 60 ++++++++++---- config/routes | 2 +- config/settings.yml | 6 +- src-old/Vervis.hs | 19 ----- src-old/Vervis/Git.hs | 159 -------------------------------------- src-old/Vervis/Persist.hs | 77 ------------------ src/Foundation.hs | 33 +++++--- src/Git.hs | 117 ++++++++++++++++++++++++++++ src/Handler/Home.hs | 71 +++++++++-------- src/Model.hs | 8 +- templates/homepage.hamlet | 66 +++++----------- vervis.cabal | 61 ++++++++------- 12 files changed, 285 insertions(+), 394 deletions(-) delete mode 100644 src-old/Vervis.hs delete mode 100644 src-old/Vervis/Git.hs create mode 100644 src/Git.hs diff --git a/config/models b/config/models index 8b50e5c..624eae4 100644 --- a/config/models +++ b/config/models @@ -12,20 +12,48 @@ -- with this software. If not, see -- . -User - ident Text - password Text Maybe - UniqueUser ident - deriving Typeable -Email - email Text - userId UserId Maybe - verkey Text Maybe - UniqueEmail email -Comment json -- Adding "json" causes ToJSON and FromJSON instances to be derived. - message Text - userId UserId Maybe - deriving Eq - deriving Show +IrcChannel + network Text + name Text - -- By default this file is used in Model.hs (which is imported by Foundation.hs) +Sharer + ident Text --CI + name Text Maybe + + UniqueIdent ident + +Person + ident SharerId + login Text + hash Text Maybe + email Text Maybe + + UniquePersonIdent ident + UniquePersonLogin login + +Group + ident SharerId + + UniqueGroupIdent ident + +Project + ident Text --CI + sharer SharerId + name Text Maybe + desc Text Maybe + + UniqueProject ident sharer + +Repo + ident Text --CI + project ProjectId + irc IrcChannelId Maybe + ml Text Maybe + + UniqueRepo ident project + +PersonInGroup + person PersonId + group GroupId + + UniquePersonInGroup person group diff --git a/config/routes b/config/routes index 79163ba..ed840f6 100644 --- a/config/routes +++ b/config/routes @@ -18,4 +18,4 @@ /favicon.ico FaviconR GET /robots.txt RobotsR GET -/ HomeR GET POST +/ HomeR GET diff --git a/config/settings.yml b/config/settings.yml index 9a70811..c1342d9 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -31,11 +31,11 @@ ip-from-header: "_env:IP_FROM_HEADER:false" # page. database: - user: "_env:PGUSER:vervis" - password: "_env:PGPASS:vervis_password_here" + user: "_env:PGUSER:vervis_dev" + password: "_env:PGPASS:vervis_dev_password" host: "_env:PGHOST:localhost" port: "_env:PGPORT:5432" - database: "_env:PGDATABASE:vervis" + database: "_env:PGDATABASE:vervis_dev" poolsize: "_env:PGPOOLSIZE:10" copyright: Insert your statement against copyright here diff --git a/src-old/Vervis.hs b/src-old/Vervis.hs deleted file mode 100644 index c2db79b..0000000 --- a/src-old/Vervis.hs +++ /dev/null @@ -1,19 +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 - - . - -} - -module Vervis - ( - ) -where diff --git a/src-old/Vervis/Git.hs b/src-old/Vervis/Git.hs deleted file mode 100644 index bba9f4e..0000000 --- a/src-old/Vervis/Git.hs +++ /dev/null @@ -1,159 +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.Git - ( 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.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.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 - -{-data Server = Server - { serverName :: Text - , serverDir :: FilePath - , serverUsers :: HashMap Int User - , serverGroups :: HashMap Int Group - , serverRepos :: HashMap (Either Int Int) [Repository] - }-} - --- | 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 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)-} diff --git a/src-old/Vervis/Persist.hs b/src-old/Vervis/Persist.hs index 16251b6..4a984b5 100644 --- a/src-old/Vervis/Persist.hs +++ b/src-old/Vervis/Persist.hs @@ -43,69 +43,6 @@ import Yesod hiding ((==.)) import qualified Data.Text as T import qualified Database.Esqueleto as E -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| - -IrcChannel - network Text - name Text - -Sharer - ident Text --CI - name Text Maybe - - UniqueIdent ident - -Person - ident SharerId - hash Text Maybe - email Text Maybe - - UniquePersonIdent ident - -Group - ident SharerId - - UniqueGroupIdent ident - -Project - ident Text --CI - sharer SharerId - name Text Maybe - desc Text Maybe - - UniqueProject ident sharer - -Repo - ident Text --CI - project ProjectId - irc IrcChannelId Maybe - ml Text Maybe - - UniqueRepo ident project - -PersonInGroup - person PersonId - group GroupId - - UniquePersonInGroup person group - -|] - -data MainView = MainView ConnectionPool - -mkYesod "MainView" [parseRoutes| -/ HomeR GET -|] - -instance Yesod MainView - -instance YesodPersist MainView where - type YesodPersistBackend MainView = SqlBackend - - runDB action = do - MainView pool <- getYesod - runSqlPool action pool - getHomeR :: Handler Html getHomeR = do rows <- runDB $ do @@ -136,20 +73,6 @@ getHomeR = do ago <- timeAgo dt return (sharer, project, repo, T.pack ago) - defaultLayout - [whamlet| - - $forall (sharer, proj, repo, ago) <- rows - -
#{sharer} - #{proj} - #{repo} - #{ago} - |] - -openConnectionCount :: Int -openConnectionCount = 10 - mainView :: IO () mainView = runStderrLoggingT $ diff --git a/src/Foundation.hs b/src/Foundation.hs index 4aaa2f9..accb7e9 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -19,8 +19,8 @@ import Import.NoFoundation import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) import Text.Jasmine (minifym) -import Yesod.Auth.BrowserId (authBrowserId) -import Yesod.Auth.Message (AuthMessage (InvalidLogin)) +import Yesod.Auth.HashDB (authHashDB) +import Yesod.Auth.Message (AuthMessage (IdentifierNotFound)) import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types (Logger) @@ -144,7 +144,7 @@ instance YesodPersistRunner App where getDBRunner = defaultGetDBRunner appConnPool instance YesodAuth App where - type AuthId App = UserId + type AuthId App = PersonId -- Where to send a user after successful login loginDest _ = HomeR @@ -153,17 +153,31 @@ instance YesodAuth App where -- Override the above two destinations when a Referer: header is present redirectToReferer _ = True - authenticate creds = runDB $ do - x <- getBy $ UniqueUser $ credsIdent creds - case x of + authenticate creds = do + let ident = credsIdent creds + mpid <- runDB $ getBy $ UniquePersonLogin $ credsIdent creds + return $ case mpid of + Nothing -> UserError $ IdentifierNotFound ident + Just (Entity pid _) -> Authenticated pid + {-ps <- select $ from $ \ (sharer, person) -> do + where_ $ + sharer ^. SharerIdent ==. val ident &&. + sharer ^. SharerId ==. person ^. PersonIdent + return (person ^. PersonId, person ^. PersonHash)-} + {-case x of Just (Entity uid _) -> return $ Authenticated uid Nothing -> Authenticated <$> insert User { userIdent = credsIdent creds , userPassword = Nothing - } + }-} + {-return $ case ps of + [] -> UserError $ IdentifierNotFound ident + [(pid, phash)] -> + _ -> ServerError "Data model error, non-unique ident" + -} -- You can add other plugins like BrowserID, email or OAuth here - authPlugins _ = [authBrowserId def] + authPlugins _ = [authHashDB $ Just . UniquePersonLogin] authHttpManager = getHttpManager @@ -176,7 +190,8 @@ instance RenderMessage App FormMessage where -- Useful when writing code that is re-usable outside of the Handler context. -- An example is background jobs that send email. --- This can also be useful for writing code that works across multiple Yesod applications. +-- This can also be useful for writing code that works across multiple Yesod +-- applications. instance HasHttpManager App where getHttpManager = appHttpManager diff --git a/src/Git.hs b/src/Git.hs new file mode 100644 index 0000000..aeb453f --- /dev/null +++ b/src/Git.hs @@ -0,0 +1,117 @@ +{- 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 Git + ( lastChange + , 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.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 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 -> 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 + let sec = timeDiff now dt + (period, duration) = fromSec sec + return $ showAgo period duration diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 4e20539..80850f4 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -13,43 +13,46 @@ - . -} -module Handler.Home where +module Handler.Home + ( getHomeR + ) +where -import Import -import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, - withSmallInput) +import Import hiding ((==.)) + +import Database.Esqueleto +import Git --- This is a handler function for the GET request method on the HomeR --- resource pattern. All of your resource patterns are defined in --- config/routes --- --- The majority of the code you will write in Yesod lives in these handler --- functions. You can spread them across multiple files if you are so --- inclined, or create a single monolithic file. getHomeR :: Handler Html getHomeR = do - (formWidget, formEnctype) <- generateFormPost sampleForm - let submission = Nothing :: Maybe (FileInfo, Text) - handlerName = "getHomeR" :: Text + rows <- do + repos <- runDB $ select $ from $ \ (sharer, project, repo) -> do + where_ $ + project ^. ProjectSharer ==. sharer ^. SharerId &&. + repo ^. RepoProject ==. project ^. ProjectId + orderBy + [ asc $ sharer ^. SharerIdent + , asc $ project ^. ProjectIdent + , asc $ repo ^. RepoIdent + ] + return + ( sharer ^. SharerIdent + , project ^. ProjectIdent + , repo ^. RepoIdent + ) + liftIO $ forM repos $ \ (Value sharer, Value project, Value repo) -> do + let path = + unpack $ + intercalate "/" + [ "state2" + , sharer + , project + , repo + ] + dt <- lastChange path + ago <- timeAgo dt + return (sharer, project, repo, ago) + mp <- maybeAuth defaultLayout $ do - aDomId <- newIdent - setTitle "Welcome To Yesod!" + setTitle "Welcome to Vervis!" $(widgetFile "homepage") - -postHomeR :: Handler Html -postHomeR = do - ((result, formWidget), formEnctype) <- runFormPost sampleForm - let handlerName = "postHomeR" :: Text - submission = case result of - FormSuccess res -> Just res - _ -> Nothing - - defaultLayout $ do - aDomId <- newIdent - setTitle "Welcome To Yesod!" - $(widgetFile "homepage") - -sampleForm :: Form (FileInfo, Text) -sampleForm = renderBootstrap3 BootstrapBasicForm $ (,) - <$> fileAFormReq "Choose a file" - <*> areq textField (withSmallInput "What's on the file?") Nothing diff --git a/src/Model.hs b/src/Model.hs index 85efa4d..dc3d687 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -19,10 +19,14 @@ module Model where import ClassyPrelude.Yesod import Database.Persist.Quasi +import Yesod.Auth.HashDB (HashDBUser (..)) -- You can define all of your database entities in the entities file. --- You can find more information on persistent and how to declare entities --- at: +-- You can find more information on persistent and how to declare entities at: -- http://www.yesodweb.com/book/persistent/ share [mkPersist sqlSettings, mkMigrate "migrateAll"] $(persistFileWith lowerCaseSettings "config/models") + +instance HashDBUser Person where + userPasswordHash = personHash + setPasswordHash hash person = person { personHash = Just hash } diff --git a/templates/homepage.hamlet b/templates/homepage.hamlet index 15cafa7..fd2cf1d 100644 --- a/templates/homepage.hamlet +++ b/templates/homepage.hamlet @@ -1,49 +1,23 @@ - - Welcome to Yesod! +

Vervis -<.page-header>

Starting +

+ Vervis is hopefully going to be, eventually, a decentralized project hosting + platform. At the time of writing (2016-02-14), it is a simple scaffolded + Yesod web application which displays a table of Git repositories. - - - Now that you have a working project you should use the - - Yesod book - to learn more. - You can also use this scaffolded site to explore some basic concepts. +$maybe Entity _pid person <- mp +

+ You are logged in as #{personLogin person}. + Log out. +$nothing +

+ You are not logged in. + Log in. - - This page was generated by the #{handlerName} handler in - Handler/Home.hs. - - - The #{handlerName} handler is set to generate your - site's home screen in Routes file - config/routes - - - The HTML you are seeing now is actually composed by a number of widgets, # - most of them are brought together by the defaultLayout function which # - is defined in the Foundation.hs module, and used by #{handlerName}. # - All the files for templates and wigdets are in templates. - - - A Widget's Html, Css and Javascript are separated in three files with the - .hamlet, .lucius and .julius extensions. - - - If you had javascript enabled then you wouldn't be seeing this. - - -

Forms - -
- This is an example trivial Form. Read the - Forms chapter # - on the yesod book to learn more about them. - $maybe (info,con) <- submission -
- Your file's type was #{fileContentType info}. You say it has: #{con} -
- ^{formWidget} -