clckwrks 0.26.1 → 0.26.2

raw patch · 4 files changed

+83/−29 lines, 4 filesdep +http-typesdep ~aesondep ~bytestringdep ~randomPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: http-types

Dependency ranges changed: aeson, bytestring, random, web-plugins

API changes (from Hackage documentation)

Files

• Clckwrks/Authenticate/Plugin.hs +5/−5
• Clckwrks/Plugin.hs +5/−5
• Clckwrks/Server.hs +67/−14
• clckwrks.cabal +6/−5

@@ -117,11 +117,11 @@ -} authenticatePlugin :: Plugin AuthURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt authenticatePlugin = Plugin-    { pluginName       = "authenticate"-    , pluginInit       = authenticateInit-    , pluginDepends    = []-    , pluginToPathInfo = toPathInfo-    , pluginPostHook   = addAuthAdminMenu+    { pluginName           = "authenticate"+    , pluginInit           = authenticateInit+    , pluginDepends        = []+    , pluginToPathSegments = toPathSegments+    , pluginPostHook       = addAuthAdminMenu     }  plugin :: ClckPlugins

@@ -51,11 +51,11 @@  clckPlugin :: Plugin ClckURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt clckPlugin = Plugin-    { pluginName       = "clck"-    , pluginInit       = clckInit-    , pluginDepends    = []-    , pluginToPathInfo = toPathInfo-    , pluginPostHook   = addClckAdminMenu+    { pluginName           = "clck"+    , pluginInit           = clckInit+    , pluginDepends        = []+    , pluginToPathSegments = toPathSegments+    , pluginPostHook       = addClckAdminMenu     }  plugin :: ClckPlugins

@@ -11,26 +11,34 @@ import Clckwrks.ProfileData.URL     (ProfileDataURL(..)) import Control.Arrow                (second) import Control.Concurrent           (forkIO, killThread)-import Control.Concurrent.STM       (atomically, newTVar)+import Control.Concurrent.STM       (atomically, newTVar, readTVar) import Control.Monad.State          (get, evalStateT) import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as LB import Data.Acid.Advanced           (query') import           Data.Map           (Map) import qualified Data.Map           as Map import Data.Maybe                   (fromJust, fromMaybe, isNothing) import Data.Monoid                  ((<>))+import qualified Data.ByteString.Lazy.UTF8 as UTF8+import Data.ByteString.Builder      (toLazyByteString) import Data.String                  (fromString) import           Data.Text          (Text) import qualified Data.Text          as Text+import Data.Text.Encoding (decodeUtf8, decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode) import qualified Data.UUID.Types    as UUID import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile)+import Happstack.Server.Internal.Multipart (simpleInput) import Happstack.Server.Internal.Types (canHaveBody) import Happstack.Server.Monads      (askRq) import Happstack.Server.SimpleHTTPS (TLSConf(..), nullTLSConf, simpleHTTPS) import Happstack.Server.Types       (Request(rqMethod))+import Network.HTTP.Types           (encodePathSegments)+import Network.HTTP.Types.URI       (renderQueryText) import System.FilePath              ((</>), makeRelative, splitDirectories) import Web.Routes.Happstack         (implSite)-import Web.Plugins.Core             (Plugins, withPlugins, getPluginRouteFn, getPostHooks, serve)+import Web.Plugins.Core             (Plugins(..), PluginsState(pluginsRewrite), Rewrite(Rewrite, Redirect), withPlugins, getPluginRouteFn, getPostHooks, serve) import qualified Paths_clckwrks     as Clckwrks  withClckwrks :: ClckwrksConfig -> (ClckState -> IO b) -> IO b@@ -132,17 +140,62 @@ clckSite :: ClckwrksConfig -> ClckState -> ServerPart Response clckSite cc clckState =     do ~(Just clckShowFn) <- getPluginRouteFn (plugins clckState) (Text.pack "clck")-       evalClckT clckShowFn clckState (pluginsHandler (plugins clckState))+       evalClckT clckShowFn clckState (pluginsHandler cc (plugins clckState)) -pluginsHandler :: (Functor m, ServerMonad m, FilterMonad Response m, MonadIO m) =>-               Plugins theme (m Response) hook config ppm+pluginsHandler :: (Functor m, Happstack m, MonadIO m) =>+                  ClckwrksConfig+               -> Plugins theme (m Response) hook config ppm             -> m Response-pluginsHandler plugins =-    do paths <- (map Text.pack . rqPaths) <$> askRq-       case paths of-         (p : ps) ->-             do e <- liftIO $ serve plugins p ps-                case e of-                  (Right c) -> c-                  (Left e) -> notFound $ toResponse e-         _ -> notFound (toResponse ())+pluginsHandler cc plugins@(Plugins tvp) =+    do ps' <- liftIO $ atomically $ readTVar tvp+       req <- askRq+       let paths' = map Text.pack $ rqPaths req+           params'=+             let conv :: (String, Input) -> (Text, Maybe Text)+                 conv (k, i) =+                   case inputValue i of+                     (Left _)   -> (Text.pack k, Nothing)+                     (Right bs) -> (Text.pack k, Just $ decodeUtf8With lenientDecode (LB.toStrict bs))+             in map conv (rqInputsQuery req)+       -- we figure out which plugin to call by looking at the+       -- first path segment in the url+       let cont paths =+             case paths of+               (p : ps) ->+                 do e <- liftIO $ serve plugins p ps+                    case e of+                      (Right c) -> c+                      (Left e) -> notFound $ toResponse e+               _ -> notFound (toResponse ())++       -- before we can figure out what the path segment is, we+       -- need to rewrite the URL.+       -- FIXME: Somewhat annoyingly, we rewrite the url and then+       -- throw out the results.+       case pluginsRewrite ps' of+         Nothing  -> cont paths'+         (Just (mf, _)) ->+           let conv :: (Text, Maybe Text) -> (String, Input)+               conv (k, v) = (Text.unpack k, maybe (simpleInput "") (\v' -> simpleInput $ Text.unpack v') v)+           in do f <- liftIO mf+                 case f paths' params' of+                   (Just (Rewrite, paths, params))  ->+                     let qry = decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ renderQueryText True params+                         pi  = (decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ encodePathSegments paths)+                     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+                                            , rqInputsQuery = map conv params+                                            }) $ do rq <- askRq+                                                    liftIO $ print rq+                                                    cont paths+                   (Just (Redirect mBaseURI, paths, params))  ->+                     let qry = decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ renderQueryText True params+                         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 ())+                   Nothing -> cont paths'++--                (Redirect, paths) -> seeOther

