snaplet-actionlog-0.3.1: src/Snap/Snaplet/ActionLog/Resource.hs
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Snap.Snaplet.ActionLog.Resource
( actionLogR
, indexH
, showH
, actionLogSplices
, actionLogISplices
) where
------------------------------------------------------------------------------
import Blaze.ByteString.Builder.Char8
import Control.Applicative as A
import Control.Error
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Syntax as MS
import Data.Monoid
import qualified Data.Readable as R
import Data.Text (Text)
import qualified Data.Text as T
import Database.Persist
import Heist
import Heist.Compiled
import qualified Heist.Interpreted as I
import Snap
import Snap.Restful
import Snap.Snaplet.ActionLog.API
import Snap.Snaplet.ActionLog.Types
import Snap.Snaplet.Heist.Generic
import Snap.Snaplet.Persistent
import Text.Digestive
import qualified Text.Digestive as Form
import qualified Text.Digestive.Heist as DHI
import Text.Digestive.Heist.Compiled
import Text.Digestive.Snap hiding (method)
import qualified Text.Digestive.Snap as Form
import qualified Text.XmlHtml as X
------------------------------------------------------------------------------
snapletRender :: HasHeist b => ByteString -> Handler b v ()
snapletRender name = do
root <- getSnapletRootURL
let p = B.intercalate "/" $ filter (not . B.null) [root, name]
gRender p
indexH :: HasHeist b => Handler b v ()
indexH = snapletRender "index"
showH :: HasHeist b => Handler b v ()
showH = snapletRender "show"
-------------------------------------------------------------------------------
-- | A restful-snap resource for the action log CRUD.
actionLogR :: Resource
actionLogR = Resource
{ rName = "actionlog"
, rRoot = ""
, rResourceEndpoints = []
, rItemEndpoints = []
}
data LogFilter = LogFilter
{ filterUser :: Maybe Int
, filterEntity :: Maybe Text
, filterEntityId :: Maybe Int
, filterAction :: Maybe ActionType
} deriving (Show)
instance Monoid LogFilter where
mempty = LogFilter Nothing Nothing Nothing Nothing
mappend (LogFilter u1 e1 i1 a1) (LogFilter u2 e2 i2 a2) =
LogFilter (getFirst $ mappend (First u1) (First u2))
(getFirst $ mappend (First e1) (First e2))
(getFirst $ mappend (First i1) (First i2))
(getFirst $ mappend (First a1) (First a2))
mkFilters :: LogFilter -> [Filter LoggedAction]
mkFilters (LogFilter u e eid a) =
maybe [] (\x -> [LoggedActionUserId ==. x]) u ++
maybe [] (\x -> [LoggedActionEntityName ==. x]) e ++
maybe [] (\x -> [LoggedActionEntityId ==. x]) eid ++
maybe [] (\x -> [LoggedActionAction ==. x]) a
disableOnJust :: (Maybe a -> Form v m b) -> Maybe a -> Form v m b
disableOnJust f Nothing = f Nothing
disableOnJust f def = disable $ f def
------------------------------------------------------------------------------
-- |
logFilterForm :: HasActionLog m
=> Bool
-> Maybe LogFilter -> Form Text m LogFilter
logFilterForm isDisabling d = monadic $ do
entities <- getTenantEntities
let entityPairs = noFilter : map (\x -> (Just x,x)) entities
uids <- getTenantUids
names <- mapM alGetName uids
let userPairs = noFilter : (map firstJust $ zip uids names)
return $ LogFilter
A.<$> "user" .: choice userPairs ?$ (filterUser <$> d)
<*> "entity" .: choice entityPairs ?$ (filterEntity <$> d)
<*> "entity-id" .: optionalStringRead "id must be an int" ?$
(filterEntityId =<< d)
<*> "action" .: choice actions ?$ (filterAction <$> d)
where
noFilter = (Nothing, "Any")
firstJust (k,u) = (Just k, u)
actions = noFilter : map (\x -> (Just x,T.pack $ show x)) [minBound..maxBound]
-- An infix function here makes the syntax nice
infixr 6 ?$
(?$) :: (Maybe a -> Form v m b) -> Maybe a -> Form v m b
(?$) = if isDisabling then disableOnJust else ($)
logFilterFormName :: Text
logFilterFormName = "log-filter-form"
-------------------------------------------------------------------------------
runLogFilterForm :: (HasActionLog m, MonadSnap m)
=> Bool -> Maybe LogFilter -> m (View Text, Maybe LogFilter)
runLogFilterForm isDisabling def =
runFormWith cfg logFilterFormName (logFilterForm isDisabling def)
where
cfg = defaultSnapFormConfig { Form.method = Just Form.Post }
-------------------------------------------------------------------------------
-- Splices
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
actionLogSplices :: (HasActionLog n, MonadSnap n)
=> Resource -> Splices (Splice n)
actionLogSplices r = mconcat
[ MS.mapV ($ mempty) (coupledSplices r False)
, splices ]
where
splices = do
"actionDetails" MS.## actionViewSplice r
"defaultActions" MS.## defaultActionsSplice r
coupledSplices :: (HasActionLog n, MonadSnap n)
=> Resource
-> Bool
-> Splices (RuntimeSplice n LogFilter -> Splice n)
coupledSplices r b = do
"actionlogListing" MS.## actionsSplice r (runLogFilterForm b)
"actionlogFilterForm" MS.## logFilterFormSplice (runLogFilterForm b)
getFilterFunc :: Monad n => HeistT n IO (RuntimeSplice n LogFilter)
getFilterFunc = do
n <- getParamNode
attrFunc <- runAttributesRaw $ X.elementAttrs n
return $ do
as <- attrFunc
return $ filterCommon as
filterCommon :: [(Text, Text)] -> LogFilter
filterCommon as =
LogFilter
(R.fromText =<< lookup "uid" as)
(lookup "entity" as)
(R.fromText =<< lookup "entity-id" as)
(R.fromText =<< lookup "action" as)
------------------------------------------------------------------------------
-- | This is a splice that wraps both the action log filter form splice and
-- the listing splice. It handles greying out the appropriate form fields and
-- limiting the things in the listing.
defaultActionsSplice :: (MonadSnap m, HasActionLog m) => Resource -> Splice m
defaultActionsSplice r = do
filterFunc <- getFilterFunc
withSplices runChildren (coupledSplices r True) filterFunc
actionFromId :: (MonadSnap m, HasPersistPool m)
=> m (Maybe (Entity LoggedAction))
actionFromId = runMaybeT $ do
idBS <- MaybeT $ getParam "id"
_id <- R.fromBS idBS
let key = mkKey _id
action <- MaybeT $ getLoggedAction key
return $ Entity key action
actionViewSplice :: (HasActionLog n, MonadSnap n) => Resource -> Splice n
actionViewSplice r = manyWithSplices runChildren (actionSplices r) $ do
ma <- lift actionFromId
return $ maybe [] (:[]) ma
actionsSplice :: HasActionLog n
=> Resource
-> (Maybe a -> n (t, Maybe LogFilter))
-> RuntimeSplice n LogFilter
-> Splice n
actionsSplice res form rt = manyWithSplices runChildren (actionSplices res) $ do
f <- rt
(_,r) <- lift $ form Nothing
let filters = case r of
Nothing -> []
Just lf -> mkFilters (f `mappend` lf)
lift $ getTenantActions filters []
actionSplices :: HasActionLog n
=> Resource
-> Splices (RuntimeSplice n (Entity LoggedAction) -> Splice n)
actionSplices r = mconcat
[ MS.mapV pureSplice loggedActionCSplices
, alCustomCSplices
, MS.mapV ( deferMap (return . Just . DBId . mkWord64 . entityKey)
. pureSplice . textSplice) (itemCSplices r)
, splices
]
where
splices = do
"loggedActionUserName" MS.## getUserName
"loggedActionDetails" MS.## detailsSplice
detailsSplice :: HasActionLog n
=> RuntimeSplice n (Entity LoggedAction)
-> Splice n
detailsSplice rt =
manyWithSplices runChildren (MS.mapV pureSplice detailsCSplices)
(lift . getActionDetails . entityKey =<< rt)
getUserName :: HasActionLog n
=> RuntimeSplice n (Entity LoggedAction)
-> Splice n
getUserName = bindLater $ \entity -> lift $ do
name <- alGetName $ loggedActionUserId $ entityVal entity
return $ fromText name
-------------------------------------------------------------------------------
logFilterFormSplice :: MonadIO m
=> (Maybe a -> m (View Text, b))
-> RuntimeSplice m a
-> Splice m
logFilterFormSplice form rt =
formSplice mempty mempty $ do
f <- rt
lift $ liftM fst $ form (Just f)
-------------------------------------------------------------------------------
-- Interpreted
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
logFilterFormISplice :: MonadIO m
=> (Maybe a -> m (View Text, t))
-> a -> HeistT m m Template
logFilterFormISplice form f = do
(v,_) <- lift $ form (Just f)
localHS (DHI.bindDigestiveSplices v) (DHI.dfForm v >>= I.runNodeList)
--crudUrlISplice :: MonadSnap m => ByteString -> CRUD -> HeistT n m Template
--crudUrlISplice root crud =
-- I.textSplice . decodeUtf8 . (root -/-) =<< go crud
-- where
-- go RIndex = return ""
-- go RCreate = return ""
-- go RShow = (getParam "id") >>= maybe (go RIndex) return
-- go RNew = return "new"
-- go REdit = (getParam "id") >>= maybe (go RIndex) (return . (-/- "edit"))
-- go RUpdate = (getParam "id") >>= maybe (go RIndex) return
-- go RDestroy =
-- (getParam "id") >>= maybe (go RIndex) (return . (-/- "/destroy"))
--
--
--viewLinkISplice :: MonadSnap m => ByteString -> I.Splice m
--viewLinkISplice root = do
-- n <- getParamNode
-- case X.getAttribute "entity" n of
-- Nothing -> return []
-- Just e -> do
-- mid <- lift $ getParam "id"
-- case mid of
-- Nothing -> return []
-- Just _id -> do
-- let page = printf "%s?%s&%s" (kv "entity" e)
-- (kv "entity-id" (decodeUtf8 _id))
-- url = root -/- encodeUtf8 (T.pack page)
-- I.runChildrenWithText [("linkUrl", decodeUtf8 url)]
-- where
-- kv :: Text -> Text -> String
-- kv k v = printf "%s.%s=%s" (T.unpack logFilterFormName)
-- (T.unpack k) (T.unpack v)
-------------------------------------------------------------------------------
-- | Interpreted splice for an action log listing.
actionLogISplices :: (HasActionLog n, MonadSnap n)
=> Resource -> Splices (I.Splice n)
actionLogISplices r =
splices `mappend` coupledISplices r False mempty
where
splices = do
"actionDetails" MS.## actionDetailsISplice r
"defaultActions" MS.## defaultActionsISplice r
coupledISplices :: (HasActionLog m, MonadSnap m)
=> Resource -> Bool -> LogFilter -> Splices (I.Splice m)
coupledISplices r b f = do
"actionlogListing" MS.## actionLogListingISplice r (runLogFilterForm b) f
"actionlogFilterForm" MS.## logFilterFormISplice (runLogFilterForm b) f
actionDetailsISplice :: (HasActionLog n, MonadSnap n)
=> Resource -> I.Splice n
actionDetailsISplice r = do
ma <- lift $ actionFromId
maybe (return []) (I.runChildrenWith . actionISplices r) ma
actionLogListingISplice :: HasActionLog m
=> Resource
-> (Maybe a -> m (t, Maybe LogFilter))
-> LogFilter
-> I.Splice m
actionLogListingISplice res form f = do
(_,r) <- lift $ form Nothing
let filters = case r of
Nothing -> []
Just lf -> mkFilters (f `mappend` lf)
actions <- lift $ getTenantActions filters []
I.mapSplices (I.runChildrenWith . actionISplices res) actions
actionISplices :: HasActionLog m
=> Resource
-> Entity LoggedAction
-> Splices (I.Splice m)
actionISplices r e = mconcat
[ splices
, loggedActionISplices (entityVal e)
, alCustomISplices e
, itemSplices r (DBId $ mkWord64 $ entityKey e)
]
where
splices = do
"loggedActionUserName" MS.## I.textSplice =<< getUserName
"loggedActionDetails" MS.## detailsISplice
getUserName = lift $ alGetName $ loggedActionUserId $ entityVal e
detailsISplice = do
ds <- lift $ getActionDetails $ entityKey e
I.mapSplices (I.runChildrenWith . detailsISplices . entityVal) ds
------------------------------------------------------------------------------
-- | This is a splice that wraps both the action log filter form splice and
-- the listing splice. It handles greying out the appropriate form fields and
-- limiting the things in the listing.
defaultActionsISplice :: (MonadSnap m, HasActionLog m)
=> Resource -> I.Splice m
defaultActionsISplice r = do
n <- getParamNode
let f = filterCommon $ X.elementAttrs n
I.runChildrenWith $ coupledISplices r True f