diff --git a/Clckwrks/Authenticate/Plugin.hs b/Clckwrks/Authenticate/Plugin.hs --- a/Clckwrks/Authenticate/Plugin.hs +++ b/Clckwrks/Authenticate/Plugin.hs @@ -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 diff --git a/Clckwrks/Plugin.hs b/Clckwrks/Plugin.hs --- a/Clckwrks/Plugin.hs +++ b/Clckwrks/Plugin.hs @@ -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 diff --git a/Clckwrks/Server.hs b/Clckwrks/Server.hs --- a/Clckwrks/Server.hs +++ b/Clckwrks/Server.hs @@ -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 diff --git a/clckwrks.cabal b/clckwrks.cabal --- a/clckwrks.cabal +++ b/clckwrks.cabal @@ -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,