sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 17:14:52 +09:00
Code Issues Activity

Start big route change, doesn't build yet

Browse source 
I decided to add some safety to routes:

- Use dedicated newtypes
- Use CI for the CI-unique DB fields

Since such a change requires so many changes in many source files, this
is also a chance to do other such breaking changes. I'm recording the
change gradually. It won't build until I finish, so for now don't waste
time trying to build the app.
This commit is contained in:
fr33domlover 2016-05-23 12:24:14 +00:00
parent 3a65568d8f
commit 49807ed27f
20 changed files with 277 additions and 169 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
config/models
View file

@ -13,8 +13,8 @@
-- <http://creativecommons.org/publicdomain/zero/1.0/>. -- <http://creativecommons.org/publicdomain/zero/1.0/>.
Sharer Sharer
ident Text --CI ident TextCI
name Text Maybe name Text Maybe
UniqueSharerIdent ident UniqueSharerIdent ident
@ -41,7 +41,7 @@ Group
UniqueGroupIdent ident UniqueGroupIdent ident
Project Project
ident Text --CI ident TextCI
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 Text --CI ident TextCI
sharer SharerId sharer SharerId
vcs VersionControlSystem default='VCSGit' vcs VersionControlSystem default='VCSGit'
project ProjectId Maybe project ProjectId Maybe

56
config/routes
View file

@ -32,38 +32,38 @@
/ HomeR GET / HomeR GET
/u PeopleR GET POST /s PeopleR GET POST
/u/!new PersonNewR GET /s/!new PersonNewR GET
/u/#Text PersonR GET /s/#ShrIdent PersonR GET
/u/#Text/k KeysR GET POST /k KeysR GET POST
/u/#Text/k/!new KeyNewR GET /k/!new KeyNewR GET
/u/#Text/k/#Text KeyR GET DELETE POST /k/#KyIdent KeyR GET DELETE POST
/u/#Text/r ReposR GET POST /s/#ShrIdent/r ReposR GET POST
/u/#Text/r/!new RepoNewR GET /s/#ShrIdent/r/!new RepoNewR GET
/u/#Text/r/#Text RepoR GET DELETE POST /s/#ShrIdent/r/#RpIdent RepoR GET DELETE POST
/u/#Text/r/#Text/s/+Texts RepoSourceR GET /s/#ShrIdent/r/#RpIdent/s/+Texts RepoSourceR GET
/u/#Text/r/#Text/c RepoHeadChangesR GET /s/#ShrIdent/r/#RpIdent/c RepoHeadChangesR GET
/u/#Text/r/#Text/c/#Text RepoChangesR GET /s/#ShrIdent/r/#RpIdent/c/#Text RepoChangesR GET
/u/#Text/r/#Text/_darcs/+Texts DarcsDownloadR GET /s/#ShrIdent/r/#RpIdent/_darcs/+Texts DarcsDownloadR GET
/u/#Text/r/#Text/git/info/refs GitRefDiscoverR GET /s/#ShrIdent/r/#RpIdent/git/info/refs GitRefDiscoverR GET
--/u/#Text/r/#Text/git/git-upload-pack GitUploadRequestR POST --/s/#ShrIdent/r/#RpIdent/git/git-upload-pack GitUploadRequestR POST
/u/#Text/p ProjectsR GET POST /s/#ShrIdent/p ProjectsR GET POST
/u/#Text/p/!new ProjectNewR GET /s/#ShrIdent/p/!new ProjectNewR GET
/u/#Text/p/#Text ProjectR GET /s/#ShrIdent/p/#PrjIdent ProjectR GET
/u/#Text/p/#Text/t TicketsR GET POST /s/#ShrIdent/p/#PrjIdent/t TicketsR GET POST
/u/#Text/p/#Text/t/!new TicketNewR GET /s/#ShrIdent/p/#PrjIdent/t/!new TicketNewR GET
/u/#Text/p/#Text/t/#Int TicketR GET PUT DELETE POST /s/#ShrIdent/p/#PrjIdent/t/#Int TicketR GET PUT DELETE POST
/u/#Text/p/#Text/t/#Int/edit TicketEditR GET /s/#ShrIdent/p/#PrjIdent/t/#Int/edit TicketEditR GET
/u/#Text/p/#Text/t/#Int/d TicketDiscussionR GET POST /s/#ShrIdent/p/#PrjIdent/t/#Int/d TicketDiscussionR GET POST
/u/#Text/p/#Text/t/#Int/d/#Int TicketMessageR GET POST /s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Int TicketMessageR GET POST
/u/#Text/p/#Text/t/#Int/d/!reply TicketTopReplyR GET /s/#ShrIdent/p/#PrjIdent/t/#Int/d/!reply TicketTopReplyR GET
/u/#Text/p/#Text/t/#Int/d/#Int/reply TicketReplyR GET /s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Int/reply TicketReplyR GET
-- /u/#Text/p/#Text/w WikiR GET -- /s/#ShrIdent/p/#PrjIdent/w WikiR GET
-- /u/#Text/p/#Text/w/+Texts WikiPageR GET -- /s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET

14
src/Vervis/Handler/Util.hs → src/Database/Esqueleto/Local.hs
View file

@ -13,12 +13,16 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>. - <http://creativecommons.org/publicdomain/zero/1.0/>.
-} -}
module Vervis.Handler.Util module Database.Esqueleto.Local
( loggedIn (
) )
where where
import Vervis.Import hiding (loggedIn) import Prelude
loggedIn :: Handler Bool import Data.CaseInsensitive (CI)
loggedIn = isJust <$> maybeAuthId import Database.Esqueleto
import qualified Data.CaseInsensitive as CI
instance SqlString s => SqlString (CI s)

5
src/Database/Persist/Class/Local.hs
View file

@ -15,14 +15,13 @@
-- | 'PersistField' instance for 'CI', for easy case-insensitive DB fields. -- | 'PersistField' instance for 'CI', for easy case-insensitive DB fields.
module Database.Persist.Class.Local module Database.Persist.Class.Local
( TextCI (
) )
where where
import Prelude import Prelude
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Data.Text (Text)
import Database.Persist.Class import Database.Persist.Class
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
@ -30,5 +29,3 @@ import qualified Data.CaseInsensitive as CI
instance (PersistField s, CI.FoldCase s) => PersistField (CI s) where instance (PersistField s, CI.FoldCase s) => PersistField (CI s) where
toPersistValue = toPersistValue . CI.original toPersistValue = toPersistValue . CI.original
fromPersistValue = fmap CI.mk . fromPersistValue fromPersistValue = fmap CI.mk . fromPersistValue
type TextCI = CI Text

31
src/Database/Persist/Sql/Local.hs Normal file
View file

