Load bind address from environment

Application.hs

@@ -20,8 +20,9 @@ import qualified Data.ByteString.Char8      as BS
 
 app :: (Application -> IO ()) -> IO ()
 app runner = do
-  settings <- newAppSettings
-  table    <- records
+  settings    <- newAppSettings
+  (baseUrl,_) <- serverSettings
+  table       <- records
 
   runner $ controllerApp settings $ do
     get "/" (render "index.html" ())
@@ -41,8 +42,7 @@ app runner = do
       case lookup "url" form of
         Just url' -> do
           let url = BS.unpack url'
-          address <- return "http://localhost:3000/"
           word    <- liftIO (insert table url)
           liftIO $ putStrLn (printf "Registered %s -> %s " url word)
-          render "done.html" $ object ["link" .= (address ++ word)]
+          render "done.html" $ object ["link" .= (baseUrl ++ word)]
         Nothing  -> respond badRequest

Main.hs

@@ -2,14 +2,13 @@
 module Main where
 
 import Application
+import Shortener.Common
 
 import Control.Applicative
-import System.Environment
 import Network.Wai.Handler.Warp
 import Network.Wai.Middleware.RequestLogger
 
-
 main :: IO ()
 main = do
-  port <- maybe 3000 read <$> lookupEnv "PORT"
-  app (run port . logStdout)
+  (_, settings) <- serverSettings
+  app (runSettings settings . logStdout)

Shortener/Common.hs

@@ -2,11 +2,26 @@
 module Shortener.Common where
 
 import Control.Applicative
+import Text.Printf
+import Data.String
+import System.Environment
+import Network.Wai.Handler.Warp
+
 import Web.Simple
 import Web.Simple.Templates
 
 data AppSettings = AppSettings { }
 
+serverSettings :: IO (String, Settings)
+serverSettings = do
+  port <- maybe  3000       read <$> lookupEnv "PORT"
+  host <- maybe "127.0.0.1" id   <$> lookupEnv "ADDRESS"
+  let opts = setPort port $ setHost (fromString host) defaultSettings
+      url  = if port == 80
+             then printf "http://%s/"    host
+             else printf "http://%s:%d/" host port
+  return (url, opts)
+
 newAppSettings :: IO AppSettings
 newAppSettings = return AppSettings