diff --git a/Clckwrks.hs b/Clckwrks.hs --- a/Clckwrks.hs +++ b/Clckwrks.hs @@ -1,34 +1,40 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, TypeFamilies #-} module Clckwrks ( module Clckwrks.Acid + , module Clckwrks.Authenticate.Plugin , module Clckwrks.Monad , module Clckwrks.ProfileData.API , module Clckwrks.ProfileData.Types + , module Clckwrks.ProfileData.URL , module Clckwrks.Types , module Clckwrks.Unauthorized , module Clckwrks.URL + , module Clckwrks.JS.URL , module Control.Applicative , module Control.Monad , module Control.Monad.Trans - , module Happstack.Auth , module Happstack.Server + , module Happstack.Authenticate.Core , module Language.Javascript.JMacro , module Web.Routes , module Web.Routes.Happstack ) where import Clckwrks.Acid +import Clckwrks.Authenticate.Plugin (getUserId) import Clckwrks.Admin.URL +import Clckwrks.JS.URL import Clckwrks.Monad import Clckwrks.ProfileData.API import Clckwrks.ProfileData.Types +import Clckwrks.ProfileData.URL import Clckwrks.Types import Clckwrks.Unauthorized import Clckwrks.URL import Control.Applicative import Control.Monad import Control.Monad.Trans -import Happstack.Auth (UserId(..)) +import Happstack.Authenticate.Core (UserId(..)) import Happstack.Server import Happstack.Server.HSP.HTML import Language.Javascript.JMacro (JExpr(..), JMacro(..), JStat(..), JType(..), JVal(..), Ident(..), toJExpr, jmacro, jmacroE) diff --git a/Clckwrks/Acid.hs b/Clckwrks/Acid.hs --- a/Clckwrks/Acid.hs +++ b/Clckwrks/Acid.hs @@ -17,8 +17,8 @@ import Data.Maybe (fromMaybe) import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension) import Data.Text (Text) -import Happstack.Auth.Core.Auth (AuthState , initialAuthState) -import Happstack.Auth.Core.Profile (ProfileState , initialProfileState) +import Happstack.Authenticate.Core (AuthenticateState) +import Happstack.Authenticate.Password.Core (PasswordState) import Network (PortID(UnixSocket)) import Prelude hiding (catch) import System.Directory (removeFile) @@ -115,11 +115,10 @@ ]) data Acid = Acid - { acidAuth :: AcidState AuthState - , acidProfile :: AcidState ProfileState - , acidProfileData :: AcidState ProfileDataState - , acidCore :: AcidState CoreState - , acidNavBar :: AcidState NavBarState + { -- acidAuthenticate :: AcidState AuthenticateState + acidProfileData :: AcidState ProfileDataState + , acidCore :: AcidState CoreState + , acidNavBar :: AcidState NavBarState } class GetAcidState m st where @@ -128,14 +127,12 @@ withAcid :: Maybe FilePath -> (Acid -> IO a) -> IO a withAcid mBasePath f = let basePath = fromMaybe "_state" mBasePath in - bracket (openLocalStateFrom (basePath "auth") initialAuthState) (createArchiveCheckpointAndClose) $ \auth -> - bracket (openLocalStateFrom (basePath "profile") initialProfileState) (createArchiveCheckpointAndClose) $ \profile -> bracket (openLocalStateFrom (basePath "profileData") initialProfileDataState) (createArchiveCheckpointAndClose) $ \profileData -> bracket (openLocalStateFrom (basePath "core") initialCoreState) (createArchiveCheckpointAndClose) $ \core -> bracket (openLocalStateFrom (basePath "navBar") initialNavBarState) (createArchiveCheckpointAndClose) $ \navBar -> bracket (forkIO (tryRemoveFile (basePath "profileData_socket") >> acidServer skipAuthenticationCheck (UnixSocket $ basePath "profileData_socket") profileData)) (\tid -> killThread tid >> tryRemoveFile (basePath "profileData_socket")) - (const $ f (Acid auth profile profileData core navBar)) + (const $ f (Acid profileData core navBar)) where tryRemoveFile fp = removeFile fp `catch` (\e -> if isDoesNotExistError e then return () else throw e) createArchiveCheckpointAndClose acid = diff --git a/Clckwrks/Admin/Template.hs b/Clckwrks/Admin/Template.hs --- a/Clckwrks/Admin/Template.hs +++ b/Clckwrks/Admin/Template.hs @@ -1,17 +1,28 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} -{-# OPTIONS_GHC -F -pgmFhsx2hs #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings, QuasiQuotes #-} module Clckwrks.Admin.Template where -import Clckwrks -import Control.Monad.State (get) -import Data.Maybe (mapMaybe, fromMaybe) -import Data.Text.Lazy (Text) -import qualified Data.Text as T -import Data.Set (Set) -import qualified Data.Set as Set +import Control.Applicative ((<$>)) +import Control.Monad.Trans (lift) +import Clckwrks.Acid (GetSiteName(..)) +import Clckwrks.Monad (ClckT(..), ClckState(adminMenus), plugins, query) +import Clckwrks.URL (ClckURL(JS)) +import Clckwrks.JS.URL (JSURL(..)) +import {-# SOURCE #-} Clckwrks.Authenticate.Plugin (authenticatePlugin) +import Clckwrks.Authenticate.URL (AuthURL(Auth)) +import Clckwrks.ProfileData.API (getUserRoles) +import Clckwrks.ProfileData.Types (Role) +import Control.Monad.State (get) +import Data.Maybe (mapMaybe, fromMaybe) +import Data.Text.Lazy (Text) +import qualified Data.Text as T +import Data.Set (Set) +import qualified Data.Set as Set +import Happstack.Authenticate.Core (AuthenticateURL(Controllers)) +import Happstack.Server (Happstack, Response, toResponse) import HSP.XMLGenerator -import HSP.XML (XML, fromStringLit) - +import HSP.XML (XML, fromStringLit) +import Language.Haskell.HSX.QQ (hsx) +import Web.Plugins.Core (pluginName, getPluginRouteFn) template :: ( Happstack m @@ -20,20 +31,28 @@ ) => String -> headers -> body -> ClckT url m Response template title headers body = do siteName <- (fromMaybe "Your Site") <$> query GetSiteName - toResponse <$> (unXMLGenT $ + p <- plugins <$> get + (Just authShowURL) <- getPluginRouteFn p (pluginName authenticatePlugin) + (Just clckShowURL) <- getPluginRouteFn p "clck" +-- let passwordShowURL u = authShowURL (Auth (AuthenticationMethods $ Just (passwordAuthenticationMethod, toPathSegments u))) [] + toResponse <$> (unXMLGenT $ [hsx| - - + +-- - - + + + +-- + + <% title %> <% headers %> - +
@@ -53,7 +72,8 @@
- ) + + |]) emptyTemplate :: ( Happstack m @@ -62,7 +82,7 @@ ) => String -> headers -> body -> ClckT url m Response emptyTemplate title headers body = do siteName <- (fromMaybe "Your Site") <$> query GetSiteName - toResponse <$> (unXMLGenT $ + toResponse <$> (unXMLGenT $ [hsx| @@ -95,8 +115,7 @@
- ) - + |]) sidebar :: (Happstack m) => XMLGenT (ClckT url m) XML sidebar = adminMenuXML @@ -105,11 +124,11 @@ adminMenuXML = do allMenus <- adminMenus <$> get usersMenus <- filterByRole allMenus -
+ [hsx|
-
+
|] where -- filterByRole :: [(T.Text, [(Set Role, T.Text, T.Text)])] -> [(T.Text, [(Set Role, T.Text, T.Text)])] filterByRole menus = @@ -122,11 +141,12 @@ itemFilter userRoles (visibleRoles, _, _) = not (Set.null (Set.intersection userRoles visibleRoles)) -- mkMenu :: (Functor m, Monad m) => (T.Text, [(Set Role, T.Text, T.Text)]) -> XMLGenT (ClckT url m) XML - mkMenu (category, links) = + mkMenu (category, links) = [hsx| <%>
  • <% category %>
    • <% mapM mkLink links %> - + |] mkLink :: (Functor m, Monad m) => (Set Role, T.Text, T.Text) -> XMLGenT (ClckT url m) XML - mkLink (_visible, title, url) = + mkLink (_visible, title, url) = [hsx|
  • <% title %>
    • + |] diff --git a/Clckwrks/Authenticate/Page/ChangePassword.hs b/Clckwrks/Authenticate/Page/ChangePassword.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Authenticate/Page/ChangePassword.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-} +module Clckwrks.Authenticate.Page.ChangePassword where + +import Clckwrks.Admin.Template (template) +import Clckwrks.Monad +import Clckwrks.URL (ClckURL) +import Happstack.Server (Response, ServerPartT, ok, toResponse) +import Language.Haskell.HSX.QQ (hsx) + +changePasswordPanel :: ClckT ClckURL (ServerPartT IO) Response +changePasswordPanel = + do template "Upload Medium" () $ [hsx| + <%> + + |] + diff --git a/Clckwrks/Authenticate/Page/Login.hs b/Clckwrks/Authenticate/Page/Login.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Authenticate/Page/Login.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +module Clckwrks.Authenticate.Page.Login where + +import Control.Applicative ((<$>)) +import Clckwrks.Monad (ClckT, ThemeStyleId(..), plugins, themeTemplate) +import Clckwrks.URL (ClckURL(..)) +import Clckwrks.Authenticate.URL +import Control.Monad.State (get) +import Happstack.Server (Response, ServerPartT) +import HSP +import Language.Haskell.HSX.QQ (hsx) + +loginPage :: ClckT ClckURL (ServerPartT IO) Response +loginPage = + do plugins <- plugins <$> get + themeTemplate plugins (ThemeStyleId 0) "Login" () [hsx| +
    +
    +

    Login

    + +
    + +
    + +

    Logout

    +

    You have successfully logged in! Click the link below to logout.

    + + +

    Forgotten Password?

    +

    Forgot your password? Request a reset link via email!

    + +
    + +

    Create A New Account

    + +
    |] diff --git a/Clckwrks/Authenticate/Page/OpenIdRealm.hs b/Clckwrks/Authenticate/Page/OpenIdRealm.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Authenticate/Page/OpenIdRealm.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-} +module Clckwrks.Authenticate.Page.OpenIdRealm where + +import Clckwrks.Admin.Template (template) +import Clckwrks.Monad +import Clckwrks.URL (ClckURL) +import Happstack.Server (Response, ServerPartT, ok, toResponse) +import Language.Haskell.HSX.QQ (hsx) + +openIdRealmPanel :: ClckT ClckURL (ServerPartT IO) Response +openIdRealmPanel = + do template "Set OpenId Realm" () $ [hsx| +
    + +
    |] + diff --git a/Clckwrks/Authenticate/Page/ResetPassword.hs b/Clckwrks/Authenticate/Page/ResetPassword.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Authenticate/Page/ResetPassword.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +module Clckwrks.Authenticate.Page.ResetPassword where + +import Control.Applicative ((<$>)) +import Clckwrks.Monad (ClckT, ThemeStyleId(..), plugins, themeTemplate) +import Clckwrks.URL (ClckURL(..)) +import Clckwrks.Authenticate.URL +import Control.Monad.State (get) +import Happstack.Server (Response, ServerPartT) +import HSP +import Language.Haskell.HSX.QQ (hsx) + +resetPasswordPage :: ClckT ClckURL (ServerPartT IO) Response +resetPasswordPage = + do plugins <- plugins <$> get + themeTemplate plugins (ThemeStyleId 0) "Reset Password" () [hsx| + <%> +

    Reset Password

    + + |] diff --git a/Clckwrks/Authenticate/Plugin.hs b/Clckwrks/Authenticate/Plugin.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Authenticate/Plugin.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DeriveDataTypeable, RecordWildCards, FlexibleContexts, Rank2Types, OverloadedStrings #-} +module Clckwrks.Authenticate.Plugin where + +import Clckwrks.Monad +import Clckwrks.Acid (acidProfileData) +import Clckwrks.Authenticate.Route (routeAuth) +import Clckwrks.Authenticate.URL (AuthURL(..)) +import Clckwrks.ProfileData.Acid (HasRole(..)) +import Clckwrks.ProfileData.Types (Role(..)) +import Clckwrks.Types (NamedLink(..)) +import Clckwrks.URL +import Control.Applicative ((<$>)) +import Control.Lens ((^.)) +import Control.Monad.State (get) +import Control.Monad.Trans (lift) +import Data.Acid as Acid (AcidState, query) +import Data.Maybe (isJust) +import Data.Monoid ((<>)) +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Typeable (Typeable) +import qualified Data.Text as Text +import qualified Data.Set as Set +import qualified Data.Text.Lazy as TL +import Happstack.Authenticate.Core (AuthenticateState, UserId, getToken, tokenUser, userId) +import Happstack.Authenticate.Route (initAuthentication) +import Happstack.Authenticate.Password.Route (initPassword) +import Happstack.Authenticate.OpenId.Route (initOpenId) +import Happstack.Server +import System.FilePath (()) +import Web.Plugins.Core (Plugin(..), addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, getPluginsSt, initPlugin) +import Web.Routes + +newtype AcidStateAuthenticate = AcidStateAuthenticate { acidStateAuthenticate :: AcidState AuthenticateState } + deriving Typeable + +authenticateHandler + :: (AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response) + -> (AuthURL -> [(Text, Maybe Text)] -> Text) + -> ClckPlugins + -> [Text] + -> ClckT ClckURL (ServerPartT IO) Response +authenticateHandler routeAuthenticate showAuthenticateURL _plugins paths = + case parseSegments fromPathSegments paths of + (Left e) -> notFound $ toResponse (show e) + (Right u) -> routeAuth routeAuthenticate u -- ClckT $ withRouteT flattenURL $ unClckT $ + where + flattenURL :: ((url' -> [(Text, Maybe Text)] -> Text) -> (AuthURL -> [(Text, Maybe Text)] -> Text)) + flattenURL _ u p = showAuthenticateURL u p + +authMenuCallback :: (AuthURL -> [(Text, Maybe Text)] -> Text) + -> ClckT ClckURL IO (String, [NamedLink]) +authMenuCallback authShowFn = + return ("Authenticate", [NamedLink "Login" (authShowFn Login [])]) + +addAuthAdminMenu :: ClckT url IO () +addAuthAdminMenu = + do p <- plugins <$> get + (Just authShowURL) <- getPluginRouteFn p (pluginName authenticatePlugin) + addAdminMenu ("Authentication", [(Set.fromList [Visitor] , "Change Password", authShowURL ChangePassword [])]) + addAdminMenu ("Authentication", [(Set.fromList [Administrator], "OpenId Realm" , authShowURL OpenIdRealm [])]) + +authenticateInit + :: ClckPlugins + -> IO (Maybe Text) +authenticateInit plugins = + do (Just authShowFn) <- getPluginRouteFn plugins (pluginName authenticatePlugin) + addNavBarCallback plugins (authMenuCallback authShowFn) + -- addHandler plugins (pluginName clckPlugin) (authenticateHandler clckShowFn) + cc <- getConfig plugins + acid <- cpsAcid <$> getPluginsSt plugins + let basePath = maybe "_state" (\top -> top "_state") (clckTopDir cc) + baseUri = case calcTLSBaseURI cc of + Nothing -> calcBaseURI cc + (Just b) -> b + (authCleanup, routeAuthenticate, authenticateState) <- initAuthentication (Just basePath) (\uid -> Acid.query (acidProfileData acid) (HasRole uid (Set.singleton Administrator))) + [ initPassword (baseUri <> authShowFn ResetPassword [] <> "/#") (Text.pack $ clckHostname cc) + , initOpenId + ] + addHandler plugins (pluginName authenticatePlugin) (authenticateHandler routeAuthenticate authShowFn) + addPluginState plugins (pluginName authenticatePlugin) (AcidStateAuthenticate authenticateState) + return Nothing +{- +addClckAdminMenu :: ClckT url IO () +addClckAdminMenu = + do p <- plugins <$> get + (Just clckShowURL) <- getPluginRouteFn p (pluginName clckPlugin) + addAdminMenu ( "Profile" + , [ (Set.fromList [Administrator, Visitor], "Edit Your Profile" , clckShowURL (Profile EditProfileData) []) + ] + ) + + addAdminMenu ( "Clckwrks" + , [ (Set.singleton Administrator, "Console" , clckShowURL (Admin Console) []) + , (Set.singleton Administrator, "Edit Settings", clckShowURL (Admin EditSettings) []) + , (Set.singleton Administrator, "Edit Nav Bar" , clckShowURL (Admin EditNavBar) []) + ] + ) +-} +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 + } + +plugin :: ClckPlugins + -> Text + -> IO (Maybe Text) +plugin plugins baseURI = + initPlugin plugins baseURI authenticatePlugin + +getUserId :: (Happstack m) => ClckT url m (Maybe UserId) +getUserId = + do p <- plugins <$> get + (Just (AcidStateAuthenticate authenticateState)) <- getPluginState p (pluginName authenticatePlugin) + mToken <- getToken authenticateState + case mToken of + Nothing -> return Nothing + (Just (token, _)) -> return $ Just (token ^. tokenUser ^. userId) diff --git a/Clckwrks/Authenticate/Plugin.hs-boot b/Clckwrks/Authenticate/Plugin.hs-boot new file mode 100644 --- /dev/null +++ b/Clckwrks/Authenticate/Plugin.hs-boot @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveDataTypeable, RecordWildCards, FlexibleContexts, Rank2Types, OverloadedStrings #-} +module Clckwrks.Authenticate.Plugin where + +import Happstack.Authenticate.Core (UserId) +import Clckwrks.Authenticate.URL (AuthURL) +import Clckwrks.Monad +import Clckwrks.URL +import Happstack.Server +import Web.Plugins.Core (Plugin(..), addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, initPlugin) + +authenticatePlugin :: Plugin AuthURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt + +getUserId :: (Happstack m) => ClckT url m (Maybe UserId) diff --git a/Clckwrks/Authenticate/Route.hs b/Clckwrks/Authenticate/Route.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Authenticate/Route.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +module Clckwrks.Authenticate.Route where + +import Control.Applicative ((<$>)) +import Clckwrks.Monad (ClckT, plugins) +import Clckwrks.Authenticate.URL (AuthURL(..)) +import Clckwrks.Authenticate.Page.Login (loginPage) +import Clckwrks.Authenticate.Page.ChangePassword (changePasswordPanel) +import Clckwrks.Authenticate.Page.ResetPassword (resetPasswordPage) +import Clckwrks.Authenticate.Page.OpenIdRealm (openIdRealmPanel) +import Clckwrks.URL (ClckURL) +import Control.Monad.State (get) +import Control.Monad.Trans (lift) +import Happstack.Authenticate.Core (AuthenticateURL) +import Happstack.Server (Response, ServerPartT) +import Web.Routes (RouteT, askRouteFn, runRouteT) +import Web.Plugins.Core (getPluginRouteFn, pluginName) + +-- | routeAuth +routeAuth :: (AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response) + -> AuthURL + -> ClckT ClckURL (ServerPartT IO) Response +routeAuth routeAuthenticate u = + case u of + (Auth authenticateURL) -> + do p <- plugins <$> get + (Just authShowFn) <- getPluginRouteFn p "authenticate" + lift $ runRouteT routeAuthenticate (authShowFn . Auth) authenticateURL + Login -> loginPage + ResetPassword -> resetPasswordPage + ChangePassword -> changePasswordPanel + OpenIdRealm -> openIdRealmPanel + diff --git a/Clckwrks/Authenticate/URL.hs b/Clckwrks/Authenticate/URL.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Authenticate/URL.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleInstances, TemplateHaskell, TypeFamilies #-} +module Clckwrks.Authenticate.URL + ( AuthURL(..) + ) + where + +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Happstack.Authenticate.Core (AuthenticateURL(..)) +import Web.Routes.TH (derivePathInfo) + +data AuthURL + = Auth AuthenticateURL + | Login + | ResetPassword + | ChangePassword + | OpenIdRealm + deriving (Eq, Ord, Data, Typeable, Generic, Read, Show) + +derivePathInfo ''AuthURL diff --git a/Clckwrks/GetOpts.hs b/Clckwrks/GetOpts.hs --- a/Clckwrks/GetOpts.hs +++ b/Clckwrks/GetOpts.hs @@ -33,7 +33,7 @@ , 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 [] ["hide-port"] (NoArg setHidePort) "Do not show the port number in the URL" - , Option [] ["hostname"] (ReqArg setHostname "hostname") ("Server hostename, default: " ++ show (clckHostname def)) + , 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)) , Option [] ["jqueryui-path"] (ReqArg setJQueryUIPath "path") ("path to jqueryui directory, default: " ++ show (clckJQueryUIPath def)) , Option [] ["jstree-path"] (ReqArg setJSTreePath "path") ("path to jstree directory, default: " ++ show (clckJSTreePath def)) diff --git a/Clckwrks/JS/ClckwrksApp.hs b/Clckwrks/JS/ClckwrksApp.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/JS/ClckwrksApp.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} +module Clckwrks.JS.ClckwrksApp where + +import Language.Javascript.JMacro + +clckwrksAppJS :: JStat +clckwrksAppJS = [jmacro| + { + var clckwrksApp = angular.module('clckwrksApp', [ + 'happstackAuthentication', + 'usernamePassword', + 'openId', + 'ngRoute' + ]); + + clckwrksApp.config(['$routeProvider', + function($routeProvider) { + $routeProvider.when('/resetPassword', + { templateUrl: '/authenticate/authentication-methods/password/partial/reset-password-form', + controller: 'UsernamePasswordCtrl' + }); + }]); + + clckwrksApp.controller('ClckwrksCtrl', ['$scope', '$http',function($scope, $http) { + return; + }]); + } + |] diff --git a/Clckwrks/JS/Route.hs b/Clckwrks/JS/Route.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/JS/Route.hs @@ -0,0 +1,13 @@ +module Clckwrks.JS.Route where + +import Control.Applicative ((<$>)) +import Clckwrks.Monad (ClckT) +import Clckwrks.JS.ClckwrksApp (clckwrksAppJS) +import Clckwrks.JS.URL +import Happstack.Server (Happstack, Response, ok, toResponse) +import Happstack.Server.JMacro () + +routeJS :: (Happstack m) => JSURL -> ClckT u m Response +routeJS url = + case url of + ClckwrksApp -> ok $ toResponse $ clckwrksAppJS diff --git a/Clckwrks/JS/URL.hs b/Clckwrks/JS/URL.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/JS/URL.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell #-} +{- |URLs for JavaScript fragments +-} +module Clckwrks.JS.URL where + +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Web.Routes.TH (derivePathInfo) + +data JSURL + = ClckwrksApp -- AngularJS App controller + deriving (Eq, Ord, Data, Typeable, Generic, Read, Show) + +derivePathInfo ''JSURL diff --git a/Clckwrks/Markup/Pandoc.hs b/Clckwrks/Markup/Pandoc.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Markup/Pandoc.hs @@ -0,0 +1,43 @@ +module Clckwrks.Markup.Pandoc where + +import Clckwrks.Types (Trust(..)) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar) +import Control.Monad.Trans (MonadIO(liftIO)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Text.HTML.SanitizeXSS (sanitizeBalance) +import System.Exit (ExitCode(ExitFailure, ExitSuccess)) +import System.IO (hClose) +import System.Process (waitForProcess, runInteractiveProcess) + +-- | run the text through the 'markdown' executable. If successful, +-- and the input is marked 'Untrusted', run the output through +-- xss-sanitize / sanitizeBalance to prevent injection attacks. +pandoc :: (MonadIO m) => + Maybe [String] -- ^ override command-line flags + -> Trust -- ^ do we trust the author + -> Text -- ^ markdown text + -> m (Either Text Text) -- ^ Left error, Right html +pandoc mArgs trust txt = liftIO $ + do let args = case mArgs of + Nothing -> [] + (Just a) -> a + (inh, outh, errh, ph) <- runInteractiveProcess "pandoc" args Nothing Nothing + _ <- forkIO $ do T.hPutStr inh txt + hClose inh + mvOut <- newEmptyMVar + _ <- forkIO $ do c <- T.hGetContents outh + putMVar mvOut c + mvErr <- newEmptyMVar + _ <- forkIO $ do c <- T.hGetContents errh + putMVar mvErr c + ec <- waitForProcess ph + case ec of + (ExitFailure _) -> + do e <- readMVar mvErr + return (Left e) + ExitSuccess -> + do m <- readMVar mvOut + return (Right ((if (trust == Untrusted) then sanitizeBalance else id) m)) diff --git a/Clckwrks/Monad.hs b/Clckwrks/Monad.hs --- a/Clckwrks/Monad.hs +++ b/Clckwrks/Monad.hs @@ -2,7 +2,7 @@ module Clckwrks.Monad ( Clck , ClckPlugins - , ClckPluginsSt + , ClckPluginsSt(cpsAcid) , initialClckPluginsSt , ClckT(..) , ClckForm @@ -26,7 +26,6 @@ , mapClckT , withRouteClckT , ClckState(..) - , getUserId , Content(..) -- , markupToContent -- , addPreProcessor @@ -41,11 +40,8 @@ , googleAnalytics , getUnique , setUnique - , requiresRole - , requiresRole_ , setRedirectCookie , getRedirectCookie - , getUserRoles , query , update , nestURL @@ -100,9 +96,7 @@ import qualified Data.Text.Lazy.Builder as B import Data.Time.Clock (UTCTime) import Data.Time.Format (formatTime) -import Happstack.Auth (AuthProfileURL(..), AuthURL(..), AuthState, ProfileState, UserId) -import qualified Happstack.Auth as Auth - +import Happstack.Authenticate.Core (UserId(..)) import Happstack.Server ( CookieLife(Session), Happstack, ServerMonad(..), FilterMonad(..) , WebMonad(..), Input, Request(..), Response, HasRqData(..) , ServerPart, ServerPartT, UnWebT, addCookie, expireCookie, escape @@ -120,7 +114,7 @@ import HSP.JMacro (IntegerSupply(..)) import Language.Javascript.JMacro import Prelude hiding (takeWhile) -import System.Locale (defaultTimeLocale) +import Data.Time.Locale.Compat (defaultTimeLocale) -- can import from time directly when time-1.4/ghc 7.8 is not important anymore import Text.Blaze.Html (Html) import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.Reform (CommonFormError, Form, FormError(..)) @@ -324,16 +318,17 @@ data ClckPluginsSt = ClckPluginsSt { cpsPreProcessors :: [TL.Text -> ClckT ClckURL IO TL.Text] - , cpsNavBarLinks :: [ClckT ClckURL IO (String, [NamedLink])] + , cpsNavBarLinks :: [ClckT ClckURL IO (String, [NamedLink])] + , cpsAcid :: Acid -- ^ this value is also in ClckState, but it is sometimes needed by plugins during initPlugin } -initialClckPluginsSt :: ClckPluginsSt -initialClckPluginsSt = ClckPluginsSt +initialClckPluginsSt :: Acid -> ClckPluginsSt +initialClckPluginsSt acid = ClckPluginsSt { cpsPreProcessors = [] - , cpsNavBarLinks = [] + , cpsNavBarLinks = [] + , cpsAcid = acid } - -- | ClckPlugins -- -- newtype Plugins theme m hook config st @@ -383,9 +378,6 @@ instance (Functor m, MonadIO m) => IntegerSupply (ClckT url m) where nextInteger = getUnique -instance ToJExpr Text.Text where - toJExpr t = ValExpr $ JStr $ T.unpack t - nestURL :: (url1 -> url2) -> ClckT url1 m a -> ClckT url2 m a nestURL f (ClckT r) = ClckT $ R.nestURL f r @@ -422,13 +414,10 @@ instance (GetAcidState m st) => GetAcidState (XMLGenT m) st where getAcidState = XMLGenT getAcidState - -instance (Functor m, Monad m) => GetAcidState (ClckT url m) AuthState where - getAcidState = (acidAuth . acidState) <$> get - -instance (Functor m, Monad m) => GetAcidState (ClckT url m) ProfileState where - getAcidState = (acidProfile . acidState) <$> get - +{- +instance (Functor m, Monad m) => GetAcidState (ClckT url m) AuthenticateState where + getAcidState = (acidAuthenticate . acidState) <$> get +-} instance (Functor m, Monad m) => GetAcidState (ClckT url m) CoreState where getAcidState = (acidCore . acidState) <$> get @@ -438,13 +427,6 @@ instance (Functor m, Monad m) => GetAcidState (ClckT url m) ProfileDataState where getAcidState = (acidProfileData . acidState) <$> get --- | The the 'UserId' of the current user. While return 'Nothing' if they are not logged in. -getUserId :: (Happstack m, GetAcidState m AuthState, GetAcidState m ProfileState) => m (Maybe UserId) -getUserId = - do authState <- getAcidState - profileState <- getAcidState - Auth.getUserId authState profileState - -- * XMLGen / XMLGenerator instances for Clck instance (Functor m, Monad m) => XMLGen (ClckT url m) where @@ -671,35 +653,6 @@ do expireCookie "clckwrks-authenticate-redirect" optional $ lookCookieValue "clckwrks-authenticate-redirect" -requiresRole_ :: (Happstack m) => (ClckURL -> [(T.Text, Maybe T.Text)] -> T.Text) -> Set Role -> url -> ClckT u m url -requiresRole_ showFn role url = - ClckT $ RouteT $ \_ -> unRouteT (unClckT (requiresRole role url)) showFn - -requiresRole :: (Happstack m) => Set Role -> url -> ClckT ClckURL m url -requiresRole role url = - do mu <- getUserId - case mu of - Nothing -> - do rq <- askRq - escape $ do setRedirectCookie (rqUri rq ++ rqQuery rq) - seeOtherURL (Auth $ AuthURL A_Login) - (Just uid) -> - do r <- query (HasRole uid role) - if r - then return url - else escape $ unauthorizedPage ("You do not have permission to view this page." :: TL.Text) - -getUserRoles :: (Happstack m, MonadIO m) => ClckT u m (Set Role) -getUserRoles = - do mu <- getUserId - case mu of - Nothing -> return (Set.singleton Visitor) - (Just u) -> - do mr <- query (GetRoles u) - case mr of - Nothing -> return Set.empty - (Just r) -> return r - ------------------------------------------------------------------------------ -- NavBar callback ------------------------------------------------------------------------------ @@ -725,7 +678,6 @@ getPreProcessors plugins = mapClckT liftIO $ (cpsPreProcessors <$> getPluginsSt plugins) - -- | create a google analytics tracking code block -- diff --git a/Clckwrks/NavBar/EditNavBar.hs b/Clckwrks/NavBar/EditNavBar.hs --- a/Clckwrks/NavBar/EditNavBar.hs +++ b/Clckwrks/NavBar/EditNavBar.hs @@ -13,12 +13,13 @@ import Control.Monad.State (get) import Control.Monad.Trans (lift, liftIO) import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), (.:), (.=), decode, object) +import Data.Aeson.QQ (aesonQQ) import qualified Data.Text as T import Data.Text.Lazy (Text) import Data.Tree (Tree(..)) import qualified Data.Vector as Vector import Happstack.Server (Response, internalServerError, lookBS, ok, toResponse) -import HSP.XML (fromStringLit) +import HSP.XML (XML, fromStringLit) import HSP.XMLGenerator import Language.Javascript.JMacro import Web.Routes (showURL) @@ -52,17 +53,7 @@ - - --
    -
    - Other Actions
    - -
    - -
    -
    -
    @@ -72,39 +63,52 @@
    NavBar -

    Drag and Drop to rearrange. Click to rename.

    +

    Drag and Drop to rearrange. Right-click to rename or remove.

    where + headers :: NavBar -> NavBarLinks -> GenChildList (Clck ClckURL) headers currentNavBar navBarLinks = do navBarUpdate <- showURL (Admin NavBarPost) <%> - + + <% [$jmacro| - function !doubleClickCB(e, dt) { - alert(dt.rslt.o); +// function !doubleClickCB(e, dt) { +// alert(dt.rslt.o); // navBar.rename(d.rslt); - }; +// }; $(document).ready(function () - { $("#navBar").jstree(`(jstree currentNavBar)`); - var !navBar = $.jstree._reference("#navBar"); - $("#navBar").bind("select_node.jstree", function(e, d) { $("#navBar").jstree("rename", d.inst.o); } ); - - // click elsewhere in document to unselect nodes - $(document).bind("click", function (e) { - if(!$(e.target).parents(".jstree:eq(0)").length) { - $.jstree._focused().deselect_all(); - } - }); - - `(initializeDropDowns navBarLinks)`; - `(removeItem)`; - `(saveChanges navBarUpdate)`; - }); + { $("#navBar").jstree({ 'core' : + { 'data' : `(navBarToJSTree currentNavBar)` + , 'themes' : { 'variant' : 'large' } + , 'check_callback' : true + } + , 'contextmenu' : + { 'items' : function (o, cb) { + var items = $.jstree.defaults.contextmenu.items(o, cb); + return { 'rename' : items.rename + , 'remove' : items.remove + }; + } + } + , 'types' : + { 'target' : + { 'icon' : 'icon-black icon-bookmark' + , 'max_children' : 0 + } + } + , 'plugins' : [ 'contextmenu', 'dnd', 'types' ] + }); + var !navBar = $.jstree.reference("#navBar"); + `(initializeDropDowns navBarLinks)`; + `(removeItem)`; + `(saveChanges navBarUpdate)`; + }); |] %> @@ -130,6 +134,7 @@ option.text(navBarLinks[p].pluginName); pluginList.append(option); } + populateLinks(0); pluginList.change(function() { populateLinks($(this).val()); }); @@ -137,16 +142,19 @@ $("#add-link").click(function () { var indexes = navBarItemList.val().split(','); var navBarItem = navBarLinks[indexes[0]].pluginLinks[indexes[1]]; - var entry = { 'state' : 'open' - , 'data' : { 'title' : navBarItem.navBarItemName } - , 'attr' : { 'rel' : 'target' } - , 'metadata' - : { 'link' : { 'navBarName' : navBarItem.navBarItemName - , 'navBarLink' : navBarItem.navBarItemLink - } - } + + var entry = { 'state' : { 'opened' : true } + , 'text' : navBarItem.navBarItemName + , 'type' : 'target' + , 'a_attr' : { 'rel' : 'target' } + , 'data' : + { 'link' : + { 'navBarName' : navBarItem.navBarItemName + , 'navBarLink' : navBarItem.navBarItemLink + } + } }; - navBar.create(null, "last", entry , null, true); + navBar.create_node(null, entry, "last", null, false); }); |] @@ -155,7 +163,7 @@ saveChanges navBarUpdateURL = [$jmacro| $("#saveChanges").click(function () { - var tree = $("#navBar").jstree("get_json", -1); + var tree = navBar.get_json('#'); // $("#navBar").jstree("get_json", -1); var json = JSON.stringify(tree); console.log(json); $.post(`(navBarUpdateURL)`, { tree : json }); @@ -174,21 +182,21 @@ }); |] -jstree :: NavBar -> Value -jstree navBar = - object [ "types" .= - object [ "types" .= - object [ "root" .= - object [ "max_children" .= (-1 :: Int) - ] - , "navBar" .= - object [ "max_children" .= (-1 :: Int) - ] - , "target" .= - object [ "max_children" .= (0 :: Int) - , "icon" .= False - ] + {- + object [ "core" .= + object [ "data" .= navBarToJSTree navBar + ] + , "types" .= + object [ "#" .= + object [ "max_children" .= (-1 :: Int) ] + , "navBar" .= + object [ "max_children" .= (-1 :: Int) + ] + , "target" .= + object [ "max_children" .= (0 :: Int) + , "icon" .= False + ] ] , "dnd" .= object [ "drop_target" .= False @@ -197,17 +205,27 @@ , "ui" .= object [ "initially_select" .= ([ "tree-root" ] :: [String]) ] - , "json_data" .= navBarToJSTree navBar , "plugins" .= ([ "themes", "ui", "crrm", "types", "json_data", "dnd" ] :: [String]) ] - -navBarToJSTree :: NavBar -> Value +-} +navBarToJSTree :: NavBar -> [Value] navBarToJSTree (NavBar items) = - object [ "data" .= (toJSON $ map navBarItemToJSTree items) - ] + map navBarItemToJSTree items navBarItemToJSTree :: NavBarItem -> Value navBarItemToJSTree (NBLink NamedLink{..}) = + [aesonQQ| + { text : #{namedLinkTitle} + , type : "target" + , a_attr : { rel : "target" } + , data : { link : + { navBarLink : #{namedLinkURL} + } + } + + } |] +-- toJSON namedLinkTitle + {- object [ "data" .= object [ "title" .= namedLinkTitle ] @@ -220,7 +238,25 @@ ] ] ] - +-} +{- +jstree :: NavBar -> Value +jstree navBar = -- #{navBarToJSTree navBar} + [aesonQQ| + { core : + { data : [] + , themes : { variant : "large" } + , check_callback : true + } + , types : + { target : + { icon : "glyphicon glyphicon-flash" + , max_children : 0 + } + } + , plugins : ["contextmenu", "dnd", "types"] + } |] +-} navBarPost :: Clck ClckURL Response navBarPost = do t <- lookBS "tree" @@ -241,9 +277,9 @@ instance FromJSON NavBarItem where parseJSON (Object o) = - do ttl <- o .: "data" - meta <- o .: "metadata" - link <- meta .: "link" + do ttl <- o .: "text" + meta <- o .: "data" + link <- meta .: "link" navBarLink <- link .: "navBarLink" let nl = NamedLink ttl navBarLink return (NBLink nl) diff --git a/Clckwrks/ProfileData/API.hs b/Clckwrks/ProfileData/API.hs --- a/Clckwrks/ProfileData/API.hs +++ b/Clckwrks/ProfileData/API.hs @@ -1,28 +1,63 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} module Clckwrks.ProfileData.API ( getProfileData , getUsername + , getUserRoles + , requiresRole + , requiresRole_ , whoami ) where import Clckwrks.Acid (Acid(..)) import Clckwrks.Monad +import Clckwrks.URL (ClckURL) +import {-# SOURCE #-} Clckwrks.Authenticate.Plugin (getUserId) import Clckwrks.ProfileData.Acid import Clckwrks.ProfileData.Types -import Control.Applicative ((<$>)) -import Control.Monad.State (get) -import Data.Text (Text) -import Happstack.Auth (UserId(..)) +import Clckwrks.Unauthorized (unauthorizedPage) +import Control.Applicative ((<$>)) +import Control.Monad.State (get) +import Control.Monad.Trans (MonadIO) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import Happstack.Authenticate.Core (UserId(..)) +import Happstack.Server (Happstack, askRq, escape, rqUri, rqQuery) +import Web.Routes (RouteT(..)) -getProfileData :: UserId -> Clck url (Maybe ProfileData) +getProfileData :: UserId -> Clck url ProfileData getProfileData uid = query (GetProfileData uid) -getUsername :: UserId -> Clck url (Maybe Text) -getUsername uid = - query (GetUsername uid) +getUsername :: UserId -> Clck url Text +getUsername uid = query (GetUsername uid) whoami :: Clck url (Maybe UserId) -whoami = - do -- Acid{..} <- acidState <$> get - getUserId +whoami = getUserId +requiresRole_ :: (Happstack m) => (ClckURL -> [(Text, Maybe Text)] -> Text) -> Set Role -> url -> ClckT u m url +requiresRole_ showFn role url = + ClckT $ RouteT $ \_ -> unRouteT (unClckT (requiresRole role url)) showFn + +requiresRole :: (Happstack m) => Set Role -> url -> ClckT ClckURL m url +requiresRole role url = + do mu <- getUserId + case mu of + Nothing -> + do rq <- askRq + escape $ do setRedirectCookie (rqUri rq ++ rqQuery rq) + -- FIXME; redirect after login + unauthorizedPage ("You do not have permission to view this page." :: TL.Text) +-- seeOtherURL (Auth $ AuthURL A_Login) + (Just uid) -> + do r <- query (HasRole uid role) + if r + then return url + else escape $ unauthorizedPage ("You do not have permission to view this page." :: TL.Text) + +getUserRoles :: (Happstack m, MonadIO m) => ClckT u m (Set Role) +getUserRoles = + do mu <- getUserId + case mu of + Nothing -> return (Set.singleton Visitor) + (Just u) -> query (GetRoles u) diff --git a/Clckwrks/ProfileData/Acid.hs b/Clckwrks/ProfileData/Acid.hs --- a/Clckwrks/ProfileData/Acid.hs +++ b/Clckwrks/ProfileData/Acid.hs @@ -16,19 +16,19 @@ , UsernameForId(..) ) where -import Clckwrks.ProfileData.Types (ProfileData(..), Role(..), Username(..)) -import Control.Applicative ((<$>)) -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) -import Data.Acid (Update, Query, makeAcidic) -import Data.Data (Data, Typeable) -import Data.IxSet (IxSet, (@=), empty, getOne, insert, updateIx, toList) -import Data.SafeCopy (base, deriveSafeCopy) -import qualified Data.Set as Set -import Data.Set (Set) -import Data.Text (Text) -import qualified Data.Text as Text -import Happstack.Auth (UserId(..)) +import Clckwrks.ProfileData.Types (ProfileData(..), Role(..), Username(..), defaultProfileDataFor) +import Control.Applicative ((<$>)) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import Data.Acid (Update, Query, makeAcidic) +import Data.Data (Data, Typeable) +import Data.IxSet (IxSet, (@=), empty, getOne, insert, updateIx, toList) +import Data.SafeCopy (base, deriveSafeCopy) +import qualified Data.Set as Set +import Data.Set (Set) +import Data.Text (Text) +import qualified Data.Text as Text +import Happstack.Authenticate.Core (UserId(..)) data ProfileDataState = ProfileDataState { profileData :: IxSet ProfileData @@ -73,10 +73,12 @@ getProfileData :: UserId - -> Query ProfileDataState (Maybe ProfileData) + -> Query ProfileDataState ProfileData getProfileData uid = do ProfileDataState{..} <- ask - return $ getOne $ profileData @= uid + case getOne $ profileData @= uid of + (Just pd) -> return pd + Nothing -> return (defaultProfileDataFor uid) updateProfileData :: ProfileData -> Update ProfileDataState () @@ -90,11 +92,15 @@ modifyProfileData fn uid = do ps@(ProfileDataState {..}) <- get case getOne $ profileData @= uid of - Nothing -> return () + Nothing -> + do let pd' = fn (defaultProfileDataFor uid) + put ps { profileData = insert pd' profileData } (Just pd) -> - do let pd' = fn pd - put ps { profileData = updateIx (dataFor pd') pd' profileData } + do let pd' = fn pd + put ps { profileData = updateIx (dataFor pd') pd' profileData } + + -- | create the profile data, but only if it is missing newProfileData :: ProfileData -> Update ProfileDataState (ProfileData, Bool) @@ -106,9 +112,9 @@ (Just pd') -> return (pd', False) getUsername :: UserId - -> Query ProfileDataState (Maybe Text) + -> Query ProfileDataState Text getUsername uid = - fmap username <$> getProfileData uid + username <$> getProfileData uid -- | get all the users getUserIdUsernames :: Query ProfileDataState [(UserId, Text)] @@ -117,23 +123,17 @@ return $ map (\pd -> (dataFor pd, username pd)) (toList pds) getRoles :: UserId - -> Query ProfileDataState (Maybe (Set Role)) + -> Query ProfileDataState (Set Role) getRoles uid = - do mp <- getProfileData uid - case mp of - Nothing -> return Nothing - (Just profile) -> - return (Just $ roles profile) + do profile <- getProfileData uid + return (roles profile) hasRole :: UserId -> Set Role -> Query ProfileDataState Bool hasRole uid role = - do mp <- getProfileData uid - case mp of - Nothing -> return False - (Just profile) -> - return (not $ Set.null $ role `Set.intersection` roles profile) + do profile <- getProfileData uid + return (not $ Set.null $ role `Set.intersection` roles profile) addRole :: UserId -> Role diff --git a/Clckwrks/ProfileData/EditNewProfileData.hs b/Clckwrks/ProfileData/EditNewProfileData.hs --- a/Clckwrks/ProfileData/EditNewProfileData.hs +++ b/Clckwrks/ProfileData/EditNewProfileData.hs @@ -3,18 +3,18 @@ module Clckwrks.ProfileData.EditNewProfileData where import Clckwrks -import Clckwrks.Monad (getRedirectCookie) -import Clckwrks.Admin.Template (emptyTemplate) -import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr) +import Clckwrks.Monad (getRedirectCookie) +import Clckwrks.Admin.Template (emptyTemplate) +import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr) import Clckwrks.ProfileData.EditProfileData(profileDataFormlet) -import Data.Text (pack) -import qualified Data.Text as Text -import Data.Text.Lazy (Text) -import Data.Maybe (fromMaybe) -import Happstack.Auth (UserId) -import Text.Reform ((++>), mapView, transformEitherM) -import Text.Reform.HSP.Text (form, inputText, inputSubmit, labelText, fieldset, ol, li, errorList, setAttrs) -import Text.Reform.Happstack (reform) +import Data.Text (pack) +import qualified Data.Text as Text +import Data.Text.Lazy (Text) +import Data.Maybe (fromMaybe) +import Happstack.Authenticate.Core (UserId) +import Text.Reform ((++>), mapView, transformEitherM) +import Text.Reform.HSP.Text (form, inputText, inputSubmit, labelText, fieldset, ol, li, errorList, setAttrs) +import Text.Reform.Happstack (reform) import HSP.XMLGenerator import HSP.XML @@ -26,17 +26,12 @@ case mUid of Nothing -> internalServerError $ toResponse $ ("Unable to retrieve your userid" :: Text) (Just uid) -> - do mpd <- query (GetProfileData uid) - case mpd of - Nothing -> - internalServerError $ toResponse $ "Missing profile data for " ++ show uid - - (Just pd) -> - do action <- showURL here - emptyTemplate "Edit Profile Data" () $ - <%> - <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %> - + do pd <- query (GetProfileData uid) + action <- showURL here + emptyTemplate "Edit Profile Data" () $ + <%> + <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %> + where updated :: () -> Clck ProfileDataURL Response updated () = diff --git a/Clckwrks/ProfileData/EditProfileData.hs b/Clckwrks/ProfileData/EditProfileData.hs --- a/Clckwrks/ProfileData/EditProfileData.hs +++ b/Clckwrks/ProfileData/EditProfileData.hs @@ -3,16 +3,16 @@ module Clckwrks.ProfileData.EditProfileData where import Clckwrks -import Clckwrks.Admin.Template (template) -import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr) -import Data.Text (pack) -import qualified Data.Text as Text -import Data.Text.Lazy (Text) -import Data.Maybe (fromMaybe) -import Happstack.Auth (UserId) -import Text.Reform ((++>), mapView, transformEitherM) -import Text.Reform.HSP.Text (form, inputText, inputSubmit, labelText, fieldset, ol, li, errorList, setAttrs) -import Text.Reform.Happstack (reform) +import Clckwrks.Admin.Template (template) +import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr) +import Data.Text (pack) +import qualified Data.Text as Text +import Data.Text.Lazy (Text) +import Data.Maybe (fromMaybe) +import Happstack.Authenticate.Core (UserId) +import Text.Reform ((++>), mapView, transformEitherM) +import Text.Reform.HSP.Text (form, inputText, inputSubmit, labelText, fieldset, ol, li, errorList, setAttrs) +import Text.Reform.Happstack (reform) import HSP.XMLGenerator import HSP.XML @@ -24,17 +24,13 @@ case mUid of Nothing -> internalServerError $ toResponse $ ("Unable to retrieve your userid" :: Text) (Just uid) -> - do mpd <- query (GetProfileData uid) - case mpd of - Nothing -> - internalServerError $ toResponse $ "Missing profile data for " ++ show uid - - (Just pd) -> - do action <- showURL here - template "Edit Profile Data" () $ - <%> - <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %> - + do pd <- query (GetProfileData uid) + action <- showURL here + template "Edit Profile Data" () $ + <%> + <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %> + + where updated :: () -> Clck ProfileDataURL Response updated () = @@ -49,6 +45,7 @@ <* (divControlGroup (divControls (inputSubmit (pack "Update") `setAttrs` (("class" := "btn") :: Attr Text Text))))) `transformEitherM` updateProfileData where + label' :: Text -> ClckForm ProfileDataURL () label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text]) divHorizontal = mapView (\xml -> [
    <% xml %>
    ]) divControlGroup = mapView (\xml -> [
    <% xml %>
    ]) diff --git a/Clckwrks/ProfileData/EditProfileDataFor.hs b/Clckwrks/ProfileData/EditProfileDataFor.hs --- a/Clckwrks/ProfileData/EditProfileDataFor.hs +++ b/Clckwrks/ProfileData/EditProfileDataFor.hs @@ -9,7 +9,7 @@ import Data.Set as Set import Data.Text (Text, pack) import qualified Data.Text as Text -import Happstack.Auth (UserId) +import Happstack.Authenticate.Core (UserId) import HSP.XMLGenerator import HSP.XML import Text.Reform ((++>), transformEitherM) @@ -18,16 +18,10 @@ editProfileDataForPage :: ProfileDataURL -> UserId -> Clck ProfileDataURL Response editProfileDataForPage here uid = - do mpd <- query (GetProfileData uid) - case mpd of - Nothing -> - do notFound () - template "Edit Profile Data" () $ -

    No profile data for <% show uid %>.

    - (Just pd) -> - do action <- showURL here - template "Edit Profile Data" () $ - <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %> + do pd <- query (GetProfileData uid) + action <- showURL here + template "Edit Profile Data" () $ + <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %> where updated :: () -> Clck ProfileDataURL Response diff --git a/Clckwrks/ProfileData/Route.hs b/Clckwrks/ProfileData/Route.hs --- a/Clckwrks/ProfileData/Route.hs +++ b/Clckwrks/ProfileData/Route.hs @@ -20,10 +20,7 @@ case mUserId of Nothing -> internalServerError $ toResponse $ "not logged in." (Just userId) -> - do let profileData = emptyProfileData { dataFor = userId - , roles = singleton Visitor - } - (_, new) <- update (NewProfileData profileData) + do (_, new) <- update (NewProfileData (defaultProfileDataFor userId)) if new then seeOtherURL EditNewProfileData else do mRedirect <- query GetLoginRedirect diff --git a/Clckwrks/ProfileData/Types.hs b/Clckwrks/ProfileData/Types.hs --- a/Clckwrks/ProfileData/Types.hs +++ b/Clckwrks/ProfileData/Types.hs @@ -2,17 +2,18 @@ module Clckwrks.ProfileData.Types ( ProfileData(..) , Role(..) + , defaultProfileDataFor , emptyProfileData , Username(..) ) where -import Happstack.Auth (UserId(..)) +import Happstack.Authenticate.Core (UserId(..)) import Data.Data (Data, Typeable) import Data.IxSet (Indexable(..), ixSet, ixFun) import Data.IxSet.Ix (Ix) import Data.Map (Map, empty) import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension) -import Data.Set (Set, empty) +import Data.Set (Set, empty, singleton) import Data.Text (Text, empty) import Data.Typeable (Typeable) @@ -55,6 +56,12 @@ , roles = Data.Set.empty , attributes = Data.Map.empty } + +defaultProfileDataFor :: UserId -> ProfileData +defaultProfileDataFor uid = + emptyProfileData { dataFor = uid + , roles = singleton Visitor + } newtype Username = Username { unUsername :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable) diff --git a/Clckwrks/ProfileData/URL.hs b/Clckwrks/ProfileData/URL.hs --- a/Clckwrks/ProfileData/URL.hs +++ b/Clckwrks/ProfileData/URL.hs @@ -1,10 +1,10 @@ {-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} module Clckwrks.ProfileData.URL where -import Data.Data (Data, Typeable) -import Data.SafeCopy (SafeCopy(..), base, deriveSafeCopy) -import Happstack.Auth (UserId) -import Web.Routes.TH (derivePathInfo) +import Data.Data (Data, Typeable) +import Data.SafeCopy (SafeCopy(..), base, deriveSafeCopy) +import Happstack.Authenticate.Core (UserId) +import Web.Routes.TH (derivePathInfo) data ProfileDataURL = CreateNewProfileData diff --git a/Clckwrks/Route.hs b/Clckwrks/Route.hs --- a/Clckwrks/Route.hs +++ b/Clckwrks/Route.hs @@ -5,14 +5,15 @@ import Clckwrks.Admin.Route (routeAdmin) import Clckwrks.BasicTemplate (basicTemplate) import Clckwrks.Monad (calcTLSBaseURI, withAbs) +import Clckwrks.ProfileData.API (requiresRole) import Clckwrks.ProfileData.Route (routeProfileData) +import Clckwrks.JS.Route (routeJS) import Control.Monad.State (MonadState(get)) import Data.Maybe (fromJust) import Data.Monoid ((<>)) import qualified Data.Set as Set import Data.Text (Text, pack) import qualified Data.Text as Text -import Happstack.Auth (handleAuthProfile) import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile) import Network.URI (unEscapeString) import Paths_clckwrks (getDataDir) @@ -28,7 +29,7 @@ ThemeDataNoEscape{} -> return url PluginData{} -> return url Admin{} -> requiresRole (Set.singleton Administrator) url - Auth{} -> return url + JS {} -> return url Profile EditProfileData{} -> requiresRole (Set.fromList [Administrator, Visitor]) url Profile EditNewProfileData{} -> requiresRole (Set.fromList [Administrator, Visitor]) url Profile EditProfileDataFor{} -> requiresRole (Set.fromList [Administrator]) url @@ -77,21 +78,5 @@ (Profile profileDataURL) -> do nestURL Profile $ routeProfileData profileDataURL - (Auth apURL) -> - do clckState <- get - cc <- getConfig (plugins clckState) - let go = do let Acid{..} = acidState clckState - u <- showURL $ Profile CreateNewProfileData - showClckURL <- askRouteFn - cs <- get - let template' ttl hdr bdy = withRouteClckT (const showClckURL) $ themeTemplate (plugins cs) (ThemeStyleId 0) (pack ttl) hdr bdy - withAbs $ nestURL Auth $ handleAuthProfile acidAuth acidProfile template' Nothing Nothing u apURL - case clckTLS cc of - Nothing -> go - (Just tlsSettings) -> - do secure <- rqSecure <$> askRq - if secure - then go - else do u <- rqUri <$> askRq - let sslU = ((Text.unpack $ fromJust $ calcTLSBaseURI cc) ++ u) - seeOther sslU (toResponse ()) + (JS jsURL) -> + do nestURL JS $ routeJS jsURL diff --git a/Clckwrks/Server.hs b/Clckwrks/Server.hs --- a/Clckwrks/Server.hs +++ b/Clckwrks/Server.hs @@ -3,7 +3,7 @@ import Clckwrks import Clckwrks.Admin.Route (routeAdmin) -import Clckwrks.Monad (ClckwrksConfig(..), TLSSettings(..), initialClckPluginsSt) +import Clckwrks.Monad (ClckwrksConfig(..), TLSSettings(..), calcBaseURI, calcTLSBaseURI, initialClckPluginsSt) -- import Clckwrks.Page.Acid (GetPageTitle(..), IsPublishedPage(..)) -- import Clckwrks.Page.Atom (handleAtomFeed) -- import Clckwrks.Page.PreProcess (pageCmd) @@ -14,16 +14,16 @@ import Control.Concurrent (forkIO, killThread) import Control.Concurrent.STM (atomically, newTVar) import Control.Monad.State (get, evalStateT) +import qualified Data.ByteString.Char8 as B import Data.Acid.Advanced (query') import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromJust, fromMaybe, isNothing) import Data.Monoid ((<>)) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.UUID as UUID -import Happstack.Auth (handleAuthProfile) import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile) import Happstack.Server.SimpleHTTPS (TLSConf(..), nullTLSConf, simpleHTTPS) import System.FilePath ((), makeRelative, splitDirectories) @@ -32,30 +32,34 @@ import qualified Paths_clckwrks as Clckwrks withClckwrks :: ClckwrksConfig -> (ClckState -> IO b) -> IO b -withClckwrks cc action = - withPlugins cc initialClckPluginsSt $ \plugins -> - withAcid (fmap (\top -> top "_state") (clckTopDir cc)) $ \acid -> - do u <- atomically $ newTVar 0 - let clckState = ClckState { acidState = acid +withClckwrks cc action = do + let top' = fmap (\top -> top "_state") (clckTopDir cc) + withAcid top' $ \acid -> + withPlugins cc (initialClckPluginsSt acid) $ \plugins -> do + u <- atomically $ newTVar 0 + let clckState = ClckState { acidState = acid -- , currentPage = PageId 0 - , uniqueId = u - , adminMenus = [] - , enableAnalytics = clckEnableAnalytics cc - , plugins = plugins - , requestInit = return () - } - action clckState + , uniqueId = u + , adminMenus = [] + , enableAnalytics = clckEnableAnalytics cc + , plugins = plugins + , requestInit = return () + } + action clckState simpleClckwrks :: ClckwrksConfig -> IO () simpleClckwrks cc = withClckwrks cc $ \clckState -> - do (clckState', cc') <- (clckInitHook cc) (calcBaseURI cc) clckState cc + do let baseURI = + case calcTLSBaseURI cc of + (Just baseUri) -> baseUri + Nothing -> calcBaseURI cc + (clckState', cc') <- (clckInitHook cc) baseURI clckState cc let p = plugins clckState' hooks <- getPostHooks p (Just clckShowFn) <- getPluginRouteFn p "clck" let showFn = \url params -> clckShowFn url [] clckState'' <- execClckT showFn clckState' $ sequence_ hooks - httpTID <- forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) (handlers cc' clckState'') mHttpsTID <- case clckTLS cc' of @@ -68,6 +72,10 @@ } tid <- forkIO $ simpleHTTPS tlsConf (handlers cc' clckState'') return (Just tid) + + httpTID <- if isNothing mHttpsTID + then forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) (handlers cc' clckState'') + else forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) forceHTTPS -- putStrLn "Server Now Listening For Requests." waitForTermination killThread httpTID @@ -76,7 +84,8 @@ where handlers :: ClckwrksConfig -> ClckState -> ServerPart Response handlers cc clckState = - do decodeBody (defaultBodyPolicy "/tmp/" (10 * 10^6) (1 * 10^6) (1 * 10^6)) + do forceCanonicalHost + decodeBody (defaultBodyPolicy "/tmp/" (10 * 10^6) (1 * 10^6) (1 * 10^6)) requestInit clckState msum $ [ jsHandlers cc @@ -87,6 +96,26 @@ seeOther (fromMaybe ("/page/view-page/1") mRR) (toResponse ()) -- FIXME: get redirect location from database , clckSite cc clckState ] + + forceCanonicalHost :: ServerPart () + forceCanonicalHost = + do rq <- askRq + case getHeader "host" rq of + Nothing -> return () + (Just hostBS) -> + if (clckHostname cc == B.unpack 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 ()) + + -- if https:// is available, then force it to be used. + -- GET requests will be redirected automatically, POST, PUT, etc will be denied + forceHTTPS :: ServerPart Response + forceHTTPS = + msum [ do method GET + rq <- askRq + seeOther ((fromJust $ calcTLSBaseURI cc) <> (Text.pack $ rqUri rq) <> (Text.pack $ rqQuery rq)) (toResponse ()) + , do forbidden (toResponse ("https:// required." :: Text)) + ] jsHandlers :: (Happstack m) => ClckwrksConfig -> m Response jsHandlers c = diff --git a/Clckwrks/URL.hs b/Clckwrks/URL.hs --- a/Clckwrks/URL.hs +++ b/Clckwrks/URL.hs @@ -2,23 +2,18 @@ module Clckwrks.URL ( ClckURL(..) , AdminURL(..) - , AuthURL(..) - , ProfileURL(..) - , AuthProfileURL(..) - , ProfileDataURL(..) + , AuthenticateURL(..) , NoEscape(..) ) where import Clckwrks.Admin.URL (AdminURL(..)) --- import Clckwrks.Page.Acid (PageId(..)) --- import Clckwrks.Page.Types (Slug(..)) +import Clckwrks.JS.URL (JSURL) import Clckwrks.ProfileData.URL (ProfileDataURL(..)) import Control.Applicative ((<$>), many) import Data.Data (Data, Typeable) import Data.SafeCopy (Migrate(..), SafeCopy(..), base, deriveSafeCopy, extension) import Data.Text (Text, pack, unpack) -import Happstack.Auth (AuthURL(..), ProfileURL(..), AuthProfileURL(..), UserId) -import Happstack.Auth.Core.AuthURL (OpenIdURL, AuthMode, OpenIdProvider) +import Happstack.Authenticate.Core (AuthenticateURL(..)) import System.FilePath (joinPath, splitDirectories) import Web.Routes (PathInfo(..), anySegment) import Web.Routes.TH (derivePathInfo) @@ -38,15 +33,7 @@ | PluginData Text FilePath | Admin AdminURL | Profile ProfileDataURL - | Auth AuthProfileURL + | JS JSURL deriving (Eq, Ord, Data, Typeable, Read, Show) - --- TODO: move upstream -$(deriveSafeCopy 1 'base ''AuthURL) -$(deriveSafeCopy 1 'base ''ProfileURL) -$(deriveSafeCopy 1 'base ''AuthProfileURL) -$(deriveSafeCopy 1 'base ''OpenIdURL) -$(deriveSafeCopy 1 'base ''AuthMode) -$(deriveSafeCopy 1 'base ''OpenIdProvider) $(derivePathInfo ''ClckURL) diff --git a/clckwrks.cabal b/clckwrks.cabal --- a/clckwrks.cabal +++ b/clckwrks.cabal @@ -1,5 +1,5 @@ Name: clckwrks -Version: 0.22.4 +Version: 0.23.7 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 @@ -16,7 +16,7 @@ License-file: LICENSE Author: Jeremy Shaw Maintainer: Jeremy Shaw -Copyright: 2012 SeeReason Partners LLC, Jeremy Shaw +Copyright: 2012-2015 SeeReason Partners LLC, Jeremy Shaw Stability: Experimental Category: Clckwrks Build-type: Custom @@ -41,13 +41,24 @@ Clckwrks.Admin.Console Clckwrks.Admin.Route Clckwrks.Admin.EditSettings + Clckwrks.Authenticate.Page.ChangePassword + Clckwrks.Authenticate.Page.Login + Clckwrks.Authenticate.Page.OpenIdRealm + Clckwrks.Authenticate.Page.ResetPassword + Clckwrks.Authenticate.Plugin + Clckwrks.Authenticate.Route + Clckwrks.Authenticate.URL Clckwrks.BasicTemplate Clckwrks.GetOpts Clckwrks.IOThread + Clckwrks.JS.ClckwrksApp + Clckwrks.JS.Route + Clckwrks.JS.URL Clckwrks.Monad Clckwrks.Server Clckwrks.Markup.HsColour Clckwrks.Markup.Markdown + Clckwrks.Markup.Pandoc Clckwrks.NavBar.Acid Clckwrks.NavBar.API Clckwrks.NavBar.EditNavBar @@ -67,8 +78,8 @@ Clckwrks.URL Paths_clckwrks Extra-Libraries: ssl - if !os(darwin) - Extra-Libraries: cryptopp +-- if !os(darwin) +-- Extra-Libraries: cryptopp if flag(network-uri) build-depends: network > 2.6 && < 2.7, @@ -78,41 +89,46 @@ Build-depends: acid-state >= 0.12 && < 0.13, - aeson >= 0.5 && < 0.9, - attoparsec >= 0.10 && < 0.13, - base < 5, - blaze-html >= 0.5 && < 0.8, - bytestring >= 0.9 && < 0.11, - cereal >= 0.4 && < 0.5, - containers >= 0.4 && < 0.6, - directory >= 1.1 && < 1.3, - filepath >= 1.2 && < 1.4, - happstack-authenticate == 0.10.*, + aeson >= 0.5 && < 0.9, + aeson-qq >= 0.7 && < 0.8, + attoparsec >= 0.10 && < 0.14, + base < 5, + blaze-html >= 0.5 && < 0.9, + bytestring >= 0.9 && < 0.11, + cereal >= 0.4 && < 0.5, + containers >= 0.4 && < 0.6, + directory >= 1.1 && < 1.3, + filepath >= 1.2 && < 1.5, + happstack-authenticate >= 2.1 && < 2.2, happstack-hsp == 7.3.*, - happstack-server >= 7.0 && < 7.4, - happstack-server-tls >= 7.1 && < 7.2, - hsp >= 0.9 && < 0.11, + happstack-jmacro >= 7.0 && < 7.1, + happstack-server >= 7.0 && < 7.5, + happstack-server-tls >= 7.1 && < 7.2, + hsp >= 0.9 && < 0.11, hsx-jmacro == 7.3.*, + hsx2hs >= 0.13 && < 0.14, ixset == 1.0.*, jmacro == 0.6.*, - mtl >= 2.0 && < 2.3, + lens >= 4.3 && < 4.10, + mtl >= 2.0 && < 2.3, old-locale == 1.0.*, - process >= 1.0 && < 1.3, + process >= 1.0 && < 1.3, -- plugins-auto == 0.0.1.1, - random == 1.0.*, + random >= 1.0 && < 1.2, reform == 0.2.*, reform-happstack == 0.2.*, - reform-hsp >= 0.2 && < 0.3, + reform-hsp >= 0.2 && < 0.3, safecopy >= 0.6, - stm >= 2.2 && <2.5, + stm >= 2.2 && <2.5, tagsoup >= 0.12 && < 0.14, - text >= 0.11 && < 1.2, - time >= 1.2 && <1.5, - uuid >= 1.2 && < 1.4, - unordered-containers >= 0.1 && < 0.3, - utf8-string == 0.3.*, + text >= 0.11 && < 1.3, + time >= 1.2 && < 1.6, + time-locale-compat >= 0.1 && < 0.2, + uuid >= 1.2 && < 1.4, + unordered-containers >= 0.1 && < 0.3, + utf8-string >= 0.3 && < 1.1, vector >= 0.9, - web-plugins >= 0.1 && < 0.3, + web-plugins >= 0.1 && < 0.3, web-routes, web-routes-happstack, web-routes-hsp,