@ -0,0 +1,31 @@
{- 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 Database.Persist.Sql.Local
(
)
where
import Prelude
import Data.CaseInsensitive (CI)
import Database.Persist.Sql
import qualified Data.CaseInsensitive as CI
import Database.Persist.Class.Local ()
instance (PersistFieldSql s, CI.FoldCase s) => PersistFieldSql (CI s) where
sqlType = sqlType . fmap CI.original

30
src/Text/Blaze/Local.hs Normal file
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 Text.Blaze.Local
(
)
where
import Prelude
import Data.CaseInsensitive (CI)
import Text.Blaze
import qualified Data.CaseInsensitive as CI
instance ToMarkup s => ToMarkup (CI s) where
toMarkup = toMarkup . CI.original
preEscapedToMarkup = preEscapedToMarkup . CI.original

1
src/Vervis/Foundation.hs
View file

@ -32,6 +32,7 @@ import Data.Text as T (pack, intercalate)
import Text.Jasmine.Local (discardm) import Text.Jasmine.Local (discardm)
import Vervis.Import.NoFoundation hiding (last) import Vervis.Import.NoFoundation hiding (last)
import Vervis.Model.Ident
import Vervis.Widget (breadcrumbsW, revisionW) import Vervis.Widget (breadcrumbsW, revisionW)
-- | The foundation datatype for your application. This can be a good place to -- | The foundation datatype for your application. This can be a good place to

4
src/Vervis/Handler/Git.hs
View file

@ -39,8 +39,8 @@ import Vervis.Content
import Vervis.Foundation (Handler) import Vervis.Foundation (Handler)
import Vervis.Path (askRepoDir) import Vervis.Path (askRepoDir)
getGitRefDiscoverR :: Text -> Text -> Handler GitRefDiscovery getGitRefDiscoverR :: ShrIdent -> RpIdent -> Handler GitRefDiscovery
getGitRefDiscoverR sharer repo = do getGitRefDiscoverR shar repo = do
path <- askRepoDir sharer repo path <- askRepoDir sharer repo
let pathG = fromString path let pathG = fromString path
seemsThere <- liftIO $ isRepo pathG seemsThere <- liftIO $ isRepo pathG

69
src/Vervis/Handler/Key.hs
View file

@ -44,74 +44,55 @@ import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Settings import Vervis.Settings
getKeysR :: Text -> Handler Html getKeysR :: Handler Html
getKeysR user = do getKeysR = do
pid <- requireAuthId
keys <- runDB $ do keys <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharerIdent user
Entity pid _person <- getBy404 $ UniquePersonIdent sid
ks <- selectList [SshKeyPerson ==. pid] [Asc SshKeyName] ks <- selectList [SshKeyPerson ==. pid] [Asc SshKeyName]
return $ map (\ (Entity _ k) -> sshKeyName k) ks return $ map (\ (Entity _ k) -> sshKeyName k) ks
defaultLayout $ do defaultLayout $(widgetFile "key/list")
setTitle $ toHtml $
intercalate " > " ["Vervis", "People", user, "Keys"]
$(widgetFile "key/keys")
postKeysR :: Text -> Handler Html postKeysR :: Handler Html
postKeysR user = do postKeysR = do
pid <- runDB $ do pid <- requireAuthId
Entity s _sharer <- getBy404 $ UniqueSharerIdent user
Entity p _person <- getBy404 $ UniquePersonIdent s
return p
((result, widget), enctype) <- runFormPost $ newKeyForm pid ((result, widget), enctype) <- runFormPost $ newKeyForm pid
case result of case result of
FormSuccess key -> do FormSuccess key -> do
runDB $ insert_ key runDB $ insert_ key
setMessage "Key added." setMessage "Key added."
redirect $ KeysR user redirect KeysR
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing" setMessage "Field(s) missing"
defaultLayout $(widgetFile "key/key-new") defaultLayout $(widgetFile "key/new")
FormFailure _l -> do FormFailure _l -> do
setMessage "Invalid input, see below" setMessage "Invalid input, see below"
defaultLayout $(widgetFile "key/key-new") defaultLayout $(widgetFile "key/new")
getKeyNewR :: Text -> Handler Html getKeyNewR :: Handler Html
getKeyNewR user = do getKeyNewR = do
pid <- runDB $ do pid <- requireAuthId
Entity s _sharer <- getBy404 $ UniqueSharerIdent user
Entity p _person <- getBy404 $ UniquePersonIdent s
return p
((_result, widget), enctype) <- runFormPost $ newKeyForm pid ((_result, widget), enctype) <- runFormPost $ newKeyForm pid
defaultLayout $ do defaultLayout $(widgetFile "key/new")
setTitle $ toHtml $ "Vervis > People > " <> user <> " > New Key"
$(widgetFile "key/key-new")
getKeyR :: Text -> Text -> Handler Html getKeyR :: KyIdent -> Handler Html
getKeyR user tag = do getKeyR tag = do
Entity _kid key <- runDB $ do pid <- requireAuthId
Entity sid _sharer <- getBy404 $ UniqueSharerIdent user Entity _kid key <- runDB $ getBy404 $ UniqueSshKey pid tag
Entity pid _person <- getBy404 $ UniquePersonIdent sid
getBy404 $ UniqueSshKey pid tag
let toText = decodeUtf8With lenientDecode let toText = decodeUtf8With lenientDecode
content = toText $ encode $ sshKeyContent key content = toText $ encode $ sshKeyContent key
defaultLayout $ do defaultLayout $(widgetFile "key/one")
setTitle $ toHtml $
intercalate " > " ["Vervis", "People", user, "Keys", tag]
$(widgetFile "key/key")
deleteKeyR :: Text -> Text -> Handler Html deleteKeyR :: KyIdent -> Handler Html
deleteKeyR user tag = do deleteKeyR tag = do
runDB $ do runDB $ do
Entity sid _s <- getBy404 $ UniqueSharerIdent user
Entity pid _p <- getBy404 $ UniquePersonIdent sid
Entity kid _k <- getBy404 $ UniqueSshKey pid tag Entity kid _k <- getBy404 $ UniqueSshKey pid tag
delete kid delete kid
setMessage "Key deleted." setMessage "Key deleted."
redirect $ KeysR user redirect KeysR
postKeyR :: Text -> Text -> Handler Html postKeyR :: KyIdent -> Handler Html
postKeyR user tag = do postKeyR tag = do
mmethod <- lookupPostParam "_method" mmethod <- lookupPostParam "_method"
case mmethod of case mmethod of
Just "DELETE" -> deleteKeyR user tag Just "DELETE" -> deleteKeyR tag
_ -> notFound _ -> notFound

6
src/Vervis/Handler/Person.hs
View file

@ -93,12 +93,10 @@ getPersonNewR = do
$(widgetFile "person-new") $(widgetFile "person-new")
else notFound else notFound
getPersonR :: Text -> 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 $ UniqueSharerIdent ident
Entity _pid p <- getBy404 $ UniquePersonIdent sid Entity _pid p <- getBy404 $ UniquePersonIdent sid
return p return p
defaultLayout $ do defaultLayout $(widgetFile "person")
setTitle $ toHtml $ "Vervis > People > " <> ident
$(widgetFile "person")

8
src/Vervis/Handler/Project.hs
View file

@ -42,7 +42,7 @@ import Vervis.Model
import Vervis.Model.Repo import Vervis.Model.Repo
import Vervis.Settings import Vervis.Settings
getProjectsR :: Text -> Handler Html getProjectsR :: ShrIdent -> Handler Html
getProjectsR ident = do getProjectsR ident = do
projects <- runDB $ E.select $ E.from $ \ (sharer, project) -> do projects <- runDB $ E.select $ E.from $ \ (sharer, project) -> do
E.where_ $ E.where_ $
@ -52,7 +52,7 @@ getProjectsR ident = do
return $ project E.^. ProjectIdent return $ project E.^. ProjectIdent
defaultLayout $(widgetFile "project/list") defaultLayout $(widgetFile "project/list")
postProjectsR :: Text -> Handler Html postProjectsR :: ShrIdent -> Handler Html
postProjectsR ident = do postProjectsR ident = do
Entity _pid person <- requireAuth Entity _pid person <- requireAuth
let sid = personIdent person let sid = personIdent person
@ -69,14 +69,14 @@ postProjectsR ident = do
setMessage "Project creation failed, see below" setMessage "Project creation failed, see below"
defaultLayout $(widgetFile "project/new") defaultLayout $(widgetFile "project/new")
getProjectNewR :: Text -> Handler Html getProjectNewR :: ShrIdent -> Handler Html
getProjectNewR ident = do getProjectNewR ident = do
Entity _pid person <- requireAuth Entity _pid person <- requireAuth
let sid = personIdent person let sid = personIdent person
((_result, widget), enctype) <- runFormPost $ newProjectForm sid ((_result, widget), enctype) <- runFormPost $ newProjectForm sid
defaultLayout $(widgetFile "project/new") defaultLayout $(widgetFile "project/new")
getProjectR :: Text -> Text -> 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 $ UniqueSharerIdent shar

44
src/Vervis/Handler/Repo.hs
View file

@ -27,20 +27,7 @@ module Vervis.Handler.Repo
) )
where where
--TODO CONTINUE HERE import Prelude
--
-- [/] maybe list project repos in personal overview too
-- [x] make repo list page
-- [x] add new repo creation link
-- [x] make new repo form
-- [x] write the git and mkdir parts that actually create the repo
-- [x] make repo view that shows a table of commits
import ClassyPrelude.Conduit hiding (last, unpack, delete)
import Yesod hiding (Header, parseTime, (==.))
import Yesod.Auth
import Prelude (init, last, tail)
import Data.Git.Graph import Data.Git.Graph
import Data.Git.Harder import Data.Git.Harder
@ -91,7 +78,7 @@ 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.Git as G (readSourceView, readChangesView, listRefs) import qualified Vervis.Git as G (readSourceView, readChangesView, listRefs)
getReposR :: Text -> Handler Html getReposR :: ShrIdent -> Handler Html
getReposR user = do getReposR user = do
repos <- runDB $ select $ from $ \ (sharer, repo) -> do repos <- runDB $ select $ from $ \ (sharer, repo) -> do
where_ $ where_ $
@ -99,12 +86,9 @@ 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 $ do defaultLayout $(widgetFile "repo/repos")
setTitle $ toHtml $ intercalate " > "
["Vervis", "People", user, "Repos"]
$(widgetFile "repo/repos")
postReposR :: Text -> Handler Html postReposR :: ShrIdent -> Handler Html
postReposR user = do postReposR user = do
Entity _pid person <- requireAuth Entity _pid person <- requireAuth
let sid = personIdent person let sid = personIdent person
@ -128,22 +112,20 @@ postReposR user = do
setMessage "Repo creation failed, see errors below" setMessage "Repo creation failed, see errors below"
defaultLayout $(widgetFile "repo/repo-new") defaultLayout $(widgetFile "repo/repo-new")
getRepoNewR :: Text -> 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 $ do defaultLayout $(widgetFile "repo/repo-new")
setTitle $ toHtml $ mconcat ["Vervis > People > ", user, " > New Repo"]
$(widgetFile "repo/repo-new")
selectRepo :: Text -> Text -> 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 $ UniqueSharerIdent shar
Entity _rid r <- getBy404 $ UniqueRepo repo sid Entity _rid r <- getBy404 $ UniqueRepo repo sid
return r return r
getRepoR :: Text -> Text -> Handler Html getRepoR :: ShrIdent -> RpIdent -> Handler Html
getRepoR shar repo = do getRepoR shar repo = do
repository <- runDB $ selectRepo shar repo repository <- runDB $ selectRepo shar repo
case repoVcs repository of case repoVcs repository of
@ -152,7 +134,7 @@ getRepoR shar repo = do
getGitRepoSource getGitRepoSource
repository shar repo (repoMainBranch repository) [] repository shar repo (repoMainBranch repository) []
deleteRepoR :: Text -> Text -> 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 $ UniqueSharerIdent shar
@ -171,14 +153,14 @@ deleteRepoR shar repo = do
setMessage "Repo deleted." setMessage "Repo deleted."
redirect HomeR redirect HomeR
postRepoR :: Text -> Text -> Handler Html postRepoR :: ShrIdent -> RpIdent -> Handler Html
postRepoR shar repo = do postRepoR shar repo = do
mmethod <- lookupPostParam "_method" mmethod <- lookupPostParam "_method"
case mmethod of case mmethod of
Just "DELETE" -> deleteRepoR shar repo Just "DELETE" -> deleteRepoR shar repo
_ -> notFound _ -> notFound
getRepoSourceR :: Text -> Text -> [Text] -> Handler Html getRepoSourceR :: ShrIdent -> RpIdent -> [Text] -> Handler Html
getRepoSourceR shar repo refdir = do getRepoSourceR shar repo refdir = do
repository <- runDB $ selectRepo shar repo repository <- runDB $ selectRepo shar repo
case repoVcs repository of case repoVcs repository of
@ -187,14 +169,14 @@ getRepoSourceR shar repo refdir = do
[] -> notFound [] -> notFound
(ref:dir) -> getGitRepoSource repository shar repo ref dir (ref:dir) -> getGitRepoSource repository shar repo ref dir
getRepoHeadChangesR :: Text -> Text -> Handler Html getRepoHeadChangesR :: ShrIdent -> RpIdent -> Handler Html
getRepoHeadChangesR user repo = do getRepoHeadChangesR user repo = do
repository <- runDB $ selectRepo user repo repository <- runDB $ selectRepo user repo
case repoVcs repository of case repoVcs repository of
VCSDarcs -> getDarcsRepoHeadChanges user repo VCSDarcs -> getDarcsRepoHeadChanges user repo
VCSGit -> getGitRepoHeadChanges repository user repo VCSGit -> getGitRepoHeadChanges repository user repo
getRepoChangesR :: Text -> Text -> Text -> Handler Html getRepoChangesR :: ShrIdent -> RpIdent -> Text -> Handler Html
getRepoChangesR shar repo ref = do getRepoChangesR shar repo ref = do
repository <- runDB $ selectRepo shar repo repository <- runDB $ selectRepo shar repo
case repoVcs repository of case repoVcs repository of

14
src/Vervis/Handler/Repo/Darcs.hs
View file

@ -21,11 +21,7 @@ module Vervis.Handler.Repo.Darcs
) )
where where
import ClassyPrelude.Conduit hiding (last, unpack) import Prelude
import Yesod hiding (Header, parseTime, (==.), joinPath)
import Yesod.Auth
import Prelude (init, last, tail)
import Data.List (inits) import Data.List (inits)
import Data.Text (unpack) import Data.Text (unpack)
@ -60,7 +56,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 Vervis.Darcs as D (readSourceView, readChangesView) import qualified Vervis.Darcs as D (readSourceView, readChangesView)
getDarcsRepoSource :: Repo -> Text -> Text -> [Text] -> Handler Html getDarcsRepoSource :: Repo -> ShrIdent -> RpIdent -> [Text] -> Handler Html
getDarcsRepoSource repository user repo dir = do getDarcsRepoSource repository user repo dir = do
path <- askRepoDir user repo path <- askRepoDir user repo
msv <- liftIO $ D.readSourceView path dir msv <- liftIO $ D.readSourceView path dir
@ -74,7 +70,7 @@ getDarcsRepoSource repository user repo dir = do
["Vervis", "People", user, "Repos", repo] ["Vervis", "People", user, "Repos", repo]
$(widgetFile "repo/source-darcs") $(widgetFile "repo/source-darcs")
getDarcsRepoHeadChanges :: Text -> Text -> Handler Html getDarcsRepoHeadChanges :: ShrIdent -> RpIdent -> Handler Html
getDarcsRepoHeadChanges shar repo = do getDarcsRepoHeadChanges shar repo = do
path <- askRepoDir shar repo path <- askRepoDir shar repo
(entries, navModel) <- getPageAndNav $ (entries, navModel) <- getPageAndNav $
@ -87,10 +83,10 @@ getDarcsRepoHeadChanges shar repo = do
pageNav = navWidget navModel pageNav = navWidget navModel
defaultLayout $(widgetFile "repo/changes-darcs") defaultLayout $(widgetFile "repo/changes-darcs")
getDarcsRepoChanges :: Text -> Text -> Text -> Handler Html getDarcsRepoChanges :: ShrIdent -> RpIdent -> Text -> Handler Html
getDarcsRepoChanges shar repo tag = notFound getDarcsRepoChanges shar repo tag = notFound
getDarcsDownloadR :: Text -> Text -> [Text] -> Handler TypedContent getDarcsDownloadR :: ShrIdent -> RpIdent -> [Text] -> Handler TypedContent
getDarcsDownloadR shar repo dir = do getDarcsDownloadR shar repo dir = do
path <- askRepoDir shar repo path <- askRepoDir shar repo
let darcsDir = path </> "_darcs" let darcsDir = path </> "_darcs"

