Improve HTTP errors and minor improvements

* Unreachability yields 502 which is better than 500
* If a gopher menu only contains errors (type 3), the response has
  status 502
* A connection timeout has been added, which is configurable using the
  flag `--timeout`
* The default mime type can be given using a new flag,
  `--default-mime-type`
* Minor code cleanup

3 files changed, 56 insertions, 26 deletions

diff --git a/README.md b/README.md
index 04e407c..8dd64be 100644
--- a/README.md
+++ b/README.md
@@ -12,10 +12,12 @@ In this particular example, gopher-proxy would proxy the foo.org gopher server a
 
 There are these additional flags which allow tweaking of exact behavior as well:
 
-option            | meaning
-------------------|--------------------------------------------------------------------------------------------------------
-`--port`          | The port of the gopher server, defaults to `70`
-`--css-url`       | Use some specific css file instead of the default one.
-`--css-url`       | The http path of the css file, defaults to `/gopher-proxy.css` (should be changed, if your gopher server has a file with the same name
-`--base-url`      | The path of the directory which will appear as root directory of gopher-proxy to the user, defaults to `/`. Should be changed if you configured your proxying web server to expose gopher-proxy as, say `/gopher-space/`.
-`--listen-public` | If this flag is set, gopher-proxy will accept connections on its public IP address(es).
+option                | meaning
+----------------------|--------------------------------------------------------------------------------------------------------
+`--port`              | The port of the gopher server, defaults to `70`
+`--css-url`           | Use some specific css file instead of the default one.
+`--css-url`           | The http path of the css file, defaults to `/gopher-proxy.css` (should be changed, if your gopher server has a file with the same name
+`--base-url`          | The path of the directory which will appear as root directory of gopher-proxy to the user, defaults to `/`. Should be changed if you configured your proxying web server to expose gopher-proxy as, say `/gopher-space/`.
+`--listen-public`     | If this flag is set, gopher-proxy will accept connections on its public IP address(es).
+`--default-mime-type` | Mime type to use if spacecookie can't guess it, defaults to "application/octet-stream"
+`--timeout`           | Timeout when connecting in milliseconds, defaults to 10 seconds.
diff --git a/src/GopherProxy/Params.hs b/src/GopherProxy/Params.hs
index e39f8f1..131ae3c 100644
--- a/src/GopherProxy/Params.hs
+++ b/src/GopherProxy/Params.hs
@@ -10,6 +10,7 @@ import qualified Data.ByteString as BS
 import Data.Maybe (fromMaybe)
 import Data.Monoid ((<>))
 import Data.Text (Text ())
+import Network.Mime (MimeType (), defaultMimeType)
 import Network.Socket (HostName (), PortNumber ())
 import Options.Applicative
 
@@ -22,6 +23,8 @@ data Params
     , cssUrl       :: BS.ByteString
     , baseUrl      :: Text
     , listenPublic :: Bool
+    , defaultMime  :: MimeType
+    , timeoutms    :: Int
     }
 
 helpfulParams :: ParserInfo Params
@@ -56,6 +59,15 @@ params = Params
   <*> switch
     (long "listen-public"
     <> help "wether gopher-proxy should accept connection on public IP addresses.")
+  <*> optionalWithDefault defaultMimeType (option auto
+    (long "default-mime-type"
+    <> metavar "MIMETYPE"
+    <> help "spacecookie uses this mimetype, if it can't guess the type, defaults to application/octet-stream"))
+  <*> optionalWithDefault 10000000 (option auto
+    (long "timeout"
+    <> metavar "MILLISECONDS"
+    <> help "timeout for connecting to the specified gopher server, defaults to 10s."))
+
 
 optionalWithDefault :: a -> Parser a -> Parser a
 optionalWithDefault def p = fromMaybe def <$> optional p
diff --git a/src/Main.hs b/src/Main.hs
index 2ce71d8..fdf72b7 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -12,11 +12,13 @@ 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
@@ -34,15 +36,16 @@ 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 resp
+gopherProxy cfg r respond
   | 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
+    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
@@ -59,41 +62,54 @@ cssResponse cfg _ respond = do
 gopherResponse :: Params -> Application
 gopherResponse cfg r respond = do
   (resp, mime) <- (flip fmap)
-    (makeGopherRequest (hostname cfg) (port cfg) (B.fromStrict (rawPathInfo r))) $
+    (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")
-  respond $ uncurry (responseLBS status200) $
+
+  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 fmap BS.tail (BS.span (/= 47) mime) of
+        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"
 
-internalErrorResponse :: Exception e => e -> Text -> Application
-internalErrorResponse exp err _ resp = do
+exceptionResponse :: Exception e => Status -> e -> Text -> Application
+exceptionResponse status exp err _ resp = do
   T.hPutStr stderr (err <> " (" <> T.pack (show exp) <> ")\n")
-  resp $ responseLBS internalServerError500 [("Content-type", "text/plain")] (B.fromStrict (encodeUtf8 err))
+  resp $ responseLBS status [("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
+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 h
-          SockAddrInet6 _ f h s -> SockAddrInet6 port f h s
+          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)
-  connect sock addr
+
+  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")
@@ -102,7 +118,7 @@ makeGopherRequest host port req = do
     Left _ -> Nothing
     Right r -> case r of
                  MenuResponse _ -> Just (r, "text/html")
-                 FileResponse _ -> Just (r, mimeByExt defaultMimeMap defaultMimeType (decodeUtf8 (B.toStrict req)))
+                 FileResponse _ -> Just (r, mimeByExt defaultMimeMap (defaultMime cfg) (decodeUtf8 (B.toStrict req)))
 
 prependBaseUrl :: Text -> Text -> Text
 prependBaseUrl base path