diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -4,6 +4,12 @@ #### dev * ... +#### 0.3.0.1 +* Fix authentication + +#### 0.3.0.0 +* Small change to API + #### 0.2.0.0 * Use GHC 7.10 with Stackage `nightly-2015-07-09` * Use Stack diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,20 +0,0 @@ -Copyright (c) 2015 Hoppinger BV, http://lambdacms.org - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be -included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/LambdaCms/Core.hs b/LambdaCms/Core.hs --- a/LambdaCms/Core.hs +++ b/LambdaCms/Core.hs @@ -5,6 +5,16 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module : Core +Description : Exports all relevant modules for the lambdacms-core subsite. +Copyright : (c) Hoppinger BV, 2014-2015 + +This is the module to import when adding LambdaCms "core" functionality +to a Yesod application or subsite. It re-export what will mostly be needed, +and makes 'CoreAdmin` an instance of 'YesodSubDispatch'. +-} + module LambdaCms.Core ( module Export ) where @@ -20,10 +30,7 @@ import LambdaCms.Core.Import import LambdaCms.Core.Models as Export import Network.Mail.Mime as Export --- instance ( Yesod master --- , LambdaCmsAdmin master --- , SqlBackend ~ (YesodPersistBackend master) --- , PersistQuery (YesodPersistBackend master) --- ) => YesodSubDispatch Core (HandlerT master IO) where + + instance LambdaCmsAdmin master => YesodSubDispatch CoreAdmin (HandlerT master IO) where yesodSubDispatch = $(mkYesodSubDispatch resourcesCoreAdmin) diff --git a/LambdaCms/Core/Classes.hs b/LambdaCms/Core/Classes.hs --- a/LambdaCms/Core/Classes.hs +++ b/LambdaCms/Core/Classes.hs @@ -37,11 +37,10 @@ pageHeadTags :: LambdaCmsAdmin master => res -> WidgetT master IO () pageHeadTags res = toWidgetHead $(hamletFile "templates/pagehead.hamlet") - where - robotsText :: Maybe Text - robotsText = case robots res of - Just (index, follow) -> Just $ (if' index "Index" "NoIndex") <> ", " <> (if' follow "Follow" "NoFollow") - Nothing -> Nothing - if' :: Bool -> a -> a -> a - if' True t _ = t - if' False _ f = f + where + robotsText :: Maybe Text + robotsText = case robots res of + Just (index, follow) -> Just $ (if index then "Index" else "NoIndex") + <> ", " + <> (if follow then "Follow" else "NoFollow") + Nothing -> Nothing diff --git a/LambdaCms/Core/Foundation.hs b/LambdaCms/Core/Foundation.hs --- a/LambdaCms/Core/Foundation.hs +++ b/LambdaCms/Core/Foundation.hs @@ -42,34 +42,41 @@ import Yesod.Auth import Yesod.Auth.Message (AuthMessage (InvalidLogin)) --- | Foundation type. + +-- | The foundation type of the subsite. data CoreAdmin = CoreAdmin --- | Denotes what kind of user is allowed to perform an action. -data Allow a = AllowAll -- ^ Allow anyone (no authentication required). - | AllowAuthenticated -- ^ Allow any authenticated user. - | AllowRoles a -- ^ Allow anyone who as at least one matching role. - | AllowNobody -- ^ Allow nobody. +-- | Specifies the criteria for authorizing a request. +data Allow a = AllowAll -- ^ Allow any request (no authentication required). + | AllowAuthenticated -- ^ Allow requests in authenticated sessions. + | AllowRoles a -- ^ Allow requests in authenticated sessions belonging + -- to users that have at least one matching role. + -- See the `isAuthorizedTo` function for details. + | AllowNone -- ^ Allow no requests at all. -- | A menu item, also see 'adminMenu'. -- -- > MenuItem (SomeMessage MsgProduct) (ProductAdminOverviewR) "shopping-cart" data AdminMenuItem master = MenuItem - { label :: SomeMessage master -- ^ The text of the item (what the user sees). - , route :: Route master -- ^ The Route to which it points. - , icon :: Text -- ^ A without the ".glyphicon-" prefix. - } + { label :: SomeMessage master -- ^ The text of the item (what the user sees). + , route :: Route master -- ^ The Route to which it points. + , icon :: Text -- ^ A without the ".glyphicon-" prefix. + } mkYesodSubData "CoreAdmin" $(parseRoutesFile "config/routes") instance LambdaCmsAdmin master => RenderMessage master CoreMessage where renderMessage = renderCoreMessage --- | Fairly complex "handler" type, allowing persistent queries on the master's db connection, hereby simplified. -type CoreHandler a = forall master. LambdaCmsAdmin master => HandlerT CoreAdmin (HandlerT master IO) a +-- | Alias for the fairly complex HandlerT type that allows persistent queries +-- on the master's db connection. +type CoreHandler a = forall master. LambdaCmsAdmin master + => HandlerT CoreAdmin (HandlerT master IO) a --- | Fairly complex Form type, hereby simplified. -type CoreForm a = forall master. LambdaCmsAdmin master => Html -> MForm (HandlerT master IO) (FormResult a, WidgetT master IO ()) +-- | Alias for the fairly complex Form type. +type CoreForm a = forall master. LambdaCmsAdmin master + => Html + -> MForm (HandlerT master IO) (FormResult a, WidgetT master IO ()) class ( YesodAuth master , AuthId master ~ Key User @@ -111,12 +118,13 @@ defaultRoles :: HandlerT master IO (Set (Roles master)) defaultRoles = return S.empty - -- | See if a user is authorized to perform an action. + -- | Authorize a request to perform an action. + -- If a user session is present it can use the specified Roles to do so. isAuthorizedTo :: master -- Needed to make function injective. -> Maybe (Set (Roles master)) -- ^ Set of roles the user has. -> Allow (Set (Roles master)) -- ^ Set of roles allowed to perform the action. -> AuthResult - isAuthorizedTo _ _ AllowNobody = Unauthorized "Access denied." + isAuthorizedTo _ _ AllowNone = Unauthorized "Access denied." isAuthorizedTo _ _ AllowAll = Authorized isAuthorizedTo _ (Just _) AllowAuthenticated = Authorized isAuthorizedTo _ Nothing _ = AuthenticationRequired @@ -132,7 +140,7 @@ -- Knowing /which/ method is used allows for more fine grained -- permissions than only knowing whether it is /write/ request. -> Allow (Set (Roles master)) - actionAllowedFor _ _ = AllowNobody + actionAllowedFor _ _ = AllowNone -- | Both coreR and authR are used to navigate to a different controller. -- It saves you from putting "getRouteToParent" everywhere. @@ -216,8 +224,9 @@ renderLanguages :: master -> [Text] renderLanguages _ = ["en"] - -- | A default way of sending email. See for details. - -- The default is to print it all to stdout. + -- | A default way of (not) sending email: just print it to the stdout. + -- See + -- for instructions on implementing a real delivery method. lambdaCmsSendMail :: Mail -> HandlerT master IO () lambdaCmsSendMail (Mail from tos ccs bccs headers parts) = liftIO . putStrLn . unpack $ "MAIL" @@ -232,19 +241,23 @@ where subject = Data.Text.concat . map snd $ filter (\(k,_) -> k == "Subject") headers attachment :: Text - attachment = intercalate ", " . catMaybes . map (partFilename) $ concatMap (filter (isJust . partFilename)) parts + attachment = intercalate ", " . catMaybes . map (partFilename) $ + concatMap (filter (isJust . partFilename)) parts htmlBody = getFromParts "text/html; charset=utf-8" plainBody = getFromParts "text/plain; charset=utf-8" - getFromParts x = decodeUtf8 . LB.toStrict . LB.concat . map partContent $ concatMap (filter ((==) x . partType)) parts + getFromParts x = decodeUtf8 . LB.toStrict . LB.concat . map partContent $ + concatMap (filter ((==) x . partType)) parts maddress = intercalate ", " . map (address) - address (Address n e) = let e' = "<" <> e <> ">" in case n of Just n' -> n' <> " " <> e' - Nothing -> e' + address (Address n e) = let e' = "<" <> e <> ">" in case n of + Just n' -> n' <> " " <> e' + Nothing -> e' +-- | Ensures the admin user's lastLogin property is updated with logging in. authenticateByLambdaCms :: LambdaCmsAdmin master => Creds master -> HandlerT master IO (AuthenticationResult master) authenticateByLambdaCms creds = runDB $ do - user <- getBy $ UniqueUser $ credsIdent creds + user <- getBy $ UniqueAuth (credsIdent creds) True case user of Just (Entity uid _) -> do timeNow <- liftIO getCurrentTime @@ -252,6 +265,10 @@ return $ Authenticated uid Nothing -> return $ UserError InvalidLogin +-- | Replace 'defaultMaybeAuthId' with this function to ensure (for every +-- request to the admin interface) that admin users are required to have +-- an active account. +-- TODO: Provide a bit more feedback then the standard 404 page when denying access. lambdaCmsMaybeAuthId :: LambdaCmsAdmin master => HandlerT master IO (Maybe (AuthId master)) lambdaCmsMaybeAuthId = do @@ -287,7 +304,8 @@ -- $maybe r <- can (SomeRouteR) -- ... @{r} -- @ -getCan :: LambdaCmsAdmin master => HandlerT master IO (Route master -> ByteString -> Maybe (Route master)) +getCan :: LambdaCmsAdmin master + => HandlerT master IO (Route master -> ByteString -> Maybe (Route master)) getCan = do mauthId <- maybeAuthId murs <- forM mauthId getUserRoles @@ -295,10 +313,13 @@ return $ canFor y murs -- | A default admin menu. -defaultCoreAdminMenu :: LambdaCmsAdmin master => (Route CoreAdmin -> Route master) -> [AdminMenuItem master] -defaultCoreAdminMenu tp = [ MenuItem (SomeMessage Msg.MenuDashboard) (tp AdminHomeR) "home" - , MenuItem (SomeMessage Msg.MenuUsers) (tp $ UserAdminR UserAdminIndexR) "user" - ] +defaultCoreAdminMenu :: LambdaCmsAdmin master + => (Route CoreAdmin -> Route master) + -> [AdminMenuItem master] +defaultCoreAdminMenu tp = + [ MenuItem (SomeMessage Msg.MenuDashboard) (tp AdminHomeR) "home" + , MenuItem (SomeMessage Msg.MenuUsers) (tp $ UserAdminR UserAdminIndexR) "user" + ] -- | Shorcut for rendering a subsite Widget in the admin layout. adminLayoutSub :: LambdaCmsAdmin master @@ -314,7 +335,8 @@ withAttrs attrs fs = fs { fsAttrs = attrs } -- | Wrapper for humanReadableTimeI18N'. It uses Yesod's own i18n functionality. -lambdaCmsHumanTimeLocale :: LambdaCmsAdmin master => HandlerT master IO HumanTimeLocale +lambdaCmsHumanTimeLocale :: LambdaCmsAdmin master + => HandlerT master IO HumanTimeLocale lambdaCmsHumanTimeLocale = do langs <- languages y <- getYesod @@ -381,5 +403,4 @@ actionLogUserId <- requireAuthId actionLogCreatedAt <- liftIO getCurrentTime actionLogIdent <- liftIO generateUUID - mapM_ (\(actionLogLang, actionLogMessage) -> runDB . insert_ $ ActionLog {..}) messages diff --git a/LambdaCms/Core/Handler/ActionLog.hs b/LambdaCms/Core/Handler/ActionLog.hs deleted file mode 100644 --- a/LambdaCms/Core/Handler/ActionLog.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module LambdaCms.Core.Handler.ActionLog - ( getActionLogAdminIndexR - , getActionLogAdminUserR - ) where - -import Data.Int (Int64) -import Data.List (intersect) -import Data.Lists (firstOr) -import Data.String -import Data.Text -import Data.Time.Clock -import Data.Time.Format.Human -import Database.Esqueleto ((^.)) -import qualified Database.Esqueleto as E -import LambdaCms.Core.Import -import qualified LambdaCms.Core.Message as Msg -import Network.Wai -import Text.Read (readEither) -import Yesod.Core -import Yesod.Core.Types - -data JsonLog = JsonLog - { message :: Text - , username :: Text - , userUrl :: Maybe Text - , timeAgo :: String - } - -instance ToJSON JsonLog where - toJSON (JsonLog msg username' userUrl' timeAgo') = object [ "message" .= msg - , "username" .= username' - , "userUrl" .= userUrl' - , "timeAgo" .= timeAgo' - ] - -resolveApproot :: Yesod master => master -> Request -> ResolvedApproot -resolveApproot master req = - case approot of - ApprootRelative -> "" - ApprootStatic t -> t - ApprootMaster f -> f master - ApprootRequest f -> f master req - -logToJsonLog :: (LambdaCmsAdmin master, IsString method, Monad m) => - (Route master -> method -> Maybe r) - -> (r -> Text) - -> (UTCTime -> String) - -> (Entity ActionLog, Entity User) - -> m JsonLog -logToJsonLog can renderUrl toAgo (Entity _ log', Entity userId user) = do - let mUserUrl = renderUrl <$> (can (coreR $ UserAdminR $ UserAdminEditR userId) "GET") - return $ JsonLog - { message = actionLogMessage log' - , username = userName user - , userUrl = mUserUrl - , timeAgo = toAgo $ actionLogCreatedAt log' - } - -getCurrentLang :: CoreHandler Text -getCurrentLang = do - langs <- languages - y <- lift getYesod - return . firstOr "en" $ langs `intersect` (renderLanguages y) - -getActionLogs :: Maybe UserId -> Int64 -> Int64 -> Text -> CoreHandler [(Entity ActionLog, Entity User)] -getActionLogs mUserId limit offset lang = do - logs <- lift $ runDB - $ E.select - $ E.from $ \(log' `E.InnerJoin` user) -> do - E.on $ log' ^. ActionLogUserId E.==. user ^. UserId - E.where_ $ log' ^. ActionLogLang E.==. E.val lang - maybe (return ()) (E.where_ . (E.==.) (user ^. UserId) . E.val) mUserId - E.limit limit - E.offset offset - E.orderBy [E.desc (log' ^. ActionLogCreatedAt)] - - return (log', user) - return logs - -getActionLogAdminJson :: Maybe UserId -> CoreHandler TypedContent -getActionLogAdminJson mUserId = selectRep . provideRep $ do - (limit, offset) <- getFilters - lang <- getCurrentLang - can <- lift getCan - y <- lift getYesod - req <- waiRequest - timeNow <- liftIO getCurrentTime - hrtLocale <- lift lambdaCmsHumanTimeLocale - let renderUrl = flip (yesodRender y (resolveApproot y req)) [] - toAgo = humanReadableTimeI18N' hrtLocale timeNow - logs' <- getActionLogs mUserId limit offset lang - logs <- mapM (logToJsonLog can renderUrl toAgo) logs' - returnJson logs - -getActionLogAdminIndexR :: CoreHandler TypedContent -getActionLogAdminIndexR = getActionLogAdminJson Nothing - -getActionLogAdminUserR :: UserId -> CoreHandler TypedContent -getActionLogAdminUserR userId = getActionLogAdminJson (Just userId) - -getFilters :: CoreHandler (Int64, Int64) -getFilters = do - mLimitText <- lookupGetParam "limit" - mOffsetText <- lookupGetParam "offset" - - case (defaultTo 10 mLimitText, defaultTo 0 mOffsetText) of - (Left _, Left _) -> lift $ invalidArgsI [Msg.InvalidLimit, Msg.InvalidOffset] - (Left _, _) -> lift $ invalidArgsI [Msg.InvalidLimit] - (_ , Left _) -> lift $ invalidArgsI [Msg.InvalidOffset] - (Right limit, Right offset) -> return (limit, offset) - - where - defaultTo d mText = maybe (Right d) id (readEither . unpack <$> mText) diff --git a/LambdaCms/Core/Handler/Home.hs b/LambdaCms/Core/Handler/Home.hs --- a/LambdaCms/Core/Handler/Home.hs +++ b/LambdaCms/Core/Handler/Home.hs @@ -10,11 +10,16 @@ import qualified LambdaCms.Core.Message as Msg import Yesod.Auth (requireAuthId) +-- | The home of the admin section, displaying a dashboard like page. getAdminHomeR :: CoreHandler Html getAdminHomeR = lift $ do can <- getCan authId <- requireAuthId - let feedCount = 11 :: Int + + -- One less then the `actionLogChunkLength` will be displayed. + -- The potential last item is used to determain if the "show more" + -- link should be shown. + let actionLogChunkLength = 11 :: Int adminLayout $ do setTitleI Msg.Dashboard diff --git a/LambdaCms/Core/Handler/Static.hs b/LambdaCms/Core/Handler/Static.hs --- a/LambdaCms/Core/Handler/Static.hs +++ b/LambdaCms/Core/Handler/Static.hs @@ -3,8 +3,8 @@ {-# LANGUAGE TemplateHaskell #-} --- | --- A collection of helper functions to get to static resources. +-- | A collection of helper functions to allow static resources to be requested. +-- This also embeds those files into the resulting binary. module LambdaCms.Core.Handler.Static ( getNormalizeR , getBootstrapCssR diff --git a/LambdaCms/Core/Handler/User.hs b/LambdaCms/Core/Handler/User.hs --- a/LambdaCms/Core/Handler/User.hs +++ b/LambdaCms/Core/Handler/User.hs @@ -36,17 +36,20 @@ import Network.Mail.Mime import Text.Blaze.Html.Renderer.Text (renderHtml) --- data type for a form to change a user's password + +-- | Data type used by the change password form. data ComparePassword = ComparePassword { originalPassword :: Text - , _confirmPassword :: Text + , _confirmPassword :: Text } deriving (Show, Eq) +-- | Form by which account setting are changed. accountSettingsForm :: LambdaCmsAdmin master => User -> S.Set (Roles master) -> Maybe CoreMessage -> Html - -> MForm (HandlerT master IO) (FormResult (User, [Roles master]), WidgetT master IO ()) + -> MForm (HandlerT master IO) + (FormResult (User, [Roles master]), WidgetT master IO ()) accountSettingsForm user roles mlabel extra = do maRoles <- lift mayAssignRoles -- User fields @@ -55,7 +58,9 @@ -- Roles field (rolesRes, mrolesView) <- case maRoles of True -> do - (rolesRes', rolesView) <- mreq (checkboxesField roleList) "Not used" (Just $ S.toList roles) + (rolesRes', rolesView) <- mreq (checkboxesField roleList) + "Not used" + (Just $ S.toList roles) return (rolesRes', Just rolesView) False -> return (FormSuccess $ S.toList roles, Nothing) @@ -66,11 +71,13 @@ widget = $(widgetFile "user/settings-form") return (formRes, widget) - where roleList = optionsPairs $ map ((T.pack . show) &&& id) [minBound .. maxBound] + where + roleList = optionsPairs $ map ((T.pack . show) &&& id) [minBound .. maxBound] -- | Webform for changing a user's password. userChangePasswordForm :: Maybe Text -> Maybe CoreMessage -> CoreForm ComparePassword -userChangePasswordForm original submit = renderBootstrap3 BootstrapBasicForm $ ComparePassword +userChangePasswordForm original submit = + renderBootstrap3 BootstrapBasicForm $ ComparePassword <$> areq validatePasswordField (withName "original-pw" $ bfs Msg.Password) Nothing <*> areq comparePasswordField (bfs Msg.Confirm) Nothing <* bootstrapSubmit (BootstrapSubmit (fromMaybe Msg.Submit submit) " btn-success " []) @@ -107,15 +114,15 @@ emptyUser :: IO User emptyUser = generateUserWithEmail "" --- | Validate an activation token +-- | Validate an activation token. validateUserToken :: User -> Text -> Maybe Bool -validateUserToken user token = - case userToken user of - Just t - | t == token -> Just True -- tokens match - | otherwise -> Just False -- tokens don't match - Nothing -> Nothing -- there is no token (account already actived) +validateUserToken user token = case userToken user of + Just t + | t == token -> Just True -- tokens match + | otherwise -> Just False -- tokens don't match + Nothing -> Nothing -- there is no token (account already actived) +-- | Send an email to the user with a link containing the activation token. sendAccountActivationToken :: Entity User -> CoreHandler () sendAccountActivationToken (Entity userId user) = case userToken user of Just token -> do @@ -124,6 +131,7 @@ $(hamletFile "templates/mail/activation-html.hamlet") Nothing -> error "No activation token found" +-- | Send an email to the user with a link containing the reset token. sendAccountResetToken :: Entity User -> CoreHandler () sendAccountResetToken (Entity userId user) = case userToken user of Just token -> do @@ -132,6 +140,9 @@ $(hamletFile "templates/mail/reset-html.hamlet") Nothing -> error "No reset token found" +-- | Function for sending mail to the user. The method of sending mail is up +-- to the implementation by the `lambdaCmsSendMail` function in the "base" +--- application. sendMailToUser :: LambdaCmsAdmin master => User -> Text @@ -148,12 +159,11 @@ text html [] - lambdaCmsSendMail mail - where - getRenderedTemplate template = do - markup <- withUrlRenderer template - return $ renderHtml markup + where + getRenderedTemplate template = do + markup <- withUrlRenderer template + return $ renderHtml markup -- | User overview. @@ -172,24 +182,26 @@ setTitleI Msg.UserIndex $(widgetFile "user/index") --- | Create a new user. +-- | Create a new user, show the form. getUserAdminNewR :: CoreHandler Html getUserAdminNewR = do eu <- liftIO emptyUser lift $ do can <- getCan drs <- defaultRoles - (formWidget, enctype) <- generateFormPost $ accountSettingsForm eu drs (Just Msg.Create) + (formWidget, enctype) <- generateFormPost $ + accountSettingsForm eu drs (Just Msg.Create) adminLayout $ do setTitleI Msg.NewUser $(widgetFile "user/new") --- | Create a new user. +-- | Create a new user, handle a posted form. postUserAdminNewR :: CoreHandler Html postUserAdminNewR = do eu <- liftIO emptyUser drs <- lift $ defaultRoles - ((formResult, formWidget), enctype) <- lift . runFormPost $ accountSettingsForm eu drs (Just Msg.Create) + ((formResult, formWidget), enctype) <- lift . runFormPost $ + accountSettingsForm eu drs (Just Msg.Create) case formResult of FormSuccess (user, roles) -> do userId <- lift $ runDB $ insert user @@ -204,7 +216,7 @@ setTitleI Msg.NewUser $(widgetFile "user/new") --- | Edit an existing user. +-- | Show the forms to edit an existing user. getUserAdminEditR :: UserId -> CoreHandler Html getUserAdminEditR userId = do timeNow <- liftIO getCurrentTime @@ -214,24 +226,30 @@ user <- runDB $ get404 userId urs <- getUserRoles userId hrtLocale <- lambdaCmsHumanTimeLocale - (formWidget, enctype) <- generateFormPost $ accountSettingsForm user urs (Just Msg.Save) -- user form - (pwFormWidget, pwEnctype) <- generateFormPost $ userChangePasswordForm Nothing (Just Msg.Change) -- user password form + (formWidget, enctype) <- generateFormPost $ + accountSettingsForm user urs (Just Msg.Save) -- user form + (pwFormWidget, pwEnctype) <- generateFormPost $ + userChangePasswordForm Nothing (Just Msg.Change) -- user password form adminLayout $ do setTitleI . Msg.EditUser $ userName user $(widgetFile "user/edit") --- | Edit an existing user. +-- | Change a user's main properties. patchUserAdminEditR :: UserId -> CoreHandler Html patchUserAdminEditR userId = do user <- lift . runDB $ get404 userId timeNow <- liftIO getCurrentTime hrtLocale <- lift lambdaCmsHumanTimeLocale urs <- lift $ getUserRoles userId - (pwFormWidget, pwEnctype) <- lift . generateFormPost $ userChangePasswordForm Nothing (Just Msg.Change) - ((formResult, formWidget), enctype) <- lift . runFormPost $ accountSettingsForm user urs (Just Msg.Save) + (pwFormWidget, pwEnctype) <- lift . generateFormPost $ + userChangePasswordForm Nothing (Just Msg.Change) + ((formResult, formWidget), enctype) <- lift . runFormPost $ + accountSettingsForm user urs (Just Msg.Save) case formResult of FormSuccess (updatedUser, updatedRoles) -> do - _ <- lift $ runDB $ update userId [UserName =. userName updatedUser, UserEmail =. userEmail updatedUser] + _ <- lift $ runDB $ update userId [ UserName =. userName updatedUser + , UserEmail =. userEmail updatedUser + ] lift $ setUserRoles userId (S.fromList updatedRoles) lift $ logUser user >>= logAction lift $ setMessageI Msg.SuccessReplace @@ -243,7 +261,7 @@ setTitleI . Msg.EditUser $ userName user $(widgetFile "user/edit") --- | Edit password of an existing user. +-- | Change a user's password. chpassUserAdminEditR :: UserId -> CoreHandler Html chpassUserAdminEditR userId = do authId <- lift requireAuthId @@ -253,12 +271,15 @@ timeNow <- liftIO getCurrentTime hrtLocale <- lift lambdaCmsHumanTimeLocale urs <- lift $ getUserRoles userId - (formWidget, enctype) <- lift . generateFormPost $ accountSettingsForm user urs (Just Msg.Save) + (formWidget, enctype) <- lift . generateFormPost $ + accountSettingsForm user urs (Just Msg.Save) opw <- lookupPostParam "original-pw" - ((formResult, pwFormWidget), pwEnctype) <- lift . runFormPost $ userChangePasswordForm opw (Just Msg.Change) + ((formResult, pwFormWidget), pwEnctype) <- lift . runFormPost $ + userChangePasswordForm opw (Just Msg.Change) case formResult of FormSuccess f -> do - _ <- lift . runDB $ update userId [UserPassword =. Just (originalPassword f)] + _ <- lift . runDB $ + update userId [ UserPassword =. Just (originalPassword f) ] lift $ logUser user >>= logAction lift $ setMessageI Msg.SuccessChgPwd redirect $ UserAdminR $ UserAdminEditR userId @@ -269,6 +290,7 @@ $(widgetFile "user/edit") False -> error "Can't change this uses password" +-- | Request a user's password to be reset. rqpassUserAdminEditR :: UserId -> CoreHandler Html rqpassUserAdminEditR userId = do user' <- lift . runDB $ get404 userId @@ -284,6 +306,7 @@ lift $ setMessageI Msg.PasswordResetTokenSend redirectUltDest . UserAdminR $ UserAdminEditR userId +-- | Deactivate a user. deactivateUserAdminEditR :: UserId -> CoreHandler Html deactivateUserAdminEditR userId = do user' <- lift . runDB $ get404 userId @@ -297,6 +320,7 @@ _ -> lift $ setMessageI Msg.UserStillPending redirectUltDest . UserAdminR $ UserAdminEditR userId +-- | Activate a user. activateUserAdminEditR :: UserId -> CoreHandler Html activateUserAdminEditR userId = do user' <- lift . runDB $ get404 userId @@ -331,13 +355,14 @@ setMessageI Msg.SuccessDelete redirectUltDest $ UserAdminR UserAdminIndexR --- | Active an account. +-- | Active an account by emailed activation link. getUserAdminActivateR :: UserId -> Text -> CoreHandler Html getUserAdminActivateR userId token = do user <- lift . runDB $ get404 userId case validateUserToken user token of Just True -> do - (pwFormWidget, pwEnctype) <- lift . generateFormPost $ userChangePasswordForm Nothing (Just Msg.Save) + (pwFormWidget, pwEnctype) <- lift . generateFormPost $ + userChangePasswordForm Nothing (Just Msg.Save) lift . adminAuthLayout $ do setTitle . toHtml $ userName user $(widgetFile "user/activate") @@ -348,22 +373,25 @@ setTitleI Msg.AccountAlreadyActivated $(widgetFile "user/account-already-activated") --- | Active an account. +-- | Process a password change by password-reset-link email. postUserAdminActivateR :: UserId -> Text -> CoreHandler Html postUserAdminActivateR userId token = do user <- lift . runDB $ get404 userId case validateUserToken user token of Just True -> do opw <- lookupPostParam "original-pw" - ((formResult, pwFormWidget), pwEnctype) <- lift . runFormPost $ userChangePasswordForm opw (Just Msg.Save) + ((formResult, pwFormWidget), pwEnctype) <- lift . runFormPost $ + userChangePasswordForm opw (Just Msg.Save) case formResult of FormSuccess f -> do - _ <- lift . runDB $ update userId [ UserPassword =. Just (originalPassword f) - , UserToken =. Nothing - , UserActive =. True - ] + _ <- lift . runDB $ + update userId [ UserPassword =. Just (originalPassword f) + , UserToken =. Nothing + , UserActive =. True + ] lift $ setMessageI Msg.ActivationSuccess - lift . setCreds False $ Creds "lambdacms-token-activation" (userEmail user) [] + lift . setCreds False $ + Creds "lambdacms-token-activation" (userEmail user) [] redirect $ AdminHomeR _ -> do lift . adminAuthLayout $ do diff --git a/LambdaCms/Core/Settings.hs b/LambdaCms/Core/Settings.hs --- a/LambdaCms/Core/Settings.hs +++ b/LambdaCms/Core/Settings.hs @@ -14,6 +14,7 @@ import Text.Hamlet import Yesod.Default.Util + widgetFileSettings :: WidgetFileSettings widgetFileSettings = def { wfsHamletSettings = defaultHamletSettings diff --git a/LambdaCms/I18n/Dutch.hs b/LambdaCms/I18n/Dutch.hs --- a/LambdaCms/I18n/Dutch.hs +++ b/LambdaCms/I18n/Dutch.hs @@ -19,7 +19,7 @@ ("September", "Sep"), ("Oktober", "Okt"), ("November", "Nov"), ("December", "Dec")], - amPm = ("", ""), + amPm = ("am", "pm"), dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y", dateFmt = "%d-%m-%y", timeFmt = "%H:%M:%S", diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,275 +1,18 @@ - - -``` - , _ - / _, _ / _/ _, / ) _ _, - (__ (/ //) () (/ (/ (__ //)_) - - developer friendly :: type safe :: performant -``` - - -# Rationale - -LambdaCms is a set of packaged libraries —containing subsites for the -[Yesod application framework](http://www.yesodweb.com)— which allow rapid -development of robust and highly performant websites with content management -functionality. - -The `lambdacms-*` packages each provide some functionality and can depend -on eachother as they depend on other packages. -The only mandatory package is `lambdacms-core` (this package), it provides -functionality that all other `lambdacms-*` packages depend on. - -As mentioned, each `lambdacms-*` package contains a subsite which is -"mounted" in a standard Yesod application, which we will refer to as -"the base application" or simply "base". -Before a packaged subsite can be mounted, the package needs to be -included as a dependency to the base app's `.cabal` file. After that -some glue code needs to be added to the base app, as explained below. - -In the base app we have to: - -* configure a database connection, -* organize the admin backend's menu, -* specify the authentication strategies for admins, and -* define admin user roles and their permissions. - -In the base app we optionally may also: - -* override default behavior, -* override UI texts, -* provide a means to send email notifications, and last but not least, -* write the themes so the website can actually be visited (recommended). - - -# Setting up a site with LambdaCms - -This section walk through the steps of setting up a site with LambdaCms. - -**NOTE:** We're currently in the process using -[`stack`](https://github.com/commercialhaskell/stack), and upgrading to -GHC 7.10. This means we will use Stackage's `nightly-2015-07-09` package -set until LTS 3 is released. - - -### Prerequisites - -You need to be reasonably acquinted with Haskell in order to follow -along with this guide. To learn basic Haskell skills we recommend -Brent Yorgey's excellent -[Introduction to Haskell](http://www.seas.upenn.edu/~cis194/spring13) -course. - -Besides Haskell you need to be somewhat familliar with: - -* the web technologies (HTTP, HTML, CSS, JS, REST), -* RDBMS/SQL (LambdaCms makes use of a relational database), and -* the Yesod web application framework (for which an -* [awesome book](http://yesodweb.com/book) exists). - - -### Non-Haskell dependencies - -For the connection with the database, Haskell libraries typically compile -against non-Haskell libraries. One of the following libraries needs to be -available: - -* For Postgres: - - * Debian/Ubuntu: `libpq-dev` - * CentOS/Fedora/RHEL: `postgresql-devel` - * Homebrew (OSX): `postgres` - -* For Mysql: - - * Debian/Ubuntu: `libmysqlclient-dev` - * CentOS/Fedora/RHEL: `mysql-devel` - * Homebrew (OSX): `mysql` - -* For Sqlite - - * Debian/Ubuntu: `libsqlite3-dev` - * CentOS/Fedora/RHEL: `sqlite-devel` - * Homebrew (OSX): `sqlite` - -On other platforms these packages might have different names, but are -most likely available. - -If you are going to use a database other than Sqlite (which directly writes -to a file), you need to have a database accessible from where you run your -site. This means you might have to install and setup a database server locally. - - -### Create a project folder - -Choose a name for your project. In below we choose `mysite`, which you -probably want to change. Make sure to choose a valid unix file name -to avoid naming issues. Now create a directory for your project and -`cd` into it, by running the following commands: - -```bash -export PROJECT_NAME=mysite; mkdir $PROJECT_NAME; cd $PROJECT_NAME -``` - - -### Initializing the base application - -First we need to install the `yesod` command, this command requires a -lot of dependent packages to be downloaded and build (may a while). - -```bash -stack install yesod-bin --resolver nightly-2015-07-09 -``` - -With the following command you create a "scaffolded" Yesod application. -The command is interactive; you need to supply some configuration values. -Pick the database of your choice, and choose a project name: - -```bash -yesod init -n $PROJECT_NAME --bare -``` - -If you have chosen a database other than Sqlite, you need to create a -database and a sufficiently priviledged database user, and set these -credentials in the `config/setting.yml` file. - -Now we will create a `stack.yaml` file for this project which specifies -the nightly snapshot we would like to use. - -``` -stack init --resolver nightly-2015-07-09 -``` - -**NOTE:** This command complains that the some version constraints in -the `$PROJECT_NAME.cabal` file are too strict. Please raise the -upper bounds of these dependencies manually. **This step may be -removed once LTS 3 is out.** - - -This installs all dependencies and builds the scaffoled application -(may take a while): - -```bash -stack install -``` - -When you experience problems during builds, while using LTS `3.x`, -we consider this a bug. Please -[raise an issue](https://github.com/lambdacms/lambdacms-core/issues). - - -### Testing your Yesod app - -The following commands will run your scaffolded Yesdo application -in development mode. - -```bash -yesod devel -``` - -Now test it by pointing the browser to: -[`http://localhost:3000`](http://localhost:3000) - -If all went well you are ready to add LambdaCms to your app. - - -### Patching a freshly init'ed Yesod app to use `lambdacms-core` - -To add `lambdacms-core` to a freshly initialized Yesod application a number -of files need to be edited. We have prepared a patch-set to simplify this -process into a couple of commands. - -First we need to download the patches by cloning the repository, we do so in -`/tmp`. Then we apply the patches with the good old `patch` command. - -Run the following from the root of your newly created Yesod project: - -```bash -(cd /tmp; git clone https://github.com/lambdacms/lambdacms-patches.git) -patch -p1 < /tmp/lambdacms-patches/all_patches_combined.patch -``` - -Because the cabal file has a different name for each project -(i.e. `$PROJECT_NAME.cabal`) the patch command will notice a patched file -is missing (we named it `project_name.cabal`). -When the patch command tries to patch this file you will be prompted for -the name of your projects cabal file, after providing the name it will -successfully complete patching. - - -#### Alternatives to the patch set - -There are two alternatives to using the patch set: - -1. Patch files individually, how to do so is explained in the `lambdacms-patches` - [README](https://github.com/lambdacms/lambdacms-patches/blob/master/README.md). -2. Follow the [Getting Started Manually](https://github.com/lambdacms/lambdacms-core/wiki/Getting-Started-Manually) - guide on the wiki. - - -### Configure the initial administrator - -By default the application uses Mozilla's [Persona](https://persona.org) -to log in: the email address used to log in need to be registered with Persona. -It is recommended to use an email address of a Persona account for -development as it simplifies logging in during development. - -Edit `config/settings.yml` to insert a valid email address. - -```yaml -admin: "_env:LAMBDACMS_ADMIN:" -``` - -Replace `` with the email address of an initial administrator -or developer, so the admin inteface can be accessed. - - -### Enjoy! - -After applying the patches `lambdacms-core` is installed in your Yesod application. -Run `stack install` again to rebuild the project with the patches. - -Start the development server, which automatically recompiles when files -have changed. - - yesod devel - -Point your browser to -[`http://localhost:3000/admin`](http://localhost:3000/admin) and you will be -prompted to login. The setup as described above has selected Mozilla's -Persona as the only means of authentication. In `config/settings.yml` -you have provided an email address for the admin user that is created -if no users exist. If this email address is known to Mozilla Persona -then you can procede to log in. - - -# Add LambdaCms "extensions" to your base application - -LambdaCms' extension system is one of its core strengths: -it allows a developer to extend the site with packages while ensuring -full type safety. - -Please refer to `lambdacms-media`'s [README](https://github.com/lambdacms/lambdacms-media/blob/master/README.md) -for installation instructions. It also explains how other LambdaCms extensions -may incorporate media items managed by the `lambdacms-media` extension. - - -# Creating your own extensions +lambdacms-core +============== -In order to make the code base of your website as modular as possible, -we recommend packaging functionality into LambdaCms extensions. -This allows functionality to be shared as a library. +Provides functionality that all other `lambdacms-*` packages depend on. +This package provides a [Yesod](http://yesodweb.com) subsite containing the +basic functionality of a CMS's admin section and all code that is shared +between the admin sections of *extensions*. -Since this takes a bit of boiler plate, we have released a well documented -[extension scaffold script](https://github.com/lambdacms/lambdacms-extension-scaffold) -that should get you started. +Please refer to +[the main README of LambdaCms](https://github.com/lambdacms/lambdacms) +for instructions on how to use this package and what LambdaCms *extensions* are. -# License +### License All code in this repository is released under the MIT license, as specified -in the [LICENSE file](https://github.com/lambdacms/lambdacms-core/blob/master/LICENSE). - - +in the [LICENSE file](https://github.com/lambdacms/lambdacms/blob/master/LICENSE). diff --git a/config/models b/config/models --- a/config/models +++ b/config/models @@ -1,29 +1,31 @@ User json - ident Text - name Text - password Text Maybe - email Text - active Bool - token Text Maybe - createdAt UTCTime - lastLogin UTCTime Maybe - deletedAt UTCTime Maybe - UniqueUser ident - UniqueName name - UniqueEmail email - UniqueAuth email active - deriving Typeable Show --- Email --- email Text --- user UserId Maybe --- verkey Text Maybe --- UniqueEmail email + ident Text + name Text + password Text Maybe + email Text + active Bool + token Text Maybe + createdAt UTCTime + lastLogin UTCTime Maybe + deletedAt UTCTime Maybe + + UniqueUser ident + UniqueName name + UniqueEmail email + UniqueAuth email active + + deriving Typeable Show + + ActionLog json - ident Text - userId UserId - message Text - lang Text - createdAt UTCTime - UniqueLog ident lang - deriving Typeable Show + + ident Text + userId UserId + message Text + lang Text + createdAt UTCTime + + UniqueLog ident lang + + deriving Typeable Show diff --git a/config/routes b/config/routes --- a/config/routes +++ b/config/routes @@ -1,30 +1,30 @@ /static AdminStaticR: - /css CssAdminR: + /css CssAdminR: /normalize.css NormalizeR GET /bootstrap.css BootstrapCssR GET - /js JsAdminR: - /bootstrap.js BootstrapJsR GET - /jquery.js JQueryR GET + /js JsAdminR: + /bootstrap.js BootstrapJsR GET + /jquery.js JQueryR GET - /fonts FontsAdminR: + /fonts FontsAdminR: /glyphicons-halflings-regular.woff GlyphiconsWoffR GET /glyphicons-halflings-regular.ttf GlyphiconsTtfR GET /glyphicons-halflings-regular.eot GlyphiconsEotR GET /glyphicons-halflings-regular.svg GlyphiconsSvgR GET - /img ImageAdminR: + /img ImageAdminR: /lambdacms-logo.png LambdaCmsLogoR GET / AdminHomeR GET /activate/#UserId/#Text UserAdminActivateR GET POST -- User CRUD -/users UserAdminR: - / UserAdminIndexR GET - /new UserAdminNewR GET POST - !/#UserId UserAdminEditR GET PATCH DELETE CHPASS RQPASS DEACTIVATE ACTIVATE +/users UserAdminR: + / UserAdminIndexR GET + /new UserAdminNewR GET POST + !/#UserId UserAdminEditR GET PATCH DELETE CHPASS RQPASS DEACTIVATE ACTIVATE -/activity ActionLogAdminR: - / ActionLogAdminIndexR GET - /user/#UserId ActionLogAdminUserR GET +/activity ActionLogAdminR: + / ActionLogAdminIndexR GET + /user/#UserId ActionLogAdminUserR GET diff --git a/lambdacms-core.cabal b/lambdacms-core.cabal --- a/lambdacms-core.cabal +++ b/lambdacms-core.cabal @@ -1,14 +1,14 @@ name: lambdacms-core -version: 0.3.0.0 +version: 0.3.0.1 license: MIT -license-file: LICENSE +license-file: ../LICENSE author: Cies Breijs, Mats Rietdijk, Rutger van Aalst maintainer: cies@AT-hoppinger.com copyright: (c) 2014-2015 Hoppinger -bug-reports: https://github.com/lambdacms/lambdacms-core/issues +bug-reports: https://github.com/lambdacms/lambdacms/issues homepage: http://lambdacms.org -synopsis: LambdaCms Core subsite for Yesod apps -description: LambdaCms is a Content Management System (CMS) in Haskell +synopsis: LambdaCms 'core' subsite for Yesod apps +description: LambdaCms is a Content Management System (CMS) in Haskell. using Yesod. stability: alpha category: Web @@ -35,22 +35,21 @@ source-repository head type: git - location: git://github.com/lambdacms/lambdacms-core.git + location: git://github.com/lambdacms/lambdacms.git library default-language: Haskell2010 exposed-modules: LambdaCms.Core , LambdaCms.Core.Message , LambdaCms.Core.Settings - - other-modules: LambdaCms.Core.Foundation - , LambdaCms.Core.Models + -- for the test suite + , LambdaCms.Core.Foundation + other-modules: LambdaCms.Core.Models , LambdaCms.Core.Classes , LambdaCms.Core.Import - , LambdaCms.Core.Handler.Static , LambdaCms.Core.Handler.Home + , LambdaCms.Core.Handler.Static , LambdaCms.Core.Handler.User - , LambdaCms.Core.Handler.ActionLog , LambdaCms.I18n , LambdaCms.I18n.Dutch , LambdaCms.I18n.Italian @@ -69,7 +68,7 @@ , old-locale >= 1.0.0.5 && < 1.0.1.0 , mime-mail >= 0.4.5.2 && < 0.5 , blaze-html - , bytestring >= 0.9 && < 0.11 + , bytestring >= 0.9 && < 0.11 , data-default , containers >= 0.5.5.1 && < 0.6 , template-haskell @@ -80,3 +79,39 @@ , esqueleto ghc-options: -Wall + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + ghc-options: -Wall + -- TODO: remove other-modules after stack can properly detect when to rebuild + other-modules: FoundationSpec + , Spec + , TestImport + + default-extensions: + TemplateHaskell + QuasiQuotes + OverloadedStrings + NoImplicitPrelude + CPP + MultiParamTypeClasses + TypeFamilies + GADTs + GeneralizedNewtypeDeriving + FlexibleContexts + EmptyDataDecls + NoMonomorphismRestriction + DeriveDataTypeable + ViewPatterns + TupleSections + + build-depends: base + , yesod-core + , yesod + , hspec + , classy-prelude + , classy-prelude-yesod + , lambdacms-core diff --git a/templates/adminhome.hamlet b/templates/adminhome.hamlet --- a/templates/adminhome.hamlet +++ b/templates/adminhome.hamlet @@ -7,7 +7,7 @@
$forall (apiRoute, title) <- [(coreR $ ActionLogAdminR $ ActionLogAdminIndexR, Msg.AllLogs), (coreR $ ActionLogAdminR $ ActionLogAdminUserR authId, Msg.PersonalLogs)] $maybe r <- can (apiRoute) "GET" -
+
_{title}
diff --git a/templates/adminhome.julius b/templates/adminhome.julius --- a/templates/adminhome.julius +++ b/templates/adminhome.julius @@ -3,12 +3,12 @@ var load_activities; $(document).ready(function() { $(".get-action-logs").each(function(index) { - var feed_count, panel_body, panel_wrapper, url; + var chunk_length, panel_body, panel_wrapper, url; panel_wrapper = $(this); panel_body = panel_wrapper.find(".panel .panel-body"); url = panel_wrapper.data("url"); - feed_count = #{toJSON feedCount}; - load_activities(url, feed_count - 1, panel_body, function() { + chunk_length = #{toJSON actionLogChunkLength}; + load_activities(url, chunk_length - 1, panel_body, function() { panel_wrapper.removeClass("hidden"); }, function() { panel_wrapper.remove(); diff --git a/test/FoundationSpec.hs b/test/FoundationSpec.hs new file mode 100644 --- /dev/null +++ b/test/FoundationSpec.hs @@ -0,0 +1,12 @@ +module FoundationSpec (spec) where + +import TestImport +import LambdaCms.Core.Foundation + +spec :: Spec +spec = do + describe "Handler.Home" $ do + context "some method" $ do + it "loads the index and checks it looks right" $ do + "some" `shouldBe` "some" + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TestImport.hs b/test/TestImport.hs new file mode 100644 --- /dev/null +++ b/test/TestImport.hs @@ -0,0 +1,21 @@ +module TestImport + ( module TestImport + , module Export + ) where + +import ClassyPrelude as Export +import Test.Hspec as Export + + +--runDB :: SqlPersistM a -> YesodExample App a +--runDB query = do +-- pool <- fmap appConnPool getTestYesod +-- liftIO $ runSqlPersistMPool query pool + +--withApp :: SpecWith App -> Spec +--withApp = before $ do +-- settings <- loadAppSettings +-- ["config/test-settings.yml", "config/settings.yml"] +-- [] +-- ignoreEnv +-- makeFoundation settings