Finish route change, it builds now

I used this chance to make some name changes, add some utils, tweak some
imports, remove more `setTitle`s and so on. I also made person, repo,
key and project creation forms verify CI-uniqueness.
This commit is contained in:
fr33domlover 2016-05-23 20:46:54 +00:00
parent 49807ed27f
commit c6c41b485c
43 changed files with 418 additions and 149 deletions

View file

@ -13,10 +13,10 @@
-- <http://creativecommons.org/publicdomain/zero/1.0/>. -- <http://creativecommons.org/publicdomain/zero/1.0/>.
Sharer Sharer
ident TextCI ident ShrIdent
name Text Maybe name Text Maybe
UniqueSharerIdent ident UniqueSharer ident
Person Person
ident SharerId ident SharerId
@ -28,12 +28,12 @@ Person
UniquePersonLogin login UniquePersonLogin login
SshKey SshKey
ident KyIdent
person PersonId person PersonId
name Text
algo ByteString algo ByteString
content ByteString content ByteString
UniqueSshKey person name UniqueSshKey person ident
Group Group
ident SharerId ident SharerId
@ -41,7 +41,7 @@ Group
UniqueGroupIdent ident UniqueGroupIdent ident
Project Project
ident TextCI ident PrjIdent
sharer SharerId sharer SharerId
name Text Maybe name Text Maybe
desc Text Maybe desc Text Maybe
@ -50,7 +50,7 @@ Project
UniqueProject ident sharer UniqueProject ident sharer
Repo Repo
ident TextCI ident RpIdent
sharer SharerId sharer SharerId
vcs VersionControlSystem default='VCSGit' vcs VersionControlSystem default='VCSGit'
project ProjectId Maybe project ProjectId Maybe

View file

@ -0,0 +1,48 @@
{- 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/>.
-}
-- | CI views for avoiding ambiguity in the meaning of some typeclass
-- instances, and allow two instances to coexist. For example, does 'show' show
-- the original or the case-folded version? Using CI views, it's easy to
-- specify that.
--
-- Note that some of the instances provided here, i.e. instances 'CI' already
-- has, are reused directly by both views. If you aren't sure about a specific
-- instance, check the source.
module Data.CaseInsensitive.Local
( AsOriginal (..)
, mkOrig
, AsCaseFolded (..)
, mkFolded
)
where
import Prelude
import Data.CaseInsensitive
import Data.Hashable (Hashable)
import Data.String (IsString)
newtype AsOriginal s = AsOriginal { unOriginal :: CI s }
deriving (Eq, Ord, Read, Show, IsString, Monoid, Hashable, FoldCase)
mkOrig :: FoldCase s => s -> AsOriginal s
mkOrig = AsOriginal . mk
newtype AsCaseFolded s = AsCaseFolded { unCaseFolded :: CI s }
deriving (Eq, Ord, Read, Show, IsString, Monoid, Hashable, FoldCase)
mkFolded :: FoldCase s => s -> AsCaseFolded s
mkFolded = AsCaseFolded . mk

View file

@ -25,4 +25,6 @@ import Database.Esqueleto
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
instance SqlString s => SqlString (CI s) import Database.Persist.Class.Local ()
instance (SqlString s, CI.FoldCase s) => SqlString (CI s)

View file

