From 49807ed27f785713e09f304ac0df905420cecbea Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 23 May 2016 12:24:14 +0000 Subject: [PATCH] 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. --- config/models | 8 +-- config/routes | 56 +++++++-------- .../Util.hs => Database/Esqueleto/Local.hs} | 14 ++-- src/Database/Persist/Class/Local.hs | 5 +- src/Database/Persist/Sql/Local.hs | 31 +++++++++ src/Text/Blaze/Local.hs | 30 ++++++++ src/Vervis/Foundation.hs | 1 + src/Vervis/Handler/Git.hs | 4 +- src/Vervis/Handler/Key.hs | 69 +++++++------------ src/Vervis/Handler/Person.hs | 6 +- src/Vervis/Handler/Project.hs | 8 +-- src/Vervis/Handler/Repo.hs | 44 ++++-------- src/Vervis/Handler/Repo/Darcs.hs | 14 ++-- src/Vervis/Handler/Repo/Git.hs | 12 ++-- src/Vervis/Handler/Ticket.hs | 30 ++++---- src/Vervis/Model.hs | 3 +- src/Vervis/Model/Ident.hs | 50 ++++++++++++++ src/Vervis/Path.hs | 24 ++++--- src/Web/PathPieces/Local.hs | 30 ++++++++ vervis.cabal | 7 +- 20 files changed, 277 insertions(+), 169 deletions(-) rename src/{Vervis/Handler/Util.hs => Database/Esqueleto/Local.hs} (73%) create mode 100644 src/Database/Persist/Sql/Local.hs create mode 100644 src/Text/Blaze/Local.hs create mode 100644 src/Vervis/Model/Ident.hs create mode 100644 src/Web/PathPieces/Local.hs diff --git a/config/models b/config/models index 17cce1e..5f4fa7e 100644 --- a/config/models +++ b/config/models @@ -13,8 +13,8 @@ -- . 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 diff --git a/config/routes b/config/routes index c245b92..1be8d78 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/src/Vervis/Handler/Util.hs b/src/Database/Esqueleto/Local.hs similarity index 73% rename from src/Vervis/Handler/Util.hs rename to src/Database/Esqueleto/Local.hs index 3a6fc9c..38ff2dd 100644 --- a/src/Vervis/Handler/Util.hs +++ b/src/Database/Esqueleto/Local.hs @@ -13,12 +13,16 @@ - . -} -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) diff --git a/src/Database/Persist/Class/Local.hs b/src/Database/Persist/Class/Local.hs index 4ff1cd3..78312b8 100644 --- a/src/Database/Persist/Class/Local.hs +++ b/src/Database/Persist/Class/Local.hs @@ -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 diff --git a/src/Database/Persist/Sql/Local.hs b/src/Database/Persist/Sql/Local.hs new file mode 100644 index 0000000..aa897f8 --- /dev/null +++ b/src/Database/Persist/Sql/Local.hs @@ -0,0 +1,31 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Text/Blaze/Local.hs b/src/Text/Blaze/Local.hs new file mode 100644 index 0000000..186533f --- /dev/null +++ b/src/Text/Blaze/Local.hs @@ -0,0 +1,30 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 4c03d52..0b6d843 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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 diff --git a/src/Vervis/Handler/Git.hs b/src/Vervis/Handler/Git.hs index 5e153a7..b3d5f00 100644 --- a/src/Vervis/Handler/Git.hs +++ b/src/Vervis/Handler/Git.hs @@ -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 diff --git a/src/Vervis/Handler/Key.hs b/src/Vervis/Handler/Key.hs index 432648b..211ebd9 100644 --- a/src/Vervis/Handler/Key.hs +++ b/src/Vervis/Handler/Key.hs @@ -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 diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 80a289d..1ea095b 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -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") diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index ec9fe11..3cb0bbd 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index fbc3aa5..0368cb6 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -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 diff --git a/src/Vervis/Handler/Repo/Darcs.hs b/src/Vervis/Handler/Repo/Darcs.hs index a69d626..7f33ad1 100644 --- a/src/Vervis/Handler/Repo/Darcs.hs +++ b/src/Vervis/Handler/Repo/Darcs.hs @@ -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" diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs index 7c42e2f..6aec71c 100644 --- a/src/Vervis/Handler/Repo/Git.hs +++ b/src/Vervis/Handler/Repo/Git.hs @@ -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 diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index b121726..79e5813 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -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) diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index b5430cc..90e3ab9 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -13,7 +13,7 @@ - . -} -{-# 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. diff --git a/src/Vervis/Model/Ident.hs b/src/Vervis/Model/Ident.hs new file mode 100644 index 0000000..6cd5d46 --- /dev/null +++ b/src/Vervis/Model/Ident.hs @@ -0,0 +1,50 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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) diff --git a/src/Vervis/Path.hs b/src/Vervis/Path.hs index dd564cb..b9033eb 100644 --- a/src/Vervis/Path.hs +++ b/src/Vervis/Path.hs @@ -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 diff --git a/src/Web/PathPieces/Local.hs b/src/Web/PathPieces/Local.hs new file mode 100644 index 0000000..85cbc55 --- /dev/null +++ b/src/Web/PathPieces/Local.hs @@ -0,0 +1,30 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/vervis.cabal b/vervis.cabal index e84bdaa..2a69dc0 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -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