12
src/Vervis/Handler/Repo/Git.hs
View file

@ -20,11 +20,7 @@ module Vervis.Handler.Repo.Git
) )
where where
import ClassyPrelude.Conduit hiding (last, unpack) import Prelude
import Yesod hiding (Header, parseTime, (==.))
import Yesod.Auth
import Prelude (init, last, tail)
import Data.Git.Graph import Data.Git.Graph
import Data.Git.Harder import Data.Git.Harder
@ -70,7 +66,7 @@ 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.Git as G (readSourceView, readChangesView, listRefs) import qualified Vervis.Git as G (readSourceView, readChangesView, listRefs)
getGitRepoSource :: Repo -> Text -> Text -> Text -> [Text] -> Handler Html getGitRepoSource :: Repo -> ShrIdent -> RpIdent -> Text -> [Text] -> Handler Html
getGitRepoSource repository user repo ref dir = do getGitRepoSource repository user repo ref dir = do
path <- askRepoDir user repo path <- askRepoDir user repo
(branches, tags, msv) <- liftIO $ G.readSourceView path ref dir (branches, tags, msv) <- liftIO $ G.readSourceView path ref dir
@ -81,11 +77,11 @@ getGitRepoSource repository user repo ref dir = do
dirs = zip parent (tail $ inits parent) dirs = zip parent (tail $ inits parent)
defaultLayout $(widgetFile "repo/source-git") defaultLayout $(widgetFile "repo/source-git")
getGitRepoHeadChanges :: Repo -> Text -> Text -> Handler Html getGitRepoHeadChanges :: Repo -> ShrIdent -> RpIdent -> Handler Html
getGitRepoHeadChanges repository shar repo = getGitRepoHeadChanges repository shar repo =
getGitRepoChanges shar repo $ repoMainBranch repository getGitRepoChanges shar repo $ repoMainBranch repository
getGitRepoChanges :: Text -> Text -> Text -> Handler Html getGitRepoChanges :: ShrIdent -> RpIdent -> Text -> Handler Html
getGitRepoChanges shar repo ref = do getGitRepoChanges shar repo ref = do
path <- askRepoDir shar repo path <- askRepoDir shar repo
(branches, tags) <- liftIO $ G.listRefs path (branches, tags) <- liftIO $ G.listRefs path

