clckwrks 0.26.3 → 0.26.4

raw patch · 4 files changed

+63/−33 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Clckwrks/GetOpts.hs +28/−17
• Clckwrks/Monad.hs +20/−5
• Clckwrks/Server.hs +14/−10
• clckwrks.cabal +1/−1

@@ -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."

@@ -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 

@@ -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

@@ -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