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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
import GopherProxy.Types
import GopherProxy.Protocol
import GopherProxy.Params
import Prelude hiding (takeWhile)
import Control.Exception
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.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)
gopherProxy :: Params -> Application
gopherProxy cfg r resp
| requestMethod r == "GET" &&
rawPathInfo r == cssUrl cfg = cssResponse cfg r resp `catch` \(e::IOException) ->
internalErrorResponse e "An IO error occured while retrieving the css." r resp
| requestMethod r == "GET" = gopherResponse cfg r resp `catch` \(e::IOException) ->
internalErrorResponse e "An IO error occured while contacting the gopher server." r resp
| otherwise = badRequestResponse cfg r resp
cssResponse :: Params -> Application
cssResponse cfg _ respond = do
css <- B.readFile . cssPath $ cfg
respond $ responseLBS status200 [("Content-type", "text/css")] css
gopherResponse :: Params -> Application
gopherResponse cfg r respond = do
(resp, mime) <- (flip fmap)
(makeGopherRequest (hostname cfg) (port cfg) (B.fromStrict (rawPathInfo r))) $
\case
Just r -> r
Nothing -> ( MenuResponse [ MenuItem '3' "An error occured while retrieving server's response." "" "" 0 ]
, "text/html")
respond $ uncurry (responseLBS status200) $
case resp of
MenuResponse _ ->
([("Content-type", "text/html")], renderBS (gResponseToHtml cfg resp))
FileResponse b ->
case fmap BS.tail (BS.span (/= 47) mime) of
("text", "html") -> ([("Content-type", mime)], b)
("text", _) -> ([("Content-type", "text/html")], renderBS (gResponseToHtml cfg resp))
_ -> ([("Content-type", mime)], b)
badRequestResponse :: Params -> Application
badRequestResponse cfg _ respond = respond $ responseLBS badRequest400
[("Content-type", "text/plain")] "gopher-proxy did not understand your request"
internalErrorResponse :: Exception e => e -> Text -> Application
internalErrorResponse exp err _ resp = do
T.hPutStr stderr (err <> " (" <> T.pack (show exp) <> ")\n")
resp $ responseLBS internalServerError500 [("Content-type", "text/plain")] (B.fromStrict (encodeUtf8 err))
makeGopherRequest :: HostName -> PortNumber -> ByteString -> IO (Maybe (GopherResponse, MimeType))
makeGopherRequest host port req = do
addri:_ <- getAddrInfo Nothing (Just host) Nothing
let addr =
case (addrAddress addri) of
SockAddrInet _ h -> SockAddrInet port h
SockAddrInet6 _ f h s -> SockAddrInet6 port f h s
x -> x
sock <- socket (addrFamily addri) Stream (addrProtocol addri)
connect sock addr
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 defaultMimeType (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"]
<> 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)
|
