diff --git a/Clckwrks/GetOpts.hs b/Clckwrks/GetOpts.hs --- a/Clckwrks/GetOpts.hs +++ b/Clckwrks/GetOpts.hs @@ -31,7 +31,8 @@ , Option [] ["https-port"] (ReqArg setTLSPort "port") ("Port to bind https server, default:" ++ maybe "disabled." show (clckTLSPort <$> (clckTLS def))) , Option [] ["tls-cert"] (ReqArg setTLSCert "path") ("Path to tls .cert file. (required for https).") , Option [] ["tls-key"] (ReqArg setTLSKey "path") ("Path to tls .key file. (required for https).") - , Option [] ["tls-ca"] (ReqArg setTLSCA "path") ("Path to tls .pem file. (required for some certs).") + , Option [] ["tls-ca"] (ReqArg setTLSCA "path") ("Path to tls .pem file. (required for some certs).") + , Option [] ["tls-rev-proxy"] (NoArg setTLSRevProxy) ("Act as a reverse proxy and trust X-Forwarded-Proto for TLS.") , Option [] ["hide-port"] (NoArg setHidePort) "Do not show the port number in the URL" , Option [] ["hostname"] (ReqArg setHostname "hostname") ("Server hostname, default: " ++ show (clckHostname def)) , Option [] ["jquery-path"] (ReqArg setJQueryPath "path") ("path to jquery directory, default: " ++ show (clckJQueryPath def)) @@ -43,9 +44,10 @@ ] where nullTLSSettings = TLSSettings { clckTLSPort = 443 - , clckTLSCert = "" - , clckTLSKey = "" + , clckTLSCert = Nothing + , clckTLSKey = Nothing , clckTLSCA = Nothing + , clckTLSRev = False } modifyTLS f cc = Just $ case clckTLS cc of @@ -54,9 +56,10 @@ noop _ = ModifyConfig $ id setPort str = ModifyConfig $ \c -> c { clckPort = read str } setTLSPort str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSPort = read str }) c } - setTLSCert str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSCert = str }) c } - setTLSKey str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSKey = str }) c } + setTLSCert str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSCert = Just str }) c } + setTLSKey str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSKey = Just str }) c } setTLSCA str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSCA = Just str }) c } + setTLSRevProxy = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSRev = True}) c } setHostname str = ModifyConfig $ \c -> c { clckHostname = str } setHidePort = ModifyConfig $ \c -> c { clckHidePort = True } setJQueryPath str = ModifyConfig $ \c -> c { clckJQueryPath = str } @@ -87,19 +90,27 @@ Nothing -> return cc (Just TLSSettings{..}) -> do mCertError <- - if null clckTLSCert - then return (Just "--tls-cert not set.") - else do b <- doesFileExist clckTLSCert - if b - then return Nothing - else return (Just $ "Can not find the file " ++ clckTLSCert) + case clckTLSCert of + Nothing -> + if clckTLSRev + then return Nothing + else return (Just "--tls-cert not set.") + (Just certPath) -> do + b <- doesFileExist certPath + if b + then return Nothing + else return (Just $ "Can not find the file " ++ certPath) mKeyError <- - if null clckTLSKey - then return (Just "--tls-key not set.") - else do b <- doesFileExist clckTLSKey - if b - then return Nothing - else return (Just $ "Can not find the file " ++ clckTLSKey) + case clckTLSKey of + Nothing -> + if clckTLSRev + then return Nothing + else return (Just "--tls-key not set.") + (Just keyPath) -> do + b <- doesFileExist keyPath + if b + then return Nothing + else return (Just $ "Can not find the file " ++ keyPath) case (mCertError, mKeyError) of (Nothing, Nothing) -> return cc _ -> do putStrLn "It seems you are trying to enable https support. To do that you need to use both the --tls-cert and --tls-key flags." diff --git a/Clckwrks/Monad.hs b/Clckwrks/Monad.hs --- a/Clckwrks/Monad.hs +++ b/Clckwrks/Monad.hs @@ -45,6 +45,7 @@ , query , update , nestURL + , isSecure , withAbs , withAbs' , segments @@ -104,7 +105,7 @@ , WebMonad(..), Input, Request(..), Response, HasRqData(..) , ServerPart, ServerPartT, UnWebT, addCookie, expireCookie, escape , internalServerError, lookCookieValue, mapServerPartT, mkCookie - , toResponse + , toResponse, getHeaderUnsafe ) import Happstack.Server.HSP.HTML () -- ToMessage XML instance import Happstack.Server.XMLGenT () -- instance Happstack XMLGenT @@ -202,9 +203,10 @@ data TLSSettings = TLSSettings { clckTLSPort :: Int - , clckTLSCert :: FilePath - , clckTLSKey :: FilePath + , clckTLSCert :: Maybe FilePath + , clckTLSKey :: Maybe FilePath , clckTLSCA :: Maybe FilePath + , clckTLSRev :: Bool } data ClckwrksConfig = ClckwrksConfig @@ -389,11 +391,24 @@ nestURL :: (url1 -> url2) -> ClckT url1 m a -> ClckT url2 m a nestURL f (ClckT r) = ClckT $ R.nestURL f r +isSecure :: ClckwrksConfig -> Request -> Bool +isSecure cc req = + case rqSecure req of + True -> True + False -> case clckTLS cc of + Nothing -> False + Just tlsSettings -> + case clckTLSRev tlsSettings of + False -> False + True -> case getHeaderUnsafe "x-forwarded-proto" req of + Nothing -> False + Just proto -> proto == "https" + withAbs :: (Happstack m) => ClckT url m a -> ClckT url m a withAbs m = - do secure <- rqSecure <$> askRq - clckState <- get + do clckState <- get cc <- getConfig (plugins clckState) + secure <- isSecure cc <$> askRq let base = if secure then (fromJust $ calcTLSBaseURI cc) else calcBaseURI cc withAbs' base m diff --git a/Clckwrks/Server.hs b/Clckwrks/Server.hs --- a/Clckwrks/Server.hs +++ b/Clckwrks/Server.hs @@ -75,14 +75,18 @@ case clckTLS cc' of Nothing -> return Nothing (Just TLSSettings{..}) -> - do let tlsConf = nullTLSConf { tlsPort = clckTLSPort - , tlsCert = clckTLSCert - , tlsKey = clckTLSKey - , tlsCA = clckTLSCA - } - tid <- forkIO $ simpleHTTPS tlsConf (handlers cc' clckState'') - return (Just tid) + case (clckTLSCert, clckTLSKey) of + (Just certPath, Just keyPath) -> do + let tlsConf = nullTLSConf { tlsPort = clckTLSPort + , tlsCert = certPath + , tlsKey = keyPath + , tlsCA = clckTLSCA + } + tid <- forkIO $ simpleHTTPS tlsConf (handlers cc' clckState'') + return (Just tid) + _ -> return Nothing + httpTID <- if isNothing mHttpsTID then forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) (handlers cc' clckState'') else forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) forceHTTPS @@ -117,7 +121,7 @@ (Just hostBS) -> if (clckHostname cc == (B.unpack $ B.takeWhile (/= ':') hostBS)) then return () - else escape $ seeOther ((if rqSecure rq then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) <> (Text.pack $ rqUri rq) <> (Text.pack $ rqQuery rq)) (toResponse ()) + else escape $ seeOther ((if isSecure cc rq then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) <> (Text.pack $ rqUri rq) <> (Text.pack $ rqQuery rq)) (toResponse ()) -- if https:// is available, then force it to be used. -- GET requests will be redirected automatically, POST, PUT, etc will be denied @@ -185,7 +189,7 @@ in localRq (\req -> req { rqQuery = UTF8.toString $ toLazyByteString $ renderQueryText True params , rqPaths = map Text.unpack paths - , rqUri = Text.unpack $ (if rqSecure req then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) <> pi <> qry + , rqUri = Text.unpack $ (if isSecure cc req then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) <> pi <> qry , rqInputsQuery = map conv params }) $ do -- rq <- askRq -- liftIO $ print rq @@ -195,7 +199,7 @@ pi = (decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ encodePathSegments paths) in do -- liftIO $ putStrLn $ show $ rqQuery req - escape $ seeOther ((fromMaybe (if rqSecure req then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) mBaseURI) <> pi <> qry) (toResponse ()) + escape $ seeOther ((fromMaybe (if isSecure cc req then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) mBaseURI) <> pi <> qry) (toResponse ()) Nothing -> cont paths' -- (Redirect, paths) -> seeOther diff --git a/clckwrks.cabal b/clckwrks.cabal --- a/clckwrks.cabal +++ b/clckwrks.cabal @@ -1,5 +1,5 @@ Name: clckwrks -Version: 0.26.3 +Version: 0.26.4 Synopsis: A secure, reliable content management system (CMS) and blogging platform Description: clckwrks (pronounced, clockworks) aims to compete directly with popular PHP-based blogging and CMS