Commit f76b1df9 authored by Antoine Fontaine's avatar Antoine Fontaine 👣

Prettify the homepage

 * Update the homepage
 * Add CSS
 * Make the instance url a parameter
 * Fixup Debian packaging a bit more
parent e34a0e99
Pipeline #1887 failed with stages
in 45 minutes and 59 seconds
gnupaste (2.0.0~rc5) unstable; urgency=medium
* Update the homepage
* Add CSS
* Make the instance url a parameter
* Fixup Debian packaging a bit more
-- Antoine Fontaine <antoine.fontaine@epfl.ch> Thu, 24 Dec 2020 10:26:13 +0100
gnupaste (2.0.0~rc4) unstable; urgency=medium
* Fixup Debian packaging
......
......@@ -3,7 +3,7 @@ Maintainer: Antoine Fontaine <antoine.fontaine@epfl.ch>
Priority: optional
Section: haskell
Build-Depends:
debhelper (>=12)
debhelper (>=12)
Vcs-Browser: https://gitlab.gnugen.ch/gnugen/gnupaste
Vcs-Git: https://gitlab.gnugen.ch/gnugen/gnupaste.git
Standards-Version: 4.3.0
......@@ -11,5 +11,7 @@ Standards-Version: 4.3.0
Package: gnupaste
Architecture: any
Depends:
${misc:Depends}, libc6, libgmp10, zlib1g
${misc:Depends}, ${shlibs:Depends}
Description: GNU Generation's new pastebin software
This is a replacement for the older pastebin
(https://gitlab.gnugen.ch/gnugen/pastebin)
......@@ -20,6 +20,7 @@ executables:
dependencies:
- blaze-html
- bytestring
- clay
- directory
- monad-logger
- network
......
......@@ -19,10 +19,11 @@ import Paste.Handlers (server)
import Paste.Database (migrateAll, cleanupPastes)
data Arguments = Args
{ port :: Int
, sqlitePath :: FilePath
, pasteDir :: FilePath
, createDB :: Bool
{ port :: Int
, sqlitePath :: FilePath
, pasteDir :: FilePath
, instanceUrl :: Text
, createDB :: Bool
}
-- argument parsing, see https://hackage.haskell.org/package/optparse-applicative
......@@ -44,6 +45,10 @@ argParser = Args
<> value "pastes"
<> metavar "DIR"
<> help "Folder where the pastes will be stored (defaults to ./pastes)" )
<*> option str
( long "instance-url"
<> metavar "URL"
<> help "The url of the instance (for example https://paste.gnugen.ch)" )
<*> switch
( long "create-db"
<> help "Create (or update) database schemas instead of running" )
......@@ -60,7 +65,7 @@ runServer Args{..} = do
pool <- runStderrLoggingT $
createSqlitePool (T.pack sqlitePath) 1
_ <- forkIO $ cleanupPastes pool (pasteDir<>"/")
let srv = server pool (pasteDir<>"/")
let srv = server pool (pasteDir<>"/") instanceUrl
pasteAPI = Proxy :: Proxy PasteAPI
application = serve pasteAPI srv
run port application
......
......@@ -41,10 +41,11 @@ import Text.Regex
-- | Server implementing our API. Contains all the logic.
server :: ConnectionPool -- ^ Database pool.
-> FilePath -- ^ Directory containing uploads.
-> Text -- ^ The address where the server is accessible
-> Server PasteAPI
server pool pasteDir = return homepage
server pool pasteDir instanceUrl = return (homepage instanceUrl)
:<|> servePastes pool pasteDir
:<|> processUpload pool pasteDir
:<|> processUpload pool pasteDir instanceUrl
servePastes :: ConnectionPool -- ^ Database pool.
-> FilePath -- ^ Directory containing uploads.
......@@ -59,11 +60,12 @@ servePastes pool pasteDir hash = do
-- | Process a file upload request to our server.
processUpload :: ConnectionPool -- ^ Database pool.
-> FilePath -- ^ Directory containing uploads.
-> Text -- ^ The address where the server is accessible
-> SockAddr -- ^ Address of the client making the request.
-> Maybe Text -- ^ Optional 'X-Forwarded-For' header.
-> MultipartData Tmp -- ^ Data uploaded in the "multipart/formdata".
-> Handler Text
processUpload pool pasteDir reqAddr mXForward multipData =
processUpload pool pasteDir instanceUrl reqAddr mXForward multipData =
-- Process and check request: first and foremost, do we have a file ?
case head $ files multipData of
Nothing -> throwError err400 { errBody = "You must include a file in the multipart/formdata you upload!" }
......@@ -98,7 +100,7 @@ processUpload pool pasteDir reqAddr mXForward multipData =
, pasteIpAdd = address
} pool
-- Send back 201 with the URL to the paste.
return $ "https://paste.gnugen.ch/raw/" <> hash
return $ instanceUrl <> "/raw/" <> hash
-- | Transform a 'SockAddr' datastructure to human-readable text to store in
-- the database.
......
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : Paste.Homepage
......@@ -13,56 +14,64 @@ This module contains the code for the generation of the homepage, written in the
module Paste.Homepage where
import Protolude
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
import Paste.Styles
-- | The homepage that serves as an instruction manual, and a post page for
-- people using browsers.
homepage :: Html
homepage = docTypeHtml $ do
H.head $
H.title "Paste"
homepage :: Text -> Html
homepage url = docTypeHtml $ do
H.head $ do
H.title "GnuPaste"
H.style (toHtml stylesheet)
H.body $ do
h1 "Paste"
h1 "GnuPaste"
h2 "Usage:"
pre "<command> | curl -F 'file=@-' -H -Expect:' https://paste.gnugen.ch"
h2 "Usage"
code $ "<command> | curl -F 'file=@-' " <> toHtml url
h2 "Details"
p $ do
" The file field is the only required field. It is the file that"
" will be uploaded and served. You can set the mime-type field"
" to force a different mime-type than the one recognized by the"
" service; and finally the expiration to change the default"
" expiration period of one year. Valid units are s(econds),"
" h(ours), d(ays), w(eeks), m(onths)."
p $ do
"See the "
a ! href "https://gitlab.gnugen.ch/gnugen/pastebin" $ "gitlab page"
" for more information on the implementation of this service."
p $ do
" This service is provided with no guarantees of any kind. Please note"
" that your IP address will be stored for security purposes."
"The "
code "file"
" field is the only required field. It is the file that"
" will be uploaded and served. You can set the "
code "type"
" field to force a different mime-type than the one recognized by the"
" service; and finally the "
code "expire"
" field to change the default expiration period of one year. Valid"
" units are s(econds), h(ours), d(ays), w(eeks), m(onths)."
h2 "Upload form"
H.form ! A.method "POST" $ do
table $ do
tr $ do
td "Select file to upload"
td $ input ! A.type_ "file" ! A.name "file" ! A.required "file"
td $ H.label ! A.for "file" $ "Select file to upload"
td $ input ! A.type_ "file" ! A.id "file" ! A.name "file" ! A.required "file"
tr $ do
td $ H.label ! A.for "type" $ "Force mimetype (leave blank to keep as is)"
td $ input ! A.type_ "text" ! A.id "type" ! A.name "type"
tr $ do
td "Force mimetype (leave blank to keep as is)"
td $ input ! A.type_ "text" ! A.name "type"
td $ H.label ! A.for "expire" $ "Expiration date (leave blank for default of one year)"
td $ input ! A.type_ "text" ! A.id "expire" ! A.name "expire"
tr $ do
td "Expiration date (leave blank for default of one year)"
td $ input ! A.type_ "text" ! A.name "expire"
input ! A.type_ "submit" ! A.formenctype "multipart/form-data"
td ""
td $ input ! A.type_ "submit" ! A.formenctype "multipart/form-data"
footer $ do
"Paste v2, BSD3 licenced. Written in "
p $ do
a ! href "https://gitlab.gnugen.ch/gnugen/gnupaste" $ "GnuPaste 2.0"
", BSD3 licenced. Written in "
a ! href "https://haskell.org" $ "haskell"
" using "
a ! href "https://hackage.haskell.org/package/servant" $ "servant"
" by J. Desroches for GNU Generation, 2018. Built on the"
" old paste program in Yesod by A. Angel, 2014"
" by J. Desroches and A. Fontaine for GNU Generation, 2018 and 2020."
p $ do
"Built on the old paste program in Yesod by A. Angel, 2014."
p $ do
"This service is provided with no guarantees of any kind. Please note"
" that your IP address will be stored for security purposes."
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment