diff --git a/config/models b/config/models index 5f4fa7e..da23a52 100644 --- a/config/models +++ b/config/models @@ -13,10 +13,10 @@ -- . Sharer - ident TextCI - name Text Maybe + ident ShrIdent + name Text Maybe - UniqueSharerIdent ident + UniqueSharer ident Person ident SharerId @@ -28,12 +28,12 @@ Person UniquePersonLogin login SshKey + ident KyIdent person PersonId - name Text algo ByteString content ByteString - UniqueSshKey person name + UniqueSshKey person ident Group ident SharerId @@ -41,7 +41,7 @@ Group UniqueGroupIdent ident Project - ident TextCI + ident PrjIdent sharer SharerId name Text Maybe desc Text Maybe @@ -50,7 +50,7 @@ Project UniqueProject ident sharer Repo - ident TextCI + ident RpIdent sharer SharerId vcs VersionControlSystem default='VCSGit' project ProjectId Maybe diff --git a/src/Data/CaseInsensitive/Local.hs b/src/Data/CaseInsensitive/Local.hs new file mode 100644 index 0000000..1d49e1a --- /dev/null +++ b/src/Data/CaseInsensitive/Local.hs @@ -0,0 +1,48 @@ +{- 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 + - . + -} + +-- | CI views for avoiding ambiguity in the meaning of some typeclass +-- instances, and allow two instances to coexist. For example, does 'show' show +-- the original or the case-folded version? Using CI views, it's easy to +-- specify that. +-- +-- Note that some of the instances provided here, i.e. instances 'CI' already +-- has, are reused directly by both views. If you aren't sure about a specific +-- instance, check the source. +module Data.CaseInsensitive.Local + ( AsOriginal (..) + , mkOrig + , AsCaseFolded (..) + , mkFolded + ) +where + +import Prelude + +import Data.CaseInsensitive +import Data.Hashable (Hashable) +import Data.String (IsString) + +newtype AsOriginal s = AsOriginal { unOriginal :: CI s } + deriving (Eq, Ord, Read, Show, IsString, Monoid, Hashable, FoldCase) + +mkOrig :: FoldCase s => s -> AsOriginal s +mkOrig = AsOriginal . mk + +newtype AsCaseFolded s = AsCaseFolded { unCaseFolded :: CI s } + deriving (Eq, Ord, Read, Show, IsString, Monoid, Hashable, FoldCase) + +mkFolded :: FoldCase s => s -> AsCaseFolded s +mkFolded = AsCaseFolded . mk diff --git a/src/Database/Esqueleto/Local.hs b/src/Database/Esqueleto/Local.hs index 38ff2dd..c25df83 100644 --- a/src/Database/Esqueleto/Local.hs +++ b/src/Database/Esqueleto/Local.hs @@ -25,4 +25,6 @@ import Database.Esqueleto import qualified Data.CaseInsensitive as CI -instance SqlString s => SqlString (CI s) +import Database.Persist.Class.Local () + +instance (SqlString s, CI.FoldCase s) => SqlString (CI s) diff --git a/src/Formatting/CaseInsensitive.hs b/src/Formatting/CaseInsensitive.hs new file mode 100644 index 0000000..62a0c69 --- /dev/null +++ b/src/Formatting/CaseInsensitive.hs @@ -0,0 +1,33 @@ +{- 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 Formatting.CaseInsensitive + ( ciOrig + , ciFolded + ) +where + +import Prelude + +import Data.CaseInsensitive +import Data.Text (Text) +import Data.Text.Lazy.Builder (fromText) +import Formatting + +ciOrig :: Format r (CI Text -> r) +ciOrig = later $ fromText . original + +ciFolded :: Format r (CI Text -> r) +ciFolded = later $ fromText . foldedCase diff --git a/src/Text/Blaze/Local.hs b/src/Text/Blaze/Local.hs index 186533f..5f7b820 100644 --- a/src/Text/Blaze/Local.hs +++ b/src/Text/Blaze/Local.hs @@ -25,6 +25,12 @@ import Text.Blaze import qualified Data.CaseInsensitive as CI -instance ToMarkup s => ToMarkup (CI s) where - toMarkup = toMarkup . CI.original - preEscapedToMarkup = preEscapedToMarkup . CI.original +import qualified Data.CaseInsensitive.Local as CIL + +instance ToMarkup s => ToMarkup (CIL.AsOriginal s) where + toMarkup = toMarkup . CI.original . CIL.unOriginal + preEscapedToMarkup = preEscapedToMarkup . CI.original . CIL.unOriginal + +instance ToMarkup s => ToMarkup (CIL.AsCaseFolded s) where + toMarkup = toMarkup . CI.foldedCase . CIL.unCaseFolded + preEscapedToMarkup = preEscapedToMarkup . CI.foldedCase . CIL.unCaseFolded diff --git a/src/Vervis/Field/Key.hs b/src/Vervis/Field/Key.hs index b2f8993..cc620b1 100644 --- a/src/Vervis/Field/Key.hs +++ b/src/Vervis/Field/Key.hs @@ -29,6 +29,7 @@ import Data.Maybe (isNothing) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) +import Database.Esqueleto import Database.Persist (checkUnique) import Yesod.Form.Fields (textField) import Yesod.Form.Functions (check, checkBool, checkM, convertField) @@ -42,6 +43,7 @@ import Data.Char.Local (isAsciiLetter) import Network.SSH.Local (supportedKeyAlgos) import Vervis.Foundation import Vervis.Model +import Vervis.Model.Ident (text2ky) mkBsField :: Field Handler Text -> Field Handler ByteString mkBsField = convertField encodeUtf8 (decodeUtf8With lenientDecode) @@ -50,16 +52,16 @@ bsField :: Field Handler ByteString bsField = mkBsField textField checkNameUnique :: PersonId -> Field Handler Text -> Field Handler Text -checkNameUnique pid = checkM $ \ name -> runDB $ do - let key = SshKey - { sshKeyPerson = pid - , sshKeyName = name - , sshKeyAlgo = mempty - , sshKeyContent = mempty - } - muk <- checkUnique key - return $ if isNothing muk - then Right name +checkNameUnique pid = checkM $ \ ident -> do + let ident' = text2ky ident + sames <- runDB $ select $ from $ \ key -> do + where_ $ + key ^. SshKeyPerson ==. val pid &&. + lower_ (key ^. SshKeyIdent) ==. lower_ (val ident') + limit 1 + return () + return $ if null sames + then Right ident else Left ("You already have a key with this label" :: Text) nameField :: PersonId -> Field Handler Text diff --git a/src/Vervis/Field/Person.hs b/src/Vervis/Field/Person.hs index fcd5a97..0ffd2b5 100644 --- a/src/Vervis/Field/Person.hs +++ b/src/Vervis/Field/Person.hs @@ -25,6 +25,7 @@ import Data.Char (isDigit) import Database.Esqueleto import Data.Char.Local (isAsciiLetter) +import Vervis.Model.Ident (text2shr) checkLoginTemplate :: Field Handler Text -> Field Handler Text checkLoginTemplate = @@ -43,8 +44,9 @@ checkLoginTemplate = checkLoginUnique :: Field Handler Text -> Field Handler Text checkLoginUnique = checkM $ \ login -> do + let login' = text2shr login sames <- runDB $ select $ from $ \ sharer -> do - where_ $ lower_ (sharer ^. SharerIdent) ==. lower_ (val login) + where_ $ lower_ (sharer ^. SharerIdent) ==. lower_ (val login') limit 1 return () return $ if null sames diff --git a/src/Vervis/Field/Project.hs b/src/Vervis/Field/Project.hs index c064b10..737bf49 100644 --- a/src/Vervis/Field/Project.hs +++ b/src/Vervis/Field/Project.hs @@ -18,11 +18,14 @@ module Vervis.Field.Project ) where -import Vervis.Import +import Vervis.Import hiding ((==.)) import Data.Char (isDigit) import Data.Char.Local (isAsciiLetter) import Data.Text (split) +import Database.Esqueleto + +import Vervis.Model.Ident (text2prj) checkIdentTemplate :: Field Handler Text -> Field Handler Text checkIdentTemplate = @@ -37,15 +40,14 @@ checkIdentTemplate = checkIdentUnique :: SharerId -> Field Handler Text -> Field Handler Text checkIdentUnique sid = checkM $ \ ident -> do - let project = Project - { projectIdent = ident - , projectSharer = sid - , projectName = Nothing - , projectDesc = Nothing - , projectNextTicket = 0 - } - mup <- runDB $ checkUnique project - return $ if isNothing mup + let ident' = text2prj ident + sames <- runDB $ select $ from $ \ project -> do + where_ $ + project ^. ProjectSharer ==. val sid &&. + lower_ (project ^. ProjectIdent) ==. lower_ (val ident') + limit 1 + return () + return $ if null sames then Right ident else Left ("You already have a project by that name" :: Text) diff --git a/src/Vervis/Field/Repo.hs b/src/Vervis/Field/Repo.hs index 46aa34e..88e7a17 100644 --- a/src/Vervis/Field/Repo.hs +++ b/src/Vervis/Field/Repo.hs @@ -18,11 +18,14 @@ module Vervis.Field.Repo ) where -import Vervis.Import +import Vervis.Import hiding ((==.)) import Data.Char (isDigit) import Data.Char.Local (isAsciiLetter) import Data.Text (split) +import Database.Esqueleto + +import Vervis.Model.Ident (text2rp) checkIdentTemplate :: Field Handler Text -> Field Handler Text checkIdentTemplate = @@ -38,8 +41,14 @@ checkIdentTemplate = -- | Make sure the sharer doesn't already have a repo by the same name. checkIdentUnique :: SharerId -> Field Handler Text -> Field Handler Text checkIdentUnique sid = checkM $ \ ident -> do - mrepo <- runDB $ getBy $ UniqueRepo ident sid - return $ if isNothing mrepo + let ident' = text2rp ident + sames <- runDB $ select $ from $ \ repo -> do + where_ $ + repo ^. RepoSharer ==. val sid &&. + lower_ (repo ^. RepoIdent) ==. lower_ (val ident') + limit 1 + return () + return $ if null sames then Right ident else Left ("You already have a repo by that name" :: Text) diff --git a/src/Vervis/Form/Key.hs b/src/Vervis/Form/Key.hs index 46fbf18..eb9849c 100644 --- a/src/Vervis/Form/Key.hs +++ b/src/Vervis/Form/Key.hs @@ -21,11 +21,12 @@ where import Vervis.Import import Vervis.Field.Key +import Vervis.Model.Ident (text2ky) newKeyAForm :: PersonId -> AForm Handler SshKey newKeyAForm pid = SshKey - <$> pure pid - <*> areq (nameField pid) "Name*" Nothing + <$> (text2ky <$> areq (nameField pid) "Name*" Nothing) + <*> pure pid <*> areq algoField "Algorithm*" Nothing <*> areq contentField "Content*" Nothing diff --git a/src/Vervis/Form/Person.hs b/src/Vervis/Form/Person.hs index 2c6d6db..e5f176e 100644 --- a/src/Vervis/Form/Person.hs +++ b/src/Vervis/Form/Person.hs @@ -26,13 +26,15 @@ import Vervis.Field.Person data PersonNew = PersonNew { uLogin :: Text , uPass :: Text + , uName :: Maybe Text , uEmail :: Maybe Text } newPersonAForm :: AForm Handler PersonNew newPersonAForm = PersonNew - <$> areq loginField "Username" Nothing - <*> areq passField "Password" Nothing + <$> areq loginField "Username*" Nothing + <*> areq passField "Password*" Nothing + <*> aopt textField "Full name" Nothing <*> aopt emailField "E-mail" Nothing formPersonNew :: Form PersonNew diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs index 5b4fb74..6e8ed88 100644 --- a/src/Vervis/Form/Project.hs +++ b/src/Vervis/Form/Project.hs @@ -21,10 +21,11 @@ where import Vervis.Import import Vervis.Field.Project +import Vervis.Model.Ident (text2prj) newProjectAForm :: SharerId -> AForm Handler Project newProjectAForm sid = Project - <$> areq (mkIdentField sid) "Identifier*" Nothing + <$> (text2prj <$> areq (mkIdentField sid) "Identifier*" Nothing) <*> pure sid <*> aopt textField "Name" Nothing <*> aopt textField "Description" Nothing diff --git a/src/Vervis/Form/Repo.hs b/src/Vervis/Form/Repo.hs index bccfa21..6ce5614 100644 --- a/src/Vervis/Form/Repo.hs +++ b/src/Vervis/Form/Repo.hs @@ -22,11 +22,12 @@ where import Vervis.Import import Vervis.Field.Repo +import Vervis.Model.Ident (prj2text, text2rp) import Vervis.Model.Repo newRepoAForm :: SharerId -> Maybe ProjectId -> AForm Handler Repo newRepoAForm sid mpid = Repo - <$> areq (mkIdentField sid) "Identifier*" Nothing + <$> (text2rp <$> areq (mkIdentField sid) "Identifier*" Nothing) <*> pure sid <*> areq (selectFieldList vcsList) "Version control system*" Nothing <*> aopt selectProject "Project" (Just mpid) @@ -40,8 +41,8 @@ newRepoAForm sid mpid = Repo ] selectProject = selectField $ - optionsPersistKey - [ProjectSharer ==. sid] [Asc ProjectIdent] projectIdent + optionsPersistKey [ProjectSharer ==. sid] [Asc ProjectIdent] $ + prj2text . projectIdent newRepoForm :: SharerId -> Maybe ProjectId -> Form Repo newRepoForm sid mpid = renderDivs $ newRepoAForm sid mpid diff --git a/src/Vervis/Formatting.hs b/src/Vervis/Formatting.hs new file mode 100644 index 0000000..f8066d1 --- /dev/null +++ b/src/Vervis/Formatting.hs @@ -0,0 +1,58 @@ +{- 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 Vervis.Formatting + ( sharer + , sharerl + , key + , keyl + , project + , projectl + , repo + , repol + ) +where + +import Prelude + +import Data.CaseInsensitive +import Data.Text.Lazy.Builder (fromText) +import Formatting + +import Vervis.Model.Ident + +sharer :: Format r (ShrIdent -> r) +sharer = later $ fromText . original . unShrIdent + +sharerl :: Format r (ShrIdent -> r) +sharerl = later $ fromText . foldedCase . unShrIdent + +key :: Format r (KyIdent -> r) +key = later $ fromText . original . unKyIdent + +keyl :: Format r (KyIdent -> r) +keyl = later $ fromText . foldedCase . unKyIdent + +project :: Format r (PrjIdent -> r) +project = later $ fromText . original . unPrjIdent + +projectl :: Format r (PrjIdent -> r) +projectl = later $ fromText . foldedCase . unPrjIdent + +repo :: Format r (RpIdent -> r) +repo = later $ fromText . original . unRpIdent + +repol :: Format r (RpIdent -> r) +repol = later $ fromText . foldedCase . unRpIdent diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 0b6d843..7333aba 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -120,12 +120,9 @@ instance Yesod App where loggedInAs user "You can’t create projects for other users" isAuthorized (RepoNewR user) _ = loggedInAs user "You can’t create repos for other users" - isAuthorized (KeysR user) _ = - loggedInAs user "You can’t watch keys of other users" - isAuthorized (KeyR user _key) _ = - loggedInAs user "You can’t watch keys of other users" - isAuthorized (KeyNewR user) _ = - loggedInAs user "You can’t add keys for other users" + isAuthorized KeysR _ = loggedIn + isAuthorized (KeyR _key) _ = loggedIn + isAuthorized KeyNewR _ = loggedIn isAuthorized (RepoR shar _) True = loggedInAs shar "You can’t modify repos for other users" isAuthorized (TicketNewR _ _) _ = loggedIn @@ -191,22 +188,6 @@ instance YesodAuth App where return $ case mpid of Nothing -> UserError $ IdentifierNotFound ident Just (Entity pid _) -> Authenticated pid - {-ps <- select $ from $ \ (sharer, person) -> do - where_ $ - sharer ^. SharerIdent ==. val ident &&. - sharer ^. SharerId ==. person ^. PersonIdent - return (person ^. PersonId, person ^. PersonHash)-} - {-case x of - Just (Entity uid _) -> return $ Authenticated uid - Nothing -> Authenticated <$> insert User - { userIdent = credsIdent creds - , userPassword = Nothing - }-} - {-return $ case ps of - [] -> UserError $ IdentifierNotFound ident - [(pid, phash)] -> - _ -> ServerError "Data model error, non-unique ident" - -} -- You can add other plugins like BrowserID, email or OAuth here authPlugins _ = [authHashDB $ Just . UniquePersonLogin] @@ -245,7 +226,7 @@ loggedIn = do Nothing -> return AuthenticationRequired Just _pid -> return Authorized -loggedInAs :: Text -> Text -> Handler AuthResult +loggedInAs :: ShrIdent -> Text -> Handler AuthResult loggedInAs ident msg = do mp <- maybeAuth case mp of @@ -269,15 +250,15 @@ instance YesodBreadcrumbs App where PeopleR -> ("People", Just HomeR) PersonNewR -> ("New", Just PeopleR) - PersonR shar -> (shar, Just PeopleR) + PersonR shar -> (shr2text shar, Just PeopleR) - KeysR shar -> ("Keys", Just $ PersonR shar) - KeyNewR shar -> ("New", Just $ KeysR shar) - KeyR shar key -> (key, Just $ KeysR shar) + KeysR -> ("Keys", Just HomeR) + KeyNewR -> ("New", Just KeysR) + KeyR key -> (ky2text key, Just KeysR) ReposR shar -> ("Repos", Just $ PersonR shar) RepoNewR shar -> ("New", Just $ ReposR shar) - RepoR shar repo -> (repo, Just $ ReposR shar) + RepoR shar repo -> (rp2text repo, Just $ ReposR shar) RepoSourceR shar repo [] -> ("Files", Just $ RepoR shar repo) RepoSourceR shar repo refdir -> ( last refdir , Just $ @@ -291,7 +272,9 @@ instance YesodBreadcrumbs App where ProjectsR shar -> ("Projects", Just $ PersonR shar) ProjectNewR shar -> ("New", Just $ ProjectsR shar) - ProjectR shar proj -> (proj, Just $ ProjectsR shar) + ProjectR shar proj -> ( prj2text proj + , Just $ ProjectsR shar + ) TicketsR shar proj -> ( "Tickets" , Just $ ProjectR shar proj diff --git a/src/Vervis/Handler/Git.hs b/src/Vervis/Handler/Git.hs index b3d5f00..9dae75b 100644 --- a/src/Vervis/Handler/Git.hs +++ b/src/Vervis/Handler/Git.hs @@ -37,11 +37,12 @@ import Yesod.Core.Handler import Vervis.BinaryBody (decodeRequestBody) import Vervis.Content import Vervis.Foundation (Handler) +import Vervis.Model.Ident import Vervis.Path (askRepoDir) getGitRefDiscoverR :: ShrIdent -> RpIdent -> Handler GitRefDiscovery getGitRefDiscoverR shar repo = do - path <- askRepoDir sharer repo + path <- askRepoDir shar repo let pathG = fromString path seemsThere <- liftIO $ isRepo pathG if seemsThere diff --git a/src/Vervis/Handler/Home.hs b/src/Vervis/Handler/Home.hs index a5175e8..751ba57 100644 --- a/src/Vervis/Handler/Home.hs +++ b/src/Vervis/Handler/Home.hs @@ -25,6 +25,7 @@ import Vervis.GitOld import qualified Database.Esqueleto as E ((==.)) +import Vervis.Model.Ident import Vervis.Model.Repo import Vervis.Path @@ -46,18 +47,16 @@ intro = do , repo ^. RepoIdent , repo ^. RepoVcs ) - root <- askRepoRootDir - liftIO $ forM repos $ + forM repos $ \ (Value sharer, Value mproj, Value repo, Value vcs) -> do ago <- case vcs of VCSDarcs -> return "[Not implemented yet]" VCSGit -> do - let path = - root unpack sharer unpack repo - mdt <- lastChange path + path <- askRepoDir sharer repo + mdt <- liftIO $ lastChange path case mdt of Nothing -> return "never" - Just dt -> timeAgo dt + Just dt -> liftIO $ timeAgo dt return (sharer, mproj, repo, vcs, ago) defaultLayout $ do setTitle "Welcome to Vervis!" diff --git a/src/Vervis/Handler/Key.hs b/src/Vervis/Handler/Key.hs index 211ebd9..e9eee88 100644 --- a/src/Vervis/Handler/Key.hs +++ b/src/Vervis/Handler/Key.hs @@ -32,6 +32,7 @@ import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Database.Persist import Text.Blaze.Html (Html, toHtml) +import Yesod.Auth (requireAuthId) import Yesod.Core (defaultLayout) import Yesod.Core.Handler import Yesod.Core.Widget (setTitle) @@ -42,14 +43,15 @@ import Yesod.Persist.Core (runDB, getBy404) import Vervis.Form.Key import Vervis.Foundation import Vervis.Model +import Vervis.Model.Ident import Vervis.Settings getKeysR :: Handler Html getKeysR = do pid <- requireAuthId keys <- runDB $ do - ks <- selectList [SshKeyPerson ==. pid] [Asc SshKeyName] - return $ map (\ (Entity _ k) -> sshKeyName k) ks + ks <- selectList [SshKeyPerson ==. pid] [Asc SshKeyIdent] + return $ map (\ (Entity _ k) -> sshKeyIdent k) ks defaultLayout $(widgetFile "key/list") postKeysR :: Handler Html @@ -84,6 +86,7 @@ getKeyR tag = do deleteKeyR :: KyIdent -> Handler Html deleteKeyR tag = do + pid <- requireAuthId runDB $ do Entity kid _k <- getBy404 $ UniqueSshKey pid tag delete kid diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 1ea095b..bc1de78 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -30,6 +30,8 @@ import Vervis.Form.Person import Text.Blaze.Html (toHtml) import Yesod.Auth.HashDB (setPassword) +import Vervis.Model.Ident + -- | Get list of users getPeopleR :: Handler Html getPeopleR = do @@ -37,14 +39,12 @@ getPeopleR = do where_ $ sharer ^. SharerId ==. person ^. PersonIdent orderBy [asc $ sharer ^. SharerIdent] return $ sharer ^. SharerIdent - defaultLayout $ do - setTitle "Vervis > People" - $(widgetFile "people") + defaultLayout $(widgetFile "people") -- | Create new user postPeopleR :: Handler Html postPeopleR = do - regEnabled <- appRegister . appSettings <$> getYesod + regEnabled <- getsYesod $ appRegister . appSettings if regEnabled then do ((result, widget), enctype) <- runFormPost formPersonNew @@ -52,8 +52,8 @@ postPeopleR = do FormSuccess pn -> do runDB $ do let sharer = Sharer - { sharerIdent = uLogin pn - , sharerName = Nothing + { sharerIdent = text2shr $ uLogin pn + , sharerName = uName pn } sid <- insert sharer let person = Person @@ -68,15 +68,10 @@ postPeopleR = do FormMissing -> do setMessage "Field(s) missing" defaultLayout $(widgetFile "person-new") - FormFailure l -> do - setMessage $ toHtml $ intercalate "; " l + FormFailure _l -> do + setMessage "User registration failed, see errors below" defaultLayout $(widgetFile "person-new") else notFound - --TODO NEXT: - -- * Maybe make the form return Form Person and just insert defaults (using - -- 'pure') for the remaining Person fields? Then, maybe the same form can - -- be used to generate the RESTful JSON API query that adds a Person with - -- their entire details. Dunno if it matters, just could be good/nice/cool. getPersonNewR :: Handler Html getPersonNewR = do @@ -96,7 +91,7 @@ getPersonNewR = do getPersonR :: ShrIdent -> Handler Html getPersonR ident = do person <- runDB $ do - Entity sid _s <- getBy404 $ UniqueSharerIdent ident + Entity sid _s <- getBy404 $ UniqueSharer ident Entity _pid p <- getBy404 $ UniquePersonIdent sid return p defaultLayout $(widgetFile "person") diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 3cb0bbd..0119534 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -39,6 +39,7 @@ import qualified Database.Esqueleto as E import Vervis.Form.Project import Vervis.Foundation import Vervis.Model +import Vervis.Model.Ident import Vervis.Model.Repo import Vervis.Settings @@ -79,7 +80,7 @@ getProjectNewR ident = do getProjectR :: ShrIdent -> PrjIdent -> Handler Html getProjectR shar proj = do (project, repos) <- runDB $ do - Entity sid _s <- getBy404 $ UniqueSharerIdent shar + Entity sid _s <- getBy404 $ UniqueSharer shar Entity pid p <- getBy404 $ UniqueProject proj sid rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent] return (p, rs) diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 0368cb6..b84eaa3 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -29,6 +29,8 @@ where import Prelude +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger (logWarn) import Data.Git.Graph import Data.Git.Harder import Data.Git.Named (RefName (..)) @@ -40,15 +42,24 @@ import Data.Git.Types (Blob (..), Commit (..), Person (..), entName) import Data.Graph.Inductive.Graph (noNodes) import Data.Graph.Inductive.Query.Topsort import Data.List (inits) -import Data.Text (unpack) +import Data.Text (Text, unpack) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Database.Esqueleto hiding (delete, (%)) +import Database.Persist (delete) import Data.Hourglass (timeConvert) import Formatting (sformat, stext, (%)) import System.Directory import System.Hourglass (dateCurrent) +import Text.Blaze.Html (Html) +import Yesod.Auth (requireAuth) +import Yesod.Core (defaultLayout, setMessage) +import Yesod.Core.Handler (lookupPostParam, redirect, notFound) +import Yesod.Form.Functions (runFormPost) +import Yesod.Form.Types (FormResult (..)) +import Yesod.Persist.Core (runDB, getBy404) +import qualified Data.CaseInsensitive as CI (foldedCase) import qualified Data.DList as D import qualified Data.Set as S (member) import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With) @@ -63,6 +74,7 @@ import Vervis.Handler.Repo.Git import Vervis.Path import Vervis.MediaType (chooseMediaType) import Vervis.Model +import Vervis.Model.Ident import Vervis.Model.Repo import Vervis.Paginate import Vervis.Readme @@ -76,6 +88,7 @@ import qualified Darcs.Local.Repository as D (createRepo) import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Data.Git.Local as G (createRepo) import qualified Vervis.Darcs as D (readSourceView, readChangesView) +import qualified Vervis.Formatting as F import qualified Vervis.Git as G (readSourceView, readChangesView, listRefs) getReposR :: ShrIdent -> Handler Html @@ -86,7 +99,7 @@ getReposR user = do sharer ^. SharerId ==. repo ^. RepoSharer orderBy [asc $ repo ^. RepoIdent] return $ repo ^. RepoIdent - defaultLayout $(widgetFile "repo/repos") + defaultLayout $(widgetFile "repo/list") postReposR :: ShrIdent -> Handler Html postReposR user = do @@ -98,7 +111,8 @@ postReposR user = do parent <- askSharerDir user liftIO $ do createDirectoryIfMissing True parent - let repoName = unpack $ repoIdent repo + let repoName = + unpack $ CI.foldedCase $ unRpIdent $ repoIdent repo case repoVcs repo of VCSDarcs -> D.createRepo parent repoName VCSGit -> G.createRepo parent repoName @@ -107,21 +121,21 @@ postReposR user = do redirect $ ReposR user FormMissing -> do setMessage "Field(s) missing" - defaultLayout $(widgetFile "repo/repo-new") + defaultLayout $(widgetFile "repo/new") FormFailure _l -> do setMessage "Repo creation failed, see errors below" - defaultLayout $(widgetFile "repo/repo-new") + defaultLayout $(widgetFile "repo/new") getRepoNewR :: ShrIdent -> Handler Html getRepoNewR user = do Entity _pid person <- requireAuth let sid = personIdent person ((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing - defaultLayout $(widgetFile "repo/repo-new") + defaultLayout $(widgetFile "repo/new") selectRepo :: ShrIdent -> RpIdent -> AppDB Repo selectRepo shar repo = do - Entity sid _s <- getBy404 $ UniqueSharerIdent shar + Entity sid _s <- getBy404 $ UniqueSharer shar Entity _rid r <- getBy404 $ UniqueRepo repo sid return r @@ -137,7 +151,7 @@ getRepoR shar repo = do deleteRepoR :: ShrIdent -> RpIdent -> Handler Html deleteRepoR shar repo = do runDB $ do - Entity sid _s <- getBy404 $ UniqueSharerIdent shar + Entity sid _s <- getBy404 $ UniqueSharer shar Entity rid _r <- getBy404 $ UniqueRepo repo sid delete rid path <- askRepoDir shar repo @@ -146,7 +160,7 @@ deleteRepoR shar repo = do then liftIO $ removeDirectoryRecursive path else $logWarn $ sformat - ( "Deleted repo " % stext % "/" % stext + ( "Deleted repo " % F.sharer % "/" % F.repo % " from DB but repo dir doesn't exist" ) shar repo diff --git a/src/Vervis/Handler/Repo/Darcs.hs b/src/Vervis/Handler/Repo/Darcs.hs index 7f33ad1..a3c54bd 100644 --- a/src/Vervis/Handler/Repo/Darcs.hs +++ b/src/Vervis/Handler/Repo/Darcs.hs @@ -23,13 +23,19 @@ where import Prelude +import Control.Monad.IO.Class (liftIO) import Data.List (inits) -import Data.Text (unpack) +import Data.Maybe (fromMaybe) +import Data.Text (Text, unpack) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Database.Esqueleto -import System.FilePath (joinPath) +import System.FilePath ((), joinPath) import System.Directory (doesFileExist) +import Text.Blaze.Html (Html) +import Yesod.Core (defaultLayout, setTitle) +import Yesod.Core.Content (TypedContent, typeOctet) +import Yesod.Core.Handler (sendFile, notFound) import qualified Data.DList as D import qualified Data.Set as S (member) @@ -43,6 +49,7 @@ import Vervis.Foundation import Vervis.Path import Vervis.MediaType (chooseMediaType) import Vervis.Model +import Vervis.Model.Ident import Vervis.Model.Repo import Vervis.Paginate import Vervis.Readme @@ -65,10 +72,7 @@ getDarcsRepoSource repository user repo dir = do Just sv -> do let parent = if null dir then [] else init dir dirs = zip parent (tail $ inits parent) - defaultLayout $ do - setTitle $ toHtml $ intercalate " > " - ["Vervis", "People", user, "Repos", repo] - $(widgetFile "repo/source-darcs") + defaultLayout $(widgetFile "repo/source-darcs") getDarcsRepoHeadChanges :: ShrIdent -> RpIdent -> Handler Html getDarcsRepoHeadChanges shar repo = do diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs index 6aec71c..70c138e 100644 --- a/src/Vervis/Handler/Repo/Git.hs +++ b/src/Vervis/Handler/Repo/Git.hs @@ -22,6 +22,7 @@ where import Prelude +import Control.Monad.IO.Class (liftIO) import Data.Git.Graph import Data.Git.Harder import Data.Git.Named (RefName (..)) @@ -33,13 +34,17 @@ import Data.Git.Types (Blob (..), Commit (..), Person (..), entName) import Data.Graph.Inductive.Graph (noNodes) import Data.Graph.Inductive.Query.Topsort import Data.List (inits) -import Data.Text (unpack) +import Data.Maybe (fromMaybe) +import Data.Text (Text, unpack) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Database.Esqueleto import Data.Hourglass (timeConvert) import System.Directory (createDirectoryIfMissing) import System.Hourglass (dateCurrent) +import Text.Blaze.Html (Html) +import Yesod.Core (defaultLayout) +import Yesod.Core.Handler (notFound) import qualified Data.DList as D import qualified Data.Set as S (member) @@ -53,6 +58,7 @@ import Vervis.Foundation import Vervis.Path import Vervis.MediaType (chooseMediaType) import Vervis.Model +import Vervis.Model.Ident import Vervis.Model.Repo import Vervis.Paginate import Vervis.Readme diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 79e5813..dc812db 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -58,10 +58,12 @@ import Vervis.Foundation import Vervis.Handler.Discussion import Vervis.MediaType (MediaType (Markdown)) import Vervis.Model +import Vervis.Model.Ident import Vervis.Render (renderSourceT) import Vervis.Settings (widgetFile) import Vervis.TicketFilter (filterTickets) import Vervis.Widget.Discussion (discussionW) +import Vervis.Widget.Person (sharerLinkW) getTicketsR :: ShrIdent -> PrjIdent -> Handler Html getTicketsR shar proj = do @@ -81,8 +83,7 @@ getTicketsR shar proj = do orderBy [asc $ ticket ^. TicketNumber] return ( ticket ^. TicketNumber - , sharer ^. SharerIdent - , sharer ^. SharerName + , sharer , ticket ^. TicketTitle , ticket ^. TicketDone ) @@ -97,7 +98,7 @@ postTicketsR shar proj = do now <- liftIO getCurrentTime tnum <- runDB $ do Entity pid project <- do - Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar + Entity sid _sharer <- getBy404 $ UniqueSharer shar getBy404 $ UniqueProject proj sid update pid [ProjectNextTicket +=. 1] let discussion = Discussion @@ -135,7 +136,7 @@ getTicketNewR shar proj = do getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketR shar proj num = do (author, closer, ticket) <- runDB $ do - Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar + Entity sid _sharer <- getBy404 $ UniqueSharer shar Entity pid _project <- getBy404 $ UniqueProject proj sid Entity _tid ticket <- getBy404 $ UniqueTicket pid num person <- get404 $ ticketCreator ticket @@ -158,7 +159,7 @@ getTicketR shar proj num = do putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html putTicketR shar proj num = do Entity tid ticket <- runDB $ do - Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar + Entity sid _sharer <- getBy404 $ UniqueSharer shar Entity pid _project <- getBy404 $ UniqueProject proj sid getBy404 $ UniqueTicket pid num user <- requireAuthId @@ -192,7 +193,7 @@ postTicketR shar proj num = do getTicketEditR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketEditR shar proj num = do Entity _tid ticket <- runDB $ do - Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar + Entity sid _sharer <- getBy404 $ UniqueSharer shar Entity pid _project <- getBy404 $ UniqueProject proj sid getBy404 $ UniqueTicket pid num user <- requireAuthId @@ -201,7 +202,7 @@ getTicketEditR shar proj num = do selectDiscussionId :: ShrIdent -> PrjIdent -> Int -> AppDB DiscussionId selectDiscussionId shar proj tnum = do - Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar + Entity sid _sharer <- getBy404 $ UniqueSharer shar Entity pid _project <- getBy404 $ UniqueProject proj sid Entity _tid ticket <- getBy404 $ UniqueTicket pid tnum return $ ticketDiscuss ticket diff --git a/src/Vervis/Model/Ident.hs b/src/Vervis/Model/Ident.hs index 6cd5d46..83230cc 100644 --- a/src/Vervis/Model/Ident.hs +++ b/src/Vervis/Model/Ident.hs @@ -17,9 +17,17 @@ -- and handlers. module Vervis.Model.Ident ( ShrIdent (..) + , shr2text + , text2shr , KyIdent (..) + , ky2text + , text2ky , PrjIdent (..) + , prj2text + , text2prj , RpIdent (..) + , rp2text + , text2rp ) where @@ -32,19 +40,49 @@ import Database.Persist.Class (PersistField) import Database.Persist.Sql (PersistFieldSql) import Web.PathPieces (PathPiece) +import qualified Data.CaseInsensitive as CI + 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 ShrIdent = ShrIdent { unShrIdent :: CI Text } + deriving + (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece) + +shr2text :: ShrIdent -> Text +shr2text = CI.original . unShrIdent + +text2shr :: Text -> ShrIdent +text2shr = ShrIdent . CI.mk newtype KyIdent = KyIdent { unKyIdent :: CI Text } - deriving (PersistField, PersistFieldSql, SqlString, PathPiece) + deriving + (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece) + +ky2text :: KyIdent -> Text +ky2text = CI.original . unKyIdent + +text2ky :: Text -> KyIdent +text2ky = KyIdent . CI.mk newtype PrjIdent = PrjIdent { unPrjIdent :: CI Text } - deriving (PersistField, PersistFieldSql, SqlString, PathPiece) + deriving + (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece) + +prj2text :: PrjIdent -> Text +prj2text = CI.original . unPrjIdent + +text2prj :: Text -> PrjIdent +text2prj = PrjIdent . CI.mk newtype RpIdent = RpIdent { unRpIdent :: CI Text } - deriving (PersistField, PersistFieldSql, SqlString, PathPiece) + deriving + (Eq, Show, Read, PersistField, PersistFieldSql, SqlString, PathPiece) + +rp2text :: RpIdent -> Text +rp2text = CI.original . unRpIdent + +text2rp :: Text -> RpIdent +text2rp = RpIdent . CI.mk diff --git a/src/Vervis/Widget/Discussion.hs b/src/Vervis/Widget/Discussion.hs index 08db0c3..c03093f 100644 --- a/src/Vervis/Widget/Discussion.hs +++ b/src/Vervis/Widget/Discussion.hs @@ -42,6 +42,7 @@ import Vervis.MediaType (MediaType (Markdown)) import Vervis.Model import Vervis.Render (renderSourceT) import Vervis.Settings (widgetFile) +import Vervis.Widget.Person (sharerLinkW) messageW :: UTCTime -> Sharer -> Message -> (Int -> Route App) -> Widget messageW now shr msg reply = diff --git a/src/Vervis/Widget/Person.hs b/src/Vervis/Widget/Person.hs new file mode 100644 index 0000000..c0de691 --- /dev/null +++ b/src/Vervis/Widget/Person.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 Vervis.Widget.Person + ( sharerLinkW + ) +where + +import Prelude + +import Vervis.Foundation +import Vervis.Model +import Vervis.Model.Ident (shr2text) +import Vervis.Settings (widgetFile) + +sharerLinkW :: Sharer -> Widget +sharerLinkW sharer = $(widgetFile "sharer-link") + diff --git a/src/Vervis/Widget/Repo.hs b/src/Vervis/Widget/Repo.hs index 460ca25..707ee93 100644 --- a/src/Vervis/Widget/Repo.hs +++ b/src/Vervis/Widget/Repo.hs @@ -28,9 +28,10 @@ import qualified Data.Text as T (take) import Vervis.Changes import Vervis.Foundation +import Vervis.Model.Ident import Vervis.Settings (widgetFile) -refSelectW :: Text -> Text -> Set Text -> Set Text -> Widget +refSelectW :: ShrIdent -> RpIdent -> Set Text -> Set Text -> Widget refSelectW shar repo branches tags = $(widgetFile "repo/widget/ref-select") changesW :: Foldable f => f LogEntry -> Widget diff --git a/templates/discussion/widget/message.hamlet b/templates/discussion/widget/message.hamlet index a5db0e3..3082780 100644 --- a/templates/discussion/widget/message.hamlet +++ b/templates/discussion/widget/message.hamlet @@ -12,9 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . -
- - #{fromMaybe (sharerIdent shr) $ sharerName shr} +^{sharerLinkW shr}
#{showTime $ messageCreated msg}
diff --git a/templates/homepage.hamlet b/templates/homepage.hamlet index 696c42b..bed5cd5 100644 --- a/templates/homepage.hamlet +++ b/templates/homepage.hamlet @@ -32,14 +32,14 @@ $# . $forall (sharer, mproj, repo, vcs, ago) <- rows - #{sharer} + #{shr2text sharer} $maybe proj <- mproj - #{proj} + #{prj2text proj} $nothing (none) - #{repo} + #{rp2text repo} $case vcs $of VCSDarcs diff --git a/templates/key/keys.hamlet b/templates/key/list.hamlet similarity index 82% rename from templates/key/keys.hamlet rename to templates/key/list.hamlet index 60e9250..35db52f 100644 --- a/templates/key/keys.hamlet +++ b/templates/key/list.hamlet @@ -12,11 +12,11 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . -

These are the SSH keys for user #{user}. +

These are your SSH keys.