~ubuntu-branches/ubuntu/trusty/gitit/trusty-proposed : revision 20

1

{-# LANGUAGE ScopedTypeVariables #-}

2

{-

3

4

5

This program is free software; you can redistribute it and/or modify

6

it under the terms of the GNU General Public License as published by

7

the Free Software Foundation; either version 2 of the License, or

8

(at your option) any later version.

9

10

This program is distributed in the hope that it will be useful,

11

but WITHOUT ANY WARRANTY; without even the implied warranty of

12

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

13

GNU General Public License for more details.

14

15

You should have received a copy of the GNU General Public License

16

along with this program; if not, write to the Free Software

17

Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

18

-}

19

20

{- Handlers for wiki functions.

21

-}

22

23

module Network.Gitit.Handlers (

24

handleAny

25

, debugHandler

26

, randomPage

27

, discussPage

28

, createPage

29

, showActivity

30

, goToPage

31

, searchResults

32

, uploadForm

33

, uploadFile

34

, indexPage

35

, categoryPage

36

, categoryListPage

37

, preview

38

, showRawPage

39

, showFileAsText

40

, showPageHistory

41

, showFileHistory

42

, showPage

43

, showPageDiff

44

, showFileDiff

45

, exportPage

46

, updatePage

47

, editPage

48

, deletePage

49

, confirmDelete

50

, showHighlightedSource

51

, expireCache

52

, feedHandler

53

)

54

where

55

import Safe

56

import Network.Gitit.Server

57

import Network.Gitit.Framework

58

import Network.Gitit.Layout

59

import Network.Gitit.Types

60

import Network.Gitit.Feed (filestoreToXmlFeed, FeedConfig(..))

61

import Network.Gitit.Util (orIfNull)

62

import Network.Gitit.Cache (expireCachedFile, lookupCache, cacheContents)

63

import Network.Gitit.ContentTransformer (showRawPage, showFileAsText, showPage,

64

exportPage, showHighlightedSource, preview, applyPreCommitPlugins)

65

import Network.Gitit.Page (readCategories)

66

import Control.Exception (throwIO, catch, try)

67

import System.FilePath

68

import Prelude hiding (catch)

69

import Network.Gitit.State

70

import Text.XHtml hiding ( (</>), dir, method, password, rev )

71

import qualified Text.XHtml as X ( method )

72

import Data.List (intersperse, nub, sortBy, find, isPrefixOf, inits, sort)

73

import Data.Maybe (fromMaybe, mapMaybe, isJust, catMaybes)

74

import Data.Ord (comparing)

75

import Data.Char (toLower, isSpace)

76

import Control.Monad.Reader

77

import qualified Data.ByteString.Lazy as B

78

import qualified Data.ByteString as S

79

import Network.HTTP (urlEncodeVars)

80

import Data.Time (getCurrentTime, addUTCTime)

81

import Data.Time.Clock (diffUTCTime, UTCTime(..))

82

import Data.FileStore

83

import System.Log.Logger (logM, Priority(..))

84

85

handleAny :: Handler

86

handleAny = uriRest $ \uri ->

87

let path' = uriPath uri

88

in do fs <- getFileStore

89

mimetype <- getMimeTypeForExtension

90

(takeExtension path')

91

res <- liftIO $ try

92

(retrieve fs path' Nothing :: IO B.ByteString)

93

case res of

94

Right contents -> ignoreFilters >> -- don't compress

95

(ok $ setContentType mimetype $

96

(toResponse noHtml) {rsBody = contents})

97

-- ugly hack

98

Left NotFound -> mzero

99

Left e -> error (show e)

100

101

debugHandler :: Handler

102

debugHandler = withData $ \(params :: Params) -> do

103

req <- askRq

104

liftIO $ logM "gitit" DEBUG (show req)

105

page <- getPage

106

liftIO $ logM "gitit" DEBUG $ "Page = '" ++ page ++ "'\n" ++

107

show params

108

mzero

109

110

randomPage :: Handler

111

randomPage = do

112

fs <- getFileStore

113

files <- liftIO $ index fs

114

base' <- getWikiBase

115

let pages = map dropExtension $

116

filter (\f -> isPageFile f && not (isDiscussPageFile f)) files

117

if null pages

118

then error "No pages found!"

119

else do

120

secs <- liftIO (fmap utctDayTime getCurrentTime)

121

let newPage = pages !!

122

(truncate (secs * 1000000) `mod` length pages)

123

seeOther (base' ++ urlForPage newPage) $ toResponse $

124

p << "Redirecting to a random page"

125

126

discussPage :: Handler

127

discussPage = do

128

page <- getPage

129

base' <- getWikiBase

130

seeOther (base' ++ urlForPage (if isDiscussPage page then page else ('@':page))) $

131

toResponse "Redirecting to discussion page"

132

133

createPage :: Handler

134

createPage = do

135

page <- getPage

136

base' <- getWikiBase

137

case page of

138

('_':_) -> mzero -- don't allow creation of _index, etc.

139

_ -> formattedPage defaultPageLayout{

140

pgPageName = page

141

, pgTabs = []

142

, pgTitle = "Create " ++ page ++ "?"

143

} $

144

p << [ stringToHtml ("There is no page '" ++ page ++

145

"'. You may create the page by "),

146

anchor ! [href $ base' ++ "/_edit" ++ urlForPage page] <<

147

"clicking here." ]

148

149

uploadForm :: Handler

150

uploadForm = withData $ \(params :: Params) -> do

151

let origPath = pFilename params

152

let wikiname = pWikiname params `orIfNull` takeFileName origPath

153

let logMsg = pLogMsg params

154

let upForm = form ! [X.method "post", enctype "multipart/form-data"] <<

155

fieldset <<

156

[ p << [label << "File to upload:"

157

, br

158

, afile "file" ! [value origPath] ]

159

, p << [ label << "Name on wiki, including extension"

160

, noscript << " (leave blank to use the same filename)"

161

, stringToHtml ":"

162

, br

163

, textfield "wikiname" ! [value wikiname]

164

, primHtmlChar "nbsp"

165

, checkbox "overwrite" "yes"

166

, label << "Overwrite existing file" ]

167

, p << [ label << "Description of content or changes:"

168

, br

169

, textfield "logMsg" ! [size "60", value logMsg]

170

, submit "upload" "Upload" ]

171

]

172

formattedPage defaultPageLayout{

173

pgMessages = pMessages params,

174

pgScripts = ["uploadForm.js"],

175

pgShowPageTools = False,

176

pgTabs = [],

177

pgTitle = "Upload a file"} upForm

178

179

uploadFile :: Handler

180

uploadFile = withData $ \(params :: Params) -> do

181

let origPath = pFilename params

182

let filePath = pFilePath params

183

let wikiname = normalise

184

$ dropWhile (=='/')

185

$ pWikiname params `orIfNull` takeFileName origPath

186

let logMsg = pLogMsg params

187

cfg <- getConfig

188

mbUser <- getLoggedInUser

189

(user, email) <- case mbUser of

190

Nothing -> return ("Anonymous", "")

191

Just u -> return (uUsername u, uEmail u)

192

let overwrite = pOverwrite params

193

fs <- getFileStore

194

exists <- liftIO $ catch (latest fs wikiname >> return True) $ \e ->

195

if e == NotFound

196

then return False

197

else throwIO e >> return True

198

let inStaticDir = staticDir cfg `isPrefixOf` (repositoryPath cfg </> wikiname)

199

let inTemplatesDir = templatesDir cfg `isPrefixOf` (repositoryPath cfg </> wikiname)

200

let dirs' = splitDirectories $ takeDirectory wikiname

201

let imageExtensions = [".png", ".jpg", ".gif"]

202

let errors = validate

203

[ (null . filter (not . isSpace) $ logMsg,

204

"Description cannot be empty.")

205

, (".." `elem` dirs', "Wikiname cannot contain '..'")

206

, (null origPath, "File not found.")

207

, (inStaticDir, "Destination is inside static directory.")

208

, (inTemplatesDir, "Destination is inside templates directory.")

209

, (not overwrite && exists, "A file named '" ++ wikiname ++

210

"' already exists in the repository: choose a new name " ++

211

"or check the box to overwrite the existing file.")

212

, (isPageFile wikiname,

213

"This file extension is reserved for wiki pages.")

214

]

215

if null errors

216

then do

217

expireCachedFile wikiname `mplus` return ()

218

fileContents <- liftIO $ B.readFile filePath

219

let len = B.length fileContents

220

liftIO $ save fs wikiname (Author user email) logMsg fileContents

221

let contents = thediv <<

222

[ h2 << ("Uploaded " ++ show len ++ " bytes")

223

, if takeExtension wikiname `elem` imageExtensions

224

then p << "To add this image to a page, use:" +++

225

pre << ("![alt text](/" ++ wikiname ++ ")")

226

else p << "To link to this resource from a page, use:" +++

227

pre << ("[link label](/" ++ wikiname ++ ")") ]

228

formattedPage defaultPageLayout{

229

pgMessages = pMessages params,

230

pgShowPageTools = False,

231

pgTabs = [],

232

pgTitle = "Upload successful"}

233

contents

234

else withMessages errors uploadForm

235

236

goToPage :: Handler

237

goToPage = withData $ \(params :: Params) -> do

238

let gotopage = pGotoPage params

239

fs <- getFileStore

240

allPageNames <- liftM (map dropExtension . filter isPageFile) $

241

liftIO $ index fs

242

let findPage f = find f allPageNames

243

let exactMatch f = gotopage == f

244

let insensitiveMatch f = (map toLower gotopage) == (map toLower f)

245

let prefixMatch f = (map toLower gotopage) `isPrefixOf` (map toLower f)

246

base' <- getWikiBase

247

case findPage exactMatch of

248

Just m -> seeOther (base' ++ urlForPage m) $ toResponse

249

"Redirecting to exact match"

250

Nothing -> case findPage insensitiveMatch of

251

Just m -> seeOther (base' ++ urlForPage m) $ toResponse

252

"Redirecting to case-insensitive match"

253

Nothing -> case findPage prefixMatch of

254

Just m -> seeOther (base' ++ urlForPage m) $

255

toResponse $ "Redirecting" ++

256

" to partial match"

257

Nothing -> searchResults

258

259

searchResults :: Handler

260

searchResults = withData $ \(params :: Params) -> do

261

let patterns = pPatterns params `orIfNull` [pGotoPage params]

262

fs <- getFileStore

263

matchLines <- if null patterns

264

then return []

265

else liftIO $ catch (search fs SearchQuery{

266

queryPatterns = patterns

267

, queryWholeWords = True

268

, queryMatchAll = True

269

, queryIgnoreCase = True })

270

-- catch error, because newer versions of git

271

-- return 1 on no match, and filestore <=0.3.3

272

-- doesn't handle this properly:

273

(\(_ :: FileStoreError) -> return [])

274

let contentMatches = map matchResourceName matchLines

275

allPages <- liftM (filter isPageFile) $ liftIO $ index fs

276

let slashToSpace = map (\c -> if c == '/' then ' ' else c)

277

let inPageName pageName' x = x `elem` (words $ slashToSpace $ dropExtension pageName')

278

let matchesPatterns pageName' = not (null patterns) &&

279

all (inPageName (map toLower pageName')) (map (map toLower) patterns)

280

let pageNameMatches = filter matchesPatterns allPages

281

let allMatchedFiles = nub $ filter isPageFile contentMatches ++

282

pageNameMatches

283

let matchesInFile f = mapMaybe (\x -> if matchResourceName x == f

284

then Just (matchLine x)

285

else Nothing) matchLines

286

let matches = map (\f -> (f, matchesInFile f)) allMatchedFiles

287

let relevance (f, ms) = length ms + if f `elem` pageNameMatches

288

then 100

289

else 0

290

let preamble = if null patterns

291

then h3 << ["Please enter a search term."]

292

else h3 << [ stringToHtml (show (length matches) ++ " matches found for ")

293

, thespan ! [identifier "pattern"] << unwords patterns]

294

base' <- getWikiBase

295

let toMatchListItem (file, contents) = li <<

296

[ anchor ! [href $ base' ++ urlForPage (dropExtension file)] << dropExtension file

297

, stringToHtml (" (" ++ show (length contents) ++ " matching lines)")

298

, stringToHtml " "

299

, anchor ! [href "#", theclass "showmatch",

300

thestyle "display: none;"] << if length contents > 0

301

then "[show matches]"

302

else ""

303

, pre ! [theclass "matches"] << unlines contents]

304

let htmlMatches = preamble +++

305

olist << map toMatchListItem

306

(reverse $ sortBy (comparing relevance) matches)

307

formattedPage defaultPageLayout{

308

pgMessages = pMessages params,

309

pgShowPageTools = False,

310

pgTabs = [],

311

pgScripts = ["search.js"],

312

pgTitle = "Search results"}

313

htmlMatches

314

315

showPageHistory :: Handler

316

showPageHistory = withData $ \(params :: Params) -> do

317

page <- getPage

318

showHistory (pathForPage page) page params

319

320

showFileHistory :: Handler

321

showFileHistory = withData $ \(params :: Params) -> do

322

file <- getPage

323

showHistory file file params

324

325

showHistory :: String -> String -> Params -> Handler

326

showHistory file page params = do

327

fs <- getFileStore

328

hist <- liftIO $ history fs [file] (TimeRange Nothing Nothing)

329

(Just $ pLimit params)

330

base' <- getWikiBase

331

let versionToHtml rev pos = li ! [theclass "difflink", intAttr "order" pos,

332

strAttr "revision" (revId rev),

333

strAttr "diffurl" (base' ++ "/_diff/" ++ page)] <<

334

[ thespan ! [theclass "date"] << (show $ revDateTime rev)

335

, stringToHtml " ("

336

, thespan ! [theclass "author"] << anchor ! [href $ base' ++ "/_activity?" ++

337

urlEncodeVars [("forUser", authorName $ revAuthor rev)]] <<

338

(authorName $ revAuthor rev)

339

, stringToHtml "): "

340

, anchor ! [href (base' ++ urlForPage page ++ "?revision=" ++ revId rev)] <<

341

thespan ! [theclass "subject"] << revDescription rev

342

, noscript <<

343

([ stringToHtml " [compare with "

344

, anchor ! [href $ base' ++ "/_diff" ++ urlForPage page ++ "?to=" ++ revId rev] <<

345

"previous" ] ++

346

(if pos /= 1

347

then [ primHtmlChar "nbsp"

348

, primHtmlChar "bull"

349

, primHtmlChar "nbsp"

350

, anchor ! [href $ base' ++ "/_diff" ++ urlForPage page ++ "?from=" ++

351

revId rev] << "current"

352

]

353

else []) ++

354

[stringToHtml "]"])

355

]

356

let contents = if null hist

357

then noHtml

358

else ulist ! [theclass "history"] <<

359

zipWith versionToHtml hist

360

[length hist, (length hist - 1)..1]

361

let more = if length hist == pLimit params

362

then anchor ! [href $ base' ++ "/_history" ++ urlForPage page

363

++ "?limit=" ++ show (pLimit params + 100)] <<

364

"Show more..."

365

else noHtml

366

let tabs = if file == page -- source file, not wiki page

367

then [ViewTab,HistoryTab]

368

else pgTabs defaultPageLayout

369

formattedPage defaultPageLayout{

370

pgPageName = page,

371

pgMessages = pMessages params,

372

pgScripts = ["dragdiff.js"],

373

pgTabs = tabs,

374

pgSelectedTab = HistoryTab,

375

pgTitle = ("Changes to " ++ page)

376

} $ contents +++ more

377

378

showActivity :: Handler

379

showActivity = withData $ \(params :: Params) -> do

380

currTime <- liftIO getCurrentTime

381

let oneMonthAgo = addUTCTime (-60 * 60 * 24 * 30) currTime

382

let since = case pSince params of

383

Nothing -> Just oneMonthAgo

384

Just t -> Just t

385

let forUser = pForUser params

386

fs <- getFileStore

387

hist <- liftIO $ history fs [] (TimeRange since Nothing)

388

(Just $ pLimit params)

389

let hist' = case forUser of

390

Nothing -> hist

391

Just u -> filter (\r -> authorName (revAuthor r) == u) hist

392

let fileFromChange (Added f) = f

393

fileFromChange (Modified f) = f

394

fileFromChange (Deleted f) = f

395

let dropDotPage file = if isPageFile file

396

then dropExtension file

397

else file

398

base' <- getWikiBase

399

let fileAnchor revis file =

400

anchor ! [href $ base' ++ "/_diff" ++ urlForPage file ++ "?to=" ++ revis] << file

401

let filesFor changes revis = intersperse (primHtmlChar "nbsp") $

402

map (fileAnchor revis . dropDotPage . fileFromChange) changes

403

let heading = h1 << ("Recent changes by " ++ fromMaybe "all users" forUser)

404

let revToListItem rev = li <<

405

[ thespan ! [theclass "date"] << (show $ revDateTime rev)

406

, stringToHtml " ("

407

, thespan ! [theclass "author"] <<

408

anchor ! [href $ base' ++ "/_activity?" ++

409

urlEncodeVars [("forUser", authorName $ revAuthor rev)]] <<

410

(authorName $ revAuthor rev)

411

, stringToHtml "): "

412

, thespan ! [theclass "subject"] << revDescription rev

413

, stringToHtml " ("

414

, thespan ! [theclass "files"] << filesFor (revChanges rev) (revId rev)

415

, stringToHtml ")"

416

]

417

let contents = ulist ! [theclass "history"] << map revToListItem hist'

418

formattedPage defaultPageLayout{

419

pgMessages = pMessages params,

420

pgShowPageTools = False,

421

pgTabs = [],

422

pgTitle = "Recent changes"

423

} (heading +++ contents)

424

425

showPageDiff :: Handler

426

showPageDiff = withData $ \(params :: Params) -> do

427

page <- getPage

428

showDiff (pathForPage page) page params

429

430

showFileDiff :: Handler

431

showFileDiff = withData $ \(params :: Params) -> do

432

page <- getPage

433

showDiff page page params

434

435

showDiff :: String -> String -> Params -> Handler

436

showDiff file page params = do

437

let from = pFrom params

438

let to = pTo params

439

-- 'to' or 'from' must be given

440

when (from == Nothing && to == Nothing) mzero

441

fs <- getFileStore

442

-- if 'to' is not specified, defaults to current revision

443

-- if 'from' is not specified, defaults to revision immediately before 'to'

444

from' <- case (from, to) of

445

(Just _, _) -> return from

446

(Nothing, Nothing) -> return from

447

(Nothing, Just t) -> do

448

pageHist <- liftIO $ history fs [file]

449

(TimeRange Nothing Nothing)

450

Nothing

451

let (_, upto) = break (\r -> idsMatch fs (revId r) t)

452

pageHist

453

return $ if length upto >= 2

454

-- immediately preceding revision

455

then Just $ revId $ upto !! 1

456

else Nothing

457

result' <- liftIO $ try $ getDiff fs file from' to

458

case result' of

459

Left NotFound -> mzero

460

Left e -> liftIO $ throwIO e

461

Right htmlDiff -> formattedPage defaultPageLayout{

462

pgPageName = page,

463

pgRevision = from' `mplus` to,

464

pgMessages = pMessages params,

465

pgTabs = DiffTab :

466

pgTabs defaultPageLayout,

467

pgSelectedTab = DiffTab

468

}

469

htmlDiff

470

471

getDiff :: FileStore -> FilePath -> Maybe RevisionId -> Maybe RevisionId

472

-> IO Html

473

getDiff fs file from to = do

474

rawDiff <- diff fs file from to

475

let diffLineToHtml (Both xs _) = thespan << unlines xs

476

diffLineToHtml (First xs) = thespan ! [theclass "deleted"] << unlines xs

477

diffLineToHtml (Second xs) = thespan ! [theclass "added"] << unlines xs

478

return $ h2 ! [theclass "revision"] <<

479

("Changes from " ++ fromMaybe "beginning" from ++

480

" to " ++ fromMaybe "current" to) +++

481

pre ! [theclass "diff"] << map diffLineToHtml rawDiff

482

483

editPage :: Handler

484

editPage = withData editPage'

485

486

editPage' :: Params -> Handler

487

editPage' params = do

488

let rev = pRevision params -- if this is set, we're doing a revert

489

fs <- getFileStore

490

page <- getPage

491

let getRevisionAndText = catch

492

(do c <- liftIO $ retrieve fs (pathForPage page) rev

493

-- even if pRevision is set, we return revId of latest

494

-- saved version (because we're doing a revert and

495

-- we don't want gitit to merge the changes with the

496

-- latest version)

497

r <- liftIO $ latest fs (pathForPage page) >>= revision fs

498

return (Just $ revId r, c))

499

(\e -> if e == NotFound

500

then return (Nothing, "")

501

else throwIO e)

502

(mbRev, raw) <- case pEditedText params of

503

Nothing -> liftIO getRevisionAndText

504

Just t -> let r = if null (pSHA1 params)

505

then Nothing

506

else Just (pSHA1 params)

507

in return (r, t)

508

let messages = pMessages params

509

let logMsg = pLogMsg params

510

let sha1Box = case mbRev of

511

Just r -> textfield "sha1" ! [thestyle "display: none",

512

value r]

513

Nothing -> noHtml

514

let readonly = if isJust (pRevision params)

515

-- disable editing of text box if it's a revert

516

then [strAttr "readonly" "yes",

517

strAttr "style" "color: gray"]

518

else []

519

base' <- getWikiBase

520

cfg <- getConfig

521

let editForm = gui (base' ++ urlForPage page) ! [identifier "editform"] <<

522

[ sha1Box

523

, textarea ! (readonly ++ [cols "80", name "editedText",

524

identifier "editedText"]) << raw

525

, br

526

, label << "Description of changes:"

527

, br

528

, textfield "logMsg" ! (readonly ++ [value logMsg])

529

, submit "update" "Save"

530

, primHtmlChar "nbsp"

531

, submit "cancel" "Discard"

532

, primHtmlChar "nbsp"

533

, input ! [thetype "button", theclass "editButton",

534

identifier "previewButton",

535

strAttr "onClick" "updatePreviewPane();",

536

strAttr "style" "display: none;",

537

value "Preview" ]

538

, thediv ! [ identifier "previewpane" ] << noHtml

539

]

540

let pgScripts' = ["preview.js"]

541

let pgScripts'' = case mathMethod cfg of

542

JsMathScript -> "jsMath/easy/load.js" : pgScripts'

543

MathML -> "MathMLinHTML.js" : pgScripts'

544

MathJax url -> url : pgScripts'

545

_ -> pgScripts'

546

formattedPage defaultPageLayout{

547

pgPageName = page,

548

pgMessages = messages,

549

pgRevision = rev,

550

pgShowPageTools = False,

551

pgShowSiteNav = False,

552

pgMarkupHelp = Just $ markupHelp cfg,

553

pgSelectedTab = EditTab,

554

pgScripts = pgScripts'',

555

pgTitle = ("Editing " ++ page)

556

} editForm

557

558

confirmDelete :: Handler

559

confirmDelete = do

560

page <- getPage

561

fs <- getFileStore

562

-- determine whether there is a corresponding page, and if not whether there

563

-- is a corresponding file

564

pageTest <- liftIO $ try $ latest fs (pathForPage page)

565

fileToDelete <- case pageTest of

566

Right _ -> return $ pathForPage page -- a page

567

Left NotFound -> do

568

fileTest <- liftIO $ try $ latest fs page

569

case fileTest of

570

Right _ -> return page -- a source file

571

Left NotFound -> return ""

572

Left e -> fail (show e)

573

Left e -> fail (show e)

574

let confirmForm = gui "" <<

575

[ p << "Are you sure you want to delete this page?"

576

, input ! [thetype "text", name "filetodelete",

577

strAttr "style" "display: none;", value fileToDelete]

578

, submit "confirm" "Yes, delete it!"

579

, stringToHtml " "

580

, submit "cancel" "No, keep it!"

581

, br ]

582

formattedPage defaultPageLayout{ pgTitle = "Delete " ++ page ++ "?" } $

583

if null fileToDelete

584

then ulist ! [theclass "messages"] << li <<

585

"There is no file or page by that name."

586

else confirmForm

587

588

deletePage :: Handler

589

deletePage = withData $ \(params :: Params) -> do

590

page <- getPage

591

let file = pFileToDelete params

592

mbUser <- getLoggedInUser

593

(user, email) <- case mbUser of

594

Nothing -> return ("Anonymous", "")

595

Just u -> return (uUsername u, uEmail u)

596

let author = Author user email

597

let descrip = "Deleted using web interface."

598

base' <- getWikiBase

599

if pConfirm params && (file == page || file == page <.> "page")

600

then do

601

fs <- getFileStore

602

liftIO $ delete fs file author descrip

603

seeOther (base' ++ "/") $ toResponse $ p << "File deleted"

604

else seeOther (base' ++ urlForPage page) $ toResponse $ p << "Not deleted"

605

606

updatePage :: Handler

607

updatePage = withData $ \(params :: Params) -> do

608

page <- getPage

609

cfg <- getConfig

610

mbUser <- getLoggedInUser

611

(user, email) <- case mbUser of

612

Nothing -> return ("Anonymous", "")

613

Just u -> return (uUsername u, uEmail u)

614

editedText <- case pEditedText params of

615

Nothing -> error "No body text in POST request"

616

Just b -> applyPreCommitPlugins b

617

let logMsg = pLogMsg params `orIfNull` defaultSummary cfg

618

let oldSHA1 = pSHA1 params

619

fs <- getFileStore

620

base' <- getWikiBase

621

if null . filter (not . isSpace) $ logMsg

622

then withMessages ["Description cannot be empty."] editPage

623

else do

624

when (length editedText > fromIntegral (maxPageSize cfg)) $

625

error "Page exceeds maximum size."

626

-- check SHA1 in case page has been modified, merge

627

modifyRes <- if null oldSHA1

628

then liftIO $ create fs (pathForPage page)

629

(Author user email) logMsg editedText >>

630

return (Right ())

631

else do

632

expireCachedFile (pathForPage page) `mplus` return ()

633

liftIO $ catch (modify fs (pathForPage page)

634

oldSHA1 (Author user email) logMsg

635

editedText)

636

(\e -> if e == Unchanged

637

then return (Right ())

638

else throwIO e)

639

case modifyRes of

640

Right () -> seeOther (base' ++ urlForPage page) $ toResponse $ p << "Page updated"

641

Left (MergeInfo mergedWithRev conflicts mergedText) -> do

642

let mergeMsg = "The page has been edited since you checked it out. " ++

643

"Changes from revision " ++ revId mergedWithRev ++

644

" have been merged into your edits below. " ++

645

if conflicts

646

then "Please resolve conflicts and Save."

647

else "Please review and Save."

648

editPage' $

649

params{ pEditedText = Just mergedText,

650

pSHA1 = revId mergedWithRev,

651

pMessages = [mergeMsg] }

652

653

indexPage :: Handler

654

indexPage = do

655

path' <- getPath

656

base' <- getWikiBase

657

let prefix' = if null path' then "" else path' ++ "/"

658

fs <- getFileStore

659

listing <- liftIO $ directory fs prefix'

660

let isDiscussionPage (FSFile f) = isDiscussPageFile f

661

isDiscussionPage (FSDirectory _) = False

662

let prunedListing = filter (not . isDiscussionPage) listing

663

let htmlIndex = fileListToHtml base' prefix' prunedListing

664

formattedPage defaultPageLayout{

665

pgPageName = prefix',

666

pgShowPageTools = False,

667

pgTabs = [],

668

pgScripts = [],

669

pgTitle = "Contents"} htmlIndex

670

671

fileListToHtml :: String -> String -> [Resource] -> Html

672

fileListToHtml base' prefix files =

673

let fileLink (FSFile f) | isPageFile f =

674

li ! [theclass "page" ] <<

675

anchor ! [href $ base' ++ urlForPage (prefix ++ dropExtension f)] <<

676

dropExtension f

677

fileLink (FSFile f) =

678

li ! [theclass "upload"] << anchor ! [href $ base' ++ urlForPage (prefix ++ f)] << f

679

fileLink (FSDirectory f) =

680

li ! [theclass "folder"] <<

681

anchor ! [href $ base' ++ urlForPage (prefix ++ f) ++ "/"] << f

682

updirs = drop 1 $ inits $ splitPath $ '/' : prefix

683

uplink = foldr (\d accum ->

684

concatHtml [ anchor ! [theclass "updir",

685

href $ if length d <= 1

686

then base' ++ "/_index"

687

else base' ++

688

urlForPage (joinPath $ drop 1 d)] <<

689

lastNote "fileListToHtml" d, accum]) noHtml updirs

690

in uplink +++ ulist ! [theclass "index"] << map fileLink files

691

692

categoryPage :: Handler

693

categoryPage = do

694

category <- getPath

695

cfg <- getConfig

696

let repoPath = repositoryPath cfg

697

let categoryDescription = "Category: " ++ category

698

fs <- getFileStore

699

files <- liftIO $ index fs

700

let pages = filter (\f -> isPageFile f && not (isDiscussPageFile f)) files

701

matches <- liftM catMaybes $

702

forM pages $ \f -> do

703

categories <- liftIO $ readCategories $ repoPath </> f

704

return $ if category `elem` categories

705

then Just f

706

else Nothing

707

base' <- getWikiBase

708

let toMatchListItem file = li <<

709

[ anchor ! [href $ base' ++ urlForPage (dropExtension file)] << dropExtension file ]

710

let htmlMatches = ulist << map toMatchListItem matches

711

formattedPage defaultPageLayout{

712

pgPageName = categoryDescription,

713

pgShowPageTools = False,

714

pgTabs = [],

715

pgScripts = ["search.js"],

716

pgTitle = categoryDescription }

717

htmlMatches

718

719

categoryListPage :: Handler

720

categoryListPage = do

721

cfg <- getConfig

722

let repoPath = repositoryPath cfg

723

fs <- getFileStore

724

files <- liftIO $ index fs

725

let pages = filter (\f -> isPageFile f && not (isDiscussPageFile f)) files

726

categories <- liftIO $ liftM (nub . sort . concat) $ forM pages $ \f ->

727

readCategories (repoPath </> f)

728

base' <- getWikiBase

729

let toCatLink ctg = li <<

730

[ anchor ! [href $ base' ++ "/_category" ++ urlForPage ctg] << ctg ]

731

let htmlMatches = ulist << map toCatLink categories

732

formattedPage defaultPageLayout{

733

pgPageName = "Categories",

734

pgShowPageTools = False,

735

pgTabs = [],

736

pgScripts = ["search.js"],

737

pgTitle = "Categories" } htmlMatches

738

739

expireCache :: Handler

740

expireCache = do

741

page <- getPage

742

-- try it as a page first, then as an uploaded file

743

expireCachedFile (pathForPage page)

744

expireCachedFile page

745

ok $ toResponse ()

746

747

feedHandler :: Handler

748

feedHandler = do

749

cfg <- getConfig

750

when (not $ useFeed cfg) mzero

751

base' <- getWikiBase

752

feedBase <- if null (baseUrl cfg) -- if baseUrl blank, try to get it from Host header

753

then do

754

mbHost <- getHost

755

case mbHost of

756

Nothing -> error "Could not determine base URL"

757

Just hn -> return $ "http://" ++ hn ++ base'

758

else case baseUrl cfg ++ base' of

759

x@('h':'t':'t':'p':':':'/':'/':_) -> return x

760

y -> return $ "http://" ++ y

761

let fc = FeedConfig{

762

fcTitle = wikiTitle cfg

763

, fcBaseUrl = feedBase

764

, fcFeedDays = feedDays cfg }

765

path' <- getPath -- e.g. "foo/bar" if they hit /_feed/foo/bar

766

let file = (path' `orIfNull` "_site") <.> "feed"

767

let mbPath = if null path' then Nothing else Just path'

768

-- first, check for a cached version that is recent enough

769

now <- liftIO getCurrentTime

770

let isRecentEnough t = truncate (diffUTCTime now t) < 60 * feedRefreshTime cfg

771

mbCached <- lookupCache file

772

case mbCached of

773

Just (modtime, contents) | isRecentEnough modtime -> do

774

let emptyResponse = setContentType "application/atom+xml; charset=utf-8" . toResponse $ ()

775

ok $ emptyResponse{rsBody = B.fromChunks [contents]}

776

_ -> do

777

fs <- getFileStore

778

resp' <- liftM toResponse $ liftIO (filestoreToXmlFeed fc fs mbPath)

779

cacheContents file $ S.concat $ B.toChunks $ rsBody resp'

780

ok . setContentType "application/atom+xml; charset=UTF-8" $ resp'