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.
2024-12-27 17:24:53 +09:00 · 2016-05-23 12:24:14 +00:00 · 2016-05-23 12:24:14 +00:00 · 49807ed27f
commit 49807ed27f
parent 3a65568d8f
20 changed files with 277 additions and 169 deletions
--- a/config/models
+++ b/config/models
@ -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
--- 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
--- a/src/Database/Esqueleto/Local.hs
+++ b/src/Database/Esqueleto/Local.hs
@ -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)
--- 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
--- a/src/Database/Persist/Sql/Local.hs
+++ b/src/Database/Persist/Sql/Local.hs
@ -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
--- a/src/Text/Blaze/Local.hs
+++ b/src/Text/Blaze/Local.hs
@ -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
--- 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
--- 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
--- 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
--- 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")
--- 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
--- 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
--- 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"
--- 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
--- 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)
--- a/src/Vervis/Model.hs
+++ b/src/Vervis/Model.hs
@ -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.
--- a/src/Vervis/Model/Ident.hs
+++ b/src/Vervis/Model/Ident.hs
@ -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)
--- 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
--- a/src/Web/PathPieces/Local.hs
+++ b/src/Web/PathPieces/Local.hs
@ -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
--- 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