Merge branch 'master' into errors

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

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