clckwrks 0.22.4 → 0.23.7
raw patch · 30 files changed
+781/−354 lines, 30 filesdep +aeson-qqdep +happstack-jmacrodep +hsx2hsdep ~attoparsecdep ~blaze-htmldep ~filepath
Dependencies added: aeson-qq, happstack-jmacro, hsx2hs, lens, time-locale-compat
Dependency ranges changed: attoparsec, blaze-html, filepath, happstack-authenticate, happstack-server, random, text, time, utf8-string
Files
- Clckwrks.hs +8/−2
- Clckwrks/Acid.hs +7/−10
- Clckwrks/Admin/Template.hs +46/−26
- Clckwrks/Authenticate/Page/ChangePassword.hs +16/−0
- Clckwrks/Authenticate/Page/Login.hs +36/−0
- Clckwrks/Authenticate/Page/OpenIdRealm.hs +16/−0
- Clckwrks/Authenticate/Page/ResetPassword.hs +20/−0
- Clckwrks/Authenticate/Plugin.hs +122/−0
- Clckwrks/Authenticate/Plugin.hs-boot +13/−0
- Clckwrks/Authenticate/Route.hs +33/−0
- Clckwrks/Authenticate/URL.hs +20/−0
- Clckwrks/GetOpts.hs +1/−1
- Clckwrks/JS/ClckwrksApp.hs +28/−0
- Clckwrks/JS/Route.hs +13/−0
- Clckwrks/JS/URL.hs +14/−0
- Clckwrks/Markup/Pandoc.hs +43/−0
- Clckwrks/Monad.hs +13/−61
- Clckwrks/NavBar/EditNavBar.hs +100/−64
- Clckwrks/ProfileData/API.hs +47/−12
- Clckwrks/ProfileData/Acid.hs +31/−31
- Clckwrks/ProfileData/EditNewProfileData.hs +17/−22
- Clckwrks/ProfileData/EditProfileData.hs +18/−21
- Clckwrks/ProfileData/EditProfileDataFor.hs +5/−11
- Clckwrks/ProfileData/Route.hs +1/−4
- Clckwrks/ProfileData/Types.hs +9/−2
- Clckwrks/ProfileData/URL.hs +4/−4
- Clckwrks/Route.hs +5/−20
- Clckwrks/Server.hs +47/−18
- Clckwrks/URL.hs +4/−17
- clckwrks.cabal +44/−28
Clckwrks.hs view
@@ -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)
Clckwrks/Acid.hs view
@@ -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 =
Clckwrks/Admin/Template.hs view
@@ -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| <html> <head>- <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/css/bootstrap.min.css" rel="stylesheet" media="screen" />- <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/css/bootstrap-responsive.css" rel="stylesheet" />+ <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.3.2/css/bootstrap-combined.min.css" rel="stylesheet" media="screen" />+-- <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/css/bootstrap-responsive.css" rel="stylesheet" /> <link type="text/css" href="/static/admin.css" rel="stylesheet" /> <script type="text/javascript" src="/jquery/jquery.js" ></script> <script type="text/javascript" src="/json2/json2.js" ></script>- <script type="text/javascript" src="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/js/bootstrap.min.js" ></script>-+ <script type="text/javascript" src="//netdna.bootstrapcdn.com/twitter-bootstrap/2.3.2/js/bootstrap.min.js" ></script>+ <script src="//ajax.googleapis.com/ajax/libs/angularjs/1.2.24/angular.min.js"></script>+ <script src="//ajax.googleapis.com/ajax/libs/angularjs/1.2.24/angular-route.min.js"></script>+-- <script src=(passwordShowURL UsernamePasswordCtrl)></script>+ <script src=(clckShowURL (JS ClckwrksApp) [])></script>+ <script src=(authShowURL (Auth Controllers) [])></script> <title><% title %></title> <% headers %> </head>- <body>+ <body ng-app="clckwrksApp" ng-controller="AuthenticationCtrl"> <div class="navbar"> <div class="navbar-inner"> <div class="container-fluid">@@ -53,7 +72,8 @@ </div> </div> </body>- </html>)+ </html>+ |]) 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| <html> <head> <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/css/bootstrap.min.css" rel="stylesheet" media="screen" />@@ -95,8 +115,7 @@ </div> </div> </body>- </html>)-+ </html> |]) sidebar :: (Happstack m) => XMLGenT (ClckT url m) XML sidebar = adminMenuXML@@ -105,11 +124,11 @@ adminMenuXML = do allMenus <- adminMenus <$> get usersMenus <- filterByRole allMenus- <div class="well">+ [hsx| <div class="well"> <ul class="nav nav-list"> <% mapM mkMenu usersMenus %> </ul>- </div>+ </div> |] 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| <%> <li class="nav-header"><% category %></li> <% 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| <li><a href=url><% title %></a></li>+ |]
+ Clckwrks/Authenticate/Page/ChangePassword.hs view
@@ -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|+ <%>+ <up-change-password />+ </%> |]+
+ Clckwrks/Authenticate/Page/Login.hs view
@@ -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|+ <div ng-controller="UsernamePasswordCtrl">+ <div up-authenticated=False>+ <h2>Login</h2>+ <up-login-inline />+ </div>++ <div up-authenticated=True>++ <h2>Logout</h2>+ <p>You have successfully logged in! Click the link below to logout.</p>+ <up-logout />++ <h2>Forgotten Password?</h2>+ <p>Forgot your password? Request a reset link via email!</p>+ <up-request-reset-password />+ </div>++ <h2>Create A New Account</h2>+ <up-signup-password />+ </div> |]
+ Clckwrks/Authenticate/Page/OpenIdRealm.hs view
@@ -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|+ <div ng-controller="OpenIdCtrl">+ <openid-realm />+ </div> |]+
+ Clckwrks/Authenticate/Page/ResetPassword.hs view
@@ -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|+ <%>+ <h2>Reset Password</h2>+ <up-reset-password />+ </%> |]
+ Clckwrks/Authenticate/Plugin.hs view
@@ -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)
+ Clckwrks/Authenticate/Plugin.hs-boot view
@@ -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)
+ Clckwrks/Authenticate/Route.hs view
@@ -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+
+ Clckwrks/Authenticate/URL.hs view
@@ -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
Clckwrks/GetOpts.hs view
@@ -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))
+ Clckwrks/JS/ClckwrksApp.hs view
@@ -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;+ }]);+ }+ |]
+ Clckwrks/JS/Route.hs view
@@ -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
+ Clckwrks/JS/URL.hs view
@@ -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
+ Clckwrks/Markup/Pandoc.hs view
@@ -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))
Clckwrks/Monad.hs view
@@ -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 --
@@ -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 @@ </div> </div> </div>- </fieldset>- -- <button id="add-sub-navBar">Add Sub-NavBar</button><br />- <fieldset>- <legend>Other Actions</legend> <div class="control-group">- <label class="control-label" for="remove-item"></label>- <div class="controls">- <button class="btn btn-danger" id="remove-item"><i class="icon-remove icon-white"></i> Remove Selected Item</button>- </div>- </div>- <div class="control-group"> <label class="control-label" for="saveChanges"></label> <div class="controls"> <button class="btn btn-success" id="saveChanges"><i class="icon-ok icon-white"></i> Save Changes</button>@@ -72,39 +63,52 @@ <fieldset> <legend>NavBar</legend>- <p><i>Drag and Drop to rearrange. Click to rename.</i></p>+ <p><i>Drag and Drop to rearrange. Right-click to rename or remove.</i></p> <div id="navBar"></div> </fieldset> </div> </%> where+ headers :: NavBar -> NavBarLinks -> GenChildList (Clck ClckURL) headers currentNavBar navBarLinks = do navBarUpdate <- showURL (Admin NavBarPost) <%>- <script type="text/javascript" src="/jstree/jquery.jstree.js" ></script>+ <link rel="stylesheet" href="/jstree/themes/default/style.min.css" />+ <script type="text/javascript" src="/jstree/jstree.min.js" ></script> <% [$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)
Clckwrks/ProfileData/API.hs view
@@ -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)
Clckwrks/ProfileData/Acid.hs view
@@ -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
Clckwrks/ProfileData/EditNewProfileData.hs view
@@ -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 () =
Clckwrks/ProfileData/EditProfileData.hs view
@@ -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) %>+ <up-change-password />+ </%> 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 -> [<div class="form-horizontal"><% xml %></div>]) divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])
Clckwrks/ProfileData/EditProfileDataFor.hs view
@@ -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" () $- <p>No profile data for <% show uid %>.</p>- (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
Clckwrks/ProfileData/Route.hs view
@@ -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
Clckwrks/ProfileData/Types.hs view
@@ -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)
Clckwrks/ProfileData/URL.hs view
@@ -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
Clckwrks/Route.hs view
@@ -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
Clckwrks/Server.hs view
@@ -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 =
Clckwrks/URL.hs view
@@ -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)
clckwrks.cabal view
@@ -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 <jeremy@n-heptane.com>-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,