@@ -1,5 +1,5 @@ Name:                clckwrks-Version:             0.26.1+Version:             0.26.2 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@@ -94,12 +94,12 @@    Build-depends:      acid-state                   >= 0.12 && < 0.17,-     aeson                        (>= 0.4  && < 0.10) || (>= 0.11 && < 1.5),+     aeson                        (>= 0.4  && < 0.10) || (>= 0.11 && < 1.6),      aeson-qq                     >= 0.7  && < 0.9,      attoparsec                   >= 0.10 && < 0.14,      base                                    < 5,      blaze-html                   >= 0.5  && < 0.10,-     bytestring                   >= 0.9  && < 0.11,+     bytestring                   >= 0.9  && < 0.12,      cereal                       >= 0.4  && < 0.6,      containers                   >= 0.4  && < 0.7,      directory                    >= 1.1  && < 1.4,@@ -112,6 +112,7 @@      hsp                          >= 0.9  && < 0.11,      hsx-jmacro                   == 7.3.*,      hsx2hs                       >= 0.13 && < 0.15,+     http-types                              < 0.13,      ixset                        >= 1.0 && < 1.2,      jmacro                       == 0.6.*,      lens                         >= 4.3  && < 4.20,@@ -119,7 +120,7 @@      old-locale                   ==  1.0.*,      process                      >= 1.0  && < 1.7, --     plugins-auto == 0.0.1.1,-     random                       >= 1.0  && < 1.2,+     random                       >= 1.0  && < 1.3,      reform                       >= 0.2 && < 0.4,      reform-happstack             == 0.2.*,      reform-hsp                   >= 0.2  && < 0.3,@@ -134,7 +135,7 @@      userid                       >= 0.1  && < 0.2,      utf8-string                  >= 0.3  && < 1.1,      vector                       >= 0.9,-     web-plugins                  >= 0.1  && < 0.3,+     web-plugins                  >= 0.4  && < 0.5,      web-routes,      web-routes-happstack,      web-routes-hsp,