module LambdaCms.Core.Foundation where
import Control.Arrow ((&&&))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LB (concat, toStrict)
import Data.List (find, sortBy)
import Data.Maybe (catMaybes, isJust)
import Data.Monoid ((<>))
import Data.Ord (comparing)
import Data.Set (Set)
import qualified Data.Set as S (empty, intersection, null)
import Data.Text (Text, concat, intercalate, pack,
unpack)
import Data.Text.Encoding (decodeUtf8)
import Data.Time (getCurrentTime, utc)
import Data.Time.Format.Human
import Data.Traversable (forM)
import Database.Persist.Sql (SqlBackend)
import LambdaCms.Core.Message (CoreMessage, defaultMessage,
dutchMessage, englishMessage)
import qualified LambdaCms.Core.Message as Msg
import LambdaCms.Core.Models
import LambdaCms.Core.Settings
import LambdaCms.I18n
import Network.Gravatar (GravatarOptions(..), Size(..),
def, gravatar)
import Network.Mail.Mime
import Network.Wai (requestMethod)
import Text.Hamlet (hamletFile)
import Yesod
import Yesod.Auth
import Yesod.Auth.Message (AuthMessage (InvalidLogin))
data CoreAdmin = CoreAdmin
data Allow a = AllowAll
| AllowAuthenticated
| AllowRoles a
| AllowNone
data AdminMenuItem master = MenuItem
{ label :: SomeMessage master
, route :: Route master
, icon :: Text
}
mkYesodSubData "CoreAdmin" $(parseRoutesFile "config/routes")
instance LambdaCmsAdmin master => RenderMessage master CoreMessage where
renderMessage = renderCoreMessage
type CoreHandler a = forall master. LambdaCmsAdmin master
=> HandlerT CoreAdmin (HandlerT master IO) a
type CoreForm a = forall master. LambdaCmsAdmin master
=> Html
-> MForm (HandlerT master IO) (FormResult a, WidgetT master IO ())
class ( YesodAuth master
, AuthId master ~ Key User
, AuthEntity master ~ User
, YesodAuthPersist master
, YesodPersistBackend master ~ SqlBackend
, ParseRoute master
, Ord (Roles master)
, Enum (Roles master)
, Bounded (Roles master)
, Show (Roles master)
, Eq (Roles master)
) => LambdaCmsAdmin master where
type Roles master
getUserRoles :: Key User -> HandlerT master IO (Set (Roles master))
setUserRoles :: Key User -> Set (Roles master) -> HandlerT master IO ()
mayAssignRoles :: HandlerT master IO Bool
defaultRoles :: HandlerT master IO (Set (Roles master))
defaultRoles = return S.empty
isAuthorizedTo :: master
-> Maybe (Set (Roles master))
-> Allow (Set (Roles master))
-> AuthResult
isAuthorizedTo _ _ AllowNone = Unauthorized "Access denied."
isAuthorizedTo _ _ AllowAll = Authorized
isAuthorizedTo _ (Just _) AllowAuthenticated = Authorized
isAuthorizedTo _ Nothing _ = AuthenticationRequired
isAuthorizedTo _ (Just urs) (AllowRoles rrs) = do
case (not . S.null $ urs `S.intersection` rrs) of
True -> Authorized
False -> Unauthorized "Access denied."
actionAllowedFor :: Route master
-> ByteString
-> Allow (Set (Roles master))
actionAllowedFor _ _ = AllowNone
coreR :: Route CoreAdmin -> Route master
authR :: Route Auth -> Route master
masterHomeR :: Route master
adminTitle :: SomeMessage master
adminTitle = SomeMessage Msg.LambdaCms
welcomeWidget :: Maybe (WidgetT master IO ())
welcomeWidget = Just $ do
Entity _ user <- handlerToWidget requireAuth
messageRenderer <- getMessageRender
$(widgetFile "admin-welcome")
adminLayout :: WidgetT master IO () -> HandlerT master IO Html
adminLayout widget = do
auth <- requireAuth
mCurrentR <- getCurrentRoute
mmsg <- getMessage
can <- getCan
let am = filter (isJust . flip can "GET" . route) adminMenu
mActiveMenuR = routeBestMatch mCurrentR $ map route am
gravatarSize = 28 :: Int
gOpts = def
{ gSize = Just $ Size $ gravatarSize * 2
}
pc <- widgetToPageContent $ do
addStylesheet $ coreR $ AdminStaticR $ CssAdminR NormalizeR
addStylesheet $ coreR $ AdminStaticR $ CssAdminR BootstrapCssR
addScript $ coreR $ AdminStaticR $ JsAdminR JQueryR
addScript $ coreR $ AdminStaticR $ JsAdminR BootstrapJsR
$(widgetFile "admin-layout")
withUrlRenderer $(hamletFile "templates/admin-layout-wrapper.hamlet")
adminAuthLayout :: WidgetT master IO () -> HandlerT master IO Html
adminAuthLayout widget = do
mmsg <- getMessage
logoRowId <- newIdent
pc <- widgetToPageContent $ do
addStylesheet $ coreR $ AdminStaticR $ CssAdminR NormalizeR
addStylesheet $ coreR $ AdminStaticR $ CssAdminR BootstrapCssR
addScript $ coreR $ AdminStaticR $ JsAdminR JQueryR
addScript $ coreR $ AdminStaticR $ JsAdminR BootstrapJsR
$(widgetFile "admin-auth-layout")
withUrlRenderer $(hamletFile "templates/admin-auth-layout-wrapper.hamlet")
authLogoR :: Route master
authLogoR = coreR $ AdminStaticR $ ImageAdminR LambdaCmsLogoR
adminMenu :: [AdminMenuItem master]
adminMenu = []
renderCoreMessage :: master
-> [Text]
-> CoreMessage
-> Text
renderCoreMessage m (lang:langs) = do
case (lang `elem` (renderLanguages m), lang) of
(True, "en") -> englishMessage
(True, "nl") -> dutchMessage
_ -> renderCoreMessage m langs
renderCoreMessage _ _ = defaultMessage
renderLanguages :: master -> [Text]
renderLanguages _ = ["en"]
lambdaCmsSendMail :: Mail -> HandlerT master IO ()
lambdaCmsSendMail (Mail from tos ccs bccs headers parts) =
liftIO . putStrLn . unpack $ "MAIL"
<> "\n From: " <> (address from)
<> "\n To: " <> (maddress tos)
<> "\n Cc: " <> (maddress ccs)
<> "\n Bcc: " <> (maddress bccs)
<> "\n Subject: " <> subject
<> "\n Attachment: " <> attachment
<> "\n Plain body: " <> plainBody
<> "\n Html body: " <> htmlBody
where
subject = Data.Text.concat . map snd $ filter (\(k,_) -> k == "Subject") headers
attachment :: Text
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
maddress = intercalate ", " . map (address)
address (Address n e) = let e' = "<" <> e <> ">" in case n of
Just n' -> n' <> " " <> e'
Nothing -> e'
authenticateByLambdaCms :: LambdaCmsAdmin master
=> Creds master
-> HandlerT master IO (AuthenticationResult master)
authenticateByLambdaCms creds = runDB $ do
user <- getBy $ UniqueAuth (credsIdent creds) True
case user of
Just (Entity uid _) -> do
timeNow <- liftIO getCurrentTime
_ <- update uid [UserLastLogin =. Just timeNow]
return $ Authenticated uid
Nothing -> return $ UserError InvalidLogin
lambdaCmsMaybeAuthId :: LambdaCmsAdmin master
=> HandlerT master IO (Maybe (AuthId master))
lambdaCmsMaybeAuthId = do
mauthId <- defaultMaybeAuthId
maybe (return Nothing) maybeActiveAuthId mauthId
where
maybeActiveAuthId authId = do
user <- runDB $ get404 authId
return $ case userActive user of
True -> Just authId
False -> Nothing
canFor :: LambdaCmsAdmin master
=> master
-> Maybe (Set (Roles master))
-> Route master
-> ByteString
-> Maybe (Route master)
canFor m murs theRoute method = case isAuthorizedTo m murs $ actionAllowedFor theRoute method of
Authorized -> Just theRoute
_ -> Nothing
getCan :: LambdaCmsAdmin master
=> HandlerT master IO (Route master -> ByteString -> Maybe (Route master))
getCan = do
mauthId <- maybeAuthId
murs <- forM mauthId getUserRoles
y <- getYesod
return $ canFor y murs
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"
]
adminLayoutSub :: LambdaCmsAdmin master
=> WidgetT sub IO ()
-> HandlerT sub (HandlerT master IO) Html
adminLayoutSub widget = widgetToParentWidget widget >>= lift . adminLayout
withName :: Text -> FieldSettings site -> FieldSettings site
withName name fs = fs { fsName = Just name }
withAttrs :: [(Text, Text)] -> FieldSettings site -> FieldSettings site
withAttrs attrs fs = fs { fsAttrs = attrs }
lambdaCmsHumanTimeLocale :: LambdaCmsAdmin master
=> HandlerT master IO HumanTimeLocale
lambdaCmsHumanTimeLocale = do
langs <- languages
y <- getYesod
let rm = unpack . renderMessage y langs
return $ HumanTimeLocale
{ justNow = rm Msg.TimeJustNow
, secondsAgo = (\_ x -> rm . Msg.TimeSecondsAgo $ pack x)
, oneMinuteAgo = (\_ -> rm Msg.TimeOneMinuteAgo)
, minutesAgo = (\_ x -> rm . Msg.TimeMinutesAgo $ pack x)
, oneHourAgo = (\_ -> rm Msg.TimeOneHourAgo)
, aboutHoursAgo = (\_ x -> rm . Msg.TimeAboutHoursAgo $ pack x)
, at = (\_ x -> rm $ Msg.TimeAt $ pack x)
, daysAgo = (\_ x -> rm . Msg.TimeDaysAgo $ pack x)
, weekAgo = (\_ x -> rm . Msg.TimeWeekAgo $ pack x)
, weeksAgo = (\_ x -> rm . Msg.TimeWeeksAgo $ pack x)
, onYear = rm . Msg.TimeOnYear . pack
, locale = lambdaCmsTimeLocale langs
, dayOfWeekFmt = rm Msg.DayOfWeekFmt
, thisYearFmt = "%b %e"
, prevYearFmt = "%b %e, %Y"
, timeZone = utc
}
routeBestMatch :: RenderRoute master
=> Maybe (Route master)
-> [Route master]
-> Maybe (Route master)
routeBestMatch (Just cr) rs = fmap snd $ find cmp orrs
where
(cparts, _) = renderRoute cr
rrs = map ((fst . renderRoute) &&& id) rs
orrs = reverse $ sortBy (comparing (length . fst)) rrs
cmp (route', _) = route' == (take (length route') cparts)
routeBestMatch _ _ = Nothing
class LambdaCmsLoggable master entity where
logMessage :: master -> ByteString -> entity -> [(Text, Text)]
instance LambdaCmsAdmin master => LambdaCmsLoggable master User where
logMessage y "POST" = translateUserLogs y Msg.LogCreatedUser
logMessage y "PATCH" = translateUserLogs y Msg.LogUpdatedUser
logMessage y "DELETE" = translateUserLogs y Msg.LogDeletedUser
logMessage y "CHPASS" = translateUserLogs y Msg.LogChangedPasswordUser
logMessage y "RQPASS" = translateUserLogs y Msg.LogRequestedPasswordUser
logMessage y "DEACTIVATE" = translateUserLogs y Msg.LogDeactivatedUser
logMessage y "ACTIVATE" = translateUserLogs y Msg.LogActivatedUser
logMessage _ _ = const []
translateUserLogs :: forall b master.
( LambdaCmsAdmin master
, RenderMessage master b
) => master -> (Text -> b) -> User -> [(Text, Text)]
translateUserLogs y msg u = map (id &&& messageFor) $ renderLanguages y
where messageFor lang = renderMessage y [lang] . msg $ userName u
logUser :: LambdaCmsAdmin master => User -> HandlerT master IO [(Text, Text)]
logUser user = do
y <- getYesod
method <- waiRequest >>= return . requestMethod
return $ logMessage y method user
logAction :: LambdaCmsAdmin master => [(Text, Text)] -> HandlerT master IO ()
logAction messages = do
actionLogUserId <- requireAuthId
actionLogCreatedAt <- liftIO getCurrentTime
actionLogIdent <- liftIO generateUUID
mapM_ (\(actionLogLang, actionLogMessage) -> runDB . insert_ $ ActionLog {..}) messages