diff --git a/Clckwrks.hs b/Clckwrks.hs --- a/Clckwrks.hs +++ b/Clckwrks.hs @@ -1,16 +1,19 @@ {-# 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 Data.UserId , module Happstack.Server , module Language.Javascript.JMacro , module Web.Routes @@ -18,17 +21,20 @@ ) 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 Data.UserId (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 @@ -1,25 +1,34 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, TypeFamilies #-} module Clckwrks.Acid where -import Clckwrks.NavBar.Acid (NavBarState , initialNavBarState) +import Clckwrks.NavBar.Acid (NavBarState , initialNavBarState) import Clckwrks.ProfileData.Acid (ProfileDataState, initialProfileDataState) import Clckwrks.Types (UUID) import Clckwrks.URL (ClckURL) import Control.Applicative ((<$>)) import Control.Exception (bracket, catch, throw) +import Control.Lens ((?=), (.=), (^.), (.~), makeLenses, view, set) +import Control.Lens.At (IxValue(..), Ixed(..), Index(..), At(at)) import Control.Concurrent (killThread, forkIO) import Control.Monad.Reader (ask) import Control.Monad.State (modify, put) import Data.Acid (AcidState, Query, Update, createArchive, makeAcidic) import Data.Acid.Local (openLocalStateFrom, createCheckpointAndClose) +#if MIN_VERSION_acid_state (0,16,0) +import Data.Acid.Remote (acidServerSockAddr, skipAuthenticationCheck) +import Data.Int (Int64) +import Network.Socket (SockAddr(SockAddrUnix)) +#else import Data.Acid.Remote (acidServer, skipAuthenticationCheck) +import Network (PortID(UnixSocket)) +#endif import Data.Data (Data, Typeable) 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 Network (PortID(UnixSocket)) +import qualified Data.Text as Text +import Happstack.Authenticate.Core (AuthenticateState, SimpleAddress(..)) +import Happstack.Authenticate.Password.Core (PasswordState) import Prelude hiding (catch) import System.Directory (removeFile) import System.FilePath (()) @@ -39,60 +48,184 @@ -- | 'CoreState' holds some values that are required by the core -- itself, or which are useful enough to be shared with numerous -- plugins/themes. -data CoreState = CoreState - { coreSiteName :: Maybe Text - , coreUACCT :: Maybe UACCT -- ^ Google Account UAACT - , coreRootRedirect :: Maybe Text - , coreLoginRedirect :: Maybe Text +data CoreState_1 = CoreState_1 + { coreSiteName_1 :: Maybe Text + , coreUACCT_1 :: Maybe UACCT -- ^ Google Account UAACT + , coreRootRedirect_1 :: Maybe Text + , coreLoginRedirect_1 :: Maybe Text } deriving (Eq, Data, Typeable, Show) -$(deriveSafeCopy 1 'extension ''CoreState) +instance Migrate CoreState_1 where + type MigrateFrom CoreState_1 = CoreState_v0 + migrate (CoreState_v0 ua rr) = CoreState_1 Nothing ua rr Nothing + +$(deriveSafeCopy 1 'extension ''CoreState_1) + + + +-- | 'CoreState' holds some values that are required by the core +-- itself, or which are useful enough to be shared with numerous +-- plugins/themes. +data CoreState_2 = CoreState_2 + { _coreSiteName_2 :: Maybe Text + , _coreUACCT_2 :: Maybe UACCT -- ^ Google Account UAACT + , _coreRootRedirect_2 :: Maybe Text + , _coreLoginRedirect_2 :: Maybe Text + , _coreFromAddress_2 :: Maybe SimpleAddress + , _coreReplyToAddress_2 :: Maybe SimpleAddress + , _coreSendmailPath_2 :: Maybe FilePath + , _coreEnableOpenId_2 :: Bool -- ^ allow OpenId authentication + } + deriving (Eq, Data, Typeable, Show) +$(deriveSafeCopy 2 'extension ''CoreState_2) + +instance Migrate CoreState_2 where + type MigrateFrom CoreState_2 = CoreState_1 + migrate (CoreState_1 sn ua rr lr) = CoreState_2 sn ua rr lr Nothing Nothing Nothing True + +-- | 'CoreState' holds some values that are required by the core +-- itself, or which are useful enough to be shared with numerous +-- plugins/themes. +data CoreState_3 = CoreState_3 + { _coreSiteName_3 :: Maybe Text + , _coreUACCT_3 :: Maybe UACCT -- ^ Google Account UAACT + , _coreRootRedirect_3 :: Maybe Text + , _coreLoginRedirect_3 :: Maybe Text + , _coreFromAddress_3 :: Maybe SimpleAddress + , _coreReplyToAddress_3 :: Maybe SimpleAddress + , _coreSendmailPath_3 :: Maybe FilePath + , _coreEnableOpenId_3 :: Bool -- ^ allow OpenId authentication + , _coreBodyPolicy_3 :: (FilePath, Int64, Int64, Int64) -- ^ (temp directory for uploads, maxDisk, maxRAM, maxHeader) + } + deriving (Eq, Data, Typeable, Show) +$(deriveSafeCopy 3 'extension ''CoreState_3) + +instance Migrate CoreState_3 where + type MigrateFrom CoreState_3 = CoreState_2 + migrate (CoreState_2 sn ua rr lr fa rta smp eo) = CoreState_3 sn ua rr lr fa rta smp eo ("/tmp/", (10 * 10^6), (1 * 10^6), (1 * 10^6)) + +-- | 'CoreState' holds some values that are required by the core +-- itself, or which are useful enough to be shared with numerous +-- plugins/themes. +data CoreState = CoreState + { _coreSiteName :: Maybe Text + , _coreUACCT :: Maybe UACCT -- ^ Google Account UAACT + , _coreRootRedirect :: Maybe Text + , _coreLoginRedirect :: Maybe Text + , _coreBackToSiteRedirect :: Text -- ^ where 'Back To ' link in settings panel should go + , _coreFromAddress :: Maybe SimpleAddress + , _coreReplyToAddress :: Maybe SimpleAddress + , _coreSendmailPath :: Maybe FilePath + , _coreEnableOpenId :: Bool -- ^ allow OpenId authentication + , _coreBodyPolicy :: (FilePath, Int64, Int64, Int64) -- ^ (temp directory for uploads, maxDisk, maxRAM, maxHeader) + } + deriving (Eq, Data, Typeable, Show) + instance Migrate CoreState where - type MigrateFrom CoreState = CoreState_v0 - migrate (CoreState_v0 ua rr) = CoreState Nothing ua rr Nothing + type MigrateFrom CoreState = CoreState_3 + migrate (CoreState_3 sn ua rr lr fa rta smp eo bp) = CoreState sn ua rr lr (Text.pack "/") fa rta smp eo bp +$(deriveSafeCopy 4 'extension ''CoreState) + +makeLenses ''CoreState + + initialCoreState :: CoreState initialCoreState = CoreState - { coreSiteName = Nothing - , coreUACCT = Nothing - , coreRootRedirect = Nothing - , coreLoginRedirect = Nothing + { _coreSiteName = Nothing + , _coreUACCT = Nothing + , _coreRootRedirect = Nothing + , _coreLoginRedirect = Nothing + , _coreBackToSiteRedirect = (Text.pack "/") + , _coreFromAddress = Nothing + , _coreReplyToAddress = Nothing + , _coreSendmailPath = Nothing + , _coreEnableOpenId = True + , _coreBodyPolicy = ("/tmp/", (10 * 10^6), (1 * 10^6), (1 * 10^6)) } +-- | get the site name +getSiteName :: Query CoreState (Maybe Text) +getSiteName = view coreSiteName + +-- | set the site name +setSiteName :: Maybe Text -> Update CoreState () +setSiteName name = coreSiteName .= name + -- | get the 'UACCT' for Google Analytics getUACCT :: Query CoreState (Maybe UACCT) -getUACCT = coreUACCT <$> ask +getUACCT = view coreUACCT -- | set the 'UACCT' for Google Analytics setUACCT :: Maybe UACCT -> Update CoreState () -setUACCT mua = modify $ \cs -> cs { coreUACCT = mua } +setUACCT mua = coreUACCT .= mua -- | get the path that @/@ should redirect to getRootRedirect :: Query CoreState (Maybe Text) -getRootRedirect = coreRootRedirect <$> ask +getRootRedirect = view coreRootRedirect +-- | get the path that 'Back To Site' should go to +getBackToSiteRedirect :: Query CoreState Text +getBackToSiteRedirect = view coreBackToSiteRedirect + +-- | set the path that 'Back To Site' should go to +setBackToSiteRedirect :: Text -> Update CoreState () +setBackToSiteRedirect path = coreBackToSiteRedirect .= path + -- | set the path that @/@ should redirect to setRootRedirect :: Maybe Text -> Update CoreState () -setRootRedirect path = modify $ \cs -> cs { coreRootRedirect = path } +setRootRedirect path = coreRootRedirect .= path +-- | get the 'BodyPolicy' data for requests which can have bodies +getBodyPolicy :: Query CoreState (FilePath, Int64, Int64, Int64) +getBodyPolicy = view coreBodyPolicy + +-- | set the 'BodyPolicy' data for requests which can have bodies +setBodyPolicy :: (FilePath, Int64, Int64, Int64) -> Update CoreState () +setBodyPolicy bp = coreBodyPolicy .= bp + -- | get the path that we should redirect to after login getLoginRedirect :: Query CoreState (Maybe Text) -getLoginRedirect = coreLoginRedirect <$> ask +getLoginRedirect = view coreLoginRedirect -- | set the path that we should redirect to after login setLoginRedirect :: Maybe Text -> Update CoreState () -setLoginRedirect path = modify $ \cs -> cs { coreLoginRedirect = path } +setLoginRedirect path = coreLoginRedirect .= path --- | get the site name -getSiteName :: Query CoreState (Maybe Text) -getSiteName = coreSiteName <$> ask +-- | get the From: address for system emails +getFromAddress :: Query CoreState (Maybe SimpleAddress) +getFromAddress = view coreFromAddress --- | set the site name -setSiteName :: Maybe Text -> Update CoreState () -setSiteName name = modify $ \cs -> cs { coreSiteName = name } +-- | get the From: address for system emails +setFromAddress :: Maybe SimpleAddress -> Update CoreState () +setFromAddress addr = coreFromAddress .= addr +-- | get the Reply-To: address for system emails +getReplyToAddress :: Query CoreState (Maybe SimpleAddress) +getReplyToAddress = view coreReplyToAddress + +-- | get the Reply-To: address for system emails +setReplyToAddress :: Maybe SimpleAddress -> Update CoreState () +setReplyToAddress addr = coreReplyToAddress .= addr + +-- | get the path to the sendmail executable +getSendmailPath :: Query CoreState (Maybe FilePath) +getSendmailPath = view coreSendmailPath + +-- | set the path to the sendmail executable +setSendmailPath :: Maybe FilePath -> Update CoreState () +setSendmailPath path = coreSendmailPath .= path + +-- | get the status of enabling OpenId +getEnableOpenId :: Query CoreState Bool +getEnableOpenId = view coreEnableOpenId + +-- | set the status of enabling OpenId +setEnableOpenId :: Bool -> Update CoreState () +setEnableOpenId b = coreEnableOpenId .= b + -- | get the entire 'CoreState' getCoreState :: Query CoreState CoreState getCoreState = ask @@ -106,20 +239,31 @@ , 'setUACCT , 'getRootRedirect , 'setRootRedirect + , 'getBackToSiteRedirect + , 'setBackToSiteRedirect , 'getLoginRedirect , 'setLoginRedirect + , 'getBodyPolicy + , 'setBodyPolicy , 'getSiteName , 'setSiteName + , 'getFromAddress + , 'setFromAddress + , 'getReplyToAddress + , 'setReplyToAddress + , 'getSendmailPath + , 'setSendmailPath + , 'setEnableOpenId + , 'getEnableOpenId , 'getCoreState , 'setCoreState ]) 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,16 +272,30 @@ 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 -> + -- open acid-state databases bracket (openLocalStateFrom (basePath "core") initialCoreState) (createArchiveCheckpointAndClose) $ \core -> + bracket (openLocalStateFrom (basePath "profileData") initialProfileDataState) (createArchiveCheckpointAndClose) $ \profileData -> bracket (openLocalStateFrom (basePath "navBar") initialNavBarState) (createArchiveCheckpointAndClose) $ \navBar -> + -- create sockets to allow `clckwrks-cli` to talk to the databases +#if MIN_VERSION_acid_state (0,16,0) + bracket (forkIO (tryRemoveFile (basePath "core_socket") >> acidServerSockAddr skipAuthenticationCheck (SockAddrUnix $ basePath "core_socket") profileData)) + (\tid -> killThread tid >> tryRemoveFile (basePath "core_socket")) $ const $ + +#else + bracket (forkIO (tryRemoveFile (basePath "core_socket") >> acidServer skipAuthenticationCheck (UnixSocket $ basePath "core_socket") profileData)) + (\tid -> killThread tid >> tryRemoveFile (basePath "core_socket")) $ const $ +#endif +#if MIN_VERSION_acid_state (0,16,0) + bracket (forkIO (tryRemoveFile (basePath "profileData_socket") >> acidServerSockAddr skipAuthenticationCheck (SockAddrUnix $ basePath "profileData_socket") profileData)) + (\tid -> killThread tid >> tryRemoveFile (basePath "profileData_socket")) +#else 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)) +#endif + (const $ f (Acid profileData core navBar)) where tryRemoveFile fp = removeFile fp `catch` (\e -> if isDoesNotExistError e then return () else throw e) createArchiveCheckpointAndClose acid = do createArchive acid createCheckpointAndClose acid + diff --git a/Clckwrks/Admin/EditSettings.hs b/Clckwrks/Admin/EditSettings.hs --- a/Clckwrks/Admin/EditSettings.hs +++ b/Clckwrks/Admin/EditSettings.hs @@ -2,9 +2,10 @@ {-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Admin.EditSettings where -import Clckwrks -import Clckwrks.Acid (GetUACCT(..), SetUACCT(..)) +import Clckwrks hiding (transform) +import Clckwrks.Acid (GetUACCT(..), SetUACCT(..), coreSiteName, coreUACCT, coreRootRedirect, coreLoginRedirect, coreBackToSiteRedirect) import Clckwrks.Admin.Template (template) +import Control.Lens ((&), (.~)) import Data.Maybe (fromMaybe) import Data.Text (Text, pack, unpack) import qualified Data.Text as T @@ -13,6 +14,7 @@ import HSP.Google.Analytics (UACCT(..)) import HSP.XMLGenerator import HSP.XML (fromStringLit) +import Numeric (readDec) import Text.Reform import Text.Reform.Happstack import Text.Reform.HSP.Text @@ -32,28 +34,65 @@ seeOtherURL here editSettingsForm :: CoreState -> ClckForm ClckURL CoreState -editSettingsForm CoreState{..} = +editSettingsForm c@CoreState{..} = divHorizontal $ fieldset $ - (CoreState <$> + (modifyCoreState <$> (divControlGroup $ - (labelText "site name" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> - (divControls (inputText (fromMaybe mempty coreSiteName)) `transformEither` toMaybe))) + (labelText "site name" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText (fromMaybe mempty _coreSiteName)) `transformEither` toMaybe))) <*> (divControlGroup $ (label ("Google Analytics UACCT" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> - (divControls (inputText (unUACCT coreUACCT)) `transformEither` toMUACCT)) + (divControls (inputText (unUACCT _coreUACCT)) `transformEither` toMUACCT)) <*> (divControlGroup $ (labelText "/ redirects to" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> - (divControls (inputText (fromMaybe mempty coreRootRedirect)) `transformEither` toMaybe)) + (divControls (inputText (fromMaybe mempty _coreRootRedirect)) `transformEither` toMaybe)) <*> (divControlGroup $ - (labelText "after login redirect to" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> - (divControls (inputText (fromMaybe mempty coreLoginRedirect)) `transformEither` toMaybe)) - <* + (labelText "Back To Site location" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText _coreBackToSiteRedirect))) + + <*> (divControlGroup $ + (labelText "after login redirect to" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText (fromMaybe mempty _coreLoginRedirect)) `transformEither` toMaybe)) + + <*> bodyPolicyForm + <* (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn") :: Attr Text Text]) where + bodyPolicyForm = + let (tmpPath, mDisk, mRam, mHeader) = _coreBodyPolicy in + (,,,) <$> (divControlGroup $ + (labelText "temporary directory for uploads" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText (T.pack tmpPath)) `transformEitherM` toFilePath)) + <*> (divControlGroup $ + (labelText "maximum size for file uploads" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText (T.pack $ show $ mDisk)) `transform` (decimalText InvalidDecimal))) + <*> (divControlGroup $ + (labelText "maximum size for non-file values" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText (T.pack $ show $ mRam)) `transform` (decimalText InvalidDecimal))) + <*> (divControlGroup $ + (labelText "maximum size for overhead of headers in multipart/form-data" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText (T.pack $ show $ mHeader)) `transform` (decimalText InvalidDecimal))) + + + -- | read an unsigned number in decimal notation + decimalText :: (Monad m, Eq i, Num i) => + (Text -> error) -- ^ create an error message ('String' is the value that did not parse) + -> Proof m error Decimal Text i + decimalText mkError = Proof Decimal (return . toDecimal) + where + toDecimal txt = + case readDec (T.unpack txt) of + [(d,[])] -> (Right d) + _ -> (Left $ mkError txt) + + -- | FIXME: should perhaps check that the path exists and is writable? + toFilePath :: (MonadIO m) => Text -> m (Either ClckFormError FilePath) + toFilePath t = pure $ Right (T.unpack t) + divHorizontal = mapView (\xml -> [
<% xml %>
]) divControlGroup = mapView (\xml -> [
<% xml %>
]) divControls = mapView (\xml -> [
<% xml %>
]) @@ -70,6 +109,14 @@ if T.null txt then Right $ Nothing else Right $ Just txt + + modifyCoreState sn ua rr bts lr bp = + c & coreSiteName .~ sn + & coreUACCT .~ ua + & coreRootRedirect .~ rr + & coreBackToSiteRedirect .~ bts + & coreLoginRedirect .~ lr + & coreBodyPolicy .~ bp {- editUACCTForm :: Maybe UACCT -> ClckForm ClckURL (Maybe UACCT) diff --git a/Clckwrks/Admin/Route.hs b/Clckwrks/Admin/Route.hs --- a/Clckwrks/Admin/Route.hs +++ b/Clckwrks/Admin/Route.hs @@ -4,6 +4,7 @@ import Clckwrks.Admin.Console (consolePage) import Clckwrks.Admin.EditSettings (editSettings) import Clckwrks.NavBar.EditNavBar (editNavBar, navBarPost) +import Clckwrks.Admin.SystemEmails (systemEmailsPage) -- | routes for 'AdminURL' routeAdmin :: AdminURL -> Clck ClckURL Response @@ -13,3 +14,5 @@ EditSettings -> editSettings (Admin url) EditNavBar -> editNavBar NavBarPost -> navBarPost + SystemEmails -> systemEmailsPage (Admin url) + diff --git a/Clckwrks/Admin/SystemEmails.hs b/Clckwrks/Admin/SystemEmails.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Admin/SystemEmails.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-} +module Clckwrks.Admin.SystemEmails where + +import Clckwrks +import Clckwrks.Acid (GetUACCT(..), SetUACCT(..)) +import Clckwrks.Admin.Template (template) +import Control.Lens ((.~), (&)) +import Data.Maybe (maybe, fromMaybe) +import Data.Text (Text, pack, unpack) +import qualified Data.Text as T + +-- import Clckwrks.Page.Acid (GetUACCT(..), SetUACCT(..)) +import Happstack.Authenticate.Core (Email(..), SimpleAddress(..)) +import HSP.Google.Analytics (UACCT(..)) +import HSP.XMLGenerator +import HSP.XML (fromStringLit) +import Language.Haskell.HSX.QQ (hsx) +import Text.Reform +import Text.Reform.Happstack +import Text.Reform.HSP.Text + +systemEmailsPage :: ClckURL -> Clck ClckURL Response +systemEmailsPage here = + do coreState <- query $ GetCoreState + action <- showURL here + template "Edit Settings" () $ [hsx| + <%> + <% reform (form action) "ss" updateSettings Nothing (editSettingsForm coreState) %> + |] + where + updateSettings :: CoreState -> Clck ClckURL Response + updateSettings coreState = + do update (SetCoreState coreState) + seeOtherURL here + + +editSettingsForm :: CoreState -> ClckForm ClckURL CoreState +editSettingsForm c@CoreState{..} = + divHorizontal $ + fieldset $ + (modifyCoreState <$> + (divControlGroup $ + (labelText "From: address" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText (maybe mempty (_unEmail . _saEmail) _coreFromAddress)) `transformEither` toMaybe)) + + <*> (divControlGroup $ + (label ("From: name" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText (maybe mempty (fromMaybe mempty . _saName) _coreFromAddress)) `transformEither` toMaybe)) + + <*> (divControlGroup $ + (label ("Reply-to: address" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText (maybe mempty (_unEmail . _saEmail) _coreReplyToAddress)) `transformEither` toMaybe)) + + <*> (divControlGroup $ + (label ("Reply-to: name" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText (maybe mempty (fromMaybe mempty . _saName) _coreReplyToAddress)) `transformEither` toMaybe)) + + <*> (divControlGroup $ + (labelText "sendmail path" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText (maybe mempty T.pack _coreSendmailPath)) `transformEither` toMaybe))) + + <* + (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn") :: Attr Text Text]) + where + divHorizontal = mapView (\xml -> [[hsx|
<% xml %>
|]]) + divControlGroup = mapView (\xml -> [[hsx|
<% xml %>
|]]) + divControls = mapView (\xml -> [[hsx|
<% xml %>
|]]) + + toMaybe :: Text -> Either ClckFormError (Maybe Text) + toMaybe txt = + if T.null txt + then Right $ Nothing + else Right $ Just txt + modifyCoreState mFromAddress mFromName mReplyToAddress mReplyToName mSendmailPath = + c & coreFromAddress .~ + case mFromAddress of + Nothing -> Nothing + (Just addr) -> Just (SimpleAddress mFromName (Email addr)) + & coreReplyToAddress .~ + case mReplyToAddress of + Nothing -> Nothing + (Just addr) -> Just (SimpleAddress mReplyToName (Email addr)) + & coreSendmailPath .~ (T.unpack <$> mSendmailPath) + +{- +editUACCTForm :: Maybe UACCT -> ClckForm ClckURL (Maybe UACCT) +editUACCTForm muacct = + divHorizontal $ + fieldset $ + (divControlGroup $ + (label ("Google Analytics UACCT" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputText (unUACCT muacct)) `transformEither` toMUACCT)) <* + (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn") :: Attr Text Text]) + where + divHorizontal = mapView (\xml -> [
<% xml %>
]) + divControlGroup = mapView (\xml -> [
<% xml %>
]) + divControls = mapView (\xml -> [
<% xml %>
]) + unUACCT (Just (UACCT str)) = str + unUACCT Nothing = "" + + toMUACCT :: String -> Either ClckFormError (Maybe UACCT) + toMUACCT [] = Right $ Nothing + toMUACCT str = Right $ Just (UACCT str) +-} 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(..), GetBackToSiteRedirect(..)) +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,24 +31,33 @@ ) => String -> headers -> body -> ClckT url m Response template title headers body = do siteName <- (fromMaybe "Your Site") <$> query GetSiteName - toResponse <$> (unXMLGenT $ + backURL <- query GetBackToSiteRedirect + 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 %> - +
- Back to <% siteName %> + Back to <% siteName %>
@@ -53,7 +73,8 @@ - ) + + |]) emptyTemplate :: ( Happstack m @@ -62,7 +83,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 +116,7 @@ - ) - + |]) sidebar :: (Happstack m) => XMLGenT (ClckT url m) XML sidebar = adminMenuXML @@ -105,11 +125,11 @@ adminMenuXML = do allMenus <- adminMenus <$> get usersMenus <- filterByRole allMenus -
+ [hsx|
    <% mapM mkMenu usersMenus %>
-
+
|] where -- filterByRole :: [(T.Text, [(Set Role, T.Text, T.Text)])] -> [(T.Text, [(Set Role, T.Text, T.Text)])] filterByRole menus = @@ -122,11 +142,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/Admin/URL.hs b/Clckwrks/Admin/URL.hs --- a/Clckwrks/Admin/URL.hs +++ b/Clckwrks/Admin/URL.hs @@ -10,7 +10,8 @@ | EditSettings | EditNavBar | NavBarPost + | SystemEmails deriving (Eq, Ord, Read, Show, Data, Typeable) $(derivePathInfo ''AdminURL) -$(deriveSafeCopy 2 'base ''AdminURL) +$(deriveSafeCopy 3 'base ''AdminURL) diff --git a/Clckwrks/Authenticate/API.hs b/Clckwrks/Authenticate/API.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Authenticate/API.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} +module Clckwrks.Authenticate.API + ( Username(..) + , getEmail + , getUser + , getUsername + , insecureUpdateUser + , setCreateUserCallback + ) where + +import Clckwrks.Authenticate.Plugin (authenticatePlugin) +import Clckwrks.Authenticate.Monad (AuthenticatePluginState(..)) +import Clckwrks.Monad (Clck, ClckPlugins, plugins) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TVar (modifyTVar') +import Control.Monad (join) +import Control.Monad.State (get) +import Control.Monad.Trans (liftIO) +import Data.Acid as Acid (AcidState, query, update) +import Data.Maybe (maybe) +import Data.Monoid (mempty) +import Data.Text (Text) +import Data.UserId (UserId) +import Happstack.Authenticate.Core (AuthenticateConfig(_createUserCallback), GetUserByUserId(..), Email(..), UpdateUser(..), User(..), Username(..)) +import Web.Plugins.Core (Plugin(..), When(Always), addCleanup, addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, getPluginsSt, initPlugin, modifyPluginState') + +getUser :: UserId -> Clck url (Maybe User) +getUser uid = + do p <- plugins <$> get + ~(Just aps) <- getPluginState p (pluginName authenticatePlugin) + liftIO $ Acid.query (acidStateAuthenticate aps) (GetUserByUserId uid) + +-- | Update an existing 'User'. Must already have a valid 'UserId'. +-- +-- no security checks are performed to ensure that the caller is +-- authorized to change data for the 'User'. +insecureUpdateUser :: User -> Clck url () +insecureUpdateUser user = + do p <- plugins <$> get + ~(Just aps) <- getPluginState p (pluginName authenticatePlugin) + liftIO $ Acid.update (acidStateAuthenticate aps) (UpdateUser user) + +getUsername :: UserId -> Clck url (Maybe Username) +getUsername uid = + do mUser <- getUser uid + pure $ _username <$> mUser + +getEmail :: UserId -> Clck url (Maybe Email) +getEmail uid = + do mUser <- getUser uid + pure $ join $ _email <$> mUser + +setCreateUserCallback :: ClckPlugins -> Maybe (User -> IO ()) -> IO () +setCreateUserCallback p mcb = + do ~(Just aps) <- getPluginState p (pluginName authenticatePlugin) + liftIO $ atomically $ modifyTVar' (apsAuthenticateConfigTV aps) $ (\ac -> ac { _createUserCallback = mcb }) + pure () diff --git a/Clckwrks/Authenticate/Monad.hs b/Clckwrks/Authenticate/Monad.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Authenticate/Monad.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveDataTypeable, RecordWildCards, FlexibleContexts, Rank2Types, OverloadedStrings, MultiParamTypeClasses #-} +module Clckwrks.Authenticate.Monad where + +import Clckwrks.Acid (GetAcidState(..), GetCoreState(..), GetEnableOpenId(..), acidCore, acidProfileData, coreFromAddress, coreReplyToAddress, coreSendmailPath, getAcidState) +import Clckwrks.Monad +import Control.Concurrent.STM.TVar (TVar) +import Control.Monad.State (get) +import Control.Monad.Trans (MonadIO, lift) +import Data.Acid as Acid (AcidState, query) +import Data.Typeable (Typeable) +import Happstack.Authenticate.Core (AuthenticateState, AuthenticateConfig(..), User, getToken, tokenUser, userId, usernamePolicy) +import Happstack.Authenticate.Password.Core (PasswordConfig, PasswordState) +import Web.Plugins.Core (getPluginState) + +data AuthenticatePluginState = AuthenticatePluginState + { acidStateAuthenticate :: AcidState AuthenticateState + , acidStatePassword :: AcidState PasswordState + , apsAuthenticateConfigTV :: TVar AuthenticateConfig + , apsPasswordConfigTV :: TVar PasswordConfig + } + deriving Typeable + +instance (Functor m, MonadIO m) => GetAcidState (ClckT url m) AuthenticateState where + getAcidState = + do p <- plugins <$> get + ~(Just aps) <- getPluginState p "authenticate" + pure (acidStateAuthenticate aps) + +instance (Functor m, MonadIO m) => GetAcidState (ClckT url m) PasswordState where + getAcidState = + do p <- plugins <$> get + ~(Just aps) <- getPluginState p "authenticate" + pure (acidStatePassword aps) + diff --git a/Clckwrks/Authenticate/Page/AuthModes.hs b/Clckwrks/Authenticate/Page/AuthModes.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Authenticate/Page/AuthModes.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-} +module Clckwrks.Authenticate.Page.AuthModes where + +import Clckwrks.Acid (GetEnableOpenId(..), SetEnableOpenId(..)) +import Clckwrks.Admin.Template (template) +import Clckwrks.Authenticate.URL (AuthURL(..)) +import Clckwrks.Monad +import Clckwrks.URL (ClckURL) +import Control.Lens ((.~), (&)) +import Data.Maybe (maybe, fromMaybe) +import Data.Text.Lazy (Text) +import qualified Data.Text as T +import Happstack.Server (Response, ServerPartT, ok, toResponse) +import HSP.XMLGenerator +import HSP.XML (fromStringLit) +import Language.Haskell.HSX.QQ (hsx) +import Text.Reform +import Text.Reform.Happstack +import Text.Reform.HSP.Text +import Web.Routes (showURL) +import Web.Routes.Happstack (seeOtherURL) + +authModesPage :: AuthURL -> Clck AuthURL Response +authModesPage here = + do enableOpenId <- query $ GetEnableOpenId + action <- showURL here + template "Authentication Modes" () $ + [hsx| + <%> + <% reform (form action) "am" updateAuthModes Nothing (authModesForm enableOpenId) %> + + |] + where + updateAuthModes :: Bool -> Clck AuthURL Response + updateAuthModes b = + do update (SetEnableOpenId b) + seeOtherURL here + +authModesForm :: Bool -> ClckForm AuthURL Bool +authModesForm b = + divHorizontal $ + fieldset $ + (divControlGroup $ + (labelText "Enable OpenId" `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> + (divControls (inputCheckbox b))) + <* (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn") :: Attr Text Text]) + + where + label' :: Text -> ClckForm AuthURL () + label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text]) + divHorizontal = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + divControlGroup = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + divControls = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + + +-- (divControls (inputText (maybe mempty (_unEmail . _saEmail) _coreFromAddress)) `transformEither` toMaybe)) 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,19 @@ +{-# 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 "Change Password" () $ [hsx| + <%> +

    Change Password

    +
    + +
    + |] + 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,35 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +module Clckwrks.Authenticate.Page.Login where + +import Control.Applicative ((<$>)) +import Clckwrks.Monad (ClckT, ThemeStyleId(..), plugins, themeTemplate) +import Clckwrks.Authenticate.URL +import Clckwrks.URL (ClckURL) +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

    + + +

    Forgotten Password?

    +

    Forgot your password? Request a reset link via email!

    + +
    + +
    +

    Logout

    +

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

    + +
    + +

    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,22 @@ +{-# 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/Page/ViewUsers.hs b/Clckwrks/Authenticate/Page/ViewUsers.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Authenticate/Page/ViewUsers.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies, QuasiQuotes, OverloadedStrings #-} +module Clckwrks.Authenticate.Page.ViewUsers where + +import Clckwrks.Admin.Template (template) +import Clckwrks.Monad +import Clckwrks.URL (ClckURL(..)) +import Clckwrks.Authenticate.Monad () +import Clckwrks.ProfileData.URL(ProfileDataURL(..)) +import Data.Maybe (maybe) +import Data.Foldable (toList) +import qualified Data.Text as Text +import Happstack.Server (Response, ServerPartT, ok, toResponse) +import Happstack.Authenticate.Core (Email(..), GetUsers(..), User(..), UserId(..), Username(..)) +import Language.Haskell.HSX.QQ (hsx) +import Web.Plugins.Core (Plugin(..), getPluginState) +import Web.Routes (showURL) + +viewUsers :: ClckT ClckURL (ServerPartT IO) Response +viewUsers = + do us <- query GetUsers + template "View Users" () $ [hsx| +
    +

    Users

    + + + + + + <% mapM mkRow (toList us) %> + +
    UserIdUsernameEmail
    +
    |] + where + mkRow u = + do epdf <- showURL (Profile (EditProfileDataFor (_userId u))) + [hsx| <% show $ _unUserId $ _userId u %><% _unUsername $ _username u %><% maybe (Text.empty) _unEmail (_email u) %> |] + 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,146 @@ +{-# LANGUAGE DeriveDataTypeable, RecordWildCards, FlexibleContexts, Rank2Types, OverloadedStrings, MultiParamTypeClasses #-} +module Clckwrks.Authenticate.Plugin where + +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TVar (TVar, newTVar) +import Clckwrks.Monad +import Clckwrks.Acid (GetAcidState(..), GetCoreState(..), GetEnableOpenId(..), acidCore, acidProfileData, coreFromAddress, coreLoginRedirect, coreReplyToAddress, coreSendmailPath, getAcidState) +import Clckwrks.Authenticate.Monad (AuthenticatePluginState(..)) +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.Reader (ask) +import Control.Monad.State (get) +import Control.Monad.Trans (MonadIO, lift) +import Data.Acid as Acid (AcidState, query, openLocalStateFrom) +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 Data.UserId (UserId) +import Happstack.Authenticate.Core (AuthenticateState, AuthenticateConfig(..), getToken, tokenUser, userId, usernamePolicy) +import Happstack.Authenticate.Route (initAuthentication) +import Happstack.Authenticate.Password.Core (PasswordConfig(..), initialPasswordState) +import Happstack.Authenticate.Password.Route (initPassword') +import Happstack.Authenticate.OpenId.Route (initOpenId) +import Happstack.Server +import System.FilePath ((), combine) +import Web.Plugins.Core (Plugin(..), When(Always), addCleanup, addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, getPluginsSt, initPlugin) +import Web.Routes + +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) -> ClckT $ withRouteT flattenURL $ unClckT $ 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 [])]) + addAdminMenu ("Authentication", [(Set.fromList [Administrator], "Authentication Modes", authShowURL AuthModes [])]) + addAdminMenu ("Authentication", [(Set.fromList [Administrator], "View Users" , authShowURL ViewUsers [])]) + +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 + cs <- Acid.query (acidCore acid) GetCoreState + let authenticateConfig = AuthenticateConfig { + _isAuthAdmin = \uid -> Acid.query (acidProfileData acid) (HasRole uid (Set.singleton Administrator)) + , _usernameAcceptable = usernamePolicy + , _requireEmail = True + , _systemFromAddress = cs ^. coreFromAddress + , _systemReplyToAddress = cs ^. coreReplyToAddress + , _systemSendmailPath = cs ^. coreSendmailPath + , _postLoginRedirect = cs ^. coreLoginRedirect + , _createUserCallback = Nothing + } + passwordConfig = PasswordConfig { + _resetLink = baseUri <> authShowFn ResetPassword [] <> "/#" + , _domain = Text.pack $ clckHostname cc + , _passwordAcceptable = const Nothing + } + + passwordState <- openLocalStateFrom (combine (combine basePath "authenticate") "password") initialPasswordState + passwordConfigTV <- atomically $ newTVar passwordConfig + (authCleanup, routeAuthenticate, authenticateState, authenticateConfigTV) <- initAuthentication (Just basePath) authenticateConfig + ((initPassword' passwordConfigTV passwordState) : if True then [ initOpenId ] else []) + addHandler plugins (pluginName authenticatePlugin) (authenticateHandler routeAuthenticate authShowFn) + addPluginState plugins (pluginName authenticatePlugin) (AuthenticatePluginState authenticateState passwordState authenticateConfigTV passwordConfigTV) + addCleanup plugins Always authCleanup + 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 = [] + , pluginToPathSegments = toPathSegments + , 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 aps) <- getPluginState p (pluginName authenticatePlugin) + mToken <- getToken (acidStateAuthenticate aps) + 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 Clckwrks.Authenticate.URL (AuthURL) +import Clckwrks.Monad +import Clckwrks.URL +import Data.UserId (UserId) +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,60 @@ +{-# LANGUAGE OverloadedStrings #-} +module Clckwrks.Authenticate.Route where + +import Control.Applicative ((<$>)) +import Clckwrks.Monad (ClckT(..), plugins) +import Clckwrks.Authenticate.URL (AuthURL(..)) +import Clckwrks.Authenticate.Page.AuthModes (authModesPage) +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.Authenticate.Page.ViewUsers (viewUsers) +import Clckwrks.ProfileData.API (Role(..), requiresRole_) +import Clckwrks.URL (ClckURL) +-- import Clckwrks.Plugin (clckPlugin) +import Control.Monad.State (get) +import Control.Monad.Trans (lift) +import qualified Data.Set as Set +import Happstack.Authenticate.Core (AuthenticateURL) +import Happstack.Server (Happstack, Response, ServerPartT) +import Web.Routes (RouteT(..), askRouteFn, runRouteT) +import Web.Plugins.Core (getPluginRouteFn, pluginName) + +-- | routeAuth +-- there is much craziness here. This should be more like clckwrks-plugin-page or something +routeAuth :: (AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response) + -> AuthURL + -> ClckT AuthURL (ServerPartT IO) Response +routeAuth routeAuthenticate u' = + do u <- checkAuth u' + p <- plugins <$> get + ~(Just clckShowFn) <- getPluginRouteFn p "clck" -- (pluginName clckPlugin) -- a mildly dangerous hack to avoid circular depends + let withClckURL m = ClckT $ RouteT $ \_ -> unRouteT (unClckT m) clckShowFn + case u of + (Auth authenticateURL) -> + do p <- plugins <$> get + ~(Just authShowFn) <- getPluginRouteFn p "authenticate" + lift $ runRouteT routeAuthenticate (authShowFn . Auth) authenticateURL + Login -> withClckURL loginPage + ResetPassword -> withClckURL resetPasswordPage + ChangePassword -> withClckURL changePasswordPanel + OpenIdRealm -> withClckURL openIdRealmPanel + AuthModes -> authModesPage u + ViewUsers -> withClckURL viewUsers + +checkAuth :: (Happstack m, Monad m) => + AuthURL + -> ClckT AuthURL m AuthURL +checkAuth url = + do p <- plugins <$> get + ~(Just clckShowFn) <- getPluginRouteFn p "clck" -- (pluginName clckPlugin) -- a mildly dangerous hack to avoid circular depends + let requiresRole = requiresRole_ clckShowFn + case url of + (Auth {}) -> pure url + Login -> pure url + ResetPassword -> pure url + AuthModes -> requiresRole (Set.fromList [Administrator]) url + ChangePassword -> requiresRole (Set.fromList [Visitor]) url + OpenIdRealm -> requiresRole (Set.fromList [Administrator]) url + ViewUsers -> requiresRole (Set.fromList [Administrator]) url 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,22 @@ +{-# 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 + | AuthModes + | ViewUsers + 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 @@ -31,9 +31,10 @@ , Option [] ["https-port"] (ReqArg setTLSPort "port") ("Port to bind https server, default:" ++ maybe "disabled." show (clckTLSPort <$> (clckTLS def))) , Option [] ["tls-cert"] (ReqArg setTLSCert "path") ("Path to tls .cert file. (required for https).") , Option [] ["tls-key"] (ReqArg setTLSKey "path") ("Path to tls .key file. (required for https).") - , Option [] ["tls-ca"] (ReqArg setTLSCA "path") ("Path to tls .pem file. (required for some certs).") + , Option [] ["tls-ca"] (ReqArg setTLSCA "path") ("Path to tls .pem file. (required for some certs).") + , Option [] ["tls-rev-proxy"] (NoArg setTLSRevProxy) ("Act as a reverse proxy and trust X-Forwarded-Proto for TLS.") , Option [] ["hide-port"] (NoArg setHidePort) "Do not show the port number in the URL" - , Option [] ["hostname"] (ReqArg setHostname "hostname") ("Server 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)) @@ -43,9 +44,10 @@ ] where nullTLSSettings = TLSSettings { clckTLSPort = 443 - , clckTLSCert = "" - , clckTLSKey = "" + , clckTLSCert = Nothing + , clckTLSKey = Nothing , clckTLSCA = Nothing + , clckTLSRev = False } modifyTLS f cc = Just $ case clckTLS cc of @@ -54,9 +56,10 @@ noop _ = ModifyConfig $ id setPort str = ModifyConfig $ \c -> c { clckPort = read str } setTLSPort str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSPort = read str }) c } - setTLSCert str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSCert = str }) c } - setTLSKey str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSKey = str }) c } + setTLSCert str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSCert = Just str }) c } + setTLSKey str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSKey = Just str }) c } setTLSCA str = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSCA = Just str }) c } + setTLSRevProxy = ModifyConfig $ \c -> c { clckTLS = modifyTLS (\tls -> tls { clckTLSRev = True}) c } setHostname str = ModifyConfig $ \c -> c { clckHostname = str } setHidePort = ModifyConfig $ \c -> c { clckHidePort = True } setJQueryPath str = ModifyConfig $ \c -> c { clckJQueryPath = str } @@ -87,19 +90,27 @@ Nothing -> return cc (Just TLSSettings{..}) -> do mCertError <- - if null clckTLSCert - then return (Just "--tls-cert not set.") - else do b <- doesFileExist clckTLSCert - if b - then return Nothing - else return (Just $ "Can not find the file " ++ clckTLSCert) + case clckTLSCert of + Nothing -> + if clckTLSRev + then return Nothing + else return (Just "--tls-cert not set.") + (Just certPath) -> do + b <- doesFileExist certPath + if b + then return Nothing + else return (Just $ "Can not find the file " ++ certPath) mKeyError <- - if null clckTLSKey - then return (Just "--tls-key not set.") - else do b <- doesFileExist clckTLSKey - if b - then return Nothing - else return (Just $ "Can not find the file " ++ clckTLSKey) + case clckTLSKey of + Nothing -> + if clckTLSRev + then return Nothing + else return (Just "--tls-key not set.") + (Just keyPath) -> do + b <- doesFileExist keyPath + if b + then return Nothing + else return (Just $ "Can not find the file " ++ keyPath) case (mCertError, mKeyError) of (Nothing, Nothing) -> return cc _ -> do putStrLn "It seems you are trying to enable https support. To do that you need to use both the --tls-cert and --tls-key flags." 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,49 @@ +{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} +module Clckwrks.JS.ClckwrksApp where + +import Language.Javascript.JMacro + +clckwrksAppJS :: Bool -> JStat +clckwrksAppJS True = [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; + }]); + } + |] +clckwrksAppJS False = [jmacro| + { + var clckwrksApp = angular.module('clckwrksApp', [ + 'happstackAuthentication', + 'usernamePassword', + '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) => Bool -> JSURL -> ClckT u m Response +routeJS enableOpenId url = + case url of + ClckwrksApp -> ok $ toResponse $ clckwrksAppJS enableOpenId 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/Markdown.hs b/Clckwrks/Markup/Markdown.hs --- a/Clckwrks/Markup/Markdown.hs +++ b/Clckwrks/Markup/Markdown.hs @@ -40,4 +40,5 @@ return (Left e) ExitSuccess -> do m <- readMVar mvOut + e <- readMVar mvErr return (Right ((if (trust == Untrusted) then sanitizeBalance else id) m)) 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 @@ -1,8 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, TypeFamilies, RankNTypes, RecordWildCards, ScopedTypeVariables, UndecidableInstances, OverloadedStrings, TemplateHaskell #-} +{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, TypeFamilies, RankNTypes, RecordWildCards, ScopedTypeVariables, UndecidableInstances, OverloadedStrings, TemplateHaskell #-} module Clckwrks.Monad ( Clck , ClckPlugins - , ClckPluginsSt + , ClckPluginsSt(cpsAcid) , initialClckPluginsSt , ClckT(..) , ClckForm @@ -26,7 +26,6 @@ , mapClckT , withRouteClckT , ClckState(..) - , getUserId , Content(..) -- , markupToContent -- , addPreProcessor @@ -41,14 +40,12 @@ , googleAnalytics , getUnique , setUnique - , requiresRole - , requiresRole_ , setRedirectCookie , getRedirectCookie - , getUserRoles , query , update , nestURL + , isSecure , withAbs , withAbs' , segments @@ -60,7 +57,7 @@ import Clckwrks.Admin.URL (AdminURL(..)) import Clckwrks.Acid (Acid(..), CoreState, GetAcidState(..), GetUACCT(..)) -import Clckwrks.ProfileData.Acid (ProfileDataState, ProfileDataError(..), GetRoles(..), HasRole(..)) +import Clckwrks.ProfileData.Acid (ProfileDataState, GetRoles(..), HasRole(..)) import Clckwrks.ProfileData.Types (Role(..)) import Clckwrks.NavBar.Acid (NavBarState) import Clckwrks.NavBar.Types (NavBarLinks(..)) @@ -68,6 +65,9 @@ import Clckwrks.Unauthorized (unauthorizedPage) import Clckwrks.URL (ClckURL(..)) import Control.Applicative (Alternative, Applicative, (<$>), (<|>), many, optional) +#if MIN_VERSION_base (4,9,0) && !MIN_VERSION_base (4,13,0) +import Control.Monad.Fail (MonadFail) +#endif import Control.Monad (MonadPlus, foldM) import Control.Monad.State (MonadState, StateT, evalStateT, execStateT, get, mapStateT, modify, put, runStateT) import Control.Monad.Reader (MonadReader, ReaderT, mapReaderT) @@ -100,14 +100,12 @@ 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 Data.UserId (UserId(..)) import Happstack.Server ( CookieLife(Session), Happstack, ServerMonad(..), FilterMonad(..) , WebMonad(..), Input, Request(..), Response, HasRqData(..) , ServerPart, ServerPartT, UnWebT, addCookie, expireCookie, escape , internalServerError, lookCookieValue, mapServerPartT, mkCookie - , toResponse + , toResponse, getHeaderUnsafe ) import Happstack.Server.HSP.HTML () -- ToMessage XML instance import Happstack.Server.XMLGenT () -- instance Happstack XMLGenT @@ -120,7 +118,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(..)) @@ -148,7 +146,8 @@ { themeStyleName :: T.Text , themeStyleDescription :: T.Text , themeStylePreview :: Maybe FilePath - , themeStyleTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers + , themeStyleTemplate :: forall headers body. + ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body) => T.Text -> headers @@ -204,9 +203,10 @@ data TLSSettings = TLSSettings { clckTLSPort :: Int - , clckTLSCert :: FilePath - , clckTLSKey :: FilePath + , clckTLSCert :: Maybe FilePath + , clckTLSKey :: Maybe FilePath , clckTLSCA :: Maybe FilePath + , clckTLSRev :: Bool } data ClckwrksConfig = ClckwrksConfig @@ -254,7 +254,11 @@ ------------------------------------------------------------------------------ newtype ClckT url m a = ClckT { unClckT :: RouteT url (StateT ClckState m) a } +#if MIN_VERSION_base(4,9,0) + deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadFail, MonadPlus, ServerMonad, HasRqData, FilterMonad r, WebMonad r, MonadState ClckState) +#else deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadPlus, ServerMonad, HasRqData, FilterMonad r, WebMonad r, MonadState ClckState) +#endif instance (Happstack m) => Happstack (ClckT url m) @@ -304,8 +308,8 @@ -- | error returned when a reform 'Form' fails to validate data ClckFormError = ClckCFE (CommonFormError [Input]) - | PDE ProfileDataError | EmptyUsername + | InvalidDecimal T.Text deriving (Show) instance FormError ClckFormError where @@ -323,17 +327,18 @@ ------------------------------------------------------------------------------ data ClckPluginsSt = ClckPluginsSt - { cpsPreProcessors :: [TL.Text -> ClckT ClckURL IO TL.Text] - , cpsNavBarLinks :: [ClckT ClckURL IO (String, [NamedLink])] + { cpsPreProcessors :: forall m. (Functor m, MonadIO m, Happstack m) => [TL.Text -> ClckT ClckURL m TL.Text] + , 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,17 +388,27 @@ 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 +isSecure :: ClckwrksConfig -> Request -> Bool +isSecure cc req = + case rqSecure req of + True -> True + False -> case clckTLS cc of + Nothing -> False + Just tlsSettings -> + case clckTLSRev tlsSettings of + False -> False + True -> case getHeaderUnsafe "x-forwarded-proto" req of + Nothing -> False + Just proto -> proto == "https" + withAbs :: (Happstack m) => ClckT url m a -> ClckT url m a withAbs m = - do secure <- rqSecure <$> askRq - clckState <- get + do clckState <- get cc <- getConfig (plugins clckState) + secure <- isSecure cc <$> askRq let base = if secure then (fromJust $ calcTLSBaseURI cc) else calcBaseURI cc withAbs' base m @@ -423,12 +438,6 @@ 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) CoreState where getAcidState = (acidCore . acidState) <$> get @@ -438,13 +447,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 @@ -604,7 +606,7 @@ addPreProc :: (MonadIO m) => Plugins theme n hook config ClckPluginsSt - -> (TL.Text -> ClckT ClckURL IO TL.Text) + -> (forall mm. (Functor mm, MonadIO mm, Happstack mm) => TL.Text -> ClckT ClckURL mm TL.Text) -> m () addPreProc plugins p = modifyPluginsSt plugins $ \cps -> cps { cpsPreProcessors = p : (cpsPreProcessors cps) } @@ -671,35 +673,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 ------------------------------------------------------------------------------ @@ -721,11 +694,10 @@ getPreProcessors :: (MonadIO m) => Plugins theme n hook config ClckPluginsSt - -> ClckT url m [TL.Text -> ClckT ClckURL IO TL.Text] + -> (forall mm. (Functor mm, MonadIO mm, Happstack mm) => ClckT url m [TL.Text -> ClckT ClckURL mm TL.Text]) getPreProcessors plugins = - mapClckT liftIO $ - (cpsPreProcessors <$> getPluginsSt plugins) - + do st <- liftIO $ getPluginsSt plugins + pure (cpsPreProcessors st) -- | 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/NavBar/Types.hs b/Clckwrks/NavBar/Types.hs --- a/Clckwrks/NavBar/Types.hs +++ b/Clckwrks/NavBar/Types.hs @@ -1,25 +1,31 @@ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards, TemplateHaskell #-} +{-# LANGUAGE CPP, DeriveGeneric, DeriveDataTypeable, OverloadedStrings, RecordWildCards, TemplateHaskell, FlexibleContexts, UndecidableInstances #-} module Clckwrks.NavBar.Types where import Clckwrks.Types (NamedLink(..)) import Data.Aeson (ToJSON(..), (.=), object) import Data.Data (Data, Typeable) -import Data.SafeCopy (base, deriveSafeCopy) +import Data.SafeCopy (SafeCopy(..), base, contain, deriveSafeCopy, getSafePut, getSafeGet) +import Data.Serialize (label, putWord8, getWord8) import Data.Text (Text) +import GHC.Generics (Generic) newtype NavBar = NavBar { navBarItems :: [NavBarItem] } - deriving (Eq, Read, Show, Data, Typeable) - - + deriving (Eq, Read, Show, Data, Typeable, Generic) data NavBarItem = NBLink NamedLink | NBSubNavBar Text NavBar - deriving (Eq, Read, Show, Data, Typeable) + deriving (Eq, Read, Show, Data, Typeable, Generic) + +#if __GLASGOW_HASKELL >= __900__ +instance SafeCopy NavBar where version = 1 +instance SafeCopy NavBarItem where version = 1 +#else $(deriveSafeCopy 1 'base ''NavBar) $(deriveSafeCopy 1 'base ''NavBarItem) +#endif newtype NavBarLinks = NavBarLinks [(String, [NamedLink])] deriving (Eq, Read, Show, Data, Typeable) @@ -30,4 +36,3 @@ object [ "pluginName" .= plugName , "pluginLinks" .= map toJSON links ]) navBarLinks - diff --git a/Clckwrks/Plugin.hs b/Clckwrks/Plugin.hs --- a/Clckwrks/Plugin.hs +++ b/Clckwrks/Plugin.hs @@ -27,7 +27,7 @@ clckInit :: ClckPlugins -> IO (Maybe Text) clckInit plugins = - do (Just clckShowFn) <- getPluginRouteFn plugins (pluginName clckPlugin) + do ~(Just clckShowFn) <- getPluginRouteFn plugins (pluginName clckPlugin) addNavBarCallback plugins clckMenuCallback addHandler plugins (pluginName clckPlugin) (clckHandler clckShowFn) return Nothing @@ -35,26 +35,27 @@ addClckAdminMenu :: ClckT url IO () addClckAdminMenu = do p <- plugins <$> get - (Just clckShowURL) <- getPluginRouteFn p (pluginName clckPlugin) + ~(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) []) + , [ (Set.singleton Administrator, "Console" , clckShowURL (Admin Console) []) + , (Set.singleton Administrator, "Edit Settings" , clckShowURL (Admin EditSettings) []) + , (Set.singleton Administrator, "Edit Nav Bar" , clckShowURL (Admin EditNavBar) []) + , (Set.singleton Administrator, "System Emails" , clckShowURL (Admin SystemEmails) []) ] ) clckPlugin :: Plugin ClckURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt clckPlugin = Plugin - { pluginName = "clck" - , pluginInit = clckInit - , pluginDepends = [] - , pluginToPathInfo = toPathInfo - , pluginPostHook = addClckAdminMenu + { pluginName = "clck" + , pluginInit = clckInit + , pluginDepends = [] + , pluginToPathSegments = toPathSegments + , pluginPostHook = addClckAdminMenu } plugin :: ClckPlugins diff --git a/Clckwrks/ProfileData/API.hs b/Clckwrks/ProfileData/API.hs --- a/Clckwrks/ProfileData/API.hs +++ b/Clckwrks/ProfileData/API.hs @@ -1,28 +1,65 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} module Clckwrks.ProfileData.API - ( getProfileData - , getUsername + ( getDisplayName + , getProfileData + , getUserRoles + , requiresRole + , requiresRole_ , whoami + , Role(..) ) 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 Data.UserId (UserId(..)) +import Happstack.Authenticate.Core (Username(..)) +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) +getDisplayName :: UserId -> Clck url (Maybe DisplayName) +getDisplayName uid = displayName <$> query (GetProfileData 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 @@ -2,33 +2,29 @@ module Clckwrks.ProfileData.Acid ( ProfileDataState(..) , initialProfileDataState - , ProfileDataError(..) - , profileDataErrorStr , SetProfileData(..) , GetProfileData(..) , NewProfileData(..) - , GetUsername(..) - , GetUserIdUsernames(..) + , UpdateProfileData(..) , HasRole(..) , GetRoles(..) , AddRole(..) , RemoveRole(..) - , 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(..), 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 Data.UserId (UserId(..)) data ProfileDataState = ProfileDataState { profileData :: IxSet ProfileData @@ -40,43 +36,20 @@ initialProfileDataState :: ProfileDataState initialProfileDataState = ProfileDataState { profileData = empty } -data ProfileDataError - = UsernameAlreadyInUse - deriving (Eq, Ord, Read, Show, Data, Typeable) -$(deriveSafeCopy 0 'base ''ProfileDataError) - -profileDataErrorStr :: ProfileDataError -> String -profileDataErrorStr UsernameAlreadyInUse = "Username already in use." - -checkInvariants :: ProfileDataState -> ProfileData -> Maybe ProfileDataError -checkInvariants pds@ProfileDataState{..} pd = - case getOne $ profileData @= (Username $ username pd) of - (Just existingPd) - | ((username existingPd) == (username pd)) && - ((username pd) /= Text.pack "Anonymous") && - (not $ Text.null (username pd)) -> - (Just UsernameAlreadyInUse) - _ -> - Nothing - - setProfileData :: ProfileData - -> Update ProfileDataState (Maybe ProfileDataError) + -> Update ProfileDataState () setProfileData pd = do pds@(ProfileDataState{..}) <- get - case checkInvariants pds pd of - (Just err) -> return (Just err) - Nothing -> - do put $ pds { profileData = updateIx (dataFor pd) pd profileData } - return Nothing - + put $ pds { profileData = updateIx (dataFor pd) pd profileData } 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 +63,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) @@ -105,35 +82,18 @@ return (pd, True) (Just pd') -> return (pd', False) -getUsername :: UserId - -> Query ProfileDataState (Maybe Text) -getUsername uid = - fmap username <$> getProfileData uid - --- | get all the users -getUserIdUsernames :: Query ProfileDataState [(UserId, Text)] -getUserIdUsernames = - do pds <- profileData <$> ask - 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 @@ -151,30 +111,13 @@ where fn profileData = profileData { roles = Set.delete role (roles profileData) } -usernameForId :: UserId - -> Query ProfileDataState (Maybe Text) -usernameForId uid = - do ProfileDataState{..} <- ask - case getOne $ profileData @= uid of - Nothing -> return Nothing - (Just pd) -> return $ Just $ username pd - -dataForUsername :: Text -- ^ username - -> Query ProfileDataState (Maybe ProfileData) -dataForUsername uname = - do ProfileDataState{..} <- ask - return $ getOne $ profileData @= (Username uname) - $(makeAcidic ''ProfileDataState [ 'setProfileData , 'getProfileData , 'newProfileData - , 'getUsername - , 'getUserIdUsernames + , 'updateProfileData , 'getRoles , 'hasRole , 'addRole , 'removeRole - , 'usernameForId - , 'dataForUsername ]) diff --git a/Clckwrks/ProfileData/EditNewProfileData.hs b/Clckwrks/ProfileData/EditNewProfileData.hs --- a/Clckwrks/ProfileData/EditNewProfileData.hs +++ b/Clckwrks/ProfileData/EditNewProfileData.hs @@ -3,20 +3,27 @@ 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.Authenticate.Plugin (authenticatePlugin) +import Clckwrks.Authenticate.Monad (AuthenticatePluginState(..)) +import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..)) 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 Control.Monad.State (get) +import Control.Monad.Trans (liftIO) +import qualified Data.Acid as Acid +import Data.Text (pack) +import qualified Data.Text as Text +import Data.Text.Lazy (Text) +import Data.Maybe (fromMaybe) +import Data.UserId (UserId) +import Happstack.Authenticate.Core (Email(..), User(..), GetUserByUserId(..), UpdateUser(..)) +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 +import Web.Plugins.Core (Plugin(..), getPluginState) -- FIXME: this currently uses the admin template. Which is sort of right, and sort of not. @@ -26,17 +33,16 @@ 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) + p <- plugins <$> get + ~(Just aps) <- getPluginState p (pluginName authenticatePlugin) + ~(Just user) <- liftIO $ Acid.query (acidStateAuthenticate aps) (GetUserByUserId uid) + pd <- query (GetProfileData uid) + action <- showURL here + emptyTemplate "Edit Profile Data" () $ + <%> + <% reform (form action) "epd" updated Nothing (profileDataFormlet user 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 @@ -1,20 +1,28 @@ -{-# LANGUAGE RecordWildCards, OverloadedStrings #-} -{-# OPTIONS_GHC -F -pgmFhsx2hs #-} +{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-} 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.Monad (plugins) +import Clckwrks.Admin.Template (template) +import Clckwrks.Authenticate.Plugin (authenticatePlugin) +import Clckwrks.Authenticate.Monad (AuthenticatePluginState(..)) +import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..)) +import Control.Monad.State (get) +import Control.Monad.Trans (liftIO) +import qualified Data.Acid as Acid +import Data.Text (pack) +import qualified Data.Text as Text +import Data.Text.Lazy (Text) +import Data.Maybe (fromMaybe) +import Data.UserId (UserId) +import Happstack.Authenticate.Core (Email(..), User(..), GetUserByUserId(..), UpdateUser(..)) +import Language.Haskell.HSX.QQ (hsx) +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 +import Web.Plugins.Core (Plugin(..), getPluginState) -- FIXME: this currently uses the admin template. Which is sort of right, and sort of not. @@ -24,42 +32,47 @@ 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) + p <- plugins <$> get + ~(Just aps) <- getPluginState p (pluginName authenticatePlugin) + ~(Just user) <- liftIO $ Acid.query (acidStateAuthenticate aps) (GetUserByUserId uid) + pd <- query (GetProfileData uid) + action <- showURL here + template "Edit Profile Data" () $ [hsx| + <%> + <% reform (form action) "epd" updated Nothing (profileDataFormlet user pd) %> +--
    +-- +--
    + |] where updated :: () -> Clck ProfileDataURL Response updated () = do seeOtherURL here -profileDataFormlet :: ProfileData -> ClckForm ProfileDataURL () -profileDataFormlet pd@ProfileData{..} = +profileDataFormlet :: User -> ProfileData -> ClckForm ProfileDataURL () +profileDataFormlet u@User{..} pd = divHorizontal $ errorList ++> - ((,) <$> (divControlGroup (label' "Username" ++> (divControls (inputText username)))) - <*> (divControlGroup (label'" Email (optional)" ++> (divControls (inputText (fromMaybe Text.empty email))))) - <* (divControlGroup (divControls (inputSubmit (pack "Update") `setAttrs` (("class" := "btn") :: Attr Text Text))))) + ((,) <$> (divControlGroup (label' "Email" ++> (divControls (inputText (maybe Text.empty _unEmail _email))))) + <*> (divControlGroup (label' "DisplayName" ++> (divControls (inputText (maybe Text.empty unDisplayName (displayName pd)))))) + <* (divControlGroup (divControls (inputSubmit (pack "Update") `setAttrs` (("class" := "btn") :: Attr Text Text)))) + ) `transformEitherM` updateProfileData - where - label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text]) - divHorizontal = mapView (\xml -> [
    <% xml %>
    ]) - divControlGroup = mapView (\xml -> [
    <% xml %>
    ]) - divControls = mapView (\xml -> [
    <% xml %>
    ]) + where + label' :: Text -> ClckForm ProfileDataURL () + label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text]) + divHorizontal = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + divControlGroup = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + divControls = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) - updateProfileData :: (Text.Text, Text.Text) -> Clck ProfileDataURL (Either ClckFormError ()) - updateProfileData (usrnm, eml) = - do let newPd = pd { username = usrnm - , email = if Text.null eml then Nothing else (Just eml) - } - merr <- update (SetProfileData newPd) - case merr of - Nothing -> return $ Right () - (Just err) -> return $ Left (PDE err) + updateProfileData :: (Text.Text, Text.Text) -> Clck ProfileDataURL (Either ClckFormError ()) + updateProfileData (eml, dn) = + do let user = u { _email = if Text.null eml then Nothing else (Just (Email eml)) + } + p <- plugins <$> get + ~(Just aps) <- getPluginState p (pluginName authenticatePlugin) + liftIO $ Acid.update (acidStateAuthenticate aps) (UpdateUser user) + pd <- query (GetProfileData _userId) + update (SetProfileData (pd { displayName = if Text.null dn then Nothing else Just (DisplayName dn) })) + pure $ Right () diff --git a/Clckwrks/ProfileData/EditProfileDataFor.hs b/Clckwrks/ProfileData/EditProfileDataFor.hs --- a/Clckwrks/ProfileData/EditProfileDataFor.hs +++ b/Clckwrks/ProfileData/EditProfileDataFor.hs @@ -1,59 +1,146 @@ -{-# LANGUAGE RecordWildCards, OverloadedStrings #-} -{-# OPTIONS_GHC -F -pgmFhsx2hs #-} +{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-} module Clckwrks.ProfileData.EditProfileDataFor where import Clckwrks -import Clckwrks.Admin.Template (template) -import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr) -import Data.Maybe (fromMaybe) -import Data.Set as Set -import Data.Text (Text, pack) -import qualified Data.Text as Text -import Happstack.Auth (UserId) +import Clckwrks.Admin.Template (template) +import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..)) +import Clckwrks.Authenticate.Monad (AuthenticatePluginState(..)) +import Clckwrks.Authenticate.URL (AuthURL(ResetPassword)) +import Control.Monad.State (get) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Set as Set +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as LT +import qualified Data.Text as Text +import Data.UserId (UserId) + +import Language.Haskell.HSX.QQ (hsx) +import Happstack.Authenticate.Core (Email(..), GetUserByUserId(..), User(..), UserId(..), Username(..)) +import Happstack.Authenticate.Password.Core (SetPassword(..), mkHashedPass, resetTokenForUserId) import HSP.XMLGenerator import HSP.XML -import Text.Reform ((++>), transformEitherM) +import System.FilePath (()) +import Text.Reform ((++>), mapView, transformEitherM) import Text.Reform.Happstack (reform) -import Text.Reform.HSP.Text (inputCheckboxes, inputText, labelText, inputSubmit, fieldset, ol, li, form) +import Text.Reform.HSP.Text (inputCheckboxes, inputPassword, inputText, labelText, inputSubmit, fieldset, ol, li, form, setAttrs) +import Web.Plugins.Core (getConfig, getPluginState, getPluginRouteFn) editProfileDataForPage :: ProfileDataURL -> UserId -> Clck ProfileDataURL Response editProfileDataForPage here uid = - do mpd <- query (GetProfileData uid) - case mpd of + do pd <- query (GetProfileData uid) + mu <- query (GetUserByUserId uid) + case mu of Nothing -> - do notFound () - template "Edit Profile Data" () $ -

    No profile data for <% show uid %>.

    - (Just pd) -> - do action <- showURL here - template "Edit Profile Data" () $ + template "Edit Profile Data" () $ + [hsx| +
    Invalid UserId <% show uid %>
    + |] + (Just u) -> + do action <- showURL here + template "Edit Profile Data" () $ [hsx| +
    +

    User Info

    +
    +
    UserId
    <% show $ _unUserId $ _userId u %>
    +
    Username
    <% _unUsername $ _username u %>
    +
    Email
    <% maybe Text.empty _unEmail (_email u) %>
    +
    +

    Roles

    <% reform (form action) "epd" updated Nothing (profileDataFormlet pd) %> - +

    Update User's Password

    + <% reform (form action) "pf" updated Nothing (passwordForFormlet uid) %> +

    Generate Password Reset Link

    + <% reform (form action) "prl" (generateResetLink uid) Nothing generateResetLinkFormlet %> +
    + |] where updated :: () -> Clck ProfileDataURL Response updated () = do seeOtherURL here + generateResetLink :: UserId -> Maybe Text.Text -> Clck ProfileDataURL Response + generateResetLink uid _ = + do p <- plugins <$> get + ~(Just aps) <- getPluginState p "authenticate" + ~(Just authShowURL) <- getPluginRouteFn p "authenticate" + cc <- getConfig p + let basePath = maybe "_state" (\top -> top "_state") (clckTopDir cc) + baseUri = case calcTLSBaseURI cc of + Nothing -> calcBaseURI cc + (Just b) -> b + + resetLink = (authShowURL ResetPassword []) <> "/#" + eResetTokenLink <- liftIO $ resetTokenForUserId resetLink (acidStateAuthenticate aps) (acidStatePassword aps) uid + case eResetTokenLink of + (Left e) -> template "Reset Password Link" () $ + [hsx| +
    +

    Reset Password Link Error

    + <% show e %> +
    + |] + (Right lnk) -> + template "Reset Password Link" () $ + [hsx| +
    +

    Reset Password Link

    +

    Share this link with the user

    + <% lnk %> +
    + |] + +generateResetLinkFormlet :: ClckForm ProfileDataURL (Maybe Text.Text) +generateResetLinkFormlet = + do (fieldset $ + (divControlGroup $ divControls $ inputSubmit "Generate Change Password Link" `setAttrs` [("class" := "btn") :: Attr Text Text])) + where + divControlGroup = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + divControls = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + + +passwordForFormlet :: UserId -> ClckForm ProfileDataURL () +passwordForFormlet userid = + (fieldset $ + (divControlGroup $ + (divControls (label' "new password" ++> inputPassword)) + ) + <* (divControlGroup $ divControls $ inputSubmit "Change Password" `setAttrs` [("class" := "btn") :: Attr Text Text]) + ) `transformEitherM` updatePassword + where + label' :: Text -> ClckForm ProfileDataURL () + label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text]) +-- divHorizontal = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + divControlGroup = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + divControls = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + + updatePassword :: Text.Text -> Clck ProfileDataURL (Either ClckFormError ()) + updatePassword newPw + | Text.null newPw = pure (Right ()) + | otherwise = + do hp <- mkHashedPass newPw + update (SetPassword userid hp) + pure (Right ()) + profileDataFormlet :: ProfileData -> ClckForm ProfileDataURL () profileDataFormlet pd@ProfileData{..} = (fieldset $ - ol $ - ((,,) <$> (li $ labelText "username:") ++> (li $ inputText username) - <*> (li $ labelText "email (optional):") ++> (li $ inputText (fromMaybe Text.empty email)) - <*> (li $ labelText "roles:") ++> (li $ inputCheckboxes [ (r, show r) | r <- [minBound .. maxBound]] (\r -> Set.member r roles)) - <* inputSubmit (pack "update") - ) + (divControlGroup $ + (divControls (inputCheckboxes [ (r, show r) | r <- [minBound .. maxBound]] (\r -> Set.member r roles)) `setAttrs` (("class" := "form-check") :: Attr Text Text))) + <* (divControlGroup $ divControls $ inputSubmit "Update Roles" `setAttrs` [("class" := "btn") :: Attr Text Text]) ) `transformEitherM` updateProfileData where - updateProfileData :: (Text, Text, [Role]) -> Clck ProfileDataURL (Either ClckFormError ()) - updateProfileData (usrnm, eml, roles') = - if Text.null usrnm - then do return (Left EmptyUsername) - else do let newPd = pd { username = usrnm - , email = if Text.null eml then Nothing else (Just eml) - , roles = Set.fromList roles' - } - merr <- update (SetProfileData newPd) - case merr of - Nothing -> return $ Right () - (Just err) -> return $ Left (PDE err) + label' :: Text -> ClckForm ProfileDataURL () + label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text]) +-- divHorizontal = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + divControlGroup = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + divControls = mapView (\xml -> [[hsx|
    <% xml %>
    |]]) + + updateProfileData :: [Role] -> Clck ProfileDataURL (Either ClckFormError ()) + updateProfileData roles' = + do let newPd = pd { roles = Set.fromList roles' + } + update (SetProfileData newPd) + pure (Right ()) + +-- ((li $ labelText "roles:") ++> ((li $ inputCheckboxes [ (r, show r) | r <- [minBound .. maxBound]] (\r -> Set.member r roles)) `setAttrs` (("class" := "form-check") :: Attr Text Text)) 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 @@ -1,25 +1,28 @@ -{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell, TypeFamilies #-} module Clckwrks.ProfileData.Types - ( ProfileData(..) + ( DisplayName(..) + , ProfileData(..) , Role(..) + , defaultProfileDataFor , emptyProfileData , Username(..) ) where -import Happstack.Auth (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) +import Data.UserId (UserId(..)) +import GHC.Generics (Generic) data Role_001 = Administrator_001 | Visitor_001 - deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded) + deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded, Generic) $(deriveSafeCopy 1 'base ''Role_001) data Role @@ -27,7 +30,7 @@ | Visitor | Moderator | Editor - deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded) + deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded, Generic) $(deriveSafeCopy 2 'extension ''Role) instance Migrate Role where @@ -35,33 +38,67 @@ migrate Administrator_001 = Administrator migrate Visitor_001 = Visitor +newtype Username = Username { unUsername :: Text } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) +newtype DisplayName = DisplayName { unDisplayName :: Text } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) +$(deriveSafeCopy 1 'base ''DisplayName) + +data ProfileData_1 = ProfileData_1 + { dataFor_1 :: UserId + , username_1 :: Text -- ^ now comes from happstack-authenticate + , email_1 :: Maybe Text -- ^ now comes from happstack-authenticate + , roles_1 :: Set Role + , attributes_1 :: Map Text Text + } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +$(deriveSafeCopy 1 'base ''ProfileData_1) + +data ProfileData_2 = ProfileData_2 + { dataFor_2 :: UserId + , roles_2 :: Set Role + , attributes_2 :: Map Text Text + } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +$(deriveSafeCopy 2 'extension ''ProfileData_2) + +instance Migrate ProfileData_2 where + type MigrateFrom ProfileData_2 = ProfileData_1 + migrate (ProfileData_1 df _ _ rs attrs) = ProfileData_2 df rs attrs + data ProfileData = ProfileData - { dataFor :: UserId - , username :: Text - , email :: Maybe Text - , roles :: Set Role - , attributes :: Map Text Text + { dataFor :: UserId + , displayName :: Maybe DisplayName + , roles :: Set Role + , attributes :: Map Text Text } - deriving (Eq, Ord, Read, Show, Data, Typeable) + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) -$(deriveSafeCopy 1 'base ''ProfileData) +$(deriveSafeCopy 3 'extension ''ProfileData) +instance Migrate ProfileData where + type MigrateFrom ProfileData = ProfileData_2 + migrate (ProfileData_2 df rs attrs) = ProfileData df Nothing rs attrs + emptyProfileData :: ProfileData emptyProfileData = ProfileData - { dataFor = UserId 0 - , username = Data.Text.empty - , email = Nothing - , roles = Data.Set.empty - , attributes = Data.Map.empty + { dataFor = UserId 0 + , displayName = Nothing + , roles = Data.Set.empty + , attributes = Data.Map.empty } -newtype Username = Username { unUsername :: Text } - deriving (Eq, Ord, Read, Show, Data, Typeable) +defaultProfileDataFor :: UserId -> ProfileData +defaultProfileDataFor uid = + emptyProfileData { dataFor = uid + , roles = singleton Visitor + } instance Indexable ProfileData where empty = ixSet [ ixFunS dataFor - , ixFunS $ Username . username ] where ixFunS :: (Ord b, Typeable b) => (a -> b) -> Ix a 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 Data.UserId (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 @@ -2,17 +2,19 @@ module Clckwrks.Route where import Clckwrks +import Clckwrks.Acid (GetEnableOpenId(..)) import Clckwrks.Admin.Route (routeAdmin) import Clckwrks.BasicTemplate (basicTemplate) -import Clckwrks.Monad (calcTLSBaseURI, withAbs) +import Clckwrks.Monad (calcTLSBaseURI, withAbs, query) +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 +30,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 +79,6 @@ (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 b <- query GetEnableOpenId + nestURL JS $ routeJS b jsURL diff --git a/Clckwrks/Server.hs b/Clckwrks/Server.hs --- a/Clckwrks/Server.hs +++ b/Clckwrks/Server.hs @@ -3,71 +3,93 @@ 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) -import Clckwrks.ProfileData.Route (routeProfileData) import Clckwrks.ProfileData.Types (Role(..)) import Clckwrks.ProfileData.URL (ProfileDataURL(..)) import Control.Arrow (second) import Control.Concurrent (forkIO, killThread) -import Control.Concurrent.STM (atomically, newTVar) +import Control.Concurrent.STM (atomically, newTVar, readTVar) import Control.Monad.State (get, evalStateT) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as LB import Data.Acid.Advanced (query') import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromJust, fromMaybe, isNothing) import Data.Monoid ((<>)) +import qualified Data.ByteString.Lazy.UTF8 as UTF8 +import Data.ByteString.Builder (toLazyByteString) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as Text -import qualified Data.UUID as UUID -import Happstack.Auth (handleAuthProfile) +import Data.Text.Encoding (decodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.UUID.Types as UUID import Happstack.Server.FileServe.BuildingBlocks (guessContentTypeM, isSafePath, serveFile) +import Happstack.Server.Internal.Multipart (simpleInput) +import Happstack.Server.Internal.Types (canHaveBody) +import Happstack.Server.Monads (askRq) import Happstack.Server.SimpleHTTPS (TLSConf(..), nullTLSConf, simpleHTTPS) +import Happstack.Server.Types (Request(rqMethod)) +import Network.HTTP.Types (encodePathSegments) +import Network.HTTP.Types.URI (renderQueryText) import System.FilePath ((), makeRelative, splitDirectories) import Web.Routes.Happstack (implSite) -import Web.Plugins.Core (Plugins, withPlugins, getPluginRouteFn, getPostHooks, serve) +import Web.Plugins.Core (Plugins(..), PluginsState(pluginsRewrite), Rewrite(Rewrite, Redirect), withPlugins, getPluginRouteFn, getPostHooks, serve) import qualified Paths_clckwrks as Clckwrks withClckwrks :: ClckwrksConfig -> (ClckState -> IO b) -> IO b -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" + ~(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 Nothing -> return Nothing (Just TLSSettings{..}) -> - do let tlsConf = nullTLSConf { tlsPort = clckTLSPort - , tlsCert = clckTLSCert - , tlsKey = clckTLSKey - , tlsCA = clckTLSCA - } - tid <- forkIO $ simpleHTTPS tlsConf (handlers cc' clckState'') - return (Just tid) + case (clckTLSCert, clckTLSKey) of + (Just certPath, Just keyPath) -> do + let tlsConf = nullTLSConf { tlsPort = clckTLSPort + , tlsCert = certPath + , tlsKey = keyPath + , tlsCA = clckTLSCA + } + tid <- forkIO $ simpleHTTPS tlsConf (handlers cc' clckState'') + return (Just tid) + _ -> return Nothing + + + httpTID <- if isNothing mHttpsTID + then forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) (handlers cc' clckState'') + else forkIO $ simpleHTTP (nullConf { port = clckPort cc' }) forceHTTPS -- putStrLn "Server Now Listening For Requests." waitForTermination killThread httpTID @@ -76,11 +98,14 @@ where handlers :: ClckwrksConfig -> ClckState -> ServerPart Response handlers cc clckState = - do decodeBody (defaultBodyPolicy "/tmp/" (10 * 10^6) (1 * 10^6) (1 * 10^6)) + do forceCanonicalHost + req <- askRq + when (canHaveBody (rqMethod req)) $ + do (p, mDisk, mRam, mHeader) <- query' (acidCore $ acidState clckState) GetBodyPolicy + decodeBody (defaultBodyPolicy p mDisk mRam mHeader) requestInit clckState msum $ [ jsHandlers cc - , dir "favicon.ico" $ notFound (toResponse ()) , dir "static" $ (liftIO $ Clckwrks.getDataFileName "static") >>= serveDirectory DisableBrowsing [] , do nullDir mRR <- query' (acidCore . acidState $ clckState) GetRootRedirect @@ -88,6 +113,26 @@ , clckSite cc clckState ] + forceCanonicalHost :: ServerPart () + forceCanonicalHost = + do rq <- askRq + case getHeader "host" rq of + Nothing -> return () + (Just hostBS) -> + if (clckHostname cc == (B.unpack $ B.takeWhile (/= ':') hostBS)) + then return () + else escape $ seeOther ((if isSecure cc rq then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) <> (Text.pack $ rqUri rq) <> (Text.pack $ rqQuery rq)) (toResponse ()) + + -- if https:// is available, then force it to be used. + -- GET requests will be redirected automatically, POST, PUT, etc will be denied + 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 = msum [ dir "jquery" $ serveDirectory DisableBrowsing [] (clckJQueryPath c) @@ -98,18 +143,63 @@ clckSite :: ClckwrksConfig -> ClckState -> ServerPart Response clckSite cc clckState = - do (Just clckShowFn) <- getPluginRouteFn (plugins clckState) (Text.pack "clck") - evalClckT clckShowFn clckState (pluginsHandler (plugins clckState)) + do ~(Just clckShowFn) <- getPluginRouteFn (plugins clckState) (Text.pack "clck") + evalClckT clckShowFn clckState (pluginsHandler cc (plugins clckState)) -pluginsHandler :: (Functor m, ServerMonad m, FilterMonad Response m, MonadIO m) => - Plugins theme (m Response) hook config ppm +pluginsHandler :: (Functor m, Happstack m, MonadIO m) => + ClckwrksConfig + -> Plugins theme (m Response) hook config ppm -> m Response -pluginsHandler plugins = - do paths <- (map Text.pack . rqPaths) <$> askRq - case paths of - (p : ps) -> - do e <- liftIO $ serve plugins p ps - case e of - (Right c) -> c - (Left e) -> notFound $ toResponse e - _ -> notFound (toResponse ()) +pluginsHandler cc plugins@(Plugins tvp) = + do ps' <- liftIO $ atomically $ readTVar tvp + req <- askRq + let paths' = map Text.pack $ rqPaths req + params'= + let conv :: (String, Input) -> (Text, Maybe Text) + conv (k, i) = + case inputValue i of + (Left _) -> (Text.pack k, Nothing) + (Right bs) -> (Text.pack k, Just $ decodeUtf8With lenientDecode (LB.toStrict bs)) + in map conv (rqInputsQuery req) + -- we figure out which plugin to call by looking at the + -- first path segment in the url + let cont paths = + case paths of + (p : ps) -> + do e <- liftIO $ serve plugins p ps + case e of + (Right c) -> c + (Left e) -> notFound $ toResponse e + _ -> notFound (toResponse ()) + + -- before we can figure out what the path segment is, we + -- need to rewrite the URL. + -- FIXME: Somewhat annoyingly, we rewrite the url and then + -- throw out the results. + case pluginsRewrite ps' of + Nothing -> cont paths' + (Just (mf, _)) -> + let conv :: (Text, Maybe Text) -> (String, Input) + conv (k, v) = (Text.unpack k, maybe (simpleInput "") (\v' -> simpleInput $ Text.unpack v') v) + in do f <- liftIO mf + case f paths' params' of + (Just (Rewrite, paths, params)) -> + let qry = decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ renderQueryText True params + pi = (decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ encodePathSegments paths) + in + localRq (\req -> req { rqQuery = UTF8.toString $ toLazyByteString $ renderQueryText True params + , rqPaths = map Text.unpack paths + , rqUri = Text.unpack $ (if isSecure cc req then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) <> pi <> qry + , rqInputsQuery = map conv params + }) $ do -- rq <- askRq + -- liftIO $ print rq + cont paths + (Just (Redirect mBaseURI, paths, params)) -> + let qry = decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ renderQueryText True params + pi = (decodeUtf8With lenientDecode $ LB.toStrict $ toLazyByteString $ encodePathSegments paths) + in + do -- liftIO $ putStrLn $ show $ rqQuery req + escape $ seeOther ((fromMaybe (if isSecure cc req then (fromJust $ calcTLSBaseURI cc) else (calcBaseURI cc)) mBaseURI) <> pi <> qry) (toResponse ()) + Nothing -> cont paths' + +-- (Redirect, paths) -> seeOther diff --git a/Clckwrks/Types.hs b/Clckwrks/Types.hs --- a/Clckwrks/Types.hs +++ b/Clckwrks/Types.hs @@ -12,13 +12,13 @@ import Data.SafeCopy (SafeCopy(..), base, deriveSafeCopy, safeGet, safePut, contain) import Data.Text (Text) import qualified Data.Text.Encoding as T -import Data.UUID (UUID) +import Data.UUID.Types (UUID) +import Data.UUID.Orphans () import HSP.Google.Analytics (UACCT) -- | 'SafeCopy' instances for some 3rd party types $(deriveSafeCopy 0 'base ''UACCT) -$(deriveSafeCopy 0 'base ''UUID) -- | at present this is only used by the menu editor newtype Prefix = Prefix { prefixText :: Text } 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/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -3,11 +3,6 @@ module Main where import Distribution.Simple -import Distribution.Simple.Program -hsx2hsProgram = simpleProgram "hsx2hs" - main :: IO () -main = defaultMainWithHooks simpleUserHooks { - hookedPrograms = [hsx2hsProgram] - } +main = defaultMain 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.28.0.1 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,13 +16,14 @@ 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 -Cabal-version: >=1.6 +Build-type: Simple +Cabal-version: 1.18 +tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2 Data-Files: - static/admin.css + static/admin.css source-repository head type: git @@ -33,7 +34,9 @@ default: True Library - Build-tools: hsx2hs + GHC-Options: -Wunused-top-binds + Build-tool-depends: hsx2hs:hsx2hs + default-language: Haskell2010 Exposed-modules: Clckwrks Clckwrks.Acid Clckwrks.Admin.Template @@ -41,13 +44,29 @@ Clckwrks.Admin.Console Clckwrks.Admin.Route Clckwrks.Admin.EditSettings + Clckwrks.Admin.SystemEmails + Clckwrks.Authenticate.API + Clckwrks.Authenticate.Monad + Clckwrks.Authenticate.Page.AuthModes + Clckwrks.Authenticate.Page.ChangePassword + Clckwrks.Authenticate.Page.Login + Clckwrks.Authenticate.Page.OpenIdRealm + Clckwrks.Authenticate.Page.ResetPassword + Clckwrks.Authenticate.Page.ViewUsers + 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,52 +86,59 @@ 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, - network-uri >= 2.6 && < 2.7 + build-depends: network > 2.6 && < 3.2, + network-uri >= 2.6 && < 3.2 else build-depends: network < 2.6 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.*, + acid-state >= 0.12 && < 0.17, + aeson (>= 0.4 && < 0.10) || (>= 0.11 && < 1.6) || (>= 2 && <= 2.1), + aeson-qq >= 0.7 && < 0.9, + attoparsec >= 0.10 && < 0.15, + base < 5, + blaze-html >= 0.5 && < 0.10, + bytestring >= 0.9 && < 0.12, + cereal >= 0.4 && < 0.6, + containers >= 0.4 && < 0.7, + directory >= 1.1 && < 1.4, + filepath >= 1.2 && < 1.5, + happstack-authenticate >= 2.6 && < 2.7, 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.8, + happstack-server-tls >= 7.1 && < 7.3, + hsp >= 0.9 && < 0.11, hsx-jmacro == 7.3.*, - ixset == 1.0.*, + hsx2hs >= 0.13 && < 0.15, + http-types < 0.13, + ixset >= 1.0 && < 1.2, jmacro == 0.6.*, - mtl >= 2.0 && < 2.3, + lens >= 4.3 && < 5.2, + mtl >= 2.0 && < 2.3, old-locale == 1.0.*, - process >= 1.0 && < 1.3, + process >= 1.0 && < 1.7, -- plugins-auto == 0.0.1.1, - random == 1.0.*, - reform == 0.2.*, + random >= 1.0 && < 1.3, + reform >= 0.2 && < 0.4, reform-happstack == 0.2.*, - reform-hsp >= 0.2 && < 0.3, - safecopy >= 0.6, - 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.*, + reform-hsp >= 0.2 && < 0.3, + safecopy >= 0.10, + stm >= 2.2 && < 2.6, + text >= 0.11 && < 2.1, + time >= 1.2 && < 1.14, + time-locale-compat >= 0.1 && < 0.2, + uuid-orphans >= 1.2 && < 1.5, + uuid-types >= 1.0 && < 1.1, + unordered-containers >= 0.1 && < 0.3, + userid >= 0.1 && < 0.2, + utf8-string >= 0.3 && < 1.1, vector >= 0.9, - web-plugins >= 0.1 && < 0.3, + web-plugins >= 0.4 && < 0.5, web-routes, web-routes-happstack, web-routes-hsp,