module Routes.Repo
( getRepoR
, getFileR
, getEditRepoR
, postEditRepoR
, getRenameRepoR
, postRenameRepoR
) where
import ClassyPrelude hiding (Handler, delete, (</>))
import qualified Git
import qualified Log
import qualified System.OsPath as OsPath
import qualified System.OsPath.Internal as OsPath
import qualified Text.Blaze as Blaze
import qualified Yesod
import Data.Text.Encoding (decodeUtf8')
import Database
( EntityField (RepositoryPrivate, RepositorySummary)
, Repository
, Unique (UniqueUserRepo, UniqueUsername)
, User
, repositoryName
, repositoryPrivate
, repositorySummary
)
import Database.Persist (delete, entityKey, entityVal, insert)
import Database.Persist.Sql (update, (=.))
import HagiaSite
( HagiaSite (..)
, Handler
, Route (EditRepoR, FileR, RenameRepoR, RepoR, UserR)
, Widget
, repoPath
)
import Path
( GitBranch (..)
, PathSegment
, makeGitObjectPath
, pathSegmentFromDbString
, toPath
, toText
, (<:>)
)
import System.OsPath (OsPath, (</>))
import Yesod (Html, getYesod, runDB, whamlet)
import Yesod.Auth (maybeAuthId)
userHeader :: PathSegment -> PathSegment -> GitBranch -> Bool -> Widget
userHeader userName repoName branch isOwner =
[whamlet|
<!-- enclosing full width of color -->
<div .w100 style="background: #C8C8C8">
<!-- Real row of content -->
<div .row .content style="gap: 10px">
<div style="font-size: 30px">
<a .seamless-a href=@{UserR userName}>
#{userName}
/
<a .seamless-a href=@{RepoR userName repoName}>
#{repoName}
<div style="margin-left: auto">
<a .seamless-a href=@{RepoR userName repoName}>
overview
<div>
<a .seamless-a href=@{FileR userName repoName branch []}>
files
<div>
history
<div>
wiki
$if isOwner
<div>
<a .seamless-a href=@{EditRepoR userName repoName}>
settings
|]
-- | Check that request if coming from an authorized repo owner
isAuthorizedRepoOwnerOn :: Yesod.Entity User -> Handler Bool
isAuthorizedRepoOwnerOn repoUser = do
mAuthId <- maybeAuthId
pure $ mAuthId == Just (entityKey repoUser)
branchView :: [GitBranch] -> GitBranch -> (GitBranch -> Route HagiaSite) -> Widget
branchView branches selected route =
[whamlet|
<div .row-g5>
Viewing at
<select onchange="location = this.value" style="cursor: pointer">
$forall branch <- branches
<option value=@{route branch} :(branch == selected):selected>
#{branch}
|]
renderFile :: Text -> Blaze.Markup
renderFile =
intercalate (Blaze.preEscapedText "<br>") . map Blaze.text . splitElem '\n'
-- | Main repo view, under "overview" button
getRepoR :: PathSegment -> PathSegment -> Handler Html
getRepoR userName repoName = do
user <- runDB . Yesod.getBy404 $ UniqueUsername (toText userName)
repoKey <-
runDB . Yesod.getBy404 $
UniqueUserRepo (toText repoName) (entityKey user)
projectRoot <- repoPath userName repoName
let repo = entityVal repoKey
let repoLayout w =
Yesod.defaultLayout $
Yesod.setTitle (Yesod.toHtml userName <> "/" <> Yesod.toHtml repoName)
>> w
isOwner <- isAuthorizedRepoOwnerOn user
when (repositoryPrivate repo && not isOwner) $ do
mAuthId <- maybeAuthId
Log.debug $
tshow mAuthId <> " has no access to " <> toText userName <> "/" <> toText repoName
Yesod.permissionDenied "Access not allowed"
HagiaSite{git} <- getYesod
branches' <- liftIO $ map GitBranch <$> Git.getBranches git projectRoot
case fromNullable branches' of
Nothing ->
repoLayout
[whamlet|
^{userHeader userName repoName "none" isOwner}
<div .column-g5 .content style="margin-top: 10px">
This repository is empty
|]
Just branches -> do
let branch = findDefaultBranch branches
rootEntry <- liftIO $ Git.getObject git projectRoot (makeGitObjectPath branch [])
files <- case rootEntry of
Git.Tree xs -> traverse OsPath.fromBytes xs
_other -> pure []
readme <- case findReadme files of
Nothing -> pure ""
Just path ->
liftIO (Git.getObject git projectRoot $ branch <:> path) <&> \case
Git.Blob content -> case decodeUtf8' content of
Right x -> renderFile x
Left _e -> "Binary file not shown"
_ -> "Error fetching file version"
allRecentActivity <- liftIO $ Git.getLastCommits git projectRoot
let (recentTags, recentBranches) = partition Git.isTag allRecentActivity
let recentActivity = take 3 $ take 2 recentTags <> recentBranches
-- not implemented
let threadAmount = 0 :: Int
let issueAmount = 0 :: Int
let patchAmount = 0 :: Int
repoLayout
[whamlet|
^{userHeader userName repoName branch isOwner}
<!-- Repo header with quick access -->
<div .row-g5 .content style="padding-top: 20px; justify-content: space-between; align-items: stretch">
<!-- column of recent commits -->
<div .column-g5 style="width: 50%; margin-left: -10px">
$forall a <- recentActivity
<div .column .w100 style="background: #F5F5F5; padding: 10px; gap: 10px">
<div .row .w100 style="justify-content: space-between">
<div>
<a href=@{FileR userName repoName (GitBranch $ Git.commitHash a) []}>
#{take 8 $ Git.commitHash a}
@
<a href=@{FileR userName repoName (GitBranch $ Git.parentRef a) []}>
#{Git.parentRef a}
—
<a href=@{UserR (pathSegmentFromDbString $ Git.commitAuthor a)}>
#{Git.commitAuthor a}
<div style="font-size: 14px">
#{formatTime defaultTimeLocale "%d.%m.%Y" $ Git.createDate a}
<div .w100>
#{Git.shortCommitMessage a}
<!-- column of recent threads -->
<div .column style="width: 15%; height: 100%">
<div .w100 style="border-bottom: solid; border-width: 1px; border-color: #C8C8C8; font-size: 20px; padding-left: 5px; margin-bottom: 10px">
<a .seamless-a href="./discussion"> discussion
<div .w100 .row style="padding-left: 5px; gap: 10px">
<div .column-g5 style="align-items: flex-end">
<div> #{threadAmount}
<div> #{issueAmount}
<div> #{patchAmount}
<div .column-g5 style="align-items: flex-start">
<div>
<a href=./TODO> Threads
<div>
<a href=./TODO> Issues
<div>
<a href=./TODO> Patches
<!-- column of clone and like -->
<div .column style="width: 25%; height: 100%">
<div .w100 style="border-bottom: solid; border-width: 1px; border-color: #C8C8C8; font-size: 20px; padding-left: 5px; margin-bottom: 10px;">
summary
$maybe summary <- repositorySummary repo
<div .w100 style="padding-left: 5px; padding-right: 5px; margin-bottom: 10px">
#{summary}
<div .w100 .column-g5 style="padding-left: 5px; padding-right: 5px">
<div .w100>
0 stars
<div .w100>
1 contributor
<div .w100>
0 releases
<!-- Readme -->
<div .content style="margin-top: 20px; font-family: monospace; font-size: 15px">
<pre>
#{readme}
<div .content style="margin-top: 20px; border-top: solid; border-width: 1px; border-color: #C8C8C8; padding-top: 20px">
<a href=@{FileR userName repoName branch []}>
Browse files at #{branch}
|]
getFileR :: PathSegment -> PathSegment -> GitBranch -> [PathSegment] -> Handler Html
getFileR userName repoName branch pathPieces = do
repoUser <- runDB . Yesod.getBy404 $ UniqueUsername (toText userName)
repo <-
runDB . Yesod.getBy404 $
UniqueUserRepo (toText repoName) (entityKey repoUser)
projectRoot <- repoPath userName repoName
HagiaSite{git} <- getYesod
isOwner <- isAuthorizedRepoOwnerOn repoUser
when (repositoryPrivate (entityVal repo) && not isOwner) $ do
mAuthId <- maybeAuthId
Log.debug $
tshow mAuthId <> " has no access to " <> toText userName <> "/" <> toText repoName
Yesod.permissionDenied "Access not allowed"
let pathText = foldr (\a b -> a <> "/" <> b) mempty (map toText pathPieces)
branches <- liftIO $ map GitBranch <$> Git.getBranches git projectRoot
entry <- liftIO $ Git.getObject git projectRoot (makeGitObjectPath branch pathPieces)
let content = case entry of
Git.Blob file -> case decodeUtf8' file of
Right x ->
[whamlet|
<div style="font-family: monospace">
<pre>
#{renderFile x}
|]
Left _e -> [whamlet|<div> Binary file, can't render|]
Git.Tree files ->
case traverse (Yesod.fromPathPiece <=< right . decodeUtf8') files of
Nothing -> [whamlet|<div> ERROR: invalid file name!|]
Just files' ->
fileList
userName
repoName
branch
pathPieces
files'
_ -> "Not a file"
where
right (Right x) = Just x
right (Left _) = Nothing
Yesod.defaultLayout $ do
Yesod.setTitle $
Yesod.toHtml repoName
<> "/"
<> Yesod.toHtml userName
<> "/"
<> Yesod.toHtml pathText
let route b = FileR userName repoName b pathPieces
[whamlet|
^{userHeader userName repoName branch isOwner}
<div .column-g5 .content style="margin-top: 10px">
^{branchView branches branch route}
<div .w100>
^{content}
|]
fileList
:: Foldable t
=> PathSegment
-> PathSegment
-> GitBranch
-> [PathSegment]
-> t PathSegment
-> Widget
fileList userName repoName branchName basePath paths =
[whamlet|
<ul .w100>
$forall path <- paths
$with fullPath <- snoc basePath path
<li> <a href=@{FileR userName repoName branchName fullPath}> #{path} </a>
|]
findDefaultBranch :: NonNull [GitBranch] -> GitBranch
findDefaultBranch branches
| "master" `elem` branches = "master"
| "main" `elem` branches = "main"
| "m" `elem` branches = "m"
| otherwise = head branches
findReadme :: [OsPath] -> Maybe OsPath
findReadme entries =
findCaseInsensitive "readme.md"
<|> findCaseInsensitive "readme.txt"
where
findCaseInsensitive name = headMay . filter (\x -> lowercase x == name) $ entries
lowercase = map (charToLower . OsPath.toChar) . OsPath.unpack
data EditRepoForm = EditRepoForm
{ newSummary :: !(Maybe Text)
, private :: !Bool
}
deriving (Eq, Show)
editRepoForm
:: Repository
-> Html
-> Yesod.MForm Handler (Yesod.FormResult EditRepoForm, Widget)
editRepoForm repo =
Yesod.renderDivs $
EditRepoForm
<$> Yesod.aopt
Yesod.textField
"Change short description"
(Just $ repositorySummary repo)
<*> Yesod.areq Yesod.checkBoxField "Private" (Just $ repositoryPrivate repo)
renderEditRepoForm :: PathSegment -> PathSegment -> Widget -> Yesod.Enctype -> Handler Html
renderEditRepoForm userName repoName widget enctype =
Yesod.defaultLayout $ do
Yesod.setTitle "Edit repository"
[whamlet|
^{userHeader userName repoName "TODO" True}
<form method=post action=@{EditRepoR userName repoName} enctype=#{enctype} .column-g5 .content-narrow style="margin-top: 5px">
<a href=@{RenameRepoR userName repoName}>
Rename repo
^{widget}
<button style="align-self: start"> Save
|]
getEditRepoR :: PathSegment -> PathSegment -> Handler Html
getEditRepoR userName repoName = do
user <- runDB . Yesod.getBy404 $ UniqueUsername (toText userName)
repoKey <-
runDB . Yesod.getBy404 $
UniqueUserRepo (toText repoName) (entityKey user)
let repo = entityVal repoKey
whenM (not <$> isAuthorizedRepoOwnerOn user) $ do
mAuthId <- maybeAuthId
Log.debug $
tshow mAuthId <> " has no access to " <> toText userName <> "/" <> toText repoName
Yesod.permissionDenied "Access not allowed"
(widget, enctype) <- Yesod.generateFormPost (editRepoForm repo)
renderEditRepoForm userName repoName widget enctype
postEditRepoR :: PathSegment -> PathSegment -> Handler Html
postEditRepoR userName repoName = do
user <- runDB . Yesod.getBy404 $ UniqueUsername (toText userName)
repoEntity <-
runDB . Yesod.getBy404 $
UniqueUserRepo (toText repoName) (entityKey user)
let repo = entityVal repoEntity
whenM (not <$> isAuthorizedRepoOwnerOn user) $ do
mAuthId <- maybeAuthId
Log.debug $
tshow mAuthId <> " has no access to " <> toText userName <> "/" <> toText repoName
Yesod.permissionDenied "Access not allowed"
((result, widget), enctype) <- Yesod.runFormPost (editRepoForm repo)
let commonRender = renderEditRepoForm userName repoName widget enctype
case result of
Yesod.FormSuccess form -> do
Log.debug $ "Update repo: " <> tshow form
let updates =
catMaybes
[ (RepositorySummary =.) <$> fmap Just (newSummary form)
, Just $ RepositoryPrivate =. private form
]
runDB $ update (entityKey repoEntity) updates
Log.trace "Update repo in DB successful"
Yesod.addMessage "success" "Settings have been saved" >> commonRender
Yesod.FormMissing ->
Yesod.addMessage "failure" "Missing form data" >> commonRender
Yesod.FormFailure msgs -> do
forM_ msgs $ \msg ->
Yesod.addMessage "failure" $ Yesod.toHtml msg
commonRender
renameRepoForm
:: Html -> Yesod.MForm Handler (Yesod.FormResult (Text, Text), Widget)
renameRepoForm =
Yesod.renderDivs $
(,)
<$> Yesod.areq Yesod.textField "Old name" Nothing
<*> Yesod.areq Yesod.textField "New name" Nothing
renderRenameRepoForm :: PathSegment -> PathSegment -> Widget -> Yesod.Enctype -> Handler Html
renderRenameRepoForm userName repoName widget enctype =
Yesod.defaultLayout $ do
Yesod.setTitle "Rename Repository"
[whamlet|
^{userHeader userName repoName "TODO" True}
<form method=post action=@{RenameRepoR userName repoName} enctype=#{enctype} .column-g5 .content-narrow style="margin-top: 5px">
^{widget}
<button style="align-self: start"> Save
|]
getRenameRepoR :: PathSegment -> PathSegment -> Handler Html
getRenameRepoR userName repoName =
Yesod.generateFormPost renameRepoForm
>>= uncurry
(renderRenameRepoForm userName repoName)
postRenameRepoR :: PathSegment -> PathSegment -> Handler Html
postRenameRepoR userName repoName = do
user <- runDB . Yesod.getBy404 $ UniqueUsername (toText userName)
repoKey <- runDB . Yesod.getBy404 $ UniqueUserRepo (toText repoName) (entityKey user)
whenM (not <$> isAuthorizedRepoOwnerOn user) $ do
mAuthId <- maybeAuthId
Log.debug $
tshow mAuthId <> " has no access to " <> toText userName <> "/" <> toText repoName
Yesod.permissionDenied "Access not allowed"
((result, widget), enctype) <- Yesod.runFormPost renameRepoForm
let commonRender = renderRenameRepoForm userName repoName widget enctype
case result of
Yesod.FormMissing ->
Yesod.addMessage "failure" "Missing form data" >> commonRender
Yesod.FormFailure msgs -> do
forM_ msgs $ \msg ->
Yesod.addMessage "failure" $ Yesod.toHtml msg
commonRender
Yesod.FormSuccess (oldName', newName')
| oldName' /= repositoryName (entityVal repoKey) ->
Yesod.addMessage "failure" "Wrong name, try again" >> commonRender
| otherwise -> do
let oldName = pathSegmentFromDbString oldName'
newName <- case Yesod.fromPathPiece newName' of
Just x -> pure x
Nothing -> do
Yesod.addMessage "failure" "Incorrect name"
commonRender
Yesod.sendResponse ("" :: Text) -- TODO does this work?
let oldRepo = entityVal repoKey
let newRepo = oldRepo{repositoryName = newName'}
HagiaSite{projectsRoot, git} <- getYesod
let oldPath = projectsRoot </> toPath userName </> toPath oldName
let newPath = projectsRoot </> toPath userName </> toPath newName
-- might fail if repo exists
newKey <- runDB $ insert newRepo
-- if rename failed, delete new entry
liftIO (Git.renameRepo git oldPath newPath) `onException` runDB (delete newKey)
-- if succeeded, delete old entry
runDB $ delete (entityKey repoKey)
Yesod.addMessage "success" "Repo has been renamed"
Yesod.defaultLayout $ do
Yesod.setTitle "Rename successful"
[whamlet|
<a href=@{RepoR userName newName}>
Go to new location
|]