Paste server written in Haskell. Fork of Hpaste, fully freedom and privacy respecting and generally improved. At the time of writing there's an instance at <http://paste.rel4tion.org>.

[[ 🗃 ^aoqmo toothpaste ]] :: [📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Commits]

Clone

HTTPS: git clone https://vervis.peers.community/repos/aoqmo

SSH: git clone USERNAME@vervis.peers.community:aoqmo

Branches

Tags

hpaste :: src / Hpaste / View /

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

{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | HTML-specific view functions.

module Hpaste.View.Html
  (aClass
  ,aClasses
  ,darkSection
  ,darkNoTitleSection
  ,lightSection
  ,lightNoTitleSection
  ,warnNoTitleSection
  ,errorNoTitleSection
  ,href
  ,clear
  ,showLanguage
  ,showChannel
  ,paginate
  ,preEscapedString)
  where

import           Hpaste.Types

import           Control.Arrow               ((&&&))
import           Control.Monad               (when)
import           Data.Maybe                  (fromMaybe)
import           Data.Monoid.Operator        ((++))
import           Data.Pagination
import           Data.Text.Lazy              (Text)
import qualified Data.Text.Lazy              as T
import           Network.URI.Params
import           Network.URI
import           Prelude                     hiding ((++))
import           Text.Blaze.Html5            as H hiding (map,nav)
import qualified Text.Blaze.Html5.Attributes as A
import           Text.Blaze.Extra
import Snap.App.Types

-- | A class prefixed with nothing.
aClass :: AttributeValue -> Attribute
aClass name = A.class_ (name)

-- | A class prefixed with nothing.
aClasses :: [Text] -> Attribute
aClasses names = A.class_ $
  toValue $ T.intercalate " " $ names

-- | A warning section.
warnNoTitleSection :: Markup -> Markup
warnNoTitleSection inner =
  H.div ! aClasses ["section","section-warn"] $ do
    inner

-- | An error section.
errorNoTitleSection :: Markup -> Markup
errorNoTitleSection inner =
  H.div ! aClasses ["section","section-error"] $ do
    inner

-- | A dark section.
darkSection :: Text -> Markup -> Markup
darkSection title inner =
  H.div ! aClasses ["section","section-dark"] $ do
    h2 $ toMarkup title
    inner

-- | A dark section.
darkNoTitleSection :: Markup -> Markup
darkNoTitleSection inner =
  H.div ! aClasses ["section","section-dark"] $ do
    inner

-- | A light section.
lightSection :: Text -> Markup -> Markup
lightSection title inner =
  H.div ! aClasses ["section","section-light"] $ do
    h2 $ toMarkup title
    inner

-- | A light section with no title.
lightNoTitleSection :: Markup -> Markup
lightNoTitleSection inner =
  H.div ! aClasses ["section","section-light"] $ do
    inner

-- | An anchor link.
href :: (ToValue location,ToMarkup html) => location -> html -> Markup
href loc content = H.a ! A.href (toValue loc) $ toMarkup content

-- | A clear:both element.
clear :: Markup
clear = H.div ! aClass "clear" $ return ()

-- | Show a language.
showLanguage :: [Language] -> Maybe LanguageId -> Markup
showLanguage languages lid =
  toMarkup $ fromMaybe "-" (lid >>= (`lookup` langs))

    where langs = map (languageId &&& languageTitle) languages

-- | Show a channel.
showChannel :: Maybe Paste -> [Channel] -> Maybe ChannelId -> Markup
showChannel paste channels lid = do
  toMarkup $ fromMaybe "-" chan
  case (paste,chan) of
    (Just paste,Just c) | c == "#haskell" -> do
      " "
      href ("http://ircbrowse.net/browse/haskell/?q=" ++ show (pasteId paste)) $
        ("Context in IRC logs" :: String)
    _ -> return ()

    where langs = map (channelId &&& channelName) channels
          chan = (lid >>= (`lookup` langs))

-- | Render results with pagination.
paginate :: URI -> Pagination -> Markup -> Markup
paginate uri pn inner = do
  nav uri pn True
  inner
  nav uri pn False

-- | Show a pagination navigation, with results count, if requested.
nav :: URI -> Pagination -> Bool -> Markup
nav uri pn@Pagination{..} showTotal = do
  H.div ! aClass "pagination" $ do
    H.div ! aClass "inner" $ do
      when (pnCurrentPage-1 > 0) $ navDirection uri pn (-1) "Previous"
      toMarkup (" " :: Text)
      when (pnTotal == pnPerPage) $ navDirection uri pn 1 "Next"
      when showTotal $ do
        br
        toMarkup $ results

    where results = unwords [show start ++ "—" ++ show end
                            ,"results of"
                            ,show pnTotal]
          start = 1 + (pnCurrentPage - 1) * pnTotal
          end = pnCurrentPage * pnTotal

-- | Link to change navigation page based on a direction.
navDirection :: URI -> Pagination -> Integer -> Text -> Markup
navDirection uri Pagination{..} change caption = do
  a ! hrefURI uri $ toMarkup caption

  where uri = updateUrlParam "page"
  	      		     (show (pnCurrentPage + change))
			     uri

-- | Migration function.
preEscapedString :: String -> Markup
preEscapedString = preEscapedToMarkup
[See repo JSON]