diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain
diff --git a/resources/templates/_details.tpl b/resources/templates/_details.tpl
new file mode 100644
--- /dev/null
+++ b/resources/templates/_details.tpl
@@ -0,0 +1,43 @@
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/schema.txt b/schema.txt
new file mode 100644
--- /dev/null
+++ b/schema.txt
@@ -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
+
diff --git a/snaplet-actionlog.cabal b/snaplet-actionlog.cabal
new file mode 100644
--- /dev/null
+++ b/snaplet-actionlog.cabal
@@ -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
diff --git a/src/Snap/Snaplet/ActionLog.hs b/src/Snap/Snaplet/ActionLog.hs
new file mode 100644
--- /dev/null
+++ b/src/Snap/Snaplet/ActionLog.hs
@@ -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.
+
diff --git a/src/Snap/Snaplet/ActionLog/API.hs b/src/Snap/Snaplet/ActionLog/API.hs
new file mode 100644
--- /dev/null
+++ b/src/Snap/Snaplet/ActionLog/API.hs
@@ -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 ] []
+
+
diff --git a/src/Snap/Snaplet/ActionLog/InternalTypes.hs b/src/Snap/Snaplet/ActionLog/InternalTypes.hs
new file mode 100644
--- /dev/null
+++ b/src/Snap/Snaplet/ActionLog/InternalTypes.hs
@@ -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
diff --git a/src/Snap/Snaplet/ActionLog/Resource.hs b/src/Snap/Snaplet/ActionLog/Resource.hs
new file mode 100644
--- /dev/null
+++ b/src/Snap/Snaplet/ActionLog/Resource.hs
@@ -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
+
+
diff --git a/src/Snap/Snaplet/ActionLog/Types.hs b/src/Snap/Snaplet/ActionLog/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Snap/Snaplet/ActionLog/Types.hs
@@ -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
+