@ -0,0 +1,33 @@
{- 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 Formatting.CaseInsensitive
( ciOrig
, ciFolded
)
where
import Prelude
import Data.CaseInsensitive
import Data.Text (Text)
import Data.Text.Lazy.Builder (fromText)
import Formatting
ciOrig :: Format r (CI Text -> r)
ciOrig = later $ fromText . original
ciFolded :: Format r (CI Text -> r)
ciFolded = later $ fromText . foldedCase

View file

@ -25,6 +25,12 @@ import Text.Blaze
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
instance ToMarkup s => ToMarkup (CI s) where import qualified Data.CaseInsensitive.Local as CIL
toMarkup = toMarkup . CI.original
preEscapedToMarkup = preEscapedToMarkup . CI.original instance ToMarkup s => ToMarkup (CIL.AsOriginal s) where
toMarkup = toMarkup . CI.original . CIL.unOriginal
preEscapedToMarkup = preEscapedToMarkup . CI.original . CIL.unOriginal
instance ToMarkup s => ToMarkup (CIL.AsCaseFolded s) where
toMarkup = toMarkup . CI.foldedCase . CIL.unCaseFolded
preEscapedToMarkup = preEscapedToMarkup . CI.foldedCase . CIL.unCaseFolded

View file

@ -29,6 +29,7 @@ import Data.Maybe (isNothing)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Database.Esqueleto
import Database.Persist (checkUnique) import Database.Persist (checkUnique)
import Yesod.Form.Fields (textField) import Yesod.Form.Fields (textField)
import Yesod.Form.Functions (check, checkBool, checkM, convertField) import Yesod.Form.Functions (check, checkBool, checkM, convertField)
@ -42,6 +43,7 @@ import Data.Char.Local (isAsciiLetter)
import Network.SSH.Local (supportedKeyAlgos) import Network.SSH.Local (supportedKeyAlgos)
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident (text2ky)
mkBsField :: Field Handler Text -> Field Handler ByteString mkBsField :: Field Handler Text -> Field Handler ByteString
mkBsField = convertField encodeUtf8 (decodeUtf8With lenientDecode) mkBsField = convertField encodeUtf8 (decodeUtf8With lenientDecode)
@ -50,16 +52,16 @@ bsField :: Field Handler ByteString
bsField = mkBsField textField bsField = mkBsField textField
checkNameUnique :: PersonId -> Field Handler Text -> Field Handler Text checkNameUnique :: PersonId -> Field Handler Text -> Field Handler Text
checkNameUnique pid = checkM $ \ name -> runDB $ do checkNameUnique pid = checkM $ \ ident -> do
let key = SshKey let ident' = text2ky ident
{ sshKeyPerson = pid sames <- runDB $ select $ from $ \ key -> do
, sshKeyName = name where_ $
, sshKeyAlgo = mempty key ^. SshKeyPerson ==. val pid &&.
, sshKeyContent = mempty lower_ (key ^. SshKeyIdent) ==. lower_ (val ident')
} limit 1
muk <- checkUnique key return ()
return $ if isNothing muk return $ if null sames
then Right name then Right ident
else Left ("You already have a key with this label" :: Text) else Left ("You already have a key with this label" :: Text)
nameField :: PersonId -> Field Handler Text nameField :: PersonId -> Field Handler Text

View file

@ -25,6 +25,7 @@ import Data.Char (isDigit)
import Database.Esqueleto import Database.Esqueleto
import Data.Char.Local (isAsciiLetter) import Data.Char.Local (isAsciiLetter)
import Vervis.Model.Ident (text2shr)
checkLoginTemplate :: Field Handler Text -> Field Handler Text checkLoginTemplate :: Field Handler Text -> Field Handler Text
checkLoginTemplate = checkLoginTemplate =
@ -43,8 +44,9 @@ checkLoginTemplate =
checkLoginUnique :: Field Handler Text -> Field Handler Text checkLoginUnique :: Field Handler Text -> Field Handler Text
checkLoginUnique = checkM $ \ login -> do checkLoginUnique = checkM $ \ login -> do
let login' = text2shr login
sames <- runDB $ select $ from $ \ sharer -> do sames <- runDB $ select $ from $ \ sharer -> do
where_ $ lower_ (sharer ^. SharerIdent) ==. lower_ (val login) where_ $ lower_ (sharer ^. SharerIdent) ==. lower_ (val login')
limit 1 limit 1
return () return ()
return $ if null sames return $ if null sames

View file

@ -18,11 +18,14 @@ module Vervis.Field.Project
) )
where where
import Vervis.Import import Vervis.Import hiding ((==.))
import Data.Char (isDigit) import Data.Char (isDigit)
import Data.Char.Local (isAsciiLetter) import Data.Char.Local (isAsciiLetter)
import Data.Text (split) import Data.Text (split)
import Database.Esqueleto
import Vervis.Model.Ident (text2prj)
checkIdentTemplate :: Field Handler Text -> Field Handler Text checkIdentTemplate :: Field Handler Text -> Field Handler Text
checkIdentTemplate = checkIdentTemplate =
@ -37,15 +40,14 @@ checkIdentTemplate =
checkIdentUnique :: SharerId -> Field Handler Text -> Field Handler Text checkIdentUnique :: SharerId -> Field Handler Text -> Field Handler Text
checkIdentUnique sid = checkM $ \ ident -> do checkIdentUnique sid = checkM $ \ ident -> do
let project = Project let ident' = text2prj ident
{ projectIdent = ident sames <- runDB $ select $ from $ \ project -> do
, projectSharer = sid where_ $
, projectName = Nothing project ^. ProjectSharer ==. val sid &&.
, projectDesc = Nothing lower_ (project ^. ProjectIdent) ==. lower_ (val ident')
, projectNextTicket = 0 limit 1
} return ()
mup <- runDB $ checkUnique project return $ if null sames
return $ if isNothing mup
then Right ident then Right ident
else Left ("You already have a project by that name" :: Text) else Left ("You already have a project by that name" :: Text)

View file

@ -18,11 +18,14 @@ module Vervis.Field.Repo
) )
where where
import Vervis.Import import Vervis.Import hiding ((==.))
import Data.Char (isDigit) import Data.Char (isDigit)
import Data.Char.Local (isAsciiLetter) import Data.Char.Local (isAsciiLetter)
import Data.Text (split) import Data.Text (split)
import Database.Esqueleto
import Vervis.Model.Ident (text2rp)
checkIdentTemplate :: Field Handler Text -> Field Handler Text checkIdentTemplate :: Field Handler Text -> Field Handler Text
checkIdentTemplate = checkIdentTemplate =
@ -38,8 +41,14 @@ checkIdentTemplate =
-- | Make sure the sharer doesn't already have a repo by the same name. -- | Make sure the sharer doesn't already have a repo by the same name.
checkIdentUnique :: SharerId -> Field Handler Text -> Field Handler Text checkIdentUnique :: SharerId -> Field Handler Text -> Field Handler Text
checkIdentUnique sid = checkM $ \ ident -> do checkIdentUnique sid = checkM $ \ ident -> do
mrepo <- runDB $ getBy $ UniqueRepo ident sid let ident' = text2rp ident
return $ if isNothing mrepo sames <- runDB $ select $ from $ \ repo -> do
where_ $
repo ^. RepoSharer ==. val sid &&.
lower_ (repo ^. RepoIdent) ==. lower_ (val ident')
limit 1
return ()
return $ if null sames
then Right ident then Right ident
else Left ("You already have a repo by that name" :: Text) else Left ("You already have a repo by that name" :: Text)

View file

@ -21,11 +21,12 @@ where
import Vervis.Import import Vervis.Import
import Vervis.Field.Key import Vervis.Field.Key
import Vervis.Model.Ident (text2ky)
newKeyAForm :: PersonId -> AForm Handler SshKey newKeyAForm :: PersonId -> AForm Handler SshKey
newKeyAForm pid = SshKey newKeyAForm pid = SshKey
<$> pure pid <$> (text2ky <$> areq (nameField pid) "Name*" Nothing)
<*> areq (nameField pid) "Name*" Nothing <*> pure pid
<*> areq algoField "Algorithm*" Nothing <*> areq algoField "Algorithm*" Nothing
<*> areq contentField "Content*" Nothing <*> areq contentField "Content*" Nothing

View file

@ -26,13 +26,15 @@ import Vervis.Field.Person
data PersonNew = PersonNew data PersonNew = PersonNew
{ uLogin :: Text { uLogin :: Text
, uPass :: Text , uPass :: Text
, uName :: Maybe Text
, uEmail :: Maybe Text , uEmail :: Maybe Text
} }
newPersonAForm :: AForm Handler PersonNew newPersonAForm :: AForm Handler PersonNew
newPersonAForm = PersonNew newPersonAForm = PersonNew
<$> areq loginField "Username" Nothing <$> areq loginField "Username*" Nothing
<*> areq passField "Password" Nothing <*> areq passField "Password*" Nothing
<*> aopt textField "Full name" Nothing
<*> aopt emailField "E-mail" Nothing <*> aopt emailField "E-mail" Nothing
formPersonNew :: Form PersonNew formPersonNew :: Form PersonNew

View file

@ -21,10 +21,11 @@ where
import Vervis.Import import Vervis.Import
import Vervis.Field.Project import Vervis.Field.Project
import Vervis.Model.Ident (text2prj)
newProjectAForm :: SharerId -> AForm Handler Project newProjectAForm :: SharerId -> AForm Handler Project
newProjectAForm sid = Project newProjectAForm sid = Project
<$> areq (mkIdentField sid) "Identifier*" Nothing <$> (text2prj <$> areq (mkIdentField sid) "Identifier*" Nothing)
<*> pure sid <*> pure sid
<*> aopt textField "Name" Nothing <*> aopt textField "Name" Nothing
<*> aopt textField "Description" Nothing <*> aopt textField "Description" Nothing

View file

@ -22,11 +22,12 @@ where
import Vervis.Import import Vervis.Import
import Vervis.Field.Repo import Vervis.Field.Repo
import Vervis.Model.Ident (prj2text, text2rp)
import Vervis.Model.Repo import Vervis.Model.Repo
newRepoAForm :: SharerId -> Maybe ProjectId -> AForm Handler Repo newRepoAForm :: SharerId -> Maybe ProjectId -> AForm Handler Repo
newRepoAForm sid mpid = Repo newRepoAForm sid mpid = Repo
<$> areq (mkIdentField sid) "Identifier*" Nothing <$> (text2rp <$> areq (mkIdentField sid) "Identifier*" Nothing)
<*> pure sid <*> pure sid
<*> areq (selectFieldList vcsList) "Version control system*" Nothing <*> areq (selectFieldList vcsList) "Version control system*" Nothing
<*> aopt selectProject "Project" (Just mpid) <*> aopt selectProject "Project" (Just mpid)
@ -40,8 +41,8 @@ newRepoAForm sid mpid = Repo
] ]
selectProject = selectProject =
selectField $ selectField $
optionsPersistKey optionsPersistKey [ProjectSharer ==. sid] [Asc ProjectIdent] $
[ProjectSharer ==. sid] [Asc ProjectIdent] projectIdent prj2text . projectIdent
newRepoForm :: SharerId -> Maybe ProjectId -> Form Repo newRepoForm :: SharerId -> Maybe ProjectId -> Form Repo
newRepoForm sid mpid = renderDivs $ newRepoAForm sid mpid newRepoForm sid mpid = renderDivs $ newRepoAForm sid mpid

