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:
fr33domlover 2016-05-23 12:24:14 +00:00
parent 3a65568d8f
commit 49807ed27f
20 changed files with 277 additions and 169 deletions

View file

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

View file

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

View file

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

View file

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

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

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

View file

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