Merge branch 'master' into errors

Conflicts:
	src/Main.hs
	src/Middleware.hs

src/Dbapi.hs

@@ -47,9 +47,8 @@ import Data.Ranged.Ranges (emptyRange)
 data AppConfig = AppConfig {
     configDbUri :: String
   , configPort  :: Int
-  , configSslCert :: FilePath
-  , configSslKey  :: FilePath
   , configAnonRole :: String
+  , configSecure :: Bool
   }
 
 jsonContentType :: (HeaderName, BS.ByteString)

src/Main.hs

@@ -2,14 +2,15 @@
 
 module Main where
 import Dbapi
-import Middleware (inTransaction, authenticated, withSavepoint, clientErrors)
+import Middleware (inTransaction, authenticated, withSavepoint, clientErrors,
+  redirectInsecure)
 import Network.Wai.Handler.Warp hiding (Connection)
 import Database.HDBC.PostgreSQL (connectPostgreSQL')
 import Data.String.Conversions (cs)
 
+import Control.Monad (unless)
 import Control.Applicative
 import Options.Applicative hiding (columns)
-import Network.Wai.Handler.WarpTLS (tlsSettings, runTLS)
 import Network.Wai.Middleware.Gzip (gzip, def)
 import Network.Wai.Middleware.Cors (cors)
 
@@ -19,12 +20,10 @@ argParser = AppConfig
     <> help "database uri to expose, e.g. postgres://user:pass@host:port/database")
   <*> option (long "port" <> short 'p' <> metavar "NUMBER" <> value 3000
     <> help "port number on which to run HTTP server")
-  <*> strOption (long "sslcert" <> short 'c' <> metavar "PATH" <> value "test/test.crt"
-    <> help "path to SSL cert file")
-  <*> strOption (long "sslkey" <> short 'k' <> metavar "PATH" <> value "test/test.key"
-    <> help "path to SSL key file")
   <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE"
     <> help "postgres role to use for non-authenticated requests")
+  <*> switch (long "secure" <> short 's'
+    <> help "Redirect all requests to HTTPS" )
 
 main :: IO ()
 main = do
@@ -32,13 +31,14 @@ main = do
   let port = configPort conf
   let dburi = configDbUri conf
 
-  let tls = tlsSettings (configSslCert conf) (configSslKey conf)
-  let settings = setPort port defaultSettings
+  unless (configSecure conf) $
+    putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
 
   Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
   conn <- connectPostgreSQL' dburi
-  runTLS tls settings . gzip def . cors corsPolicy . clientErrors $ (
-    inTransaction . authenticated (cs $ configAnonRole conf) . withSavepoint) app conn
-
+  run port $ (if configSecure conf then redirectInsecure else id)
+    . gzip def . cors corsPolicy . clientErrors
+    $ (inTransaction . authenticated (cs $ configAnonRole conf) . withSavepoint)
+    app conn
   where
     describe = progDesc "create a REST API to an existing Postgres database"

src/Middleware.hs

@@ -5,6 +5,7 @@ module Middleware where
 
 import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
 import Data.Maybe (fromMaybe)
+import Data.Monoid (mconcat)
 
 import Database.HDBC (runRaw)
 import Database.HDBC.PostgreSQL (Connection)
@@ -12,29 +13,31 @@ import Database.HDBC.Types (SqlError(..))
 
 import Data.String.Conversions(cs)
 import qualified Data.ByteString.Char8 as BS
-import Control.Exception (finally, throw, catchJust, catch,  SomeException,
+import Control.Exception (finally, throw, catchJust, catch, SomeException,
     bracket_)
 
-import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization)
-import Network.HTTP.Types.Status (status400, status401)
-import Network.Wai (Application, requestHeaders, responseLBS)
+import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization,
+  hLocation)
+import Network.HTTP.Types.Status (status400, status401, status301)
+import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
+                   rawQueryString, isSecure)
+import Network.URI (URI(..), parseURI)
 
 import PgQuery(LoginAttempt(..), signInRole, setRole, resetRole)
 import Codec.Binary.Base64.String (decode)
 
-
 inTransaction :: (Connection -> Application) -> (Connection -> Application)
 inTransaction app conn req respond =
   finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit")
 
-withSavepoint :: (Connection -> Application) -> Connection -> Application
+withSavepoint :: (Connection -> Application) -> (Connection -> Application)
 withSavepoint app conn req respond = do
   runRaw conn "savepoint req_sp"
   catch (app conn req respond) (\e -> let _ = (e::SomeException) in
     runRaw conn "rollback to savepoint req_sp" >> throw e)
 
-authenticated :: BS.ByteString -> (Connection -> Application)
-                 -> Connection -> Application
+authenticated :: BS.ByteString -> (Connection -> Application) ->
+                 (Connection -> Application)
 authenticated anon app conn req respond = do
   attempt <- httpRequesterRole (requestHeaders req)
   case attempt of
@@ -58,7 +61,6 @@ authenticated anon app conn req respond = do
           _ -> return MalformedAuth
       _ -> return NoCredentials
 
-
 instance ToJSON SqlError where
   toJSON t = object [
       "error" .= object [
@@ -78,3 +80,25 @@ clientErrors app req respond =
   where
     isPgException :: SqlError -> Maybe SqlError
     isPgException = Just
+
+
+redirectInsecure :: Application -> Application
+redirectInsecure app req respond = do
+  let hdrs = requestHeaders req
+      host = lookup "host" hdrs
+      uriM = parseURI . cs =<< mconcat [
+        Just "https://",
+        host,
+        Just $ rawPathInfo req,
+        Just $ rawQueryString req]
+      isHerokuSecure = lookup "x-forwarded-proto" hdrs == Just "https"
+
+  if not (isSecure req || isHerokuSecure)
+    then case uriM of
+              Just uri ->
+                respond $ responseLBS status301 [
+                    (hLocation, cs . show $ uri { uriScheme = "https:" })
+                  ] ""
+              Nothing ->
+                respond $ responseLBS status400 [] "SSL is required"
+    else app req respond