58
src/Vervis/Formatting.hs Normal file
View file

@ -0,0 +1,58 @@
{- 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.Formatting
( sharer
, sharerl
, key
, keyl
, project
, projectl
, repo
, repol
)
where
import Prelude
import Data.CaseInsensitive
import Data.Text.Lazy.Builder (fromText)
import Formatting
import Vervis.Model.Ident
sharer :: Format r (ShrIdent -> r)
sharer = later $ fromText . original . unShrIdent
sharerl :: Format r (ShrIdent -> r)
sharerl = later $ fromText . foldedCase . unShrIdent
key :: Format r (KyIdent -> r)
key = later $ fromText . original . unKyIdent
keyl :: Format r (KyIdent -> r)
keyl = later $ fromText . foldedCase . unKyIdent
project :: Format r (PrjIdent -> r)
project = later $ fromText . original . unPrjIdent
projectl :: Format r (PrjIdent -> r)
projectl = later $ fromText . foldedCase . unPrjIdent
repo :: Format r (RpIdent -> r)
repo = later $ fromText . original . unRpIdent
repol :: Format r (RpIdent -> r)
repol = later $ fromText . foldedCase . unRpIdent

View file

@ -120,12 +120,9 @@ instance Yesod App where
loggedInAs user "You cant create projects for other users" loggedInAs user "You cant create projects for other users"
isAuthorized (RepoNewR user) _ = isAuthorized (RepoNewR user) _ =
loggedInAs user "You cant create repos for other users" loggedInAs user "You cant create repos for other users"
isAuthorized (KeysR user) _ = isAuthorized KeysR _ = loggedIn
loggedInAs user "You cant watch keys of other users" isAuthorized (KeyR _key) _ = loggedIn
isAuthorized (KeyR user _key) _ = isAuthorized KeyNewR _ = loggedIn
loggedInAs user "You cant watch keys of other users"
isAuthorized (KeyNewR user) _ =
loggedInAs user "You cant add keys for other users"
isAuthorized (RepoR shar _) True = isAuthorized (RepoR shar _) True =
loggedInAs shar "You cant modify repos for other users" loggedInAs shar "You cant modify repos for other users"
isAuthorized (TicketNewR _ _) _ = loggedIn isAuthorized (TicketNewR _ _) _ = loggedIn
@ -191,22 +188,6 @@ instance YesodAuth App where
return $ case mpid of return $ case mpid of
Nothing -> UserError $ IdentifierNotFound ident Nothing -> UserError $ IdentifierNotFound ident
Just (Entity pid _) -> Authenticated pid 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 -- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [authHashDB $ Just . UniquePersonLogin] authPlugins _ = [authHashDB $ Just . UniquePersonLogin]
@ -245,7 +226,7 @@ loggedIn = do
Nothing -> return AuthenticationRequired Nothing -> return AuthenticationRequired
Just _pid -> return Authorized Just _pid -> return Authorized
loggedInAs :: Text -> Text -> Handler AuthResult loggedInAs :: ShrIdent -> Text -> Handler AuthResult
loggedInAs ident msg = do loggedInAs ident msg = do
mp <- maybeAuth mp <- maybeAuth
case mp of case mp of
@ -269,15 +250,15 @@ instance YesodBreadcrumbs App where
PeopleR -> ("People", Just HomeR) PeopleR -> ("People", Just HomeR)
PersonNewR -> ("New", Just PeopleR) PersonNewR -> ("New", Just PeopleR)
PersonR shar -> (shar, Just PeopleR) PersonR shar -> (shr2text shar, Just PeopleR)
KeysR shar -> ("Keys", Just $ PersonR shar) KeysR -> ("Keys", Just HomeR)
KeyNewR shar -> ("New", Just $ KeysR shar) KeyNewR -> ("New", Just KeysR)
KeyR shar key -> (key, Just $ KeysR shar) KeyR key -> (ky2text key, Just KeysR)
ReposR shar -> ("Repos", Just $ PersonR shar) ReposR shar -> ("Repos", Just $ PersonR shar)
RepoNewR shar -> ("New", Just $ ReposR shar) RepoNewR shar -> ("New", Just $ ReposR shar)
RepoR shar repo -> (repo, Just $ ReposR shar) RepoR shar repo -> (rp2text repo, Just $ ReposR shar)
RepoSourceR shar repo [] -> ("Files", Just $ RepoR shar repo) RepoSourceR shar repo [] -> ("Files", Just $ RepoR shar repo)
RepoSourceR shar repo refdir -> ( last refdir RepoSourceR shar repo refdir -> ( last refdir
, Just $ , Just $
@ -291,7 +272,9 @@ instance YesodBreadcrumbs App where
ProjectsR shar -> ("Projects", Just $ PersonR shar) ProjectsR shar -> ("Projects", Just $ PersonR shar)
ProjectNewR shar -> ("New", Just $ ProjectsR shar) ProjectNewR shar -> ("New", Just $ ProjectsR shar)
ProjectR shar proj -> (proj, Just $ ProjectsR shar) ProjectR shar proj -> ( prj2text proj
, Just $ ProjectsR shar
)
TicketsR shar proj -> ( "Tickets" TicketsR shar proj -> ( "Tickets"
, Just $ ProjectR shar proj , Just $ ProjectR shar proj

View file

@ -37,11 +37,12 @@ import Yesod.Core.Handler
import Vervis.BinaryBody (decodeRequestBody) import Vervis.BinaryBody (decodeRequestBody)
import Vervis.Content import Vervis.Content
import Vervis.Foundation (Handler) import Vervis.Foundation (Handler)
import Vervis.Model.Ident
import Vervis.Path (askRepoDir) import Vervis.Path (askRepoDir)
getGitRefDiscoverR :: ShrIdent -> RpIdent -> Handler GitRefDiscovery getGitRefDiscoverR :: ShrIdent -> RpIdent -> Handler GitRefDiscovery
getGitRefDiscoverR shar repo = do getGitRefDiscoverR shar repo = do
path <- askRepoDir sharer repo path <- askRepoDir shar repo
let pathG = fromString path let pathG = fromString path
seemsThere <- liftIO $ isRepo pathG seemsThere <- liftIO $ isRepo pathG
if seemsThere if seemsThere

View file

@ -25,6 +25,7 @@ import Vervis.GitOld
import qualified Database.Esqueleto as E ((==.)) import qualified Database.Esqueleto as E ((==.))
import Vervis.Model.Ident
import Vervis.Model.Repo import Vervis.Model.Repo
import Vervis.Path import Vervis.Path
@ -46,18 +47,16 @@ intro = do
, repo ^. RepoIdent , repo ^. RepoIdent
, repo ^. RepoVcs , repo ^. RepoVcs
) )
root <- askRepoRootDir forM repos $
liftIO $ forM repos $
\ (Value sharer, Value mproj, Value repo, Value vcs) -> do \ (Value sharer, Value mproj, Value repo, Value vcs) -> do
ago <- case vcs of ago <- case vcs of
VCSDarcs -> return "[Not implemented yet]" VCSDarcs -> return "[Not implemented yet]"
VCSGit -> do VCSGit -> do
let path = path <- askRepoDir sharer repo
root </> unpack sharer </> unpack repo mdt <- liftIO $ lastChange path
mdt <- lastChange path
case mdt of case mdt of
Nothing -> return "never" Nothing -> return "never"
Just dt -> timeAgo dt Just dt -> liftIO $ timeAgo dt
return (sharer, mproj, repo, vcs, ago) return (sharer, mproj, repo, vcs, ago)
defaultLayout $ do defaultLayout $ do
setTitle "Welcome to Vervis!" setTitle "Welcome to Vervis!"

View file

@ -32,6 +32,7 @@ import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Database.Persist import Database.Persist
import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Html (Html, toHtml)
import Yesod.Auth (requireAuthId)
import Yesod.Core (defaultLayout) import Yesod.Core (defaultLayout)
import Yesod.Core.Handler import Yesod.Core.Handler
import Yesod.Core.Widget (setTitle) import Yesod.Core.Widget (setTitle)
@ -42,14 +43,15 @@ import Yesod.Persist.Core (runDB, getBy404)
import Vervis.Form.Key import Vervis.Form.Key
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident
import Vervis.Settings import Vervis.Settings
getKeysR :: Handler Html getKeysR :: Handler Html
getKeysR = do getKeysR = do
pid <- requireAuthId pid <- requireAuthId
keys <- runDB $ do keys <- runDB $ do
ks <- selectList [SshKeyPerson ==. pid] [Asc SshKeyName] ks <- selectList [SshKeyPerson ==. pid] [Asc SshKeyIdent]
return $ map (\ (Entity _ k) -> sshKeyName k) ks return $ map (\ (Entity _ k) -> sshKeyIdent k) ks
defaultLayout $(widgetFile "key/list") defaultLayout $(widgetFile "key/list")
postKeysR :: Handler Html postKeysR :: Handler Html
@ -84,6 +86,7 @@ getKeyR tag = do
deleteKeyR :: KyIdent -> Handler Html deleteKeyR :: KyIdent -> Handler Html
deleteKeyR tag = do deleteKeyR tag = do
pid <- requireAuthId
runDB $ do runDB $ do
Entity kid _k <- getBy404 $ UniqueSshKey pid tag Entity kid _k <- getBy404 $ UniqueSshKey pid tag
delete kid delete kid

View file

@ -30,6 +30,8 @@ import Vervis.Form.Person
import Text.Blaze.Html (toHtml) import Text.Blaze.Html (toHtml)
import Yesod.Auth.HashDB (setPassword) import Yesod.Auth.HashDB (setPassword)
import Vervis.Model.Ident
-- | Get list of users -- | Get list of users
getPeopleR :: Handler Html getPeopleR :: Handler Html
getPeopleR = do getPeopleR = do
@ -37,14 +39,12 @@ getPeopleR = do
where_ $ sharer ^. SharerId ==. person ^. PersonIdent where_ $ sharer ^. SharerId ==. person ^. PersonIdent
orderBy [asc $ sharer ^. SharerIdent] orderBy [asc $ sharer ^. SharerIdent]
return $ sharer ^. SharerIdent return $ sharer ^. SharerIdent
defaultLayout $ do defaultLayout $(widgetFile "people")
setTitle "Vervis > People"
$(widgetFile "people")
-- | Create new user -- | Create new user
postPeopleR :: Handler Html postPeopleR :: Handler Html
postPeopleR = do postPeopleR = do
regEnabled <- appRegister . appSettings <$> getYesod regEnabled <- getsYesod $ appRegister . appSettings
if regEnabled if regEnabled
then do then do
((result, widget), enctype) <- runFormPost formPersonNew ((result, widget), enctype) <- runFormPost formPersonNew
@ -52,8 +52,8 @@ postPeopleR = do
FormSuccess pn -> do FormSuccess pn -> do
runDB $ do runDB $ do
let sharer = Sharer let sharer = Sharer
{ sharerIdent = uLogin pn { sharerIdent = text2shr $ uLogin pn
, sharerName = Nothing , sharerName = uName pn
} }
sid <- insert sharer sid <- insert sharer
let person = Person let person = Person
@ -68,15 +68,10 @@ postPeopleR = do
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing" setMessage "Field(s) missing"
defaultLayout $(widgetFile "person-new") defaultLayout $(widgetFile "person-new")
FormFailure l -> do FormFailure _l -> do
setMessage $ toHtml $ intercalate "; " l setMessage "User registration failed, see errors below"
defaultLayout $(widgetFile "person-new") defaultLayout $(widgetFile "person-new")
else notFound else notFound
--TODO NEXT:
-- * Maybe make the form return Form Person and just insert defaults (using
-- 'pure') for the remaining Person fields? Then, maybe the same form can
-- be used to generate the RESTful JSON API query that adds a Person with
-- their entire details. Dunno if it matters, just could be good/nice/cool.
getPersonNewR :: Handler Html getPersonNewR :: Handler Html
getPersonNewR = do getPersonNewR = do
@ -96,7 +91,7 @@ getPersonNewR = do
getPersonR :: ShrIdent -> Handler Html getPersonR :: ShrIdent -> Handler Html
getPersonR ident = do getPersonR ident = do
person <- runDB $ do person <- runDB $ do
Entity sid _s <- getBy404 $ UniqueSharerIdent ident Entity sid _s <- getBy404 $ UniqueSharer ident
Entity _pid p <- getBy404 $ UniquePersonIdent sid Entity _pid p <- getBy404 $ UniquePersonIdent sid
return p return p
defaultLayout $(widgetFile "person") defaultLayout $(widgetFile "person")

View file

@ -39,6 +39,7 @@ import qualified Database.Esqueleto as E
import Vervis.Form.Project import Vervis.Form.Project
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Repo import Vervis.Model.Repo
import Vervis.Settings import Vervis.Settings
@ -79,7 +80,7 @@ getProjectNewR ident = do
getProjectR :: ShrIdent -> PrjIdent -> Handler Html getProjectR :: ShrIdent -> PrjIdent -> Handler Html
getProjectR shar proj = do getProjectR shar proj = do
(project, repos) <- runDB $ do (project, repos) <- runDB $ do
Entity sid _s <- getBy404 $ UniqueSharerIdent shar Entity sid _s <- getBy404 $ UniqueSharer shar
Entity pid p <- getBy404 $ UniqueProject proj sid Entity pid p <- getBy404 $ UniqueProject proj sid
rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent] rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent]
return (p, rs) return (p, rs)

View file

@ -29,6 +29,8 @@ where
import Prelude import Prelude
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (logWarn)
import Data.Git.Graph import Data.Git.Graph
import Data.Git.Harder import Data.Git.Harder
import Data.Git.Named (RefName (..)) import Data.Git.Named (RefName (..))
@ -40,15 +42,24 @@ import Data.Git.Types (Blob (..), Commit (..), Person (..), entName)
import Data.Graph.Inductive.Graph (noNodes) import Data.Graph.Inductive.Graph (noNodes)
import Data.Graph.Inductive.Query.Topsort import Data.Graph.Inductive.Query.Topsort
import Data.List (inits) import Data.List (inits)
import Data.Text (unpack) import Data.Text (Text, unpack)
import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Database.Esqueleto hiding (delete, (%)) import Database.Esqueleto hiding (delete, (%))
import Database.Persist (delete)
import Data.Hourglass (timeConvert) import Data.Hourglass (timeConvert)
import Formatting (sformat, stext, (%)) import Formatting (sformat, stext, (%))
import System.Directory import System.Directory
import System.Hourglass (dateCurrent) import System.Hourglass (dateCurrent)
import Text.Blaze.Html (Html)
import Yesod.Auth (requireAuth)
import Yesod.Core (defaultLayout, setMessage)
import Yesod.Core.Handler (lookupPostParam, redirect, notFound)
import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, getBy404)
import qualified Data.CaseInsensitive as CI (foldedCase)
import qualified Data.DList as D import qualified Data.DList as D
import qualified Data.Set as S (member) import qualified Data.Set as S (member)
import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With) import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
@ -63,6 +74,7 @@ import Vervis.Handler.Repo.Git
import Vervis.Path import Vervis.Path
import Vervis.MediaType (chooseMediaType) import Vervis.MediaType (chooseMediaType)
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Repo import Vervis.Model.Repo
import Vervis.Paginate import Vervis.Paginate
import Vervis.Readme import Vervis.Readme
@ -76,6 +88,7 @@ import qualified Darcs.Local.Repository as D (createRepo)
import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString)
import qualified Data.Git.Local as G (createRepo) import qualified Data.Git.Local as G (createRepo)
import qualified Vervis.Darcs as D (readSourceView, readChangesView) import qualified Vervis.Darcs as D (readSourceView, readChangesView)
import qualified Vervis.Formatting as F
import qualified Vervis.Git as G (readSourceView, readChangesView, listRefs) import qualified Vervis.Git as G (readSourceView, readChangesView, listRefs)
getReposR :: ShrIdent -> Handler Html getReposR :: ShrIdent -> Handler Html
@ -86,7 +99,7 @@ getReposR user = do
sharer ^. SharerId ==. repo ^. RepoSharer sharer ^. SharerId ==. repo ^. RepoSharer
orderBy [asc $ repo ^. RepoIdent] orderBy [asc $ repo ^. RepoIdent]
return $ repo ^. RepoIdent return $ repo ^. RepoIdent
defaultLayout $(widgetFile "repo/repos") defaultLayout $(widgetFile "repo/list")
postReposR :: ShrIdent -> Handler Html postReposR :: ShrIdent -> Handler Html
postReposR user = do postReposR user = do
@ -98,7 +111,8 @@ postReposR user = do
parent <- askSharerDir user parent <- askSharerDir user
liftIO $ do liftIO $ do
createDirectoryIfMissing True parent createDirectoryIfMissing True parent
let repoName = unpack $ repoIdent repo let repoName =
unpack $ CI.foldedCase $ unRpIdent $ repoIdent repo
case repoVcs repo of case repoVcs repo of
VCSDarcs -> D.createRepo parent repoName VCSDarcs -> D.createRepo parent repoName
VCSGit -> G.createRepo parent repoName VCSGit -> G.createRepo parent repoName
@ -107,21 +121,21 @@ postReposR user = do
redirect $ ReposR user redirect $ ReposR user
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing" setMessage "Field(s) missing"
defaultLayout $(widgetFile "repo/repo-new") defaultLayout $(widgetFile "repo/new")
FormFailure _l -> do FormFailure _l -> do
setMessage "Repo creation failed, see errors below" setMessage "Repo creation failed, see errors below"
defaultLayout $(widgetFile "repo/repo-new") defaultLayout $(widgetFile "repo/new")
getRepoNewR :: ShrIdent -> Handler Html getRepoNewR :: ShrIdent -> Handler Html
getRepoNewR user = do getRepoNewR user = do
Entity _pid person <- requireAuth Entity _pid person <- requireAuth
let sid = personIdent person let sid = personIdent person
((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing ((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
defaultLayout $(widgetFile "repo/repo-new") defaultLayout $(widgetFile "repo/new")
selectRepo :: ShrIdent -> RpIdent -> AppDB Repo selectRepo :: ShrIdent -> RpIdent -> AppDB Repo
selectRepo shar repo = do selectRepo shar repo = do
Entity sid _s <- getBy404 $ UniqueSharerIdent shar Entity sid _s <- getBy404 $ UniqueSharer shar
Entity _rid r <- getBy404 $ UniqueRepo repo sid Entity _rid r <- getBy404 $ UniqueRepo repo sid
return r return r
@ -137,7 +151,7 @@ getRepoR shar repo = do
deleteRepoR :: ShrIdent -> RpIdent -> Handler Html deleteRepoR :: ShrIdent -> RpIdent -> Handler Html
deleteRepoR shar repo = do deleteRepoR shar repo = do
runDB $ do runDB $ do
Entity sid _s <- getBy404 $ UniqueSharerIdent shar Entity sid _s <- getBy404 $ UniqueSharer shar
Entity rid _r <- getBy404 $ UniqueRepo repo sid Entity rid _r <- getBy404 $ UniqueRepo repo sid
delete rid delete rid
path <- askRepoDir shar repo path <- askRepoDir shar repo
@ -146,7 +160,7 @@ deleteRepoR shar repo = do
then liftIO $ removeDirectoryRecursive path then liftIO $ removeDirectoryRecursive path
else else
$logWarn $ sformat $logWarn $ sformat
( "Deleted repo " % stext % "/" % stext ( "Deleted repo " % F.sharer % "/" % F.repo
% " from DB but repo dir doesn't exist" % " from DB but repo dir doesn't exist"
) )
shar repo shar repo

View file

@ -23,13 +23,19 @@ where
import Prelude import Prelude
import Control.Monad.IO.Class (liftIO)
import Data.List (inits) import Data.List (inits)
import Data.Text (unpack) import Data.Maybe (fromMaybe)
import Data.Text (Text, unpack)
import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Database.Esqueleto import Database.Esqueleto
import System.FilePath (joinPath) import System.FilePath ((</>), joinPath)
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import Text.Blaze.Html (Html)
import Yesod.Core (defaultLayout, setTitle)
import Yesod.Core.Content (TypedContent, typeOctet)
import Yesod.Core.Handler (sendFile, notFound)
import qualified Data.DList as D import qualified Data.DList as D
import qualified Data.Set as S (member) import qualified Data.Set as S (member)
@ -43,6 +49,7 @@ import Vervis.Foundation
import Vervis.Path import Vervis.Path
import Vervis.MediaType (chooseMediaType) import Vervis.MediaType (chooseMediaType)
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Repo import Vervis.Model.Repo
import Vervis.Paginate import Vervis.Paginate
import Vervis.Readme import Vervis.Readme
@ -65,10 +72,7 @@ getDarcsRepoSource repository user repo dir = do
Just sv -> do Just sv -> do
let parent = if null dir then [] else init dir let parent = if null dir then [] else init dir
dirs = zip parent (tail $ inits parent) dirs = zip parent (tail $ inits parent)
defaultLayout $ do defaultLayout $(widgetFile "repo/source-darcs")
setTitle $ toHtml $ intercalate " > "
["Vervis", "People", user, "Repos", repo]
$(widgetFile "repo/source-darcs")
getDarcsRepoHeadChanges :: ShrIdent -> RpIdent -> Handler Html getDarcsRepoHeadChanges :: ShrIdent -> RpIdent -> Handler Html
getDarcsRepoHeadChanges shar repo = do getDarcsRepoHeadChanges shar repo = do

View file

@ -22,6 +22,7 @@ where
import Prelude import Prelude
import Control.Monad.IO.Class (liftIO)
import Data.Git.Graph import Data.Git.Graph
import Data.Git.Harder import Data.Git.Harder
import Data.Git.Named (RefName (..)) import Data.Git.Named (RefName (..))
@ -33,13 +34,17 @@ import Data.Git.Types (Blob (..), Commit (..), Person (..), entName)
import Data.Graph.Inductive.Graph (noNodes) import Data.Graph.Inductive.Graph (noNodes)
import Data.Graph.Inductive.Query.Topsort import Data.Graph.Inductive.Query.Topsort
import Data.List (inits) import Data.List (inits)
import Data.Text (unpack) import Data.Maybe (fromMaybe)
import Data.Text (Text, unpack)
import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Database.Esqueleto import Database.Esqueleto
import Data.Hourglass (timeConvert) import Data.Hourglass (timeConvert)
import System.Directory (createDirectoryIfMissing) import System.Directory (createDirectoryIfMissing)
import System.Hourglass (dateCurrent) import System.Hourglass (dateCurrent)
import Text.Blaze.Html (Html)
import Yesod.Core (defaultLayout)
import Yesod.Core.Handler (notFound)
import qualified Data.DList as D import qualified Data.DList as D
import qualified Data.Set as S (member) import qualified Data.Set as S (member)
@ -53,6 +58,7 @@ import Vervis.Foundation
import Vervis.Path import Vervis.Path
import Vervis.MediaType (chooseMediaType) import Vervis.MediaType (chooseMediaType)
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Repo import Vervis.Model.Repo
import Vervis.Paginate import Vervis.Paginate
import Vervis.Readme import Vervis.Readme

View file

@ -58,10 +58,12 @@ import Vervis.Foundation
import Vervis.Handler.Discussion import Vervis.Handler.Discussion
import Vervis.MediaType (MediaType (Markdown)) import Vervis.MediaType (MediaType (Markdown))
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident
import Vervis.Render (renderSourceT) import Vervis.Render (renderSourceT)
import Vervis.Settings (widgetFile) import Vervis.Settings (widgetFile)
import Vervis.TicketFilter (filterTickets) import Vervis.TicketFilter (filterTickets)
import Vervis.Widget.Discussion (discussionW) import Vervis.Widget.Discussion (discussionW)
import Vervis.Widget.Person (sharerLinkW)
getTicketsR :: ShrIdent -> PrjIdent -> Handler Html getTicketsR :: ShrIdent -> PrjIdent -> Handler Html
getTicketsR shar proj = do getTicketsR shar proj = do
@ -81,8 +83,7 @@ getTicketsR shar proj = do
orderBy [asc $ ticket ^. TicketNumber] orderBy [asc $ ticket ^. TicketNumber]
return return
( ticket ^. TicketNumber ( ticket ^. TicketNumber
, sharer ^. SharerIdent , sharer
, sharer ^. SharerName
, ticket ^. TicketTitle , ticket ^. TicketTitle
, ticket ^. TicketDone , ticket ^. TicketDone
) )
@ -97,7 +98,7 @@ postTicketsR shar proj = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
tnum <- runDB $ do tnum <- runDB $ do
Entity pid project <- do Entity pid project <- do
Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar Entity sid _sharer <- getBy404 $ UniqueSharer shar
getBy404 $ UniqueProject proj sid getBy404 $ UniqueProject proj sid
update pid [ProjectNextTicket +=. 1] update pid [ProjectNextTicket +=. 1]
let discussion = Discussion let discussion = Discussion
@ -135,7 +136,7 @@ getTicketNewR shar proj = do
getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketR shar proj num = do getTicketR shar proj num = do
(author, closer, ticket) <- runDB $ do (author, closer, ticket) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar Entity sid _sharer <- getBy404 $ UniqueSharer shar
Entity pid _project <- getBy404 $ UniqueProject proj sid Entity pid _project <- getBy404 $ UniqueProject proj sid
Entity _tid ticket <- getBy404 $ UniqueTicket pid num Entity _tid ticket <- getBy404 $ UniqueTicket pid num
person <- get404 $ ticketCreator ticket person <- get404 $ ticketCreator ticket
@ -158,7 +159,7 @@ getTicketR shar proj num = do
putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
putTicketR shar proj num = do putTicketR shar proj num = do
Entity tid ticket <- runDB $ do Entity tid ticket <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar Entity sid _sharer <- getBy404 $ UniqueSharer shar
Entity pid _project <- getBy404 $ UniqueProject proj sid Entity pid _project <- getBy404 $ UniqueProject proj sid
getBy404 $ UniqueTicket pid num getBy404 $ UniqueTicket pid num
user <- requireAuthId user <- requireAuthId
@ -192,7 +193,7 @@ postTicketR shar proj num = do
getTicketEditR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketEditR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketEditR shar proj num = do getTicketEditR shar proj num = do
Entity _tid ticket <- runDB $ do Entity _tid ticket <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar Entity sid _sharer <- getBy404 $ UniqueSharer shar
Entity pid _project <- getBy404 $ UniqueProject proj sid Entity pid _project <- getBy404 $ UniqueProject proj sid
getBy404 $ UniqueTicket pid num getBy404 $ UniqueTicket pid num
user <- requireAuthId user <- requireAuthId
@ -201,7 +202,7 @@ getTicketEditR shar proj num = do
selectDiscussionId :: ShrIdent -> PrjIdent -> Int -> AppDB DiscussionId selectDiscussionId :: ShrIdent -> PrjIdent -> Int -> AppDB DiscussionId
selectDiscussionId shar proj tnum = do selectDiscussionId shar proj tnum = do
Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar Entity sid _sharer <- getBy404 $ UniqueSharer shar
Entity pid _project <- getBy404 $ UniqueProject proj sid Entity pid _project <- getBy404 $ UniqueProject proj sid
Entity _tid ticket <- getBy404 $ UniqueTicket pid tnum Entity _tid ticket <- getBy404 $ UniqueTicket pid tnum
return $ ticketDiscuss ticket return $ ticketDiscuss ticket

View file

@ -17,9 +17,17 @@
-- and handlers. -- and handlers.
module Vervis.Model.Ident module Vervis.Model.Ident
( ShrIdent (..) ( ShrIdent (..)
, shr2text
, text2shr
, KyIdent (..) , KyIdent (..)
, ky2text
, text2ky
, PrjIdent (..) , PrjIdent (..)
, prj2text
, text2prj
, RpIdent (..) , RpIdent (..)
, rp2text
, text2rp
) )
where where
@ -32,19 +40,49 @@ import Database.Persist.Class (PersistField)
import Database.Persist.Sql (PersistFieldSql) import Database.Persist.Sql (PersistFieldSql)
import Web.PathPieces (PathPiece) import Web.PathPieces (PathPiece)
import qualified Data.CaseInsensitive as CI
import Database.Esqueleto.Local () import Database.Esqueleto.Local ()
import Database.Persist.Class.Local () import Database.Persist.Class.Local ()
import Database.Persist.Sql.Local () import Database.Persist.Sql.Local ()
import Web.PathPieces.Local () import Web.PathPieces.Local ()
newtype ShrIdent = ShrIdent { unSharIdent :: CI Text } newtype ShrIdent = ShrIdent { unShrIdent :: CI Text }
deriving (PersistField, PersistFieldSql, SqlString, PathPiece) deriving
(Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
shr2text :: ShrIdent -> Text
shr2text = CI.original . unShrIdent
text2shr :: Text -> ShrIdent
text2shr = ShrIdent . CI.mk
newtype KyIdent = KyIdent { unKyIdent :: CI Text } newtype KyIdent = KyIdent { unKyIdent :: CI Text }
deriving (PersistField, PersistFieldSql, SqlString, PathPiece) deriving
(Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
ky2text :: KyIdent -> Text
ky2text = CI.original . unKyIdent
text2ky :: Text -> KyIdent
text2ky = KyIdent . CI.mk
newtype PrjIdent = PrjIdent { unPrjIdent :: CI Text } newtype PrjIdent = PrjIdent { unPrjIdent :: CI Text }
deriving (PersistField, PersistFieldSql, SqlString, PathPiece) deriving
(Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
prj2text :: PrjIdent -> Text
prj2text = CI.original . unPrjIdent
text2prj :: Text -> PrjIdent
text2prj = PrjIdent . CI.mk
newtype RpIdent = RpIdent { unRpIdent :: CI Text } newtype RpIdent = RpIdent { unRpIdent :: CI Text }
deriving (PersistField, PersistFieldSql, SqlString, PathPiece) deriving
(Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece)
rp2text :: RpIdent -> Text
rp2text = CI.original . unRpIdent
text2rp :: Text -> RpIdent
text2rp = RpIdent . CI.mk

View file

@ -42,6 +42,7 @@ import Vervis.MediaType (MediaType (Markdown))
import Vervis.Model import Vervis.Model
import Vervis.Render (renderSourceT) import Vervis.Render (renderSourceT)
import Vervis.Settings (widgetFile) import Vervis.Settings (widgetFile)
import Vervis.Widget.Person (sharerLinkW)
messageW :: UTCTime -> Sharer -> Message -> (Int -> Route App) -> Widget messageW :: UTCTime -> Sharer -> Message -> (Int -> Route App) -> Widget
messageW now shr msg reply = messageW now shr msg reply =

View file

@ -0,0 +1,30 @@
{- 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.Widget.Person
( sharerLinkW
)
where
import Prelude
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident (shr2text)
import Vervis.Settings (widgetFile)
sharerLinkW :: Sharer -> Widget
sharerLinkW sharer = $(widgetFile "sharer-link")

View file

@ -28,9 +28,10 @@ import qualified Data.Text as T (take)
import Vervis.Changes import Vervis.Changes
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model.Ident
import Vervis.Settings (widgetFile) import Vervis.Settings (widgetFile)
refSelectW :: Text -> Text -> Set Text -> Set Text -> Widget refSelectW :: ShrIdent -> RpIdent -> Set Text -> Set Text -> Widget
refSelectW shar repo branches tags = $(widgetFile "repo/widget/ref-select") refSelectW shar repo branches tags = $(widgetFile "repo/widget/ref-select")
changesW :: Foldable f => f LogEntry -> Widget changesW :: Foldable f => f LogEntry -> Widget

View file

@ -12,9 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div> ^{sharerLinkW shr}
<a href=@{PersonR $ sharerIdent shr}>
#{fromMaybe (sharerIdent shr) $ sharerName shr}
<div> <div>
#{showTime $ messageCreated msg} #{showTime $ messageCreated msg}
<div> <div>

View file

@ -32,14 +32,14 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
$forall (sharer, mproj, repo, vcs, ago) <- rows $forall (sharer, mproj, repo, vcs, ago) <- rows
<tr> <tr>
<td> <td>
<a href=@{PersonR sharer}>#{sharer} <a href=@{PersonR sharer}>#{shr2text sharer}
<td> <td>
$maybe proj <- mproj $maybe proj <- mproj
<a href=@{ProjectR sharer proj}>#{proj} <a href=@{ProjectR sharer proj}>#{prj2text proj}
$nothing $nothing
(none) (none)
<td> <td>
<a href=@{RepoR sharer repo}>#{repo} <a href=@{RepoR sharer repo}>#{rp2text repo}
<td> <td>
$case vcs $case vcs
$of VCSDarcs $of VCSDarcs

View file

@ -12,11 +12,11 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>These are the SSH keys for user #{user}. <p>These are your SSH keys.
<ul> <ul>
$forall key <- keys $forall key <- keys
<li> <li>
<a href=@{KeyR user key}>#{key} <a href=@{KeyR key}>#{ky2text key}
<li> <li>
<a href=@{KeyNewR user}>Add new… <a href=@{KeyNewR}>Add new…

View file

@ -14,6 +14,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
Enter the details and click "Submit" to add a new SSH key. Enter the details and click "Submit" to add a new SSH key.
<form method=POST action=@{KeysR user} enctype=#{enctype}> <form method=POST action=@{KeysR} enctype=#{enctype}>
^{widget} ^{widget}
<input type=submit> <input type=submit>

View file

@ -13,7 +13,7 @@ $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p> <p>
<form method=POST action=@{KeyR user tag}> <form method=POST action=@{KeyR tag}>
<input type=hidden name=_method value=DELETE> <input type=hidden name=_method value=DELETE>
<input type=submit value="Delete this key"> <input type=submit value="Delete this key">

View file

@ -18,4 +18,4 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<ul> <ul>
$forall Value ident <- people $forall Value ident <- people
<li> <li>
<a href=@{PersonR ident}>#{ident} <a href=@{PersonR ident}>#{shr2text ident}

View file

@ -22,11 +22,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<ul> <ul>
$forall project <- projects $forall project <- projects
<li> <li>
<a href=@{ProjectR ident project}>#{project} <a href=@{ProjectR ident project}>#{prj2text project}
<li> <li>
<a href=@{ProjectNewR ident}>Create new… <a href=@{ProjectNewR ident}>Create new…
<h2>SSH Keys <h2>SSH Keys
<p> <p>
See <a href=@{KeysR ident}>keys</a>. See <a href=@{KeysR}>keys</a>.

View file

@ -12,9 +12,9 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>These are projects shared by #{ident}. <p>These are projects shared by #{shr2text ident}.
<ul> <ul>
$forall E.Value project <- projects $forall E.Value project <- projects
<li> <li>
<a href=@{ProjectR ident project}>#{project} <a href=@{ProjectR ident project}>#{prj2text project}

View file

@ -12,7 +12,9 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>This is the project page for <b>#{proj}</b>, shared by <b>#{shar}</b>. <p>
This is the project page for <b>#{prj2text proj}</b>, shared by
<b>#{shr2text shar}</b>.
<ul> <ul>
<li> <li>
@ -35,7 +37,8 @@ $else
$forall Entity _ repository <- repos $forall Entity _ repository <- repos
<tr> <tr>
<td> <td>
<a href=@{RepoR shar $ repoIdent repository}>#{repoIdent repository} <a href=@{RepoR shar $ repoIdent repository}>
#{rp2text $ repoIdent repository}
<td> <td>
$case repoVcs repository $case repoVcs repository
$of VCSDarcs $of VCSDarcs

View file

@ -12,11 +12,11 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>These are the repositories shared by #{user}. <p>These are the repositories shared by #{shr2text user}.
<ul> <ul>
$forall Value repo <- repos $forall Value repo <- repos
<li> <li>
<a href=@{RepoR user repo}>#{repo} <a href=@{RepoR user repo}>#{rp2text repo}
<li> <li>
<a href=@{RepoNewR user}>Create new… <a href=@{RepoNewR user}>Create new…

View file

@ -0,0 +1,19 @@
$# 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/>.
<a href=@{PersonR $ sharerIdent sharer}>
$maybe name <- sharerName sharer
#{name}
$nothing
#{shr2text $ sharerIdent sharer}

View file

@ -26,13 +26,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th>Title <th>Title
<th>Done <th>Done
$forall $forall
(Value number, Value authorIdent, Value mAuthorName, Value title, Value done) (Value number, Entity _ author, Value title, Value done)
<- rows <- rows
<tr> <tr>
<td> <td>
<a href=@{TicketR shar proj number}>#{number} <a href=@{TicketR shar proj number}>#{number}
<td> <td>
<a href=@{PersonR authorIdent}>#{fromMaybe authorIdent mAuthorName} ^{sharerLinkW author}
<td> <td>
<a href=@{TicketR shar proj number}>#{title} <a href=@{TicketR shar proj number}>#{title}
<td> <td>

View file

@ -21,13 +21,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p> <p>
Created on #{formatTime defaultTimeLocale "%F" $ ticketCreated ticket} by Created on #{formatTime defaultTimeLocale "%F" $ ticketCreated ticket} by
#{fromMaybe (sharerIdent author) $ sharerName author} ^{sharerLinkW author}
<p> <p>
Status: Status:
$if ticketDone ticket $if ticketDone ticket
Closed on #{formatTime defaultTimeLocale "%F" $ ticketClosed ticket} by Closed on #{formatTime defaultTimeLocale "%F" $ ticketClosed ticket} by
#{fromMaybe (sharerIdent closer) $ sharerName closer} ^{sharerLinkW closer}
$else $else
Open Open

View file

@ -47,6 +47,7 @@ library
Data.Binary.Local Data.Binary.Local
Data.ByteString.Char8.Local Data.ByteString.Char8.Local
Data.ByteString.Local Data.ByteString.Local
Data.CaseInsensitive.Local
Data.Char.Local Data.Char.Local
Data.Either.Local Data.Either.Local
Data.EventTime.Local Data.EventTime.Local
@ -64,7 +65,9 @@ library
Database.Persist.Class.Local Database.Persist.Class.Local
Database.Persist.Sql.Local Database.Persist.Sql.Local
Development.DarcsRev Development.DarcsRev
Formatting.CaseInsensitive
Network.SSH.Local Network.SSH.Local
Text.Blaze.Local
Text.FilePath.Local Text.FilePath.Local
Text.Jasmine.Local Text.Jasmine.Local
Web.PathPieces.Local Web.PathPieces.Local
@ -86,6 +89,7 @@ library
Vervis.Form.Project Vervis.Form.Project
Vervis.Form.Repo Vervis.Form.Repo
Vervis.Form.Ticket Vervis.Form.Ticket
Vervis.Formatting
Vervis.Foundation Vervis.Foundation
Vervis.Git Vervis.Git
Vervis.GitOld Vervis.GitOld
@ -118,6 +122,7 @@ library
Vervis.TicketFilter Vervis.TicketFilter
Vervis.Widget Vervis.Widget
Vervis.Widget.Discussion Vervis.Widget.Discussion
Vervis.Widget.Person
Vervis.Widget.Repo Vervis.Widget.Repo
-- other-modules: -- other-modules:
default-extensions: TemplateHaskell default-extensions: TemplateHaskell