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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
import GopherProxy.Types
import GopherProxy.Protocol
import GopherProxy.Params
import Paths_gopher_proxy
import Prelude hiding (takeWhile)
import Control.Exception
import Control.Monad (when)
import Data.Attoparsec.ByteString.Lazy
import Data.ByteString.Lazy (ByteString ())
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as BS
import Data.Char (chr)
import Data.Maybe (isNothing)
import Data.Monoid ((<>))
import Data.Text (Text ())
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import GHC.IO.Handle
import GHC.IO.IOMode
import Network.HTTP.Types
import Network.Mime
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString
import Network.Wai
import Network.Wai.Handler.Warp
import Lucid
import qualified Options.Applicative as O
import System.IO (stderr)
import System.Directory (doesFileExist)
import System.Timeout
gopherProxy :: Params -> Application
gopherProxy cfg r respond
| requestMethod r == "GET" &&
rawPathInfo r == cssUrl cfg = cssResponse cfg r respond `catch` \(e::IOException) ->
exceptionResponse status500 e "Could not open css file" r respond
| requestMethod r == "GET" = gopherResponse cfg r respond `catch` \(e::IOException) ->
exceptionResponse status502 e "Could not reach the gopher server" r respond
| otherwise = badRequestResponse cfg r respond
cssResponse :: Params -> Application
cssResponse cfg _ respond = do
path <- case cssPath cfg of
Just p -> pure p
Nothing -> getDataFileName "gopher-proxy.css"
exists <- doesFileExist path
if exists
then B.readFile path >>=
respond . responseLBS status200 [("Content-type", "text/css")]
else respond $
responseLBS status404 [("Content-type", "text/plain")] "Could not find css"
gopherResponse :: Params -> Application
gopherResponse cfg r respond = do
(resp, mime) <- (flip fmap)
(makeGopherRequest cfg (B.fromStrict (rawPathInfo r))) $
\case
Just r -> r
Nothing -> ( MenuResponse [ MenuItem '3' "An error occured while retrieving server's response." "" "" 0 ]
, "text/html")
let status =
case resp of
FileResponse _ -> status200
MenuResponse items -> if all (\(MenuItem c _ _ _ _) -> c == '3') items
then status502
else status200
respond $ uncurry (responseLBS status) $
case resp of
MenuResponse _ ->
([("Content-type", "text/html")], renderBS (gResponseToHtml cfg resp))
FileResponse b ->
case mimeTuple mime of
("text", "html") -> ([("Content-type", mime)], b)
("text", _) -> ([("Content-type", "text/html")], renderBS (gResponseToHtml cfg resp))
_ -> ([("Content-type", mime)], b)
mimeTuple :: MimeType -> (BS.ByteString, BS.ByteString)
mimeTuple = fmap BS.tail . BS.span (/= 47)
badRequestResponse :: Params -> Application
badRequestResponse cfg _ respond = respond $ responseLBS badRequest400
[("Content-type", "text/plain")] "gopher-proxy did not understand your request"
exceptionResponse :: Exception e => Status -> e -> Text -> Application
exceptionResponse status exp err _ resp = do
T.hPutStr stderr (err <> " (" <> T.pack (show exp) <> ")\n")
resp $ responseLBS status [("Content-type", "text/plain")] (B.fromStrict (encodeUtf8 err))
makeGopherRequest :: Params -> ByteString -> IO (Maybe (GopherResponse, MimeType))
makeGopherRequest cfg req = do
addri:_ <- getAddrInfo Nothing (Just (hostname cfg)) Nothing
let addr =
case (addrAddress addri) of
SockAddrInet _ h -> SockAddrInet (port cfg) h
SockAddrInet6 _ f h s -> SockAddrInet6 (port cfg) f h s
x -> x
sock <- socket (addrFamily addri) Stream (addrProtocol addri)
connected <- timeout (timeoutms cfg) $ connect sock addr
when (isNothing connected) $ throw (userError "connection timeout")
hdl <- socketToHandle sock ReadWriteMode
hSetBuffering hdl NoBuffering
B.hPutStr hdl (req <> "\r\n")
resp <- BS.hGetContents hdl
pure $ case parseOnly (gopherResponseParser Nothing) resp of
Left _ -> Nothing
Right r -> case r of
MenuResponse _ -> Just (r, "text/html")
FileResponse _ -> Just (r, mimeByExt defaultMimeMap (defaultMime cfg) (decodeUtf8 (B.toStrict req)))
prependBaseUrl :: Text -> Text -> Text
prependBaseUrl base path
| T.null base || T.null path = base <> path
| T.head path == '/' = if T.last base == '/'
then base <> T.tail path
else base <> path
| T.last base == '/' = base <> path
| otherwise = base <> "/" <> path
-- we generally assume that everything is utf-8 encoded
gResponseToHtml :: Params -> GopherResponse -> Html ()
gResponseToHtml cfg res
= doctype_ <> html_
(head_ (meta_ [charset_ "utf-8"]
<> meta_ [term "viewport" "width=device-width"]
<> title_ "gopher-proxy"
<> link_ [rel_ "stylesheet", type_ "text/css", href_ . decodeUtf8 . cssUrl $ cfg])
<> body_ bodyContent)
where bodyContent = case res of
FileResponse bytes -> pre_ (toHtml bytes)
MenuResponse items -> ul_ $ foldl (itemChain cfg) mempty items
itemChain :: Params -> Html () -> MenuItem -> Html ()
itemChain cfg acc (MenuItem typec desc path' host' port')
= acc <> li_ itemHtml
where path = decodeUtf8 . B.toStrict $ path'
itemHtml = case typec of
'i' -> toHtml desc
'3' -> span_ [class_ "error"] (toHtml desc)
_ -> a_ [href_ url] (toHtml desc)
url = if "URL:" `T.isPrefixOf` path
then T.drop 4 path
else if host' == hostname cfg && port' == port cfg
then prependBaseUrl (baseUrl cfg) path
else prependBaseUrl ("gopher://" <> (T.pack host') <> ":" <> (T.pack (show port'))) path
main :: IO ()
main = do
params <- O.execParser helpfulParams
let preference = if listenPublic params then "*" else "127.0.0.1"
settings = setPort (httpPort params) . setHost preference $ defaultSettings
runSettings settings (gopherProxy params)
|
