mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 18:14:52 +09:00
Make initial homepage with table and simple login
This commit is contained in:
parent
3da488b3a2
commit
7857a8a964
12 changed files with 285 additions and 394 deletions
|
@ -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
|
||||
|
|
|
@ -18,4 +18,4 @@
|
|||
/favicon.ico FaviconR GET
|
||||
/robots.txt RobotsR GET
|
||||
|
||||
/ HomeR GET POST
|
||||
/ HomeR GET
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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)-}
|
|
@ -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 $
|
||||
|
|
|
@ -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
117
src/Git.hs
Normal 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
|
|
@ -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
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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}
|
||||
|
|
61
vervis.cabal
61
vervis.cabal
|
@ -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
|
||||
|
||||
|
|
Loading…
Reference in a new issue