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
|
-- upload a paste to lpaste.net
--
-- This example is pretty beefy, as it does double duty.
--
-- Perhaps the majority of it shows off some complex uses of the
-- optparse-applicative package.
--
-- The POST portion is in the function named upload below. It uploads
-- an application/x-www-urlencoded form that creates a paste on the
-- Haskell community pastebin at <http://lpaste.net/>.
{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}
import Control.Applicative
import Control.Lens
import Data.Char (toLower)
import Data.Maybe (listToMaybe)
import Data.Monoid (mempty, (<>))
import Network.Wreq (FormParam((:=)), post, responseBody)
import Network.Wreq.Types (FormValue(..))
import Options.Applicative as Opts
import Options.Applicative.Types (readerAsk)
import System.FilePath (takeExtension, takeFileName)
import Text.HTML.TagSoup
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
-- A post to lpaste.net can either be private or public (visible in an
-- index).
data Visibility = Private | Public
deriving (Show)
-- Wreq supports uploading an application/x-www-urlencoded form (see
-- uses of the := operator in the upload function below), so we tell
-- it how to render a value of a custom datatype.
instance FormValue Visibility where
renderFormValue = renderFormValue . show
-- The languages that lpaste.net supports. It just so happens that if
-- we convert one of these constructor names to a lower-case string,
-- it exactly matches what lpaste.net needs in its upload form.
data Language =
Haskell | Agda | Assembly | Bash | C | Coq | Cpp | Cs | Diff | Elm | ELisp |
Erlang | Go | Idris | Java | JavaScript | LiterateHaskell | Lisp |
Lua | OCaml | ObjectiveC | Perl | Prolog | Python | Ruby | SQL | Scala |
Scheme | Smalltalk | TeX
deriving (Eq, Show)
instance FormValue Language where
renderFormValue = renderFormValue . fmap toLower . show
-- An association between filename suffixes and our Language type.
languages :: [([String], Language)]
languages = [
([".hs"], Haskell), ([".agda"], Agda), ([".el"], ELisp), ([".ocaml"], OCaml),
([".cl"], Lisp), ([".erl"], Erlang), ([".lhs"], LiterateHaskell),
([".scala"], Scala), ([".go"], Go), ([".py"], Python), ([".rb"], Ruby),
([".elm"], Elm), ([".idris"], Idris), ([".prl"], Prolog), ([".scm"], Scheme),
([".coq"], Coq), ([".s", ".asm"], Assembly), ([".sh"], Bash),
([".c", ".h"], C), ([".cs"], Cs), ([".tex"], TeX), ([".lua"], Lua),
([".cxx", ".cpp", ".cc", ".hxx", ".hpp", ".hh"], Cpp), ([".pl", ".pm"], Perl),
([".diff", ".patch"], Diff), ([".java"], Java), ([".js"], JavaScript),
([".m"], ObjectiveC), ([".smalltalk"], Smalltalk), ([".sql"], SQL)
]
-- An IRC channel to which an announcement of a paste can be posted.
-- We wrap this in a newtype so we can control how it is rendered in a
-- form.
newtype Channel = Channel { fromChannel :: String }
deriving (Eq, Show)
-- If a user forgot to supply a leading '#' for a channel name, we add
-- it here.
instance FormValue Channel where
renderFormValue = renderFormValue . checkHash . fromChannel
where checkHash cs@('#':_) = cs
checkHash cs@(_:_) = '#' : cs
checkHash cs = cs
-- This type plays two roles. It describes the command line options
-- we accept, and also the contents of the form we'll upload to create
-- a new paste.
--
-- We've parameterised the type so that the payload field can either
-- be a filename or the actual contents of the file.
data Paste a = Paste {
_private :: Visibility
, _title :: Maybe String
, _author :: Maybe String
, _channel :: Maybe Channel
, _language :: Maybe Language
, _payload :: a
, _email :: () -- used by lpaste.net for spam protection
} deriving (Show)
makeLenses ''Paste
-- Try to match a user-supplied name to a Language type, looking at
-- both full names and filename extensions.
readLanguage :: ReadM Language
readLanguage = do
l <- readerAsk
let ll = toLower <$> l
ms = [lang | (suffixes, lang) <- languages,
ll == (toLower <$> show lang) || ll `elem` (tail <$> suffixes)]
case ms of
[m] -> return m
_ -> fail $ "unsupported language " ++ show l
-- Figure out the language to specify for a file, either explicitly as
-- specified by the user, or implicitly from the filename extension.
guessLanguage :: FilePath -> Paste a -> Maybe Language
guessLanguage filename p =
(p ^. language) <|>
listToMaybe [lang | (suffixes, lang) <- languages, sfx `elem` suffixes]
where sfx = toLower <$> takeExtension filename
upload :: Paste FilePath -> IO ()
upload p0 = do
let path = p0 ^. payload
body <- B.readFile path
-- Transform command line options into form contents.
let p = p0 & payload .~ body
& title .~ (p0 ^. title <|> Just (takeFileName path))
& language .~ guessLanguage path p0
-- The := operator defines a key/value pair for a form.
resp <- post "http://lpaste.net/new" [
"private" := p ^. private
, "title" := p ^. title
, "author" := p ^. author
, "channel" := p ^. channel
, "language" := p ^. language
, "paste" := p ^. payload
, "email" := p ^. email
]
-- Since lpaste.net doesn't provide an API and just spits HTML back
-- at us, we use tagsoup to look through the tags for the permalink
-- of the paste we just uploaded.
let findURI (TagOpen "strong" [] : TagText "Paste:" : TagClose "strong" :
TagOpen "a" [("href",uri)] : _) = Just uri
findURI (_:xs) = findURI xs
findURI _ = Nothing
case findURI (parseTagsOptions parseOptionsFast (resp ^. responseBody)) of
Just uri -> L.putStrLn $ "http://lpaste.net" <> uri
Nothing -> putStrLn "no uri in response!?"
main :: IO ()
main = upload =<< execParser opts
where opts = info (helper <*> optionParser) mempty
optionParser = Paste <$>
(flag Private Public $ long "public" <>
help "display in index of pastes") <*>
(optional . strOption $
long "title" <> short 't' <> metavar "TITLE" <>
help "title to use for paste") <*>
(optional . strOption $
long "author" <> short 'a' <> metavar "AUTHOR" <>
help "author to display for paste") <*>
(optional . fmap Channel . strOption $
long "channel" <> short 'c' <> metavar "CHANNEL" <>
help "name of IRC channel to announce") <*>
(optional . option readLanguage $
long "language" <> short 'l' <> metavar "LANG" <>
help "language to use") <*>
(Opts.argument str $ metavar "PATH" <>
help "file to upload") <*>
(pure ())
|