30
src/Vervis/Handler/Ticket.hs
View file

@ -63,7 +63,7 @@ import Vervis.Settings (widgetFile)
import Vervis.TicketFilter (filterTickets) import Vervis.TicketFilter (filterTickets)
import Vervis.Widget.Discussion (discussionW) import Vervis.Widget.Discussion (discussionW)
getTicketsR :: Text -> Text -> Handler Html getTicketsR :: ShrIdent -> PrjIdent -> Handler Html
getTicketsR shar proj = do getTicketsR shar proj = do
((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
let tf = let tf =
@ -88,7 +88,7 @@ getTicketsR shar proj = do
) )
defaultLayout $(widgetFile "ticket/list") defaultLayout $(widgetFile "ticket/list")
postTicketsR :: Text -> Text -> Handler Html postTicketsR :: ShrIdent -> PrjIdent -> Handler Html
postTicketsR shar proj = do postTicketsR shar proj = do
((result, widget), enctype) <- runFormPost newTicketForm ((result, widget), enctype) <- runFormPost newTicketForm
case result of case result of
@ -127,12 +127,12 @@ postTicketsR shar proj = do
setMessage "Ticket creation failed, see errors below." setMessage "Ticket creation failed, see errors below."
defaultLayout $(widgetFile "ticket/new") defaultLayout $(widgetFile "ticket/new")
getTicketNewR :: Text -> Text -> Handler Html getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
getTicketNewR shar proj = do getTicketNewR shar proj = do
((_result, widget), enctype) <- runFormPost newTicketForm ((_result, widget), enctype) <- runFormPost newTicketForm
defaultLayout $(widgetFile "ticket/new") defaultLayout $(widgetFile "ticket/new")
getTicketR :: Text -> Text -> 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 $ UniqueSharerIdent shar
@ -155,7 +155,7 @@ getTicketR shar proj num = do
(TicketReplyR shar proj num) (TicketReplyR shar proj num)
defaultLayout $(widgetFile "ticket/one") defaultLayout $(widgetFile "ticket/one")
putTicketR :: Text -> Text -> 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 $ UniqueSharerIdent shar
@ -175,13 +175,13 @@ putTicketR shar proj num = do
setMessage "Ticket update failed, see errors below." setMessage "Ticket update failed, see errors below."
defaultLayout $(widgetFile "ticket/edit") defaultLayout $(widgetFile "ticket/edit")
deleteTicketR :: Text -> Text -> Int -> Handler Html deleteTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
deleteTicketR shar proj num = deleteTicketR shar proj num =
--TODO: I can easily implement this, but should it even be possible to --TODO: I can easily implement this, but should it even be possible to
--delete tickets? --delete tickets?
error "Not implemented" error "Not implemented"
postTicketR :: Text -> Text -> Int -> Handler Html postTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketR shar proj num = do postTicketR shar proj num = do
mmethod <- lookupPostParam "_method" mmethod <- lookupPostParam "_method"
case mmethod of case mmethod of
@ -189,7 +189,7 @@ postTicketR shar proj num = do
Just "DELETE" -> deleteTicketR shar proj num Just "DELETE" -> deleteTicketR shar proj num
_ -> notFound _ -> notFound
getTicketEditR :: Text -> Text -> 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 $ UniqueSharerIdent shar
@ -199,35 +199,35 @@ getTicketEditR shar proj num = do
((_result, widget), enctype) <- runFormPost $ editTicketForm ticket user ((_result, widget), enctype) <- runFormPost $ editTicketForm ticket user
defaultLayout $(widgetFile "ticket/edit") defaultLayout $(widgetFile "ticket/edit")
selectDiscussionId :: Text -> Text -> 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 $ UniqueSharerIdent 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
getTicketDiscussionR :: Text -> Text -> Int -> Handler Html getTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketDiscussionR shar proj num = getTicketDiscussionR shar proj num =
getDiscussion getDiscussion
(TicketReplyR shar proj num) (TicketReplyR shar proj num)
(TicketTopReplyR shar proj num) (TicketTopReplyR shar proj num)
(selectDiscussionId shar proj num) (selectDiscussionId shar proj num)
postTicketDiscussionR :: Text -> Text -> Int -> Handler Html postTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketDiscussionR shar proj num = postTicketDiscussionR shar proj num =
postTopReply postTopReply
(TicketDiscussionR shar proj num) (TicketDiscussionR shar proj num)
(const $ TicketR shar proj num) (const $ TicketR shar proj num)
(selectDiscussionId shar proj num) (selectDiscussionId shar proj num)
getTicketMessageR :: Text -> Text -> Int -> Int -> Handler Html getTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
getTicketMessageR shar proj tnum cnum = getTicketMessageR shar proj tnum cnum =
getMessage getMessage
(TicketReplyR shar proj tnum) (TicketReplyR shar proj tnum)
(selectDiscussionId shar proj tnum) (selectDiscussionId shar proj tnum)
cnum cnum
postTicketMessageR :: Text -> Text -> Int -> Int -> Handler Html postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
postTicketMessageR shar proj tnum cnum = postTicketMessageR shar proj tnum cnum =
postReply postReply
(TicketReplyR shar proj tnum) (TicketReplyR shar proj tnum)
@ -236,11 +236,11 @@ postTicketMessageR shar proj tnum cnum =
(selectDiscussionId shar proj tnum) (selectDiscussionId shar proj tnum)
cnum cnum
getTicketTopReplyR :: Text -> Text -> Int -> Handler Html getTicketTopReplyR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketTopReplyR shar proj num = getTicketTopReplyR shar proj num =
getTopReply $ TicketDiscussionR shar proj num getTopReply $ TicketDiscussionR shar proj num
getTicketReplyR :: Text -> Text -> Int -> Int -> Handler Html getTicketReplyR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
getTicketReplyR shar proj tnum cnum = getTicketReplyR shar proj tnum cnum =
getReply getReply
(TicketReplyR shar proj tnum) (TicketReplyR shar proj tnum)

