Make initial homepage with table and simple login

This commit is contained in:
fr33domlover 2016-02-16 11:41:13 +00:00
parent 3da488b3a2
commit 7857a8a964
12 changed files with 285 additions and 394 deletions

View file

@ -12,20 +12,48 @@
-- with this software. If not, see
-- <http://creativecommons.org/publicdomain/zero/1.0/>.
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

View file

@ -18,4 +18,4 @@
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/ HomeR GET POST
/ HomeR GET

View file

@ -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

View file

@ -1,19 +0,0 @@
{- 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/>.
-}
module Vervis
(
)
where

View file

@ -1,159 +0,0 @@
{- 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 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)-}

View file

@ -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|
<table>
$forall (sharer, proj, repo, ago) <- rows
<tr>
<td>#{sharer}
<td>#{proj}
<td>#{repo}
<td>#{ago}
|]
openConnectionCount :: Int
openConnectionCount = 10
mainView :: IO ()
mainView =
runStderrLoggingT $

View file

@ -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

117
src/Git.hs Normal file
View file

@ -0,0 +1,117 @@
{- 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 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

View file

@ -13,43 +13,46 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
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

View file

@ -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 }

View file

@ -1,49 +1,23 @@
<h1.jumbotron>
Welcome to Yesod!
<h1>Vervis
<.page-header><h2>Starting
<p>
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.
<section.list-group>
<span .list-group-item>
Now that you have a working project you should use the
<a href=http://www.yesodweb.com/book/>
Yesod book <span class="glyphicon glyphicon-book"></span>
to learn more.
You can also use this scaffolded site to explore some basic concepts.
$maybe Entity _pid person <- mp
<p>
You are logged in as #{personLogin person}.
<a href=@{AuthR LogoutR}>Log out.
$nothing
<p>
You are not logged in.
<a href=@{AuthR LoginR}>Log in.
<span .list-group-item>
This page was generated by the <tt>#{handlerName}</tt> handler in
<tt>Handler/Home.hs</tt>.
<span .list-group-item>
The <tt>#{handlerName}</tt> handler is set to generate your
site's home screen in Routes file
<tt>config/routes
<span .list-group-item>
The HTML you are seeing now is actually composed by a number of <em>widgets</em>, #
most of them are brought together by the <tt>defaultLayout</tt> function which #
is defined in the <tt>Foundation.hs</tt> module, and used by <tt>#{handlerName}</tt>. #
All the files for templates and wigdets are in <tt>templates</tt>.
<span .list-group-item>
A Widget's Html, Css and Javascript are separated in three files with the
<tt>.hamlet</tt>, <tt>.lucius</tt> and <tt>.julius</tt> extensions.
<span .list-group-item ##{aDomId}>
If you had javascript enabled then you wouldn't be seeing this.
<section.page-header>
<h2>Forms
<div>
This is an example trivial Form. Read the
<a href="http://www.yesodweb.com/book/forms">Forms chapter<span class="glyphicon glyphicon-bookmark"></span></a> #
on the yesod book to learn more about them.
$maybe (info,con) <- submission
<div .message .alert .alert-success>
Your file's type was <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em>
<form method=post action=@{HomeR}#form enctype=#{formEnctype}>
^{formWidget}
<button .btn .btn-primary type="submit">
Send it! <span class="glyphicon glyphicon-upload"></span>
<table>
$forall (sharer, proj, repo, ago) <- rows
<tr>
<td>#{sharer}
<td>#{proj}
<td>#{repo}
<td>#{ago}

View file

@ -36,6 +36,7 @@ flag library-only
library
exposed-modules: Application
Foundation
Git
Import
Import.NoFoundation
Model
@ -69,43 +70,47 @@ library
-- , hourglass
-- , time-units
-- , unordered-containers >=0.2.5
build-depends: base >= 4 && < 5
, yesod >= 1.4.1 && < 1.5
, yesod-core >= 1.4.17 && < 1.5
, yesod-auth >= 1.4.0 && < 1.5
, yesod-static >= 1.4.0.3 && < 1.6
, yesod-form >= 1.4.0 && < 1.5
build-depends: aeson >= 0.6 && < 0.11
, base >= 4 && < 5
, bytestring >= 0.9 && < 0.11
, case-insensitive
, classy-prelude >= 0.10.2
, classy-prelude-conduit >= 0.10.2
, classy-prelude-yesod >= 0.10.2
, bytestring >= 0.9 && < 0.11
, text >= 0.11 && < 2.0
, conduit >= 1.0 && < 2.0
, containers
, data-default
, directory >= 1.1 && < 1.3
, esqueleto
, fast-logger >= 2.2 && < 2.5
, file-embed
, hit
, hjsmin >= 0.1 && < 0.2
, hourglass
, http-conduit >= 2.1 && < 2.2
, monad-control >= 0.3 && < 1.1
, monad-logger >= 0.3 && < 0.4
, persistent >= 2.0 && < 2.3
, persistent-postgresql >= 2.1.1 && < 2.3
, persistent-template >= 2.0 && < 2.3
, template-haskell
, shakespeare >= 2.0 && < 2.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 1.1
, wai-extra >= 3.0 && < 3.1
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.1 && < 2.2
, directory >= 1.1 && < 1.3
, warp >= 3.0 && < 3.3
, data-default
, aeson >= 0.6 && < 0.11
, conduit >= 1.0 && < 2.0
, monad-logger >= 0.3 && < 0.4
, fast-logger >= 2.2 && < 2.5
, wai-logger >= 2.2 && < 2.3
, file-embed
, safe
, unordered-containers
, containers
, vector
, shakespeare >= 2.0 && < 2.1
, template-haskell
, text >= 0.11 && < 2.0
, time
, case-insensitive
, unordered-containers
, vector
, wai
, wai-extra >= 3.0 && < 3.1
, wai-logger >= 2.2 && < 2.3
, warp >= 3.0 && < 3.3
, yaml >= 0.8 && < 0.9
, yesod >= 1.4.1 && < 1.5
, yesod-auth >= 1.4.0 && < 1.5
, yesod-auth-hashdb
, yesod-core >= 1.4.17 && < 1.5
, yesod-form >= 1.4.0 && < 1.5
, yesod-static >= 1.4.0.3 && < 1.6
hs-source-dirs: src
default-language: Haskell2010