lambdacms-core 0.3.0.0 → 0.3.0.1
raw patch · 20 files changed
+294/−553 lines, 20 filesdep +classy-preludedep +classy-prelude-yesoddep +hspecdep ~base
Dependencies added: classy-prelude, classy-prelude-yesod, hspec, lambdacms-core
Dependency ranges changed: base
Files
- CHANGES.md +6/−0
- LICENSE +0/−20
- LambdaCms/Core.hs +12/−5
- LambdaCms/Core/Classes.hs +7/−8
- LambdaCms/Core/Foundation.hs +52/−31
- LambdaCms/Core/Handler/ActionLog.hs +0/−120
- LambdaCms/Core/Handler/Home.hs +6/−1
- LambdaCms/Core/Handler/Static.hs +2/−2
- LambdaCms/Core/Handler/User.hs +70/−42
- LambdaCms/Core/Settings.hs +1/−0
- LambdaCms/I18n/Dutch.hs +1/−1
- README.md +11/−268
- config/models +28/−26
- config/routes +13/−13
- lambdacms-core.cabal +47/−12
- templates/adminhome.hamlet +1/−1
- templates/adminhome.julius +3/−3
- test/FoundationSpec.hs +12/−0
- test/Spec.hs +1/−0
- test/TestImport.hs +21/−0
CHANGES.md view
@@ -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
− LICENSE
@@ -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.
LambdaCms/Core.hs view
@@ -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)
LambdaCms/Core/Classes.hs view
@@ -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
LambdaCms/Core/Foundation.hs view
@@ -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 <http://glyphicons.bootstrapcheatsheets.com glyphicon> 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 <http://glyphicons.bootstrapcheatsheets.com glyphicon> 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 <https://github.com/lambdacms/lambdacms-core/blob/master/sending-emails.md github> 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 <https://github.com/lambdacms/lambdacms/blob/master/docs/implement-mail-deivery-method.md>+ -- 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
− LambdaCms/Core/Handler/ActionLog.hs
@@ -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)
LambdaCms/Core/Handler/Home.hs view
@@ -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
LambdaCms/Core/Handler/Static.hs view
@@ -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
LambdaCms/Core/Handler/User.hs view
@@ -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
LambdaCms/Core/Settings.hs view
@@ -14,6 +14,7 @@ import Text.Hamlet import Yesod.Default.Util + widgetFileSettings :: WidgetFileSettings widgetFileSettings = def { wfsHamletSettings = defaultHamletSettings
LambdaCms/I18n/Dutch.hs view
@@ -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",
README.md view
@@ -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:<email address>"-```--Replace `<email address>` 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).
config/models view
@@ -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
config/routes view
@@ -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
lambdacms-core.cabal view
@@ -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
templates/adminhome.hamlet view
@@ -7,7 +7,7 @@ <div .row> $forall (apiRoute, title) <- [(coreR $ ActionLogAdminR $ ActionLogAdminIndexR, Msg.AllLogs), (coreR $ ActionLogAdminR $ ActionLogAdminUserR authId, Msg.PersonalLogs)] $maybe r <- can (apiRoute) "GET"- <div .hidden .col-xs-12 .col-md-6 .get-action-logs data-url=@?{(r, [("limit", pack $ show feedCount)])}>+ <div .hidden .col-xs-12 .col-md-6 .get-action-logs data-url=@?{(r, [("limit", pack $ show actionLogChunkLength)])}> <div .panel .panel-default> <div .panel-heading>_{title} <div .panel-body data-more=_{Msg.LoadMore}>
templates/adminhome.julius view
@@ -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();
+ test/FoundationSpec.hs view
@@ -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"+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TestImport.hs view
@@ -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