3
src/Vervis/Model.hs
View file

@ -13,7 +13,7 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>. - <http://creativecommons.org/publicdomain/zero/1.0/>.
-} -}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
module Vervis.Model where module Vervis.Model where
@ -24,6 +24,7 @@ import Database.Persist.Quasi
import Database.Persist.Sql (fromSqlKey) import Database.Persist.Sql (fromSqlKey)
import Yesod.Auth.HashDB (HashDBUser (..)) import Yesod.Auth.HashDB (HashDBUser (..))
import Vervis.Model.Ident
import Vervis.Model.Repo import Vervis.Model.Repo
-- You can define all of your database entities in the entities file. -- You can define all of your database entities in the entities file.

50
src/Vervis/Model/Ident.hs Normal file
View file

@ -0,0 +1,50 @@
{- 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/>.
-}
-- | Dedicated identifier name types for type safety. For use in routes, models
-- and handlers.
module Vervis.Model.Ident
( ShrIdent (..)
, KyIdent (..)
, PrjIdent (..)
, RpIdent (..)
)
where
import Prelude
import Data.CaseInsensitive (CI)
import Data.Text (Text)
import Database.Esqueleto (SqlString)
import Database.Persist.Class (PersistField)
import Database.Persist.Sql (PersistFieldSql)
import Web.PathPieces (PathPiece)
import Database.Esqueleto.Local ()
import Database.Persist.Class.Local ()
import Database.Persist.Sql.Local ()
import Web.PathPieces.Local ()
newtype ShrIdent = ShrIdent { unSharIdent :: CI Text }
deriving (PersistField, PersistFieldSql, SqlString, PathPiece)
newtype KyIdent = KyIdent { unKyIdent :: CI Text }
deriving (PersistField, PersistFieldSql, SqlString, PathPiece)
newtype PrjIdent = PrjIdent { unPrjIdent :: CI Text }
deriving (PersistField, PersistFieldSql, SqlString, PathPiece)
newtype RpIdent = RpIdent { unRpIdent :: CI Text }
deriving (PersistField, PersistFieldSql, SqlString, PathPiece)

24
src/Vervis/Path.hs
View file

@ -24,28 +24,34 @@ where
import Prelude import Prelude
import Data.Text (Text, unpack) import Data.Text (Text)
import System.FilePath ((</>)) import System.FilePath ((</>))
import Yesod.Core.Handler (getYesod) import Yesod.Core.Handler (getsYesod)
import qualified Data.CaseInsensitive as CI (foldedCase)
import qualified Data.Text as T (unpack)
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model.Ident
import Vervis.Settings import Vervis.Settings
askRepoRootDir :: Handler FilePath askRepoRootDir :: Handler FilePath
askRepoRootDir = appRepoDir . appSettings <$> getYesod askRepoRootDir = getsYesod $ appRepoDir . appSettings
sharerDir :: FilePath -> Text -> FilePath sharerDir :: FilePath -> ShrIdent -> FilePath
sharerDir root sharer = root </> unpack sharer sharerDir root sharer =
root </> (T.unpack $ CI.foldedCase $ unShrIdent sharer)
askSharerDir :: Text -> Handler FilePath askSharerDir :: ShrIdent -> Handler FilePath
askSharerDir sharer = do askSharerDir sharer = do
root <- askRepoRootDir root <- askRepoRootDir
return $ sharerDir root sharer return $ sharerDir root sharer
repoDir :: FilePath -> Text -> Text -> FilePath repoDir :: FilePath -> ShrIdent -> RpIdent -> FilePath
repoDir root sharer repo = sharerDir root sharer </> unpack repo repoDir root sharer repo =
sharerDir root sharer </> (T.unpack $ CI.foldedCase $ unRpIdent repo)
askRepoDir :: Text -> Text -> Handler FilePath askRepoDir :: ShrIdent -> RpIdent -> Handler FilePath
askRepoDir sharer repo = do askRepoDir sharer repo = do
root <- askRepoRootDir root <- askRepoRootDir
return $ repoDir root sharer repo return $ repoDir root sharer repo

30
src/Web/PathPieces/Local.hs Normal file
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 Web.PathPieces.Local
(
)
where
import Prelude
import Data.CaseInsensitive (CI)
import Web.PathPieces
import qualified Data.CaseInsensitive as CI
instance (PathPiece s, CI.FoldCase s) => PathPiece (CI s) where
fromPathPiece = fmap CI.mk . fromPathPiece
toPathPiece = toPathPiece . CI.original

7
vervis.cabal
View file

@ -60,11 +60,14 @@ library
Data.Text.Lazy.UTF8.Local Data.Text.Lazy.UTF8.Local
Data.Time.Clock.Local Data.Time.Clock.Local
Data.Tree.Local Data.Tree.Local
Database.Esqueleto.Local
Database.Persist.Class.Local Database.Persist.Class.Local
Database.Persist.Sql.Local
Development.DarcsRev Development.DarcsRev
Network.SSH.Local Network.SSH.Local
Text.FilePath.Local Text.FilePath.Local
Text.Jasmine.Local Text.Jasmine.Local
Web.PathPieces.Local
Yesod.Paginate.Local Yesod.Paginate.Local
Vervis.Application Vervis.Application
@ -97,11 +100,11 @@ library
Vervis.Handler.Repo.Darcs Vervis.Handler.Repo.Darcs
Vervis.Handler.Repo.Git Vervis.Handler.Repo.Git
Vervis.Handler.Ticket Vervis.Handler.Ticket
Vervis.Handler.Util
Vervis.Import Vervis.Import
Vervis.Import.NoFoundation Vervis.Import.NoFoundation
Vervis.MediaType Vervis.MediaType
Vervis.Model Vervis.Model
Vervis.Model.Ident
Vervis.Model.Repo Vervis.Model.Repo
Vervis.Paginate Vervis.Paginate
Vervis.Path Vervis.Path
@ -197,6 +200,8 @@ library
, monad-logger , monad-logger
, pandoc , pandoc
, pandoc-types , pandoc-types
-- for PathPiece instance for CI, Web.PathPieces.Local
, path-pieces
, persistent , persistent
, persistent-postgresql , persistent-postgresql
, persistent-template , persistent-template