Start big route change, doesn't build yet
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:
parent
3a65568d8f
commit
49807ed27f
20 changed files with 277 additions and 169 deletions
|
@ -13,8 +13,8 @@
|
|||
-- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
|
||||
Sharer
|
||||
ident Text --CI
|
||||
name Text Maybe
|
||||
ident TextCI
|
||||
name Text Maybe
|
||||
|
||||
UniqueSharerIdent ident
|
||||
|
||||
|
@ -41,7 +41,7 @@ Group
|
|||
UniqueGroupIdent ident
|
||||
|
||||
Project
|
||||
ident Text --CI
|
||||
ident TextCI
|
||||
sharer SharerId
|
||||
name Text Maybe
|
||||
desc Text Maybe
|
||||
|
@ -50,7 +50,7 @@ Project
|
|||
UniqueProject ident sharer
|
||||
|
||||
Repo
|
||||
ident Text --CI
|
||||
ident TextCI
|
||||
sharer SharerId
|
||||
vcs VersionControlSystem default='VCSGit'
|
||||
project ProjectId Maybe
|
||||
|
|
|
@ -32,38 +32,38 @@
|
|||
|
||||
/ HomeR GET
|
||||
|
||||
/u PeopleR GET POST
|
||||
/u/!new PersonNewR GET
|
||||
/u/#Text PersonR GET
|
||||
/s PeopleR GET POST
|
||||
/s/!new PersonNewR GET
|
||||
/s/#ShrIdent PersonR GET
|
||||
|
||||
/u/#Text/k KeysR GET POST
|
||||
/u/#Text/k/!new KeyNewR GET
|
||||
/u/#Text/k/#Text KeyR GET DELETE POST
|
||||
/k KeysR GET POST
|
||||
/k/!new KeyNewR GET
|
||||
/k/#KyIdent KeyR GET DELETE POST
|
||||
|
||||
/u/#Text/r ReposR GET POST
|
||||
/u/#Text/r/!new RepoNewR GET
|
||||
/u/#Text/r/#Text RepoR GET DELETE POST
|
||||
/u/#Text/r/#Text/s/+Texts RepoSourceR GET
|
||||
/u/#Text/r/#Text/c RepoHeadChangesR GET
|
||||
/u/#Text/r/#Text/c/#Text RepoChangesR GET
|
||||
/s/#ShrIdent/r ReposR GET POST
|
||||
/s/#ShrIdent/r/!new RepoNewR GET
|
||||
/s/#ShrIdent/r/#RpIdent RepoR GET DELETE POST
|
||||
/s/#ShrIdent/r/#RpIdent/s/+Texts RepoSourceR GET
|
||||
/s/#ShrIdent/r/#RpIdent/c RepoHeadChangesR 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
|
||||
--/u/#Text/r/#Text/git/git-upload-pack GitUploadRequestR POST
|
||||
/s/#ShrIdent/r/#RpIdent/git/info/refs GitRefDiscoverR GET
|
||||
--/s/#ShrIdent/r/#RpIdent/git/git-upload-pack GitUploadRequestR POST
|
||||
|
||||
/u/#Text/p ProjectsR GET POST
|
||||
/u/#Text/p/!new ProjectNewR GET
|
||||
/u/#Text/p/#Text ProjectR GET
|
||||
/s/#ShrIdent/p ProjectsR GET POST
|
||||
/s/#ShrIdent/p/!new ProjectNewR GET
|
||||
/s/#ShrIdent/p/#PrjIdent ProjectR GET
|
||||
|
||||
/u/#Text/p/#Text/t TicketsR GET POST
|
||||
/u/#Text/p/#Text/t/!new TicketNewR GET
|
||||
/u/#Text/p/#Text/t/#Int TicketR GET PUT DELETE POST
|
||||
/u/#Text/p/#Text/t/#Int/edit TicketEditR GET
|
||||
/u/#Text/p/#Text/t/#Int/d TicketDiscussionR GET POST
|
||||
/u/#Text/p/#Text/t/#Int/d/#Int TicketMessageR GET POST
|
||||
/u/#Text/p/#Text/t/#Int/d/!reply TicketTopReplyR GET
|
||||
/u/#Text/p/#Text/t/#Int/d/#Int/reply TicketReplyR GET
|
||||
/s/#ShrIdent/p/#PrjIdent/t TicketsR GET POST
|
||||
/s/#ShrIdent/p/#PrjIdent/t/!new TicketNewR GET
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int TicketR GET PUT DELETE POST
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/edit TicketEditR GET
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/d TicketDiscussionR GET POST
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Int TicketMessageR GET POST
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/!reply TicketTopReplyR GET
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Int/reply TicketReplyR GET
|
||||
|
||||
-- /u/#Text/p/#Text/w WikiR GET
|
||||
-- /u/#Text/p/#Text/w/+Texts WikiPageR GET
|
||||
-- /s/#ShrIdent/p/#PrjIdent/w WikiR GET
|
||||
-- /s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET
|
||||
|
|
|
@ -13,12 +13,16 @@
|
|||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module Vervis.Handler.Util
|
||||
( loggedIn
|
||||
module Database.Esqueleto.Local
|
||||
(
|
||||
)
|
||||
where
|
||||
|
||||
import Vervis.Import hiding (loggedIn)
|
||||
import Prelude
|
||||
|
||||
loggedIn :: Handler Bool
|
||||
loggedIn = isJust <$> maybeAuthId
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Database.Esqueleto
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
instance SqlString s => SqlString (CI s)
|
|
@ -15,14 +15,13 @@
|
|||
|
||||
-- | 'PersistField' instance for 'CI', for easy case-insensitive DB fields.
|
||||
module Database.Persist.Class.Local
|
||||
( TextCI
|
||||
(
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Data.Text (Text)
|
||||
import Database.Persist.Class
|
||||
|
||||
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
|
||||
toPersistValue = toPersistValue . CI.original
|
||||
fromPersistValue = fmap CI.mk . fromPersistValue
|
||||
|
||||
type TextCI = CI Text
|
||||
|
|
31
src/Database/Persist/Sql/Local.hs
Normal file
31
src/Database/Persist/Sql/Local.hs
Normal 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
30
src/Text/Blaze/Local.hs
Normal 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
|
|
@ -32,6 +32,7 @@ import Data.Text as T (pack, intercalate)
|
|||
|
||||
import Text.Jasmine.Local (discardm)
|
||||
import Vervis.Import.NoFoundation hiding (last)
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Widget (breadcrumbsW, revisionW)
|
||||
|
||||
-- | The foundation datatype for your application. This can be a good place to
|
||||
|
|
|
@ -39,8 +39,8 @@ import Vervis.Content
|
|||
import Vervis.Foundation (Handler)
|
||||
import Vervis.Path (askRepoDir)
|
||||
|
||||
getGitRefDiscoverR :: Text -> Text -> Handler GitRefDiscovery
|
||||
getGitRefDiscoverR sharer repo = do
|
||||
getGitRefDiscoverR :: ShrIdent -> RpIdent -> Handler GitRefDiscovery
|
||||
getGitRefDiscoverR shar repo = do
|
||||
path <- askRepoDir sharer repo
|
||||
let pathG = fromString path
|
||||
seemsThere <- liftIO $ isRepo pathG
|
||||
|
|
|
@ -44,74 +44,55 @@ import Vervis.Foundation
|
|||
import Vervis.Model
|
||||
import Vervis.Settings
|
||||
|
||||
getKeysR :: Text -> Handler Html
|
||||
getKeysR user = do
|
||||
getKeysR :: Handler Html
|
||||
getKeysR = do
|
||||
pid <- requireAuthId
|
||||
keys <- runDB $ do
|
||||
Entity sid _sharer <- getBy404 $ UniqueSharerIdent user
|
||||
Entity pid _person <- getBy404 $ UniquePersonIdent sid
|
||||
ks <- selectList [SshKeyPerson ==. pid] [Asc SshKeyName]
|
||||
return $ map (\ (Entity _ k) -> sshKeyName k) ks
|
||||
defaultLayout $ do
|
||||
setTitle $ toHtml $
|
||||
intercalate " > " ["Vervis", "People", user, "Keys"]
|
||||
$(widgetFile "key/keys")
|
||||
defaultLayout $(widgetFile "key/list")
|
||||
|
||||
postKeysR :: Text -> Handler Html
|
||||
postKeysR user = do
|
||||
pid <- runDB $ do
|
||||
Entity s _sharer <- getBy404 $ UniqueSharerIdent user
|
||||
Entity p _person <- getBy404 $ UniquePersonIdent s
|
||||
return p
|
||||
postKeysR :: Handler Html
|
||||
postKeysR = do
|
||||
pid <- requireAuthId
|
||||
((result, widget), enctype) <- runFormPost $ newKeyForm pid
|
||||
case result of
|
||||
FormSuccess key -> do
|
||||
runDB $ insert_ key
|
||||
setMessage "Key added."
|
||||
redirect $ KeysR user
|
||||
redirect KeysR
|
||||
FormMissing -> do
|
||||
setMessage "Field(s) missing"
|
||||
defaultLayout $(widgetFile "key/key-new")
|
||||
defaultLayout $(widgetFile "key/new")
|
||||
FormFailure _l -> do
|
||||
setMessage "Invalid input, see below"
|
||||
defaultLayout $(widgetFile "key/key-new")
|
||||
defaultLayout $(widgetFile "key/new")
|
||||
|
||||
getKeyNewR :: Text -> Handler Html
|
||||
getKeyNewR user = do
|
||||
pid <- runDB $ do
|
||||
Entity s _sharer <- getBy404 $ UniqueSharerIdent user
|
||||
Entity p _person <- getBy404 $ UniquePersonIdent s
|
||||
return p
|
||||
getKeyNewR :: Handler Html
|
||||
getKeyNewR = do
|
||||
pid <- requireAuthId
|
||||
((_result, widget), enctype) <- runFormPost $ newKeyForm pid
|
||||
defaultLayout $ do
|
||||
setTitle $ toHtml $ "Vervis > People > " <> user <> " > New Key"
|
||||
$(widgetFile "key/key-new")
|
||||
defaultLayout $(widgetFile "key/new")
|
||||
|
||||
getKeyR :: Text -> Text -> Handler Html
|
||||
getKeyR user tag = do
|
||||
Entity _kid key <- runDB $ do
|
||||
Entity sid _sharer <- getBy404 $ UniqueSharerIdent user
|
||||
Entity pid _person <- getBy404 $ UniquePersonIdent sid
|
||||
getBy404 $ UniqueSshKey pid tag
|
||||
getKeyR :: KyIdent -> Handler Html
|
||||
getKeyR tag = do
|
||||
pid <- requireAuthId
|
||||
Entity _kid key <- runDB $ getBy404 $ UniqueSshKey pid tag
|
||||
let toText = decodeUtf8With lenientDecode
|
||||
content = toText $ encode $ sshKeyContent key
|
||||
defaultLayout $ do
|
||||
setTitle $ toHtml $
|
||||
intercalate " > " ["Vervis", "People", user, "Keys", tag]
|
||||
$(widgetFile "key/key")
|
||||
defaultLayout $(widgetFile "key/one")
|
||||
|
||||
deleteKeyR :: Text -> Text -> Handler Html
|
||||
deleteKeyR user tag = do
|
||||
deleteKeyR :: KyIdent -> Handler Html
|
||||
deleteKeyR tag = do
|
||||
runDB $ do
|
||||
Entity sid _s <- getBy404 $ UniqueSharerIdent user
|
||||
Entity pid _p <- getBy404 $ UniquePersonIdent sid
|
||||
Entity kid _k <- getBy404 $ UniqueSshKey pid tag
|
||||
delete kid
|
||||
setMessage "Key deleted."
|
||||
redirect $ KeysR user
|
||||
redirect KeysR
|
||||
|
||||
postKeyR :: Text -> Text -> Handler Html
|
||||
postKeyR user tag = do
|
||||
postKeyR :: KyIdent -> Handler Html
|
||||
postKeyR tag = do
|
||||
mmethod <- lookupPostParam "_method"
|
||||
case mmethod of
|
||||
Just "DELETE" -> deleteKeyR user tag
|
||||
Just "DELETE" -> deleteKeyR tag
|
||||
_ -> notFound
|
||||
|
|
|
@ -93,12 +93,10 @@ getPersonNewR = do
|
|||
$(widgetFile "person-new")
|
||||
else notFound
|
||||
|
||||
getPersonR :: Text -> Handler Html
|
||||
getPersonR :: ShrIdent -> Handler Html
|
||||
getPersonR ident = do
|
||||
person <- runDB $ do
|
||||
Entity sid _s <- getBy404 $ UniqueSharerIdent ident
|
||||
Entity _pid p <- getBy404 $ UniquePersonIdent sid
|
||||
return p
|
||||
defaultLayout $ do
|
||||
setTitle $ toHtml $ "Vervis > People > " <> ident
|
||||
$(widgetFile "person")
|
||||
defaultLayout $(widgetFile "person")
|
||||
|
|
|
@ -42,7 +42,7 @@ import Vervis.Model
|
|||
import Vervis.Model.Repo
|
||||
import Vervis.Settings
|
||||
|
||||
getProjectsR :: Text -> Handler Html
|
||||
getProjectsR :: ShrIdent -> Handler Html
|
||||
getProjectsR ident = do
|
||||
projects <- runDB $ E.select $ E.from $ \ (sharer, project) -> do
|
||||
E.where_ $
|
||||
|
@ -52,7 +52,7 @@ getProjectsR ident = do
|
|||
return $ project E.^. ProjectIdent
|
||||
defaultLayout $(widgetFile "project/list")
|
||||
|
||||
postProjectsR :: Text -> Handler Html
|
||||
postProjectsR :: ShrIdent -> Handler Html
|
||||
postProjectsR ident = do
|
||||
Entity _pid person <- requireAuth
|
||||
let sid = personIdent person
|
||||
|
@ -69,14 +69,14 @@ postProjectsR ident = do
|
|||
setMessage "Project creation failed, see below"
|
||||
defaultLayout $(widgetFile "project/new")
|
||||
|
||||
getProjectNewR :: Text -> Handler Html
|
||||
getProjectNewR :: ShrIdent -> Handler Html
|
||||
getProjectNewR ident = do
|
||||
Entity _pid person <- requireAuth
|
||||
let sid = personIdent person
|
||||
((_result, widget), enctype) <- runFormPost $ newProjectForm sid
|
||||
defaultLayout $(widgetFile "project/new")
|
||||
|
||||
getProjectR :: Text -> Text -> Handler Html
|
||||
getProjectR :: ShrIdent -> PrjIdent -> Handler Html
|
||||
getProjectR shar proj = do
|
||||
(project, repos) <- runDB $ do
|
||||
Entity sid _s <- getBy404 $ UniqueSharerIdent shar
|
||||
|
|
|
@ -27,20 +27,7 @@ module Vervis.Handler.Repo
|
|||
)
|
||||
where
|
||||
|
||||
--TODO CONTINUE HERE
|
||||
--
|
||||
-- [/] 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 Prelude
|
||||
|
||||
import Data.Git.Graph
|
||||
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.Git as G (readSourceView, readChangesView, listRefs)
|
||||
|
||||
getReposR :: Text -> Handler Html
|
||||
getReposR :: ShrIdent -> Handler Html
|
||||
getReposR user = do
|
||||
repos <- runDB $ select $ from $ \ (sharer, repo) -> do
|
||||
where_ $
|
||||
|
@ -99,12 +86,9 @@ getReposR user = do
|
|||
sharer ^. SharerId ==. repo ^. RepoSharer
|
||||
orderBy [asc $ repo ^. RepoIdent]
|
||||
return $ repo ^. RepoIdent
|
||||
defaultLayout $ do
|
||||
setTitle $ toHtml $ intercalate " > "
|
||||
["Vervis", "People", user, "Repos"]
|
||||
$(widgetFile "repo/repos")
|
||||
defaultLayout $(widgetFile "repo/repos")
|
||||
|
||||
postReposR :: Text -> Handler Html
|
||||
postReposR :: ShrIdent -> Handler Html
|
||||
postReposR user = do
|
||||
Entity _pid person <- requireAuth
|
||||
let sid = personIdent person
|
||||
|
@ -128,22 +112,20 @@ postReposR user = do
|
|||
setMessage "Repo creation failed, see errors below"
|
||||
defaultLayout $(widgetFile "repo/repo-new")
|
||||
|
||||
getRepoNewR :: Text -> Handler Html
|
||||
getRepoNewR :: ShrIdent -> Handler Html
|
||||
getRepoNewR user = do
|
||||
Entity _pid person <- requireAuth
|
||||
let sid = personIdent person
|
||||
((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
|
||||
defaultLayout $ do
|
||||
setTitle $ toHtml $ mconcat ["Vervis > People > ", user, " > New Repo"]
|
||||
$(widgetFile "repo/repo-new")
|
||||
defaultLayout $(widgetFile "repo/repo-new")
|
||||
|
||||
selectRepo :: Text -> Text -> AppDB Repo
|
||||
selectRepo :: ShrIdent -> RpIdent -> AppDB Repo
|
||||
selectRepo shar repo = do
|
||||
Entity sid _s <- getBy404 $ UniqueSharerIdent shar
|
||||
Entity _rid r <- getBy404 $ UniqueRepo repo sid
|
||||
return r
|
||||
|
||||
getRepoR :: Text -> Text -> Handler Html
|
||||
getRepoR :: ShrIdent -> RpIdent -> Handler Html
|
||||
getRepoR shar repo = do
|
||||
repository <- runDB $ selectRepo shar repo
|
||||
case repoVcs repository of
|
||||
|
@ -152,7 +134,7 @@ getRepoR shar repo = do
|
|||
getGitRepoSource
|
||||
repository shar repo (repoMainBranch repository) []
|
||||
|
||||
deleteRepoR :: Text -> Text -> Handler Html
|
||||
deleteRepoR :: ShrIdent -> RpIdent -> Handler Html
|
||||
deleteRepoR shar repo = do
|
||||
runDB $ do
|
||||
Entity sid _s <- getBy404 $ UniqueSharerIdent shar
|
||||
|
@ -171,14 +153,14 @@ deleteRepoR shar repo = do
|
|||
setMessage "Repo deleted."
|
||||
redirect HomeR
|
||||
|
||||
postRepoR :: Text -> Text -> Handler Html
|
||||
postRepoR :: ShrIdent -> RpIdent -> Handler Html
|
||||
postRepoR shar repo = do
|
||||
mmethod <- lookupPostParam "_method"
|
||||
case mmethod of
|
||||
Just "DELETE" -> deleteRepoR shar repo
|
||||
_ -> notFound
|
||||
|
||||
getRepoSourceR :: Text -> Text -> [Text] -> Handler Html
|
||||
getRepoSourceR :: ShrIdent -> RpIdent -> [Text] -> Handler Html
|
||||
getRepoSourceR shar repo refdir = do
|
||||
repository <- runDB $ selectRepo shar repo
|
||||
case repoVcs repository of
|
||||
|
@ -187,14 +169,14 @@ getRepoSourceR shar repo refdir = do
|
|||
[] -> notFound
|
||||
(ref:dir) -> getGitRepoSource repository shar repo ref dir
|
||||
|
||||
getRepoHeadChangesR :: Text -> Text -> Handler Html
|
||||
getRepoHeadChangesR :: ShrIdent -> RpIdent -> Handler Html
|
||||
getRepoHeadChangesR user repo = do
|
||||
repository <- runDB $ selectRepo user repo
|
||||
case repoVcs repository of
|
||||
VCSDarcs -> getDarcsRepoHeadChanges user repo
|
||||
VCSGit -> getGitRepoHeadChanges repository user repo
|
||||
|
||||
getRepoChangesR :: Text -> Text -> Text -> Handler Html
|
||||
getRepoChangesR :: ShrIdent -> RpIdent -> Text -> Handler Html
|
||||
getRepoChangesR shar repo ref = do
|
||||
repository <- runDB $ selectRepo shar repo
|
||||
case repoVcs repository of
|
||||
|
|
|
@ -21,11 +21,7 @@ module Vervis.Handler.Repo.Darcs
|
|||
)
|
||||
where
|
||||
|
||||
import ClassyPrelude.Conduit hiding (last, unpack)
|
||||
import Yesod hiding (Header, parseTime, (==.), joinPath)
|
||||
import Yesod.Auth
|
||||
|
||||
import Prelude (init, last, tail)
|
||||
import Prelude
|
||||
|
||||
import Data.List (inits)
|
||||
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 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
|
||||
path <- askRepoDir user repo
|
||||
msv <- liftIO $ D.readSourceView path dir
|
||||
|
@ -74,7 +70,7 @@ getDarcsRepoSource repository user repo dir = do
|
|||
["Vervis", "People", user, "Repos", repo]
|
||||
$(widgetFile "repo/source-darcs")
|
||||
|
||||
getDarcsRepoHeadChanges :: Text -> Text -> Handler Html
|
||||
getDarcsRepoHeadChanges :: ShrIdent -> RpIdent -> Handler Html
|
||||
getDarcsRepoHeadChanges shar repo = do
|
||||
path <- askRepoDir shar repo
|
||||
(entries, navModel) <- getPageAndNav $
|
||||
|
@ -87,10 +83,10 @@ getDarcsRepoHeadChanges shar repo = do
|
|||
pageNav = navWidget navModel
|
||||
defaultLayout $(widgetFile "repo/changes-darcs")
|
||||
|
||||
getDarcsRepoChanges :: Text -> Text -> Text -> Handler Html
|
||||
getDarcsRepoChanges :: ShrIdent -> RpIdent -> Text -> Handler Html
|
||||
getDarcsRepoChanges shar repo tag = notFound
|
||||
|
||||
getDarcsDownloadR :: Text -> Text -> [Text] -> Handler TypedContent
|
||||
getDarcsDownloadR :: ShrIdent -> RpIdent -> [Text] -> Handler TypedContent
|
||||
getDarcsDownloadR shar repo dir = do
|
||||
path <- askRepoDir shar repo
|
||||
let darcsDir = path </> "_darcs"
|
||||
|
|
|
@ -20,11 +20,7 @@ module Vervis.Handler.Repo.Git
|
|||
)
|
||||
where
|
||||
|
||||
import ClassyPrelude.Conduit hiding (last, unpack)
|
||||
import Yesod hiding (Header, parseTime, (==.))
|
||||
import Yesod.Auth
|
||||
|
||||
import Prelude (init, last, tail)
|
||||
import Prelude
|
||||
|
||||
import Data.Git.Graph
|
||||
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 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
|
||||
path <- askRepoDir user repo
|
||||
(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)
|
||||
defaultLayout $(widgetFile "repo/source-git")
|
||||
|
||||
getGitRepoHeadChanges :: Repo -> Text -> Text -> Handler Html
|
||||
getGitRepoHeadChanges :: Repo -> ShrIdent -> RpIdent -> Handler Html
|
||||
getGitRepoHeadChanges repository shar repo =
|
||||
getGitRepoChanges shar repo $ repoMainBranch repository
|
||||
|
||||
getGitRepoChanges :: Text -> Text -> Text -> Handler Html
|
||||
getGitRepoChanges :: ShrIdent -> RpIdent -> Text -> Handler Html
|
||||
getGitRepoChanges shar repo ref = do
|
||||
path <- askRepoDir shar repo
|
||||
(branches, tags) <- liftIO $ G.listRefs path
|
||||
|
|
|
@ -63,7 +63,7 @@ import Vervis.Settings (widgetFile)
|
|||
import Vervis.TicketFilter (filterTickets)
|
||||
import Vervis.Widget.Discussion (discussionW)
|
||||
|
||||
getTicketsR :: Text -> Text -> Handler Html
|
||||
getTicketsR :: ShrIdent -> PrjIdent -> Handler Html
|
||||
getTicketsR shar proj = do
|
||||
((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
|
||||
let tf =
|
||||
|
@ -88,7 +88,7 @@ getTicketsR shar proj = do
|
|||
)
|
||||
defaultLayout $(widgetFile "ticket/list")
|
||||
|
||||
postTicketsR :: Text -> Text -> Handler Html
|
||||
postTicketsR :: ShrIdent -> PrjIdent -> Handler Html
|
||||
postTicketsR shar proj = do
|
||||
((result, widget), enctype) <- runFormPost newTicketForm
|
||||
case result of
|
||||
|
@ -127,12 +127,12 @@ postTicketsR shar proj = do
|
|||
setMessage "Ticket creation failed, see errors below."
|
||||
defaultLayout $(widgetFile "ticket/new")
|
||||
|
||||
getTicketNewR :: Text -> Text -> Handler Html
|
||||
getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
|
||||
getTicketNewR shar proj = do
|
||||
((_result, widget), enctype) <- runFormPost newTicketForm
|
||||
defaultLayout $(widgetFile "ticket/new")
|
||||
|
||||
getTicketR :: Text -> Text -> Int -> Handler Html
|
||||
getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
getTicketR shar proj num = do
|
||||
(author, closer, ticket) <- runDB $ do
|
||||
Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar
|
||||
|
@ -155,7 +155,7 @@ getTicketR shar proj num = do
|
|||
(TicketReplyR shar proj num)
|
||||
defaultLayout $(widgetFile "ticket/one")
|
||||
|
||||
putTicketR :: Text -> Text -> Int -> Handler Html
|
||||
putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
putTicketR shar proj num = do
|
||||
Entity tid ticket <- runDB $ do
|
||||
Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar
|
||||
|
@ -175,13 +175,13 @@ putTicketR shar proj num = do
|
|||
setMessage "Ticket update failed, see errors below."
|
||||
defaultLayout $(widgetFile "ticket/edit")
|
||||
|
||||
deleteTicketR :: Text -> Text -> Int -> Handler Html
|
||||
deleteTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
deleteTicketR shar proj num =
|
||||
--TODO: I can easily implement this, but should it even be possible to
|
||||
--delete tickets?
|
||||
error "Not implemented"
|
||||
|
||||
postTicketR :: Text -> Text -> Int -> Handler Html
|
||||
postTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
postTicketR shar proj num = do
|
||||
mmethod <- lookupPostParam "_method"
|
||||
case mmethod of
|
||||
|
@ -189,7 +189,7 @@ postTicketR shar proj num = do
|
|||
Just "DELETE" -> deleteTicketR shar proj num
|
||||
_ -> notFound
|
||||
|
||||
getTicketEditR :: Text -> Text -> Int -> Handler Html
|
||||
getTicketEditR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
getTicketEditR shar proj num = do
|
||||
Entity _tid ticket <- runDB $ do
|
||||
Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar
|
||||
|
@ -199,35 +199,35 @@ getTicketEditR shar proj num = do
|
|||
((_result, widget), enctype) <- runFormPost $ editTicketForm ticket user
|
||||
defaultLayout $(widgetFile "ticket/edit")
|
||||
|
||||
selectDiscussionId :: Text -> Text -> Int -> AppDB DiscussionId
|
||||
selectDiscussionId :: ShrIdent -> PrjIdent -> Int -> AppDB DiscussionId
|
||||
selectDiscussionId shar proj tnum = do
|
||||
Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar
|
||||
Entity pid _project <- getBy404 $ UniqueProject proj sid
|
||||
Entity _tid ticket <- getBy404 $ UniqueTicket pid tnum
|
||||
return $ ticketDiscuss ticket
|
||||
|
||||
getTicketDiscussionR :: Text -> Text -> Int -> Handler Html
|
||||
getTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
getTicketDiscussionR shar proj num =
|
||||
getDiscussion
|
||||
(TicketReplyR shar proj num)
|
||||
(TicketTopReplyR shar proj num)
|
||||
(selectDiscussionId shar proj num)
|
||||
|
||||
postTicketDiscussionR :: Text -> Text -> Int -> Handler Html
|
||||
postTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
postTicketDiscussionR shar proj num =
|
||||
postTopReply
|
||||
(TicketDiscussionR shar proj num)
|
||||
(const $ TicketR 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 =
|
||||
getMessage
|
||||
(TicketReplyR shar proj tnum)
|
||||
(selectDiscussionId shar proj tnum)
|
||||
cnum
|
||||
|
||||
postTicketMessageR :: Text -> Text -> Int -> Int -> Handler Html
|
||||
postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
|
||||
postTicketMessageR shar proj tnum cnum =
|
||||
postReply
|
||||
(TicketReplyR shar proj tnum)
|
||||
|
@ -236,11 +236,11 @@ postTicketMessageR shar proj tnum cnum =
|
|||
(selectDiscussionId shar proj tnum)
|
||||
cnum
|
||||
|
||||
getTicketTopReplyR :: Text -> Text -> Int -> Handler Html
|
||||
getTicketTopReplyR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
getTicketTopReplyR 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 =
|
||||
getReply
|
||||
(TicketReplyR shar proj tnum)
|
||||
|
|
|
@ -13,7 +13,7 @@
|
|||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
module Vervis.Model where
|
||||
|
||||
|
@ -24,6 +24,7 @@ import Database.Persist.Quasi
|
|||
import Database.Persist.Sql (fromSqlKey)
|
||||
import Yesod.Auth.HashDB (HashDBUser (..))
|
||||
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Model.Repo
|
||||
|
||||
-- You can define all of your database entities in the entities file.
|
||||
|
|
50
src/Vervis/Model/Ident.hs
Normal file
50
src/Vervis/Model/Ident.hs
Normal 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,28 +24,34 @@ where
|
|||
|
||||
import Prelude
|
||||
|
||||
import Data.Text (Text, unpack)
|
||||
import Data.Text (Text)
|
||||
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.Model.Ident
|
||||
import Vervis.Settings
|
||||
|
||||
askRepoRootDir :: Handler FilePath
|
||||
askRepoRootDir = appRepoDir . appSettings <$> getYesod
|
||||
askRepoRootDir = getsYesod $ appRepoDir . appSettings
|
||||
|
||||
sharerDir :: FilePath -> Text -> FilePath
|
||||
sharerDir root sharer = root </> unpack sharer
|
||||
sharerDir :: FilePath -> ShrIdent -> FilePath
|
||||
sharerDir root sharer =
|
||||
root </> (T.unpack $ CI.foldedCase $ unShrIdent sharer)
|
||||
|
||||
askSharerDir :: Text -> Handler FilePath
|
||||
askSharerDir :: ShrIdent -> Handler FilePath
|
||||
askSharerDir sharer = do
|
||||
root <- askRepoRootDir
|
||||
return $ sharerDir root sharer
|
||||
|
||||
repoDir :: FilePath -> Text -> Text -> FilePath
|
||||
repoDir root sharer repo = sharerDir root sharer </> unpack repo
|
||||
repoDir :: FilePath -> ShrIdent -> RpIdent -> FilePath
|
||||
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
|
||||
root <- askRepoRootDir
|
||||
return $ repoDir root sharer repo
|
||||
|
|
30
src/Web/PathPieces/Local.hs
Normal file
30
src/Web/PathPieces/Local.hs
Normal 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
|
|
@ -60,11 +60,14 @@ library
|
|||
Data.Text.Lazy.UTF8.Local
|
||||
Data.Time.Clock.Local
|
||||
Data.Tree.Local
|
||||
Database.Esqueleto.Local
|
||||
Database.Persist.Class.Local
|
||||
Database.Persist.Sql.Local
|
||||
Development.DarcsRev
|
||||
Network.SSH.Local
|
||||
Text.FilePath.Local
|
||||
Text.Jasmine.Local
|
||||
Web.PathPieces.Local
|
||||
Yesod.Paginate.Local
|
||||
|
||||
Vervis.Application
|
||||
|
@ -97,11 +100,11 @@ library
|
|||
Vervis.Handler.Repo.Darcs
|
||||
Vervis.Handler.Repo.Git
|
||||
Vervis.Handler.Ticket
|
||||
Vervis.Handler.Util
|
||||
Vervis.Import
|
||||
Vervis.Import.NoFoundation
|
||||
Vervis.MediaType
|
||||
Vervis.Model
|
||||
Vervis.Model.Ident
|
||||
Vervis.Model.Repo
|
||||
Vervis.Paginate
|
||||
Vervis.Path
|
||||
|
@ -197,6 +200,8 @@ library
|
|||
, monad-logger
|
||||
, pandoc
|
||||
, pandoc-types
|
||||
-- for PathPiece instance for CI, Web.PathPieces.Local
|
||||
, path-pieces
|
||||
, persistent
|
||||
, persistent-postgresql
|
||||
, persistent-template
|
||||
|
|
Loading…
Reference in a new issue