From 90d39c76db63179a1a5a0b4aef304d01ec135717 Mon Sep 17 00:00:00 2001 From: sternenseemann Date: Wed, 28 Dec 2016 14:06:57 +0100 Subject: Rework parameter parsing --- gopher-proxy.cabal | 1 - src/GopherProxy/Config.hs | 37 ----------------------------- src/GopherProxy/Params.hs | 60 +++++++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 28 ++++++++++++---------- 4 files changed, 75 insertions(+), 51 deletions(-) delete mode 100644 src/GopherProxy/Config.hs create mode 100644 src/GopherProxy/Params.hs diff --git a/gopher-proxy.cabal b/gopher-proxy.cabal index 07d81f8..66bcf65 100644 --- a/gopher-proxy.cabal +++ b/gopher-proxy.cabal @@ -29,7 +29,6 @@ executable gopher-proxy , attoparsec , errors , mime-types - , optparse-generic , optparse-applicative hs-source-dirs: src default-language: Haskell2010 diff --git a/src/GopherProxy/Config.hs b/src/GopherProxy/Config.hs deleted file mode 100644 index ec0b44e..0000000 --- a/src/GopherProxy/Config.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -module GopherProxy.Config - ( Config (..) - , dCssUrl - , dBaseUrl - ) where - -import qualified Data.ByteString as BS -import Data.Maybe (fromMaybe) -import Network.Socket (HostName (), PortNumber ()) -import Options.Applicative.Types -import Options.Generic - -data Config - = Config - { hostname :: HostName - , port :: PortNumber - , httpPort :: Int - , cssPath :: FilePath - , cssUrl :: Maybe BS.ByteString - , baseUrl :: Maybe Text - } deriving (Generic, Show) - -instance ParseRecord PortNumber where - parseRecord = fmap getOnly parseRecord - -instance ParseFields PortNumber where - parseFields a b = fmap fromIntegral (parseFields a b :: Parser Integer) - -instance ParseRecord Config - -dCssUrl :: Config -> BS.ByteString -dCssUrl = fromMaybe "/gopher-proxy.css" . cssUrl - -dBaseUrl :: Config -> Text -dBaseUrl = fromMaybe "/" . baseUrl diff --git a/src/GopherProxy/Params.hs b/src/GopherProxy/Params.hs new file mode 100644 index 0000000..d29fe41 --- /dev/null +++ b/src/GopherProxy/Params.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module GopherProxy.Params + ( Params (..) + , params + , helpfulParams + ) where + +import qualified Data.ByteString as BS +import Data.Maybe (fromMaybe) +import Data.Text (Text ()) +import Network.Socket (HostName (), PortNumber ()) +import Options.Applicative + +data Params + = Params + { hostname :: HostName + , port :: PortNumber + , httpPort :: Int + , cssPath :: FilePath + , cssUrl :: BS.ByteString + , baseUrl :: Text + , listenPublic :: Bool + } + +helpfulParams :: ParserInfo Params +helpfulParams = info (helper <*> params) fullDesc + +params :: Parser Params +params = Params + <$> strOption + (long "host" + <> metavar "HOSTNAME" + <> help "hostname of the target gopher server") + <*> optionalWithDefault 70 (option auto + (long "port" + <> metavar "PORT" + <> help "port of the target gopher server")) + <*> option auto + (long "http-port" + <> metavar "PORT" + <> help "port gopher-proxy should listen on") + <*> strOption + (long "css-path" + <> metavar "PATH" + <> help "path of the css to be used") + <*> optionalWithDefault "/gopher-proxy.css" (option auto + (long "css-url" + <> metavar "PATH" + <> help "absolute location of the css on the web server, defaults to \"/gopher-proxy.css\"")) + <*> optionalWithDefault "/" (option auto + (long "base-url" + <> metavar "PATH" + <> help "base url where gopher-proxy is running, defaults to \"/\"")) + <*> switch + (long "listen-public" + <> help "wether gopher-proxy should accept connection on public IP addresses.") + +optionalWithDefault :: a -> Parser a -> Parser a +optionalWithDefault def p = fromMaybe def <$> optional p diff --git a/src/Main.hs b/src/Main.hs index 6b0eef1..4b1320b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,7 +7,7 @@ import GopherProxy.Types import GopherProxy.Protocol -import GopherProxy.Config +import GopherProxy.Params import Prelude hiding (takeWhile) import Control.Exception @@ -29,23 +29,23 @@ import Network.Socket.ByteString import Network.Wai import Network.Wai.Handler.Warp import Lucid -import Options.Generic +import qualified Options.Applicative as O -gopherProxy :: Config -> Application +gopherProxy :: Params -> Application gopherProxy cfg r resp | requestMethod r == "GET" && - rawPathInfo r == dCssUrl cfg = cssResponse cfg r resp `catch` \(e::IOException) -> + rawPathInfo r == cssUrl cfg = cssResponse cfg r resp `catch` \(e::IOException) -> internalErrorResponse "An IO error occured while retrieving the css." r resp | requestMethod r == "GET" = gopherResponse cfg r resp `catch` \(e::IOException) -> internalErrorResponse (T.pack "An IO error occured while contacting the gopher server.") r resp | otherwise = badRequestResponse cfg r resp -cssResponse :: Config -> Application +cssResponse :: Params -> Application cssResponse cfg _ respond = do css <- B.readFile . cssPath $ cfg respond $ responseLBS status200 [("Content-type", "text/css")] css -gopherResponse :: Config -> Application +gopherResponse :: Params -> Application gopherResponse cfg r respond = do (resp, mime) <- (flip fmap) (makeGopherRequest (hostname cfg) (port cfg) (B.fromStrict (rawPathInfo r))) $ @@ -63,7 +63,7 @@ gopherResponse cfg r respond = do ("text", _) -> ([("Content-type", "text/html")], renderBS (gResponseToHtml cfg resp)) _ -> ([("Content-type", mime)], b) -badRequestResponse :: Config -> Application +badRequestResponse :: Params -> Application badRequestResponse cfg _ respond = respond $ responseLBS badRequest400 [("Content-type", "text/plain")] "gopher-proxy did not understand your request" @@ -102,18 +102,18 @@ prependBaseUrl base path | otherwise = base <> "/" <> path -- we generally assume that everything is utf-8 encoded -gResponseToHtml :: Config -> GopherResponse -> Html () +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 . dCssUrl $ cfg]) + <> 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 :: Config -> Html () -> MenuItem -> Html () +itemChain :: Params -> Html () -> MenuItem -> Html () itemChain cfg acc (MenuItem typec desc path' host' port') = acc <> li_ itemHtml where path = decodeUtf8 . B.toStrict $ path' @@ -124,10 +124,12 @@ itemChain cfg acc (MenuItem typec desc path' host' port') url = if "URL:" `T.isPrefixOf` path then T.drop 4 path else if host' == hostname cfg && port' == port cfg - then prependBaseUrl (dBaseUrl cfg) path + then prependBaseUrl (baseUrl cfg) path else prependBaseUrl ("gopher://" <> (T.pack host') <> ":" <> (T.pack (show port'))) path main :: IO () main = do - config <- getRecord "gopher-proxy" - run (httpPort config) (gopherProxy config) + 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) -- cgit 1.4.1