-
Notifications
You must be signed in to change notification settings - Fork 198
/
Copy pathHtml.hs
2000 lines (1814 loc) · 87.2 KB
/
Html.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-# LANGUAGE RecursiveDo, FlexibleContexts, RankNTypes, NamedFieldPuns, RecordWildCards, LambdaCase #-}
module Distribution.Server.Features.Html (
HtmlFeature(..),
initHtmlFeature
) where
import Control.Arrow ((&&&))
import Prelude ()
import Distribution.Server.Prelude
import Distribution.Server.Framework
import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
import qualified Distribution.Server.Framework.ResponseContentTypes as Resource
import Distribution.Server.Framework.Templating
import Distribution.Server.Features.Core
import Distribution.Server.Features.Upload
import Distribution.Server.Features.BuildReports
import Distribution.Server.Features.BuildReports.Render
import Distribution.Server.Features.PackageCandidates
import Distribution.Server.Features.Users
import Distribution.Server.Features.DownloadCount
import Distribution.Server.Features.Votes
import Distribution.Server.Features.Search
import Distribution.Server.Features.PreferredVersions
-- [reverse index disabled] import Distribution.Server.Features.ReverseDependencies
import Distribution.Server.Features.PackageContents (PackageContentsFeature(..))
import Distribution.Server.Features.PackageList
import Distribution.Server.Features.Tags
import Distribution.Server.Features.AnalyticsPixels
import Distribution.Server.Features.Mirror
import Distribution.Server.Features.Distro
import Distribution.Server.Features.Documentation
import Distribution.Server.Features.TarIndexCache
import Distribution.Server.Features.UserDetails
import Distribution.Server.Features.EditCabalFiles
import Distribution.Server.Features.Html.HtmlUtilities
import Distribution.Server.Features.Security.SHA256
import qualified Distribution.Server.Features.BuildReports.BuildReport as BR
import Distribution.Server.Users.Types
import qualified Distribution.Server.Users.Group as Group
import Distribution.Server.Packages.Types
import Distribution.Server.Packages.Render
import qualified Distribution.Server.Users.Users as Users
import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
import Distribution.Server.Users.Group (UserGroup(..))
import qualified Distribution.Server.Pages.Package as Pages
import qualified Distribution.Server.Pages.PackageFromTemplate as PagesNew
import Distribution.Server.Pages.Template
import Distribution.Server.Pages.Util
import qualified Distribution.Server.Pages.Group as Pages
-- [reverse index disabled] import qualified Distribution.Server.Pages.Reverse as Pages
import qualified Distribution.Server.Pages.Index as Pages
import Distribution.Server.Util.CountingMap (cmFind, cmToList)
import Distribution.Server.Util.DocMeta (loadTarDocMeta)
import Distribution.Server.Util.ServeTarball (loadTarEntry)
import Distribution.Simple.Utils ( cabalVersion, toUTF8LBS )
import Distribution.Package
import Distribution.Version
import Distribution.Text (display)
import Data.List (intercalate, intersperse, insert)
import Data.Function (on)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector as Vec
import qualified Data.Text as T
import qualified Data.ByteString.Lazy.Char8 as BS (ByteString)
import qualified Network.URI as URI
import Text.XHtml.Strict
import qualified Text.XHtml.Strict as XHtml
import Text.XHtml.Table (simpleTable)
import Distribution.PackageDescription (hasLibs)
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
-- TODO: move more of the below to Distribution.Server.Pages.*, it's getting
-- close to 1K lines, way too much... it's okay to keep data-querying in here,
-- but pure HTML generation mostly needlessly clutters up the module.
-- Try to make it so no HTML combinators need to be imported.
--
-- See the TODO file for more ways to improve the HTML.
data HtmlFeature = HtmlFeature {
htmlFeatureInterface :: HackageFeature
}
instance IsHackageFeature HtmlFeature where
getFeatureInterface = htmlFeatureInterface
-- This feature provides the HTML view to the models of other features
-- currently it uses the xhtml package to render HTML (Text.XHtml.Strict)
--
-- This means of generating HTML is somewhat temporary, in that a more advanced
-- (and better-looking) HTML ajaxy scheme should come about later on.
initHtmlFeature :: ServerEnv
-> IO (UserFeature
-> CoreFeature
-> PackageContentsFeature
-> UploadFeature -> PackageCandidatesFeature
-> VersionsFeature
-- [reverse index disabled] -> ReverseFeature
-> TagsFeature
-> AnalyticsPixelsFeature
-> DownloadFeature
-> VotesFeature
-> ListFeature -> SearchFeature
-> MirrorFeature -> DistroFeature
-> DocumentationFeature
-> DocumentationFeature
-> TarIndexCacheFeature
-> ReportsFeature
-> UserDetailsFeature
-> IO HtmlFeature)
initHtmlFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode,
serverCacheDelay,
serverVerbosity = verbosity} = do
-- Page templates
templates <- loadTemplates serverTemplatesMode
[serverTemplatesDir, serverTemplatesDir </> "Html"]
[ "maintain.html", "maintain-candidate.html"
, "reports.html", "report.html"
, "maintain-docs.html"
, "distro-monitor.html"
, "revisions.html"
, "package-page.html"
, "table-interface.html"
, "tag-edit.html"
, "candidate-page.html"
, "candidate-index.html"
, "browse.html"
, "noscript-search-form.html"
, "analytics-pixels-page.html"
, "user-analytics-pixels-page.html"
]
return $ \user core@CoreFeature{packageChangeHook}
packages upload
candidates versions
-- [reverse index disabled] reverse
tags analyticsPixels download
rank
list@ListFeature{itemUpdate}
names mirror
distros
docsCore docsCandidates
tarIndexCache
reportsCore
usersdetails -> do
-- do rec, tie the knot
rec let (feature, packageIndex, packagesPage) =
htmlFeature env user core
packages upload
candidates versions
tags analyticsPixels download
rank
list names
mirror distros
docsCore docsCandidates
tarIndexCache
reportsCore
usersdetails
(htmlUtilities core candidates tags user)
mainCache namesCache
templates
-- Index page caches
mainCache <- newAsyncCacheNF packageIndex
defaultAsyncCachePolicy {
asyncCacheName = "packages index page (by category)",
asyncCacheUpdateDelay = serverCacheDelay,
asyncCacheSyncInit = False,
asyncCacheLogVerbosity = verbosity
}
namesCache <- newAsyncCacheNF packagesPage
defaultAsyncCachePolicy {
asyncCacheName = "packages index page (by name)",
asyncCacheUpdateDelay = serverCacheDelay,
asyncCacheLogVerbosity = verbosity
}
registerHook itemUpdate $ \_ -> do
prodAsyncCache mainCache "item update"
prodAsyncCache namesCache "item update"
registerHook packageChangeHook $ \_ -> do
prodAsyncCache mainCache "package change"
prodAsyncCache namesCache "package change"
return feature
htmlFeature :: ServerEnv
-> UserFeature
-> CoreFeature
-> PackageContentsFeature
-> UploadFeature
-> PackageCandidatesFeature
-> VersionsFeature
-> TagsFeature
-> AnalyticsPixelsFeature
-> DownloadFeature
-> VotesFeature
-> ListFeature
-> SearchFeature
-> MirrorFeature
-> DistroFeature
-> DocumentationFeature
-> DocumentationFeature
-> TarIndexCacheFeature
-> ReportsFeature
-> UserDetailsFeature
-> HtmlUtilities
-> AsyncCache Response
-> AsyncCache Response
-> Templates
-> (HtmlFeature, IO Response, IO Response)
htmlFeature env@ServerEnv{..}
user
core@CoreFeature{queryGetPackageIndex}
packages upload
candidates versions
-- [reverse index disabled] ReverseFeature{..}
tags analyticsPixels download
rank
list@ListFeature{getAllLists}
names
mirror distros
docsCore docsCandidates
tarIndexCache
reportsCore
usersdetails
utilities@HtmlUtilities{..}
cachePackagesPage cacheNamesPage
templates
= (HtmlFeature{..}, packageIndex, packagesPage)
where
htmlFeatureInterface = (emptyHackageFeature "html") {
featureResources = htmlResources
, featureState = []
, featureCaches = [
CacheComponent {
cacheDesc = "packages page by category",
getCacheMemSize = memSize <$> readAsyncCache cachePackagesPage
}
, CacheComponent {
cacheDesc = "packages page by name",
getCacheMemSize = memSize <$> readAsyncCache cacheNamesPage
}
]
, featurePostInit = syncAsyncCache cachePackagesPage
, featureReloadFiles = reloadTemplates templates
}
htmlCore = mkHtmlCore env
utilities
user
core
versions
upload
tags
analyticsPixels
docsCore
tarIndexCache
reportsCore
download
rank
distros
packages
htmlTags
htmlPreferred
cachePackagesPage
cacheNamesPage
templates
names
candidates
htmlUsers = mkHtmlUsers user usersdetails
htmlUploads = mkHtmlUploads utilities upload
htmlDocUploads = mkHtmlDocUploads utilities core docsCore templates
htmlDownloads = mkHtmlDownloads utilities download
htmlReports = mkHtmlReports utilities core reportsCore templates
htmlCandidates = mkHtmlCandidates utilities core versions upload
docsCandidates tarIndexCache
candidates user templates
htmlPreferred = mkHtmlPreferred utilities core versions
htmlTags = mkHtmlTags utilities core upload user list tags templates
htmlAnalyticsPixels = mkHtmlAnalyticsPixels utilities core user upload analyticsPixels templates
htmlResources = concat [
htmlCoreResources htmlCore
, htmlUsersResources htmlUsers
, htmlUploadsResources htmlUploads
, htmlDocUploadsResources htmlDocUploads
, htmlReportsResources htmlReports
, htmlCandidatesResources htmlCandidates
, htmlPreferredResources htmlPreferred
, htmlDownloadsResources htmlDownloads
, htmlTagsResources htmlTags
, htmlAnalyticsPixelsResources htmlAnalyticsPixels
-- and user groups. package maintainers, trustees, admins
, htmlGroupResource user (maintainersGroupResource . uploadResource $ upload)
, htmlGroupResource user (trusteesGroupResource . uploadResource $ upload)
, htmlGroupResource user (uploadersGroupResource . uploadResource $ upload)
, htmlGroupResource user (adminResource . userResource $ user)
, htmlGroupResource user (mirrorGroupResource . mirrorResource $ mirror)
]
-- TODO: write HTML for reports and distros to display the information
-- effectively reports
{-
, (extendResource $ reportsList reports) {
resourceGet = [("html", serveReportsList)]
}
, (extendResource $ reportsPage reports) {
resourceGet = [("html", serveReportsPage)]
}
-}
-- distros
{-
, (extendResource $ distroIndexPage distros) {
resourceGet = [("html", serveDistroIndex)]
}
, (extendResource $ distroAllPage distros) {
resourceGet = [("html", serveDistroPackages)]
}
, (extendResource $ distroPackage distros) {
resourceGet = [("html", serveDistroPackage)]
}
-}
-- reverse index (disabled)
{-
, (extendResource $ reversePackage reverses) {
resourceGet = [("html", serveReverse True)]
}
, (extendResource $ reversePackageOld reverses) {
resourceGet = [("html", serveReverse False)]
}
, (extendResource $ reversePackageAll reverses) {
resourceGet = [("html", serveReverseFlat)]
}
, (extendResource $ reversePackageStats reverses) {
resourceGet = [("html", serveReverseStats)]
}
, (extendResource $ reversePackages reverses) {
resourceGet = [("html", serveReverseList)]
}
-}
-- [reverse index disabled] reverses = reverseResource
{- [reverse index disabled]
--------------------------------------------------------------------------------
-- Reverse
serveReverse :: Bool -> DynamicPath -> ServerPart Response
serveReverse isRecent dpath =
htmlResponse $
withPackageId dpath $ \pkgid -> do
let pkgname = packageName pkgid
rdisp <- case packageVersion pkgid of
Version [] [] -> withPackageAll pkgname $ \_ -> revPackageName pkgname
_ -> withPackageVersion pkgid $ \_ -> revPackageId pkgid
render <- (if isRecent then renderReverseRecent else renderReverseOld) pkgname rdisp
return $ toResponse $ Resource.XHtml $ hackagePage (display pkgname ++ " - Reverse dependencies ") $
Pages.reversePackageRender pkgid (corePackageIdUri "") revr isRecent render
serveReverseFlat :: DynamicPath -> ServerPart Response
serveReverseFlat dpath = htmlResponse $
withPackageAllPath dpath $ \pkgname _ -> do
revCount <- query $ GetReverseCount pkgname
pairs <- revPackageFlat pkgname
return $ toResponse $ Resource.XHtml $ hackagePage (display pkgname ++ "Flattened reverse dependencies") $
Pages.reverseFlatRender pkgname (corePackageNameUri "") revr revCount pairs
serveReverseStats :: DynamicPath -> ServerPart Response
serveReverseStats dpath = htmlResponse $
withPackageAllPath dpath $ \pkgname pkgs -> do
revCount <- query $ GetReverseCount pkgname
return $ toResponse $ Resource.XHtml $ hackagePage (display pkgname ++ "Reverse dependency statistics") $
Pages.reverseStatsRender pkgname (map packageVersion pkgs) (corePackageIdUri "") revr revCount
serveReverseList :: DynamicPath -> ServerPart Response
serveReverseList _ = do
let revr = reverseResource revs
triple <- sortedRevSummary revs
hackCount <- PackageIndex.indexSize <$> queryGetPackageIndex
return $ toResponse $ Resource.XHtml $ hackagePage "Reverse dependencies" $
Pages.reversePackagesRender (corePackageNameUri "") revr hackCount triple
-}
--------------------------------------------------------------------------------
-- Additional package indices
packageIndex :: IO Response
packageIndex = do
index <- queryGetPackageIndex
let htmlIndex = toResponse $ Resource.XHtml $ Pages.packageIndex index
return htmlIndex
packagesPage :: IO Response
packagesPage = do
items <- liftIO getAllLists
let htmlpage =
toResponse $ Resource.XHtml $ hackagePage "All packages by name"
[ h2 << "All packages by name"
, ulist ! [theclass "packages"] << map renderItem (Map.elems items)
]
return htmlpage
{-
-- Currently unused, mainly because not all web browsers use eager authentication-sending
-- Setting a cookie might work here, albeit one that's stateless for the server, is not
-- used for auth and only causes GUI changes, not permission overriding
loginWidget :: UserResource -> ServerPart Html
loginWidget user = do
users <- query State.GetUserDb
auth <- Auth.getHackageAuth users
return . makeLoginWidget user $ case auth of
Left {} -> Nothing
Right (_, uinfo) -> Just $ userName uinfo
makeLoginWidget :: UserResource -> Maybe UserName -> Html
makeLoginWidget user mname = case mname of
Nothing -> anchor ! [href $ userLoginUri user Nothing] << "log in"
Just uname -> anchor ! [href $ userPageUri user "" uname] << display uname
-}
{-------------------------------------------------------------------------------
Core
-------------------------------------------------------------------------------}
data HtmlCore = HtmlCore {
htmlCoreResources :: [Resource]
}
mkHtmlCore :: ServerEnv
-> HtmlUtilities
-> UserFeature
-> CoreFeature
-> VersionsFeature
-> UploadFeature
-> TagsFeature
-> AnalyticsPixelsFeature
-> DocumentationFeature
-> TarIndexCacheFeature
-> ReportsFeature
-> DownloadFeature
-> VotesFeature
-> DistroFeature
-> PackageContentsFeature
-> HtmlTags
-> HtmlPreferred
-> AsyncCache Response
-> AsyncCache Response
-> Templates
-> SearchFeature
-> PackageCandidatesFeature
-> HtmlCore
mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
utilities@HtmlUtilities{..}
UserFeature{queryGetUserDb, checkAuthenticated, guardAuthorised_, adminGroup}
CoreFeature{coreResource}
VersionsFeature{ versionsResource
, queryGetDeprecatedFor
, queryGetPreferredInfo
, withPackagePreferred
}
UploadFeature{..}
TagsFeature{queryTagsForPackage}
AnalyticsPixelsFeature{getPackageAnalyticsPixels}
documentationFeature@DocumentationFeature{documentationResource, queryDocumentation}
TarIndexCacheFeature{cachedTarIndex}
reportsFeature
DownloadFeature{recentPackageDownloads,totalPackageDownloads}
VotesFeature{..}
DistroFeature{queryPackageStatus}
PackageContentsFeature{packageRender}
HtmlTags{..}
HtmlPreferred{..}
cachePackagesPage
cacheNamesPage
templates
SearchFeature{..}
PackageCandidatesFeature{..}
= HtmlCore{..}
where
candidatesCore = candidatesCoreResource
cores@CoreResource{packageInPath, lookupPackageName, lookupPackageId} = coreResource
versions = versionsResource
docs = documentationResource
maintainPackage = (resourceAt "/package/:package/maintain") {
resourceGet = [("html", serveMaintainPage)]
}
htmlCoreResources = [
(extendResource $ corePackagePage cores) {
resourceDesc = [(GET, "Show detailed package information")]
, resourceGet = [("html", servePackagePage)]
}
, (resourceAt "/package/:package/dependencies") {
resourceDesc = [(GET, "Show detailed package dependency information")]
, resourceGet = [("html", serveDependenciesPage)]
}
{-
, (extendResource $ coreIndexPage cores) {
resourceGet = [("html", serveIndexPage)]
}, currently in 'core' feature
-}
, (resourceAt "/packages/names" ) {
resourceGet = [("html", const $ readAsyncCache cacheNamesPage)]
}
, (resourceAt "/packages/browse" ) {
resourceDesc = [(GET, "Show browsable list of all packages")]
, resourceGet = [("html", serveBrowsePage)]
}
, (extendResource searchPackagesResource) {
resourceGet = [("html", serveBrowsePage)]
}
, (extendResource $ corePackagesPage cores) {
resourceDesc = [(GET, "Show package index")]
, resourceGet = [("html", const $ readAsyncCache cachePackagesPage)]
}
, maintainPackage
, (resourceAt "/package/:package/distro-monitor.:format") {
resourceDesc = [(GET, "A handy page for distro package change monitor tools")]
, resourceGet = [("html", serveDistroMonitorPage)]
}
, (resourceAt "/package/:package/revisions/.:format") {
resourceGet = [("html", serveCabalRevisionsPage)]
}
]
serveBrowsePage :: DynamicPath -> ServerPartE Response
serveBrowsePage _dpath = do
template <- getTemplate templates "browse.html"
noscriptForm <- getTemplate templates "noscript-search-form.html"
terms <- optional (lookText' "terms")
let
noscriptFormRendered =
renderTemplate $ noscriptForm
[ "ascending" $= True
, "default" $= True
, "pageNumber" $= "0"
, "searchQuery" $= terms
]
pleaseSubmitFragment =
if terms == mempty
then ""
else "<p>To view the search results, please submit this form with your desired sorting preferences.</p>"
return $ toResponse $ template
[ "heading" $= "Browse and search packages"
, templateUnescaped "formFragment" $
toUTF8LBS pleaseSubmitFragment
<> noscriptFormRendered
]
-- Currently the main package page is thrown together by querying a bunch
-- of features about their attributes for the given package. It'll need
-- reorganizing to look aesthetic, as opposed to the sleek and simple current
-- design that takes the 1990s school of web design.
servePackagePage :: DynamicPath -> ServerPartE Response
servePackagePage dpath = do
pkgid <- packageInPath dpath
withPackagePreferred pkgid $ \pkg pkgs -> do
render <- liftIO $ packageRender pkg
let realpkg = rendPkgId render
pkgname = packageName realpkg
docURL = packageDocsContentUri docs realpkg
execs = rendExecNames render
pkgdesc = flattenPackageDescription $ pkgDesc pkg
prefInfo <- queryGetPreferredInfo pkgname
distributions <- queryPackageStatus pkgname
totalDown <- cmFind pkgname `liftM` totalPackageDownloads
recentDown <- cmFind pkgname `liftM` recentPackageDownloads
pkgVotes <- pkgNumVotes pkgname
pkgScore <- pkgNumScore pkgname
auth <- checkAuthenticated
userRating <- case auth of Just (uid,_) -> pkgUserVote pkgname uid; _ -> return Nothing
mdoctarblob <- queryDocumentation realpkg
tags <- queryTagsForPackage pkgname
deprs <- queryGetDeprecatedFor pkgname
mreadme <- makeReadme render
hasDocs <- queryHasDocumentation documentationFeature realpkg
rptStats <- queryLastReportStats reportsFeature realpkg
candidates <- lookupCandidateName pkgname
buildStatus <- renderBuildStatus
documentationFeature reportsFeature realpkg
mdocIndex <- maybe (return Nothing)
(liftM Just . liftIO . cachedTarIndex) mdoctarblob
analyticsPixels <- getPackageAnalyticsPixels pkgname
let
idAndReport = fmap (\(rptId, rpt, _) -> (rptId, rpt)) rptStats
install = getInstall $ fmap (fst &&& BR.installOutcome . snd) idAndReport
test = getTest $ fmap ( BR.testsOutcome . snd) idAndReport
covg = getAvgCovg $ (\(_, _, cvg) -> cvg) =<< rptStats
loadDocMeta
| Just doctarblob <- mdoctarblob
, Just docIndex <- mdocIndex
= loadTarDocMeta
(BlobStorage.filepath serverBlobStore doctarblob)
docIndex
realpkg
| otherwise
= return Nothing
mdocMeta <- loadDocMeta
let infoUrl = fmap (\_ -> preferredPackageUri versions "" pkgname) $
sumRange prefInfo
-- Put it all together
template <- getTemplate templates "package-page.html"
cacheControlWithoutETag [Public, maxAgeMinutes 5]
return $ toResponse . template $
-- IO-related items
[ "baseurl" $= show (serverBaseURI { URI.uriScheme = "" })
, "sbaseurl" $= show (serverBaseURI { URI.uriScheme = "https:" })
, "cabalVersion" $= display cabalVersion
, "tags" $= (renderTags tags)
, "analyticsPixels" $= map analyticsPixelUrl (Set.toList analyticsPixels)
, "versions" $= (PagesNew.renderVersion realpkg
(classifyVersions prefInfo $ map packageVersion pkgs) infoUrl)
, "totalDownloads" $= totalDown
, "hasexecs" $= not (null execs)
, "recentDownloads" $= recentDown
, "votes" $= pkgVotes
, "hasVotes" $= pkgVotes > 0
, "hasExecOnly" $= (not . hasLibs) pkgdesc && (not . null) execs
, "userRating" $= userRating
, "score" $= pkgScore
, "buildStatus" $= buildStatus
, "hasDocs" $= hasDocs
, "install" $= install
, "test" $= test
, "covg" $= covg
, "candidates" $= case candidates of
[] -> [ toHtml "No Candidates"]
_ -> [ PagesNew.commaList $ flip map candidates $ \cand -> anchor ! [href $ corePackageIdUri candidatesCore "" $ packageId cand] << display (packageVersion cand) ]
] ++
-- Items not related to IO (mostly pure functions)
PagesNew.packagePageTemplate render
mdocIndex mdocMeta mreadme
docURL distributions
deprs
utilities
False
where
getInstall Nothing = (False, "", "", "")
getInstall (Just (rptId, buildStatus)) =
(isBadgeShowing, badgeColor, badgeText, rptUrl)
where
BuildReportId rawId = rptId
rptUrl = "reports/" <> show rawId
badgeContent BR.InstallOk = (True, "success", "InstallOk")
badgeContent (BR.DependencyFailed _) = (True, "critical", "DependencyFailed")
badgeContent k = (True, "critical", show k)
(isBadgeShowing, badgeColor, badgeText) = badgeContent buildStatus
getTest (Just BR.Ok) = (True, "success", "Passed")
getTest (Just BR.Failed) = (True, "critical", "Failed")
getTest _ = (False, "False", "")
getAvgCovg :: Maybe BR.BuildCovg -> (Bool, String, Int)
getAvgCovg Nothing = (False, "", 100)
getAvgCovg (Just c) = do
let l = [
BR.expressions c
, BR.guards (BR.boolean c)
, BR.ifConditions (BR.boolean c)
, BR.qualifiers (BR.boolean c)
, BR.alternatives c
, BR.localDeclarations c
, BR.topLevel c
]
(used,total) = foldl (\(a,b) (x, y) -> (a+x, b+y)) (0,0) l
per | total <= 0 = 100
| otherwise = (used*100) `div` total
if per > 66
then (True, "brightgreen", per)
else if per > 33
then (True, "yellowgreen", per)
else (True, "red", per)
serveDependenciesPage :: DynamicPath -> ServerPartE Response
serveDependenciesPage dpath = do
pkgname <- packageInPath dpath
withPackagePreferred pkgname $ \pkg _ -> do
cacheControlWithoutETag [Public, maxAgeMinutes 30]
render <- liftIO $ packageRender pkg
return $ toResponse $ dependenciesPage False render "docs"
serveMaintainPage :: DynamicPath -> ServerPartE Response
serveMaintainPage dpath = do
pkgname <- packageInPath dpath
pkgs <- lookupPackageName pkgname
guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup, InGroup adminGroup]
cacheControl [Public, NoCache] (etagFromHash (length pkgs))
template <- getTemplate templates "maintain.html"
return $ toResponse $ template
[ "pkgname" $= pkgname
, "versions" $= map packageId pkgs
]
serveDistroMonitorPage :: DynamicPath -> ServerPartE Response
serveDistroMonitorPage dpath = do
pkgname <- packageInPath dpath
pkgs <- lookupPackageName pkgname
cacheControl [Public, maxAgeHours 3] (etagFromHash (length pkgs))
template <- getTemplate templates "distro-monitor.html"
return $ toResponse $ template
[ "pkgname" $= pkgname
, "versions" $= map packageId pkgs
]
serveCabalRevisionsPage :: DynamicPath -> ServerPartE Response
serveCabalRevisionsPage dpath = do
pkginfo <- packageInPath dpath >>= lookupPackageId
users <- queryGetUserDb
let pkgid = packageId pkginfo
pkgname = packageName pkginfo
revisions = reverse $ Vec.toList (pkgMetadataRevisions pkginfo)
numRevisions = pkgNumRevisions pkginfo
revchanges :: [(SHA256Digest, [Change])]
revchanges = start revisions where
start [] = []
start (curr:rest) = go curr rest
go curr [] = [(sha256 (cabalFileByteString (fst curr)), [])]
go curr (prev:rest) =
( sha256 (cabalFileByteString (fst curr))
, changes curr prev )
: go prev rest
changes curr prev = either (const []) id $
diffCabalRevisionsByteString
(cabalFileByteString (fst prev))
(cabalFileByteString (fst curr))
cacheControl [NoCache] (etagFromHash numRevisions)
template <- getTemplate templates "revisions.html"
return $ toResponse $ template
[ "pkgname" $= pkgname
, "pkgid" $= pkgid
, "revisions" $= zipWith3 (revisionToTemplate users)
(map snd revisions)
[numRevisions-1, numRevisions-2..]
revchanges
]
where
revisionToTemplate :: Users.Users -> UploadInfo -> Int
-> (SHA256Digest, [Change])
-> TemplateVal
revisionToTemplate users (utime, uid) revision (sha256hash, changes) =
let uname = Users.userIdToName users uid
in templateDict
[ templateVal "number" revision
, templateVal "sha256" (show sha256hash)
, templateVal "user" (display uname)
, utcTimeTemplateVal "htmltime" utime
, templateVal "changes" changes
]
-- | Common helper used by 'serveCandidatePage' and 'servePackagePage'
makeReadme :: MonadIO m => PackageRender -> m (Maybe BS.ByteString)
makeReadme render = case rendReadme render of
Just (tarfile, _, offset, _) ->
either (\_err -> return Nothing) (return . Just . snd) =<<
liftIO (loadTarEntry tarfile offset)
Nothing -> return Nothing
{-------------------------------------------------------------------------------
Users
-------------------------------------------------------------------------------}
data HtmlUsers = HtmlUsers {
htmlUsersResources :: [Resource]
}
mkHtmlUsers :: UserFeature -> UserDetailsFeature -> HtmlUsers
mkHtmlUsers UserFeature{..} UserDetailsFeature{..} = HtmlUsers{..}
where
users = userResource
htmlUsersResources = [
-- list of users with user links; if admin, a link to add user page
(extendResource $ userList users) {
resourceDesc = [ (GET, "list of users")
, (POST, "create a new user")
]
, resourceGet = [ ("html", serveUserList) ]
, resourcePost = [ ("html", \_ -> adminAddUser) ]
}
-- form to post to /users/
, (resourceAt "/users/register") {
resourceDesc = [ (GET, "show \"add user\" form") ]
, resourceGet = [ ("html", addUserForm) ]
}
-- user page with link to password form and list of groups (how to do this?)
, (extendResource $ userPage users) {
resourceDesc = [ (GET, "show user page") ]
, resourceGet = [ ("html", serveUserPage) ]
}
-- form to PUT password
, (extendResource $ passwordResource users) {
resourceDesc = [ (GET, "show password change form")
, (PUT, "change password")
]
, resourceGet = [ ("html", servePasswordForm) ]
, resourcePut = [ ("html", servePutPassword) ]
}
]
serveUserList :: DynamicPath -> ServerPartE Response
serveUserList _ = do
userlist <- Users.enumerateActiveUsers <$> queryGetUserDb
let hlist = unordList
[ anchor ! [href $ userPageUri users "" uname] << display uname
| (_, uinfo) <- userlist, let uname = userName uinfo ]
ok $ toResponse $ Resource.XHtml $ hackagePage "Hackage users" [h2 << "Hackage users", hlist]
serveUserPage :: DynamicPath -> ServerPartE Response
serveUserPage dpath = do
uname <- userNameInPath dpath
uid <- lookupUserName uname
udetails <- queryUserDetails uid
let realname = maybe (display uname) (T.unpack . accountName) udetails
uris <- getGroupIndex uid
uriPairs <- forM uris $ \uri -> do
desc <- getIndexDesc uri
return $ Pages.renderGroupName desc (Just uri)
return $ toResponse $ Resource.XHtml $ hackagePage realname
[ h2 << realname
, case uriPairs of
[] -> noHtml
_ -> toHtml
[ toHtml $ display uname ++ " is part of the following groups:"
, unordList uriPairs
]
, hr
, anchor ! [href $ manageUserUri users "" uname] <<
"Click here to manage this account"
]
addUserForm :: DynamicPath -> ServerPartE Response
addUserForm _ =
return $ toResponse $ Resource.XHtml $ hackagePage "Register account"
[ paragraph << "Administrators can register new user accounts here."
, form ! [theclass "box", XHtml.method "post", action $ userListUri users ""] <<
[ simpleTable [] []
[ makeInput [thetype "text"] "username" "User name"
, makeInput [thetype "password"] "password" "Password"
, makeInput [thetype "password"] "repeat-password" "Confirm password"
]
, paragraph << input ! [thetype "submit", value "Create user"]
]
]
servePasswordForm :: DynamicPath -> ServerPartE Response
servePasswordForm dpath = do
uname <- userNameInPath dpath
pathUid <- lookupUserName uname
uid <- guardAuthenticated -- FIXME: why are we duplicating auth decisions in this feature?
canChange <- canChangePassword uid pathUid
case canChange of
False -> errForbidden "Can't change password" [MText "You're neither this user nor an admin."]
True -> return $ toResponse $ Resource.XHtml $ hackagePage "Change password"
[ toHtml "Change your password. You'll be prompted for authentication upon submission, if you haven't logged in already."
, form ! [theclass "box", XHtml.method "post", action $ userPasswordUri userResource "" uname] <<
[ simpleTable [] []
[ makeInput [thetype "password"] "password" "Password"
, makeInput [thetype "password"] "repeat-password" "Confirm password"
]
, paragraph << [ hidden "_method" "PUT" --method override
, input ! [thetype "submit", value "Change password"] ]
]
]
servePutPassword :: DynamicPath -> ServerPartE Response
servePutPassword dpath = do
uname <- userNameInPath dpath
changePassword uname
return $ toResponse $ Resource.XHtml $ hackagePage "Changed password"
[toHtml "Changed password for ", anchor ! [href $ userPageUri users "" uname] << display uname]
{-------------------------------------------------------------------------------
Uploads(For new package lifecycle, this might need to be removed)
-------------------------------------------------------------------------------}
data HtmlUploads = HtmlUploads {
htmlUploadsResources :: [Resource]
}
mkHtmlUploads :: HtmlUtilities -> UploadFeature -> HtmlUploads
mkHtmlUploads HtmlUtilities{..} UploadFeature{..} = HtmlUploads{..}
where
uploads = uploadResource
htmlUploadsResources = [
-- uploads
-- serve upload result as HTML
(extendResource $ uploadIndexPage uploads) {
resourceDesc = [(POST, "Upload package")]
, resourcePost = [("html", serveUploadResult)]
}
-- form for uploading
, (resourceAt "/packages/upload") {
resourceGet = [("html", serveUploadForm)]
}
]
serveUploadForm :: DynamicPath -> ServerPartE Response
serveUploadForm _ = do
return $ toResponse $ Resource.XHtml $ hackagePage "Upload package"
[ h2 << "Upload package"
, paragraph << [toHtml "See also the ", anchor ! [href "/upload"] << "upload help page", toHtml "."]
, form ! [theclass "box", XHtml.method "post", action "/packages/", enctype "multipart/form-data"] <<
[ input ! [thetype "file", name "package"]
, input ! [thetype "submit", value "Upload package"]
]
, paragraph << [toHtml "If you want to deauthenticate first, ", anchor ! [href "/packages/deauth"] << "click here", toHtml "."]
]
serveUploadResult :: DynamicPath -> ServerPartE Response
serveUploadResult _ = do
res <- uploadPackage
let warns = uploadWarnings res
pkgid = packageId (uploadDesc res)
return $ toResponse $ Resource.XHtml $ hackagePage "Upload successful" $
[ paragraph << [toHtml "Successfully uploaded ", packageLink pkgid, toHtml "!"]
] ++ case warns of
[] -> []
_ -> [paragraph << "There were some warnings:", unordList warns]
{-------------------------------------------------------------------------------
Documentation uploads
-------------------------------------------------------------------------------}
data HtmlDocUploads = HtmlDocUploads {
htmlDocUploadsResources :: [Resource]
}
mkHtmlDocUploads :: HtmlUtilities -> CoreFeature -> DocumentationFeature -> Templates -> HtmlDocUploads
mkHtmlDocUploads HtmlUtilities{..} CoreFeature{coreResource} DocumentationFeature{..} templates = HtmlDocUploads{..}
where
CoreResource{packageInPath} = coreResource
htmlDocUploadsResources = [
(extendResource $ packageDocsWhole documentationResource) {
resourcePut = [ ("html", serveUploadDocumentation) ]
, resourceDelete = [ ("html", serveDeleteDocumentation) ]
}
, (resourceAt "/package/:package/maintain/docs") {
resourceGet = [("html", serveDocUploadForm)]
}
]
serveUploadDocumentation :: DynamicPath -> ServerPartE Response
serveUploadDocumentation dpath = do
pkgid <- packageInPath dpath
uploadDocumentation dpath >> ignoreFilters -- Override 204 No Content
return $ toResponse $ Resource.XHtml $ hackagePage "Documentation uploaded"
[ paragraph << [toHtml "Successfully uploaded documentation for ", packageLink pkgid, toHtml "!"]
]
serveDeleteDocumentation :: DynamicPath -> ServerPartE Response
serveDeleteDocumentation dpath = do
pkgid <- packageInPath dpath
deleteDocumentation dpath >> ignoreFilters -- Override 204 No Content
return $ toResponse $ Resource.XHtml $ hackagePage "Documentation deleted"
[ paragraph << [toHtml "Successfully deleted documentation for ", packageLink pkgid, toHtml "!"]
]
serveDocUploadForm :: DynamicPath -> ServerPartE Response