Merge branch 'master' into errors

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

dbapi.cabal

@@ -1,5 +1,5 @@
 name:                  dbapi
-version:               0.1.0.0
+version:               0.2.0.0
 synopsis:              The database is your api
 license:               MIT
 license-file:          LICENSE
@@ -20,7 +20,7 @@ executable dbapi
                      , HTTP, convertible
                      , case-insensitive
                      , http-types, scientific, time
-                     , bytestring, aeson, network
+                     , bytestring, aeson, network >= 2.6
                      , text , containers
                      , optparse-applicative >= 0.9.1 && < 0.10
                      , unordered-containers
@@ -29,10 +29,10 @@ executable dbapi
                      , http-media, regex-tdfa
                      , Ranged-sets
                      , transformers
-                     , warp-tls
                      , bcrypt
                      , base64-string
                      , split
+                     , network-uri >= 2.6
   Other-Modules:       Dbapi
                      , PgStructure
                      , PgQuery
@@ -55,7 +55,7 @@ Test-Suite spec
                      , case-insensitive
                      , wai-extra, wai-cors, containers
                      , http-types, scientific, time
-                     , bytestring, aeson, network
+                     , bytestring, aeson, network >= 2.6
                      , text, optparse-applicative
                      , unordered-containers
                      , regex-base
@@ -63,7 +63,7 @@ Test-Suite spec
                      , http-media, regex-tdfa
                      , Ranged-sets
                      , transformers
-                     , warp-tls
                      , bcrypt
                      , base64-string
                      , split
+                     , network-uri >= 2.6

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)
+  unless (configSecure conf) $
-  let settings = setPort port defaultSettings
+    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 $ (
+  run port $ (if configSecure conf then redirectInsecure else id)
-    inTransaction . authenticated (cs $ configAnonRole conf) . withSavepoint) app conn
+    . 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.Header (RequestHeaders, hContentType, hAuthorization,
-import Network.HTTP.Types.Status (status400, status401)
+  hLocation)
-import Network.Wai (Application, requestHeaders, responseLBS)
+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)
+authenticated :: BS.ByteString -> (Connection -> Application) ->
-                 -> 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

test/SpecHelper.hs

@@ -29,7 +29,7 @@ isLeft (Left _ ) = True
 isLeft _ = False
 
 cfg :: AppConfig
-cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "test/test.crt" "test/test.key" "dbapi_anonymous"
+cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False
 
 openConnection :: IO Connection
 openConnection = connectPostgreSQL' $ configDbUri cfg
@@ -88,8 +88,8 @@ authHeader user pass =
 
 -- for hspec-wai
 pending_ :: WaiSession ()
-pending_ = liftIO pending
+pending_ = liftIO Test.Hspec.pending
 
 -- for hspec-wai
 pendingWith_ :: String -> WaiSession ()
-pendingWith_ = liftIO . pendingWith
+pendingWith_ = liftIO . Test.Hspec.pendingWith

test/test.crt

@@ -1,14 +0,0 @@
------BEGIN CERTIFICATE-----
-MIICLTCCAZYCCQCj6GtISfdwNjANBgkqhkiG9w0BAQUFADBbMQswCQYDVQQGEwJV
-UzELMAkGA1UECBMCQ0ExFjAUBgNVBAcTDVNhbiBGcmFuY2lzY28xEzARBgNVBAoT
-Ckxvb3AgUmVjdXIxEjAQBgNVBAMTCWxvY2FsaG9zdDAeFw0xNDEwMDMyMDQyNDNa
-Fw0xNTEwMDMyMDQyNDNaMFsxCzAJBgNVBAYTAlVTMQswCQYDVQQIEwJDQTEWMBQG
-A1UEBxMNU2FuIEZyYW5jaXNjbzETMBEGA1UEChMKTG9vcCBSZWN1cjESMBAGA1UE
-AxMJbG9jYWxob3N0MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC5gFnTRBge
-mXdkCMD+OycujZrCWOOLIDBqRr7kDbxVXqz/TKHRVx6bz88g9egzvR2HLyA418kd
-dAu+lMmjrRv/k0Lnk/UvC1aj0huoHpOVUgOwy3qS4cE663uU5qsrgf4RDP7bLDcQ
-FDW02SQ2n5ryv8nB9TSYpvQvYPiTMMKdrwIDAQABMA0GCSqGSIb3DQEBBQUAA4GB
-AAQwkC+GSaGArAKdMIqs8/55KAjyNd11MupiCWsu1cwBJ4QJc1PxrYOMLMYnU06J
-I0v1bJ6mG06/Js0r2FHM0NXSQO+7DLPWu4LchoBgFt4ZRm2+GbLzFrfu41yn5mJN
-VeUxCBQ9hOrE8Kwe+/9IUUVPxlISF+YHOyF3DxWUViak
------END CERTIFICATE-----

test/test.key

@@ -1,15 +0,0 @@
------BEGIN RSA PRIVATE KEY-----
-MIICXQIBAAKBgQC5gFnTRBgemXdkCMD+OycujZrCWOOLIDBqRr7kDbxVXqz/TKHR
-Vx6bz88g9egzvR2HLyA418kddAu+lMmjrRv/k0Lnk/UvC1aj0huoHpOVUgOwy3qS
-4cE663uU5qsrgf4RDP7bLDcQFDW02SQ2n5ryv8nB9TSYpvQvYPiTMMKdrwIDAQAB
-AoGAZZD0Haub9S0b5KayXMCwnFmmEaEvvR47xATGQgGPS8LRv9sKgp9LwA4RH7/k
-imeSglD4OIdVs421XH0ExlxjBiV5EzTCgLUyKbfA//xUy9ggXD1Ks4vIHL0c1DM4
-g6/zylN7CQtt4Bb6YdWDSAUXIl3U5Dj1kG7BWuXfJTxCx7ECQQDyLxoQRNkPwKP/
-xeOqfCgwyD52rnUJ7g9UViFcCU2ZLLEYxE4b3FECcwhOfUlxYvKdOx03Qts0taow
-dPU/BEXHAkEAxBVyKwTJ0T6rQmcQEx3WuaBhSjXgZigUN4OdXMg+LSO+1MON6Nhm
-J9ociy+xvfd0Cf3yABaAEU/hZ+Pmk2DI2QJBAO/XU8F+3VQrXH7l9HSXJppBBRM1
-7HScDRRhhAIIuI+UYgJ8DjqrMpLxZu2MSBqBenHZ5DIhBMOrkVMR0PrKeWsCQCHh
-gsSkIysgpP7oSALFmSCh8a2c+ZUtP7EH8NzjTLsH/iVNVOvy2FPygBQcvZ2RcF95
-naMeQCq9nrkQy/qTMqECQQDa1WjWS2ngwqGzHovqiKRg3lQ8MFNlvlStAQl8+9h0
-KJj8Rl6h+gO8eretBIe+y5j/hCC90xlJotzwO3jJF6Hc
------END RSA PRIVATE KEY-----