snaplet-actionlog (empty) → 0.2
raw patch · 14 files changed
+1276/−0 lines, 14 filesdep +basedep +blaze-builderdep +bytestringsetup-changed
Dependencies added: base, blaze-builder, bytestring, digestive-functors, digestive-functors-heist, digestive-functors-snap, errors, heist, persistent, persistent-postgresql, persistent-template, readable, restful-snap, snap, snap-extras, snaplet-persistent, text, time, transformers, unordered-containers, xmlhtml
Files
- LICENSE +26/−0
- Setup.hs +3/−0
- resources/templates/_details.tpl +43/−0
- resources/templates/_form.tpl +25/−0
- resources/templates/_list.tpl +29/−0
- resources/templates/index.tpl +23/−0
- resources/templates/show.tpl +19/−0
- schema.txt +14/−0
- snaplet-actionlog.cabal +67/−0
- src/Snap/Snaplet/ActionLog.hs +103/−0
- src/Snap/Snaplet/ActionLog/API.hs +228/−0
- src/Snap/Snaplet/ActionLog/InternalTypes.hs +102/−0
- src/Snap/Snaplet/ActionLog/Resource.hs +381/−0
- src/Snap/Snaplet/ActionLog/Types.hs +213/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2012, Soostone Inc++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++Redistributions of source code must retain the above copyright notice, this+list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright notice, this+list of conditions and the following disclaimer in the documentation and/or+other materials provided with the distribution.++Neither the name of the authors nor the names of its contributors may be used+to endorse or promote products derived from this software without specific+prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ resources/templates/_details.tpl view
@@ -0,0 +1,43 @@+<actionDetails>+ + <div class="row-fluid">+ <div class="span6">++ <h4>Timestamp</h4>+ <p><loggedActionAt/></p>++ <h4>User</h4>+ <p><loggedActionUserName/></p>++ <h4>Entity Name</h4>+ <p><loggedActionEntityName/></p>++ <h4>Entity ID</h4>+ <p><loggedActionEntityId/></p>++ <h4>Action Type</h4>+ <p><loggedActionAction/></p>+ </div>++ </div>++ <div class="form-actions">+ <a href="${actionlogIndexPath}" class="btn">Return To Listing</a>+ </div>++ <table class="table table-striped">+ <tr>+ <th>Field</th>+ <th>Old Value</th>+ <th>New Value</th>+ </tr>+ <loggedActionDetails>+ <tr>+ <td><loggedActionDetailsFieldName/></td>+ <td><loggedActionDetailsOldValue/></td>+ <td><loggedActionDetailsNewValue/></td>+ </tr>+ </loggedActionDetails>+ </table>++</actionDetails>
+ resources/templates/_form.tpl view
@@ -0,0 +1,25 @@+<actionlogFilterForm method="GET">+ <dfErrorList ref=""/>++ <dfLabel ref="user">User</dfLabel>+ <dfInputSelect ref="user" />+ <dfErrorList ref="user"/>+ <br>++ <dfLabel ref="entity">Entity</dfLabel>+ <dfInputSelect ref="entity"/>+ <dfErrorList ref="entity"/>+ <br>++ <dfLabel ref="entity-id">Entity ID</dfLabel>+ <dfInputText ref="entity-id"/>+ <dfErrorList ref="entity-id"/>+ <br>++ <dfLabel ref="action">Action</dfLabel>+ <dfInputSelect ref="action" />+ <dfErrorList ref="action"/>+ <br>++ <dfInputSubmit class="btn btn-success" value="Refresh"/>+</actionlogFilterForm>
+ resources/templates/_list.tpl view
@@ -0,0 +1,29 @@+<table class="table table-striped actionList">+ <thead>+ <tr>+ <th>Timestamp</th>+ <th>User</th>+ <th>Entity Name</th>+ <th>Entity ID</th>+ <th>Action</th>+ </tr>+ </thead>+ <tbody>+ <actionlogListing>+ <tr>+ <td><a href="${actionlogItemShowPath}"><loggedActionAt/></a></td>+ <td><loggedActionUserName/></td>+ <td><loggedActionEntityName/></td>+ <td><loggedActionEntityId/></td>+ <td><loggedActionAction/></td>+ </tr>+ </actionlogListing>+ </tbody>+</table>++<script >+ $(function() {+ $("table.actionList").tablesorter({ sortList: [[0,0]] });+ });+</script>+
+ resources/templates/index.tpl view
@@ -0,0 +1,23 @@+<apply template='_application'>++ <bind tag='pageHeader'>+ Action Log+ </bind>++ <bind tag='pageTagline'>+ history of modifications to your data+ </bind>+++ <bind tag='contentSecondary'>+ <h3>Action Log Filter</h3>+ <apply template="${actionlogTemplate}/_form"/>+ </bind>++ <bind tag='contentMain'>+ <apply template="${actionlogTemplate}/_list"/>+ </bind>++</apply>++
+ resources/templates/show.tpl view
@@ -0,0 +1,19 @@+<apply template='_application'>++ <bind tag='pageHeader'>+ Item Details+ </bind>++ <bind tag='contentSecondary'>+ <div class="alert alert-info">+ <p>Details for a single action log item</p>+ </div>+ </bind>+ + <bind tag='contentMain'>+ <apply template="${actionlogTemplate}/_details"/>+ </bind>++</apply>++
+ schema.txt view
@@ -0,0 +1,14 @@+LoggedAction+ tenantId Int+ userId Int+ entityName Text+ entityId Int+ action ActionType+ at UTCTime default=now()++LoggedActionDetails+ actionId LoggedActionId+ fieldName Text+ oldValue Text+ newValue Text+
+ snaplet-actionlog.cabal view
@@ -0,0 +1,67 @@+name: snaplet-actionlog+version: 0.2+synopsis: Generic action log snaplet for the Snap Framework+description: This snaplet contains support for logging website actions.+ Common actions are creating, updating, and deleting records.+license: BSD3+license-file: LICENSE+author: Soostone Inc. Ozgun Ataman, Doug Beardsley+maintainer: ozataman@gmail.com, mightybyte@gmail.com+build-type: Simple+cabal-version: >= 1.6+homepage: https://github.com/soostone/snaplet-actionlog+category: Web, Snap++extra-source-files: LICENSE++data-files:+ schema.txt+ resources/templates/index.tpl+ resources/templates/show.tpl+ resources/templates/_details.tpl+ resources/templates/_form.tpl+ resources/templates/_list.tpl++source-repository head+ type: git+ location: https://github.com/soostone/snaplet-actionlog.git++Library+ hs-source-dirs: src++ exposed-modules:+ Snap.Snaplet.ActionLog++ other-modules:+ Snap.Snaplet.ActionLog.API+ Snap.Snaplet.ActionLog.Resource+ Snap.Snaplet.ActionLog.Types+ Snap.Snaplet.ActionLog.InternalTypes+ Paths_snaplet_actionlog++ build-depends:+ base >= 4 && < 5,+ blaze-builder >= 0.3 && < 0.4,+ bytestring >= 0.9.1 && < 0.11,+ digestive-functors >= 0.6 && < 0.7,+ digestive-functors-heist >= 0.7 && < 0.8,+ digestive-functors-snap >= 0.6 && < 0.7,+ errors >= 1.4.1 && < 1.5,+ heist >= 0.12 && < 0.13,+ persistent >= 1.2 && < 1.3,+ persistent-postgresql >= 1.2 && < 1.3,+ persistent-template >= 1.2 && < 1.3,+ readable >= 0.1 && < 0.2,+ restful-snap >= 0.1 && < 0.2,+ snap >= 0.11.3 && < 0.13,+ snap-extras >= 0.4 && < 0.6,+ snaplet-persistent >= 0.2 && < 0.3,+ text >= 0.11 && < 0.12,+ time >= 1.1 && < 1.5,+ transformers >= 0.3 && < 0.4,+ unordered-containers >= 0.2 && < 0.3,+ xmlhtml >= 0.2 && < 0.3+++ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+ -fno-warn-orphans -fno-warn-unused-do-bind
+ src/Snap/Snaplet/ActionLog.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Snap.Snaplet.ActionLog+ ( -- * Core types and functions+ ActionLog+ , initActionLog+ , HasActionLog(..)+ , ActionType(..)+ , actionToInt+ , intToAction+ , DeltaField(..)+ , CanDelta(..)+ , storeDeltas+ , getDeltas++ -- * Retrieving actions+ , getLoggedAction+ , getEntityActions+ , getAllActions+ , getTenantActions+ , getTenantEntities+ , getTenantUids++ -- * Storing actions+ -- $storingActions+ , logAction+ , loggedInsert+ , loggedReplace+ , loggedUpdate+ , loggedDelete+ , loggedDeleteKey++ -- * Types+ , actionLogEntityDefs+ , migrateActionLog+ , LoggedActionGeneric(..)+ , LoggedAction+ , LoggedActionId+ , LoggedActionDetailsGeneric(..)+ , LoggedActionDetails+ , LoggedActionDetailsId++ ) where++------------------------------------------------------------------------------+import Data.Monoid+import Data.Text.Encoding+import Heist+import qualified Heist.Interpreted as I+import Snap+import Snap.Restful+import Snap.Snaplet.Heist.Compiled+------------------------------------------------------------------------------+import Snap.Snaplet.ActionLog.API+import Snap.Snaplet.ActionLog.Resource+import Snap.Snaplet.ActionLog.Types+import Paths_snaplet_actionlog+++------------------------------------------------------------------------------+-- | Initializer for the action log snaplet. It sets up templates, routes,+-- and compiled and interpreted splices.+--+-- Includes two built-in top level splices: actionLogListing and+-- actionLogFilterForm+initActionLog :: (HasActionLog (Handler b b), HasHeist b)+ => Snaplet (Heist b) -> SnapletInit b ActionLog+initActionLog heist = makeSnaplet "actionlog" description datadir $ do+ url <- getSnapletRootURL+ let resource = actionLogR { rRoot = decodeUtf8 url }+ addResourceRelative resource+ [(RIndex, indexH), (RShow, showH)] [] [] heist++ addConfig heist $ mempty+ { hcCompiledSplices = actionLogSplices resource+ , hcInterpretedSplices = actionLogISplices resource++ -- Load time splices are for splices that can be used in the apply and+ -- bind tags.+ , hcLoadTimeSplices =+ [ ("actionlogTemplate", I.textSplice $ decodeUtf8 url)+ ]+ }+ addTemplates heist ""+ return ActionLog+ where+ description = "Snaplet providing generalized logging"+ datadir = Just $ liftM (++"/resources") getDataDir++-- $storingActions+-- These functions provide a nice API for logging actions based on database+-- operations. Typically you should be able to simply substitute the+-- 'loggedInsert', 'loggedUpdate', etc functions in the place of your existing+-- calls to 'insert', 'update', etc from the persistent library.+
+ src/Snap/Snaplet/ActionLog/API.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Snap.Snaplet.ActionLog.API where++------------------------------------------------------------------------------+import Control.Monad+import Data.Functor.Identity+import Data.Text (Text)+import Data.Text.Encoding+import Database.Persist+import Database.Persist.Sql+import Snap.Snaplet.Persistent+------------------------------------------------------------------------------+import Snap.Snaplet.ActionLog.Types+++------------------------------------------------------------------------------+-- Adding entries to the action log+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Calculates a list of fields that changed along with ByteString+-- representations of their old and new values.+storeDeltas :: (HasPersistPool m, CanDelta a)+ => LoggedActionId -> a -> a -> m ()+storeDeltas aid old new = do+ runPersist $ mapM_ ins $ getDeltas old new+ where+ ins (f,o,n) = insert $+ LoggedActionDetails aid f (decodeUtf8 o) (decodeUtf8 n)+++------------------------------------------------------------------------------+-- Adding entries to the action log+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Low level function for logging an action. Usually you will want to use+-- one of the other functions like 'loggedInsert'. But when those aren't+-- sufficient, this function provides you maximum control to log actions as+-- you see fit.+logAction :: HasActionLog m+ => Text+ -- ^ Entity name. If you are logging database modifications,+ -- then this might be the name of the table being operated on.+ -> Int+ -- ^ Entity ID. This is the primary key for the affected row.+ -> ActionType+ -- ^ Type of action, such as create, update, or delete.+ -> m (Key LoggedAction)+logAction entityName entityId action = do+ tid <- alGetTenantId+ uid <- alGetAuthUserId+ now <- alGetTime+ runPersist $ insert $+ LoggedAction tid uid entityName entityId action now+++------------------------------------------------------------------------------+-- | Performs a logged insert into the database. Just about everything should+-- be inserted using this function instead of @runPersist' . insert@+loggedInsert val = do+ let entityName = getName val+ recKey <- runPersist $ insert val+ let entityId = mkInt recKey+ logAction entityName entityId CreateAction+ return recKey+++------------------------------------------------------------------------------+-- | Performs a logged replace of a database record.+loggedReplace key new = do+ old <- runPersist $ get key+ maybe (return ()) (\o -> loggedReplace' key o new) old+++------------------------------------------------------------------------------+-- | Performs a logged replace of a database record.+loggedReplace'+ :: (PersistEntity a, CanDelta a, HasActionLog m,+ PersistEntityBackend a ~ SqlBackend) =>+ Key a -> a -> a -> m ()+loggedReplace' key old new = do+ let entityName = getName new+ runPersist $ replace key new+ let entityId = mkInt key+ aid <- logAction entityName entityId UpdateAction+ storeDeltas aid old new+ return ()+++------------------------------------------------------------------------------+-- | Performs a logged update of a database record.+loggedUpdate key updates = do+ old <- runPersist $ get key+ maybe (return ()) (\o -> loggedUpdate' key o updates) old+++------------------------------------------------------------------------------+-- | Performs a logged update of a database record.+loggedUpdate'+ :: (PersistEntity a, CanDelta a, HasActionLog m,+ PersistEntityBackend a ~ SqlBackend)+ => Key a+ -> a+ -> [Update a]+ -> m ()+loggedUpdate' key old updates = do+ val <- runPersist $ updateGet key updates+ new <- runPersist $ get key+ let entityName = getName val+ let entityId = mkInt key+ aid <- logAction entityName entityId UpdateAction+ maybe (return ()) (\n -> storeDeltas aid old n) new+ return ()+++------------------------------------------------------------------------------+-- | Performs a logged delete of an entity in the database.+loggedDelete+ :: forall m a.+ (HasActionLog m, PersistEntity a,+ PersistEntityBackend a ~ SqlBackend)+ => Entity a+ -> m ()+loggedDelete (Entity key val) = do+ runPersist $ delete key+ logAction (getName val) (mkInt key) DeleteAction+ return ()+++------------------------------------------------------------------------------+-- | Performs a logged delete of a key in the database.+loggedDeleteKey+ :: (PersistEntity a, HasActionLog m,+ PersistEntityBackend a ~ SqlBackend)+ => Key a+ -> m ()+loggedDeleteKey key = do+ mval <- runPersist $ Database.Persist.get key+ case mval of+ Nothing -> return ()+ Just val -> loggedDelete (Entity key val)+++-- | Get human name for a database table defined to be an 'Entity'.+getName :: forall a. PersistEntity a => a -> Text+getName val = unHaskellName $ entityHaskell ed+ where+ ed = entityDef val'+ val' = return val :: Identity a+++------------------------------------------------------------------------------+-- Retrieving log entries+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Gets the LoggedAction entry for the specified entity and id.+getLoggedAction :: HasPersistPool m+ => LoggedActionId -> m (Maybe LoggedAction)+getLoggedAction actionId = runPersist $ get actionId+++------------------------------------------------------------------------------+-- | Gets the LoggedAction entry for the specified entity and id.+getEntityActions :: HasPersistPool m+ => Text -> Int -> m [Entity LoggedAction]+getEntityActions entityName entityId = runPersist $+ selectList [ LoggedActionEntityName ==. entityName+ , LoggedActionEntityId ==. entityId+ ] []+++------------------------------------------------------------------------------+-- | Gets all the actions in the action log. In multi-tenant applications+-- you probably want this to only be accessible by the administrator of the+-- whole site.+getAllActions :: HasPersistPool m => m [Entity LoggedAction]+getAllActions = runPersist $ selectList [] []+++------------------------------------------------------------------------------+-- | Gets all the logged actions for the current tenant.+getTenantActions :: HasActionLog m+ => [Filter LoggedAction]+ -> [SelectOpt LoggedAction]+ -> m [Entity LoggedAction]+getTenantActions filters opts = do+ tid <- alGetTenantId+ runPersist $ selectList ((LoggedActionTenantId ==. tid):filters) opts+++------------------------------------------------------------------------------+-- | Gets a list of all entities for a specific tenant.+getTenantEntities :: (HasActionLog m) => m [Text]+getTenantEntities = do+ tid <- alGetTenantId+ liftM (map unSingle) $ runPersist $ rawSql+ "SELECT DISTINCT entity_name from logged_action WHERE tenant_id = ?;"+ [PersistInt64 $ fromIntegral tid]+++------------------------------------------------------------------------------+-- | Gets a list of all uids for a specific tenant.+getTenantUids :: (HasActionLog m) => m [Int]+getTenantUids = do+ tid <- alGetTenantId+ liftM (map unSingle) $ runPersist $ rawSql+ "SELECT DISTINCT user_id from logged_action WHERE tenant_id = ?;"+ [PersistInt64 $ fromIntegral tid]+++------------------------------------------------------------------------------+-- | Gets a list of all uids for a specific tenant.+getActionDetails :: (HasActionLog m)+ => LoggedActionId+ -> m [Entity LoggedActionDetails]+getActionDetails aid =+ runPersist $ selectList [ LoggedActionDetailsActionId ==. aid ] []++
+ src/Snap/Snaplet/ActionLog/InternalTypes.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Snap.Snaplet.ActionLog.InternalTypes where++------------------------------------------------------------------------------+import Blaze.ByteString.Builder+import Control.Monad+import Data.ByteString (ByteString)+import Data.Int+import Data.Readable+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding+import Data.Time+import Data.Word+import Database.Persist+import Database.Persist.Quasi+import Database.Persist.Sql+import Database.Persist.TH+import Heist.Compiled+import qualified Heist.Interpreted as I+import Snap.Restful+import Snap.Restful.TH+import Snap.Snaplet.Persistent+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Opaque data type holding any state needed by the action log snaplet.+data ActionLog = ActionLog+++------------------------------------------------------------------------------+-- | Enumeration of possible actions in the action log.+data ActionType+ = CreateAction+ | UpdateAction+ | DeleteAction+ deriving (Ord, Eq, Enum, Bounded)++++------------------------------------------------------------------------------+-- | Converts an ActionType into an Int to be stored in the database. We+-- don't want to use fromEnum here because that will make the numbers+-- sensitive to the ordering of the data type and easier to screw up.+actionToInt :: ActionType -> Int+actionToInt CreateAction = 0+actionToInt UpdateAction = 1+actionToInt DeleteAction = 2+++------------------------------------------------------------------------------+-- | Converts an Int into an ActionType. Again, we want this to be explicit+-- rather than implied by toEnum.+intToAction :: Int -> Either Text ActionType+intToAction 0 = Right CreateAction+intToAction 1 = Right UpdateAction+intToAction 2 = Right DeleteAction+intToAction _ = Left "int value is not a valid ActionType"++------------------------------------------------------------------------------+-- | Use human readable names for the Show instance.+instance Show ActionType where+ show CreateAction = "Create"+ show UpdateAction = "Update"+ show DeleteAction = "Delete"+++------------------------------------------------------------------------------+-- | Use human readable names for the Show instance.+instance Readable ActionType where+ fromText "Create" = return CreateAction+ fromText "Update" = return UpdateAction+ fromText "Delete" = return DeleteAction+ fromText _ = mzero+++------------------------------------------------------------------------------+-- | We need to derive PersistField so ActionType can be a column in the+-- LoggedAction table.+instance PersistField ActionType where+ toPersistValue = PersistInt64 . fromIntegral . actionToInt+ fromPersistValue (PersistInt64 n) = intToAction $ fromIntegral n+ fromPersistValue _ = Left "ActionType must be backed by a database int"+++instance PersistFieldSql ActionType where+ sqlType _ = SqlInt32++------------------------------------------------------------------------------+-- | Create primitive splices using the show instance.+instance PrimSplice ActionType where+ iPrimSplice = iPrimShow+ cPrimSplice = cPrimShow
+ src/Snap/Snaplet/ActionLog/Resource.hs view
@@ -0,0 +1,381 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++module Snap.Snaplet.ActionLog.Resource+ ( actionLogR+ , indexH+ , showH+ , actionLogSplices+ , actionLogISplices+ ) where++------------------------------------------------------------------------------+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char8+import Control.Error+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+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+ <$> "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 -> [(Text, Splice n)]+actionLogSplices r =+ [ ("actionDetails", actionViewSplice r)+ , ("defaultActions", defaultActionsSplice r) + ]+ ++ applyDeferred (return mempty) (coupledSplices r False)+++coupledSplices :: (HasActionLog n, MonadSnap n)+ => Resource -> Bool -> [(Text, Promise LogFilter -> Splice n)]+coupledSplices r b =+ [ ("actionlogListing", actionsSplice r (runLogFilterForm b))+ , ("actionlogFilterForm", 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))+ -> Promise LogFilter+ -> Splice n+actionsSplice res form prom = manyWithSplices runChildren (actionSplices res) $ do+ f <- getPromise prom+ (_,r) <- lift $ form Nothing+ let filters = case r of+ Nothing -> []+ Just lf -> mkFilters (f `mappend` lf)+ lift $ getTenantActions filters []+++applyDeferred :: Monad n+ => RuntimeSplice n a+ -> [(Text, Promise a -> Splice n)]+ -> [(Text, Splice n)]+applyDeferred m = applySnd m . mapSnd defer+++actionSplices :: HasActionLog n+ => Resource+ -> [(Text, Promise (Entity LoggedAction) -> Splice n)]+actionSplices r =+ ("loggedActionUserName", runtimeToPromise getName) :+ ("loggedActionDetails", detailsSplice) :+ (pureSplices loggedActionCSplices +++ alCustomCSplices +++ repromise (return . DBId . mkWord64 . entityKey)+ (pureSplices $ textSplices $ itemCSplices r)+ )+ where+ getName = return . fromText <=< alGetName . loggedActionUserId . entityVal+ detailsSplice prom =+ manyWithSplices runChildren (pureSplices detailsCSplices)+ (lift . getActionDetails . entityKey =<< getPromise prom)+ ++runtimeToPromise :: (Monad n) => (t -> n Builder) -> Promise t -> Splice n+runtimeToPromise f p = return $ yieldRuntime $ do+ entity <- getPromise p+ lift $ f entity+++-------------------------------------------------------------------------------+logFilterFormSplice :: Monad m+ => (Maybe a -> m (View Text, b))+ -> Promise a+ -> Splice m+logFilterFormSplice form prom =+ formSplice [] [] $ do+ f <- getPromise prom+ 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 -> [(Text, I.Splice n)]+actionLogISplices r =+ [ ("actionDetails", actionDetailsISplice r) + , ("defaultActions", defaultActionsISplice r) + ]+ ++ coupledISplices r False mempty+++coupledISplices :: (HasActionLog m, MonadSnap m)+ => Resource -> Bool -> LogFilter -> [(Text, I.Splice m)]+coupledISplices r b f =+ [ ("actionlogListing", actionLogListingISplice r (runLogFilterForm b) f)+ , ("actionlogFilterForm", 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+ -> [(Text, I.Splice m)]+actionISplices r e =+ ("loggedActionUserName", I.textSplice =<< getName) :+ ("loggedActionDetails", detailsISplice) :+ (loggedActionISplices (entityVal e) +++ alCustomISplices e +++ itemSplices r (DBId $ mkWord64 $ entityKey e)+ )+ where+ getName = 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++
+ src/Snap/Snaplet/ActionLog/Types.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Snap.Snaplet.ActionLog.Types+ ( ActionLog (..)+ , ActionType (..)+ , actionToInt+ , intToAction++ , module Snap.Snaplet.ActionLog.Types+ ) where++------------------------------------------------------------------------------+import Blaze.ByteString.Builder+import Data.ByteString (ByteString)+import Data.Int+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding+import Data.Time+import Data.Word+import Database.Persist+import Database.Persist.Quasi+import Database.Persist.TH+import Heist.Compiled+import qualified Heist.Interpreted as I+import Snap.Restful+import Snap.Restful.TH+import Snap.Snaplet.Persistent+------------------------------------------------------------------------------+import Snap.Snaplet.ActionLog.InternalTypes+-------------------------------------------------------------------------------++++------------------------------------------------------------------------------+-- | The list of entity definitions this snaplet exposes. You need them so+-- that you can append to your application's list of entity definitions and+-- perform the migration in one block.+--+-- Here's an example of how to combine your app's own entity definitions and+-- the action log's in one migration block:+--+-- > share [mkMigrate "migrateAll"] $+-- > actionLogEntityDefs +++-- > $(persistFileWith lowerCaseSettings "schema.txt")+actionLogEntityDefs :: [EntityDef SqlType]+actionLogEntityDefs = $(persistFileWith lowerCaseSettings "schema.txt")+++share [mkPersist sqlSettings, mkMigrate "migrateActionLog"]+ $(persistFileWith lowerCaseSettings "schema.txt")+++loggedActionCSplices :: [(Text, Entity LoggedAction -> Builder)]+loggedActionCSplices = mapSnd (. entityVal) $(cSplices ''LoggedAction)+++loggedActionISplices :: Monad m => LoggedAction -> [(Text, I.Splice m)]+loggedActionISplices = $(iSplices ''LoggedAction)+++detailsCSplices :: [(Text, Entity LoggedActionDetails -> Builder)]+detailsCSplices = mapSnd (. entityVal) $(cSplices ''LoggedActionDetails)+++detailsISplices :: Monad m => LoggedActionDetails -> [(Text, I.Splice m)]+detailsISplices = $(iSplices ''LoggedActionDetails)++++instance PrimSplice LoggedActionId where+ iPrimSplice = iPrimShow . mkInt+ cPrimSplice = cPrimShow . mkInt+++------------------------------------------------------------------------------+-- | Type class that must be implemented to have an action log. You do not+-- have to have any custom splices. If you don't need to add splices to what+-- the snaplet provides by default, just have the custom splice functions+-- return an empty list.+--+-- One potential use for the custom splices might be if you want to display+-- your own custom information in action log lists. Maybe you want to display+-- a user email address in addition to their name, or maybe instead of+-- displaying raw entity IDs you want to do some DB query to get a different+-- field for display. The custom splices allow you to make any runtime+-- function of a LoggedAction into a splice that can be displayed in action+-- log templates.+class (HasPersistPool m) => HasActionLog m where++ -- | Gets a tenant ID for the current user of your application. If your+ -- application is not multi-tenanted, then you can just return a constant+ -- here.+ alGetTenantId :: m Int++ -- | Gets the current user's user ID. Again, if your application does not+ -- have the concept of a user, you can return a constant.+ alGetAuthUserId :: m Int++ -- | In latency sensitive applications where time stamps are used+ -- frequently, you may want to do the system call once and then cache the+ -- results. This function allows you to provide your own cache-aware+ -- version of getTime if you choose. Otherwise you can just lift the+ -- getCurrentTime function from Data.Time.Clock into your monad.+ alGetTime :: m UTCTime++ -- | Function that takes a user ID and returns the user's name, email, or+ -- whatever you want the snaplet to call that user. This function is used+ -- to generate the user dropdown box in action log filter controls.+ alGetName :: Int -> m Text++ -- | Complied version of any custom splices that you want to be available+ -- inside the @actionLogListing@ splice.+ alCustomCSplices :: [(Text, Promise (Entity LoggedAction) -> Splice m)]++ -- | Interpreted version of any custom splices that you want to be+ -- available inside the @actionLogListing@ splice.+ alCustomISplices :: Entity LoggedAction -> [(Text, I.Splice m)]++++------------------------------------------------------------------------------+-- | To store deltas, you need to be able to get Text representations of each+-- field.+class DeltaField a where+ toBS :: a -> ByteString++instance DeltaField ByteString where+ toBS = id++instance DeltaField Text where+ toBS = encodeUtf8++instance DeltaField String where+ toBS = toBS . T.pack++instance DeltaField Bool where+ toBS = toBS . show++instance DeltaField Int where+ toBS = toBS . show++instance DeltaField Int8 where+ toBS = toBS . show++instance DeltaField Int16 where+ toBS = toBS . show++instance DeltaField Int32 where+ toBS = toBS . show++instance DeltaField Int64 where+ toBS = toBS . show++instance DeltaField Integer where+ toBS = toBS . show++instance DeltaField Float where+ toBS = toBS . show++instance DeltaField Double where+ toBS = toBS . show++instance DeltaField Word where+ toBS = toBS . show++instance DeltaField Word8 where+ toBS = toBS . show++instance DeltaField Word16 where+ toBS = toBS . show++instance DeltaField Word32 where+ toBS = toBS . show++instance DeltaField Word64 where+ toBS = toBS . show++instance DeltaField a => DeltaField (Maybe a) where+ toBS Nothing = "Nothing"+ toBS (Just a) = toBS a++instance (b ~ PersistEntityBackend e) => DeltaField (KeyBackend b e) where+ toBS = toBS . mkInt++class CanDelta a where+ deltaFields :: [(Text, a -> ByteString)]+++------------------------------------------------------------------------------+-- | Calculates a list of fields that changed along with ByteString+-- representations of their old and new values.+getDeltas :: (CanDelta a) => a -> a -> [(Text, ByteString, ByteString)]+getDeltas old new = do+ func [] deltaFields+ where+ func !acc [] = acc+ func !acc ((name, f):fs) =+ if oldField == newField+ then func acc fs+ else func ((name, oldField, newField):acc) fs+ where+ oldField = f old+ newField = f new+