lambdacms-core 0.3.0.1 → 0.3.0.2
raw patch · 3 files changed
+150/−2 lines, 3 files
Files
- LICENSE +20/−0
- LambdaCms/Core/Handler/ActionLog.hs +127/−0
- lambdacms-core.cabal +3/−2
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014-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/Handler/ActionLog.hs view
@@ -0,0 +1,127 @@+{-# 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+++-- | REST/JSON endpoint for fetching the recent logs.+getActionLogAdminIndexR :: CoreHandler TypedContent+getActionLogAdminIndexR = getActionLogAdminJson Nothing++-- | REST/JSON endpoint for fetching the recent logs of a particular user.+getActionLogAdminUserR :: UserId -> CoreHandler TypedContent+getActionLogAdminUserR userId = getActionLogAdminJson (Just userId)++data JsonLog = JsonLog+ { message :: Text+ , username :: Text+ , userUrl :: Maybe Text+ , timeAgo :: String+ }++-- TODO: The ToJSON instance could move directly to the ActionLog model.+instance ToJSON JsonLog where+ toJSON (JsonLog msg username' userUrl' timeAgo') =+ object [ "message" .= msg+ , "username" .= username'+ , "userUrl" .= userUrl'+ , "timeAgo" .= timeAgo'+ ]++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+ jsonLogs <- mapM (logToJsonLog can renderUrl toAgo) logs+ returnJson jsonLogs++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++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'+ }++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++getCurrentLang :: CoreHandler Text+getCurrentLang = do+ langs <- languages+ y <- lift getYesod+ return . firstOr "en" $ langs `intersect` (renderLanguages y)++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.cabal view
@@ -1,7 +1,7 @@ name: lambdacms-core-version: 0.3.0.1+version: 0.3.0.2 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@@ -47,6 +47,7 @@ other-modules: LambdaCms.Core.Models , LambdaCms.Core.Classes , LambdaCms.Core.Import+ , LambdaCms.Core.Handler.ActionLog , LambdaCms.Core.Handler.Home , LambdaCms.Core.Handler.Static , LambdaCms.Core.Handler.User