hackage-server/src/Distribution/Server/Pages/Template.hs at 0014c947685593a969f19f113c18efdb86784d72 · haskell/hackage-server · GitHub

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
-- Common wrapper for HTML pages
module Distribution.Server.Pages.Template
    ( hackagePage
    , hackagePageWith
    , hackagePageWithHead
    ) where

import Text.XHtml.Strict
import qualified Text.XHtml as XHtml

--TODO: replace all this with external templates

-- | Create top-level HTML document by wrapping the Html with boilerplate.
hackagePage :: String -> [Html] -> Html
hackagePage = hackagePageWithHead []

hackagePageWithHead :: [Html] -> String -> [Html] -> Html
hackagePageWithHead headExtra docTitle docContent =
    hackagePageWith headExtra docTitle docSubtitle docContent bodyExtra
  where
    docSubtitle = anchor ! [href introductionURL, theclass "caption"] << "Hackage :: [Package]"
    bodyExtra   = []

hackagePageWith :: [Html] -> String -> Html -> [Html] -> [Html] -> Html
hackagePageWith headExtra docTitle docSubtitle docContent bodyExtra =
    toHtml [ header << (docHead ++ headExtra)
           , body   << (docBody ++ bodyExtra) ]
  where
    docHead   = [ thetitle << (docTitle ++ " | Hackage")
                , thelink ! [ rel "stylesheet"
                            , href googleFontURL] << noHtml
                , thelink ! [ rel "stylesheet"
                            , href stylesheetURL
                            , thetype "text/css"] << noHtml
                , thelink ! [ rel "icon"
                            , href faviconURL
                            , thetype "image/png"] << noHtml
                , meta ! [ name "viewport"
                         , content "width=device-width, initial-scale=1"]
                , script noHtml ! [ src "https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-chtml-full.js", thetype "text/javascript"]
                -- if Search is enabled
                , thelink ! [ rel "search", href "/packages/opensearch.xml"
                            , thetype "application/opensearchdescription+xml"
                            , title "Hackage" ] << noHtml
                ]
    docBody   = [ theheader  ! [identifier "page-header"] << docHeader
                , thediv  ! [identifier "content"] << docContent ]
    docHeader = [ docSubtitle
                , navigationBar
                ]
    theheader = XHtml.tag "header"

navigationBar :: Html
navigationBar =
    thenav $ ulist ! [theclass "links", identifier "page-menu"]
      <<  map (li <<)
          [ anchor ! [href introductionURL] << "Home"
          , form   ! [action "/packages/search", theclass "search", method "get"]
                  << [ button ! [thetype "submit"] << "Search", spaceHtml
                     , input  ! [thetype "text", name "terms" ] ]
          , anchor ! [href pkgListURL] << "Browse"
          , anchor ! [href recentAdditionsURL] << "What's new"
          , anchor ! [href uploadURL]   << "Upload"
          , anchor ! [href accountsURL] << "User accounts"
          ]
  where
    thenav = XHtml.tag "nav"


googleFontURL :: URL
googleFontURL = "https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700"

stylesheetURL :: URL
stylesheetURL = "/static/hackage.css"

faviconURL :: URL
faviconURL = "/static/favicon.png"

-- URL of the package list
pkgListURL :: URL
pkgListURL = "/packages/browse"

-- URL of the upload form
introductionURL :: URL
introductionURL = "/"

-- URL of the upload form
uploadURL :: URL
uploadURL = "/upload"

-- URL about user accounts, including the form to change passwords
accountsURL :: URL
accountsURL = "/accounts"

-- URL of the admin front end
--
-- TODO: Currently unused.
_adminURL :: URL
_adminURL = "/admin"

-- URL of the list of recent additions to the database
recentAdditionsURL :: URL
recentAdditionsURL = "/packages/recent"