yesod-datatables (empty) → 0.1
raw patch · 8 files changed
+648/−0 lines, 8 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, attoparsec, base, bytestring, data-default, monad-control, persistent, persistent-sqlite, persistent-template, resourcet, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2, text, transformers, yesod, yesod-auth, yesod-core, yesod-datatables, yesod-default, yesod-form, yesod-static
Files
- LICENSE +25/−0
- Setup.hs +2/−0
- Yesod/DataTables.hs +14/−0
- Yesod/DataTables/Query.hs +86/−0
- Yesod/DataTables/Reply.hs +33/−0
- Yesod/DataTables/Request.hs +187/−0
- tests/main.hs +218/−0
- yesod-datatables.cabal +83/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2012, Tero Laitinen. All rights reserved.++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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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,2 @@+import Distribution.Simple+main = defaultMain
+ Yesod/DataTables.hs view
@@ -0,0 +1,14 @@+-- | DataTables (http://datatables.net) is a capable plugin for jQuery +-- Javascript library. This Haskell library contains routines for implementing+-- server-side processing (e.g. request parsing and response formatting) for+-- DataTables with Yesod platform.+-- +-- See the example at http://yesod-datatables-example.herokuapp.com .+module Yesod.DataTables (+ module Yesod.DataTables.Request,+ module Yesod.DataTables.Query,+ module Yesod.DataTables.Reply) where++import Yesod.DataTables.Request+import Yesod.DataTables.Query+import Yesod.DataTables.Reply
+ Yesod/DataTables/Query.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+-- | This module is used to make database queries based on the+-- DataTables request. +module Yesod.DataTables.Query (DataTable(..), + RegexFlag,+ ColumnName,+ dataTableSelect) where++import Prelude+import Yesod.DataTables.Request+import Yesod.DataTables.Reply+import Data.Text+import Control.Monad (liftM)+import Database.Persist as D+import Data.Aeson as J+-- | Type synonym for indicating whether a search string is a regular+-- expression.+type RegexFlag = Bool++-- | The functions in a DataTable define how search strings, column sorting,+-- filtering and value fetching is implemented.+data DataTable val = DataTable {+ -- | mapping global search field to filters+ dtGlobalSearch :: Text -> RegexFlag -> [Filter val],++ -- | mapping sorting instructions to select options+ dtSort :: [(ColumnName,SortDir)] -> [SelectOpt val],++ -- | mapping a column search to filters+ dtColumnSearch :: ColumnName -> Text -> RegexFlag -> [Filter val],++ -- | filters that are always applied+ dtFilters :: [Filter val],++ -- | mapping column name and entity to a textual value+ dtValue :: forall m. (PersistQuery m,+ PersistEntityBackend val ~ PersistMonadBackend m)+ => ColumnName -> Entity val -> m Text,++ -- | mapping entity to a row identifier+ dtRowId :: forall m. (PersistQuery m,+ PersistEntityBackend val ~ PersistMonadBackend m)+ => Entity val -> m Text+ }++-- | selects records from database and populates the grid columns using +-- callback functions (which can issue follow-up queries)+dataTableSelect :: (PersistEntity val, + PersistQuery m, + PersistEntityBackend val ~ PersistMonadBackend m) + => DataTable val -> Request -> m Reply+dataTableSelect (DataTable dtGlobalSearch' dtSort' dtColumnSearch' dtFilters' dtValue' dtRowId') req = do+ totalCount <- D.count $ dtFilters'+ let filters = dtFilters' ++ colSearchFilters ++ globalSearchFilters+ displayCount <- D.count filters+ entities <- D.selectList filters selectOpts+ rowId <- dtRowId' (Prelude.head entities)+ records <- mapM formatEntity entities+ return $ Reply {+ replyNumRecords = fromIntegral totalCount,+ replyNumDisplayRecords = displayCount,+ replyRecords = J.toJSON $ records,+ replyEcho = reqEcho req+ }+ where+ colSearchFilters = Prelude.concatMap (\(c,s,r) -> dtColumnSearch' c s r) + [ (colName c, + colSearch c, + colSearchRegex c)+ | c <- reqColumns req, colSortable c ]+ globalSearchFilters = dtGlobalSearch' (reqSearch req) + (reqSearchRegex req)+ + formatEntity entity = do+ rowId <- dtRowId' entity+ columns <- mapM (formatColumn entity) [colName c | c <- reqColumns req]+ return $ J.object $ [ "DT_RowId" .= rowId ] ++ columns+ formatColumn entity cn = do+ value <- dtValue' cn entity+ return $ cn .= value+ selectOpts = [OffsetBy (reqDisplayStart req),+ LimitTo (reqDisplayLength req)] + ++ dtSort' (reqSort req)+
+ Yesod/DataTables/Reply.hs view
@@ -0,0 +1,33 @@+-- | DataTables reply formatting.+module Yesod.DataTables.Reply (Reply(..), formatReply) where+import Prelude+import qualified Data.ByteString.Lazy as L+import Data.Aeson as J++-- | Container for holding the reply to DataTables jQuery plugin.+data Reply = Reply {+ -- |Total records, before filtering + -- (i.e. the total number of records in the database).+ replyNumRecords :: Int,++ -- |Total records, after filtering (i.e. the total number of records + -- after filtering has been applied - not just the number of records + -- being returned in this result set). + replyNumDisplayRecords :: Int,++ -- |An array of JSON objects, one for each record.+ replyRecords :: J.Value,++ -- |An unaltered copy of 'sEcho' sent from the client side. + replyEcho :: Int+} deriving (Eq, Show)++-- |Translates the reply object to a JSON value that DataTables javascript+-- plugin expects.+formatReply :: Reply -> J.Value+formatReply reply = J.object [+ "iTotalRecords" .= replyNumRecords reply,+ "iTotalDisplayRecords" .= replyNumDisplayRecords reply,+ "sEcho" .= replyEcho reply,+ "aaData" .= replyRecords reply+ ]
+ Yesod/DataTables/Request.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE OverloadedStrings #-}+-- | DataTables request parsing.+module Yesod.DataTables.Request (Request(..), Column(..), ColumnName, SortDir(..),+ parseRequest) where+import Prelude+import Data.Aeson as J+import Data.Attoparsec (parse, maybeResult)+import Data.List as L+import Data.Maybe+import Data.Text as T+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.Text.Encoding as E++-- | HTTP request (GET/POST) parameter name+type ParamName = Text++-- | HTTP request (GET/POS) parameter value+type ParamValue = Text++-- | enum for sSortDir_(int) +data SortDir = SortAsc | SortDesc deriving (Eq, Show)++-- | Name of DataTables grid column +type ColumnName = Text++-- | information about grid column +data Column = Column {+ -- | whether searching is enabled at client-side+ colSearchable :: Bool,++ -- | column-specific search query + colSearch :: Text,++ -- | whether search query should be interpreted as a regular expression+ colSearchRegex :: Bool,++ -- | whether sorting is enabled at client-side+ colSortable :: Bool,++ -- | column name (client-side also expects the data in a field with the+ -- same name + colName :: Text+} deriving (Show, Eq)+++-- | DataTables grid server-side request+-- (see http://datatables.net/usage/server-side)+data Request = Request {+ -- | Display start point in the current data set.+ reqDisplayStart :: Int,++ -- | Number of records that the table can display in the current draw. It is expected that the number of records returned will be equal to this number, unless the server has fewer records to return.+ reqDisplayLength :: Int,++ -- | Global search field+ reqSearch :: Text,++ -- | True if the global filter should be treated as a regular expression for advanced filtering, false if not.+ reqSearchRegex :: Bool,++ -- | columns that the client-side knows about+ reqColumns :: [Column],++ -- | result set sorting instructions + reqSort :: [(ColumnName,SortDir)],++ -- | Information for DataTables to use for rendering (do not alter).+ reqEcho :: Int+} deriving (Show, Eq)++readMaybe :: (Read a) => Maybe Text -> Maybe a+readMaybe (Just s) = case reads (unpack s) of+ [(x, "")] -> Just x+ _ -> Nothing+readMaybe _ = Nothing++readBool :: Maybe Text -> Maybe Bool+readBool (Just "true") = Just True+readBool (Just "false") = Just False+readBool _ = Nothing++parseColumn :: Text+ -> Text+ -> Text+ -> Text+ -> Text+ -> Maybe Column+parseColumn searchable'+ search+ regex'+ sortable'+ dataProp = do++ searchable <- readBool $ Just searchable'+ regex <- readBool $ Just regex'+ sortable <- readBool $ Just sortable'+ + return $ Column {+ colSearchable = searchable,+ colSearch = search,+ colSearchRegex = regex,+ colSortable = sortable,+ colName = dataProp+ }+ +checkColumns :: [Maybe Column] -> Int -> Maybe [Column]+checkColumns mcolumns nColumns= let+ columns = catMaybes mcolumns+ in + if L.length columns == nColumns+ then Just columns+ else Nothing++readSortDir :: Text -> Maybe SortDir+readSortDir "asc" = Just SortAsc+readSortDir "desc" = Just SortDesc+readSortDir _ = Nothing++parseSortDir :: [Column] -> Text -> Text -> Maybe (ColumnName, SortDir)+parseSortDir columns idStr sortDir = do+ idNum <- readMaybe (Just idStr)+ name <- maybeColumnName idNum+ dir <- readSortDir sortDir+ return (name, dir)+ where+ maybeColumnName colId + | colId < 0 = Nothing+ | colId >= L.length columns = Nothing+ | otherwise = Just $ colName (columns !! colId)+++-- | Tries to parse DataTables request+parseRequest :: [(ParamName, ParamValue)] -> Maybe Request+parseRequest params = do+ displayStart <- readMaybe $ param "iDisplayStart" + displayLength <- readMaybe $ param "iDisplayLength"+ nColumns <- readMaybe $ param "iColumns"+ search <- param "sSearch"+ regex <- readBool $ param "bRegex"+ cSearchable <- manyParams "bSearchable_" nColumns + cSearch <- manyParams "sSearch_" nColumns+ cRegex <- manyParams "bRegex_" nColumns+ cSortable <- manyParams "bSortable_" nColumns+ cName <- manyParams "mDataProp_" nColumns+ let columnData = L.zipWith5 parseColumn + cSearchable+ cSearch+ cRegex+ cSortable+ cName+ columns <- checkColumns columnData nColumns++ nSortingCols <- readMaybe $ param "iSortingCols"++ sortingCols <- manyParams "iSortCol_" nSortingCols+ sortingColsDir <- manyParams "sSortDir_" nSortingCols++ echo <- readMaybe $ param "sEcho"++ let sortInfo = catMaybes $ L.zipWith (parseSortDir columns)+ sortingCols sortingColsDir++ return $ Request {+ reqDisplayStart = displayStart,+ reqDisplayLength = displayLength,+ reqSearch = search,+ reqSearchRegex = regex,+ reqColumns = columns,+ reqSort = sortInfo,+ reqEcho = echo+ }+ where+ param :: ParamName -> Maybe ParamValue+ param key = lookup key params+ manyParams :: ParamName -> Int -> Maybe [ParamValue]+ manyParams key num = let+ values = catMaybes $ L.map param+ [ T.concat [key, pack $ show n] + | n <- [0..num-1] ]+ numValues = L.length values+ in+ if numValues == num + then Just values+ else Nothing + +
+ tests/main.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}+{-# LANGUAGE GADTs, FlexibleContexts, EmptyDataDecls #-}+import Prelude +import Yesod.DataTables.Request+import Yesod.DataTables.Reply +import qualified Yesod.DataTables.Query as DT+import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Framework.Providers.HUnit+import Test.HUnit+import Data.Aeson as J+import Data.Attoparsec as P+import Data.ByteString as B+import Data.ByteString.Lazy as BL+import Data.Text as T+import Data.Maybe+import Database.Persist+import Database.Persist.Store+import Database.Persist.Sqlite+import Database.Persist.TH+import Control.Monad.Trans.Resource (runResourceT)++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|+Person+ name Text+ age Int Maybe+ deriving Show+|]+++++main :: IO ()+main = do+ defaultMain tests++testRequest :: Request+testRequest = Request {+ reqDisplayStart = 0,+ reqDisplayLength = 10,+ reqSearch = "foo",+ reqSearchRegex = False,+ reqColumns = [ + Column {+ colSearchable = True,+ colSearch = "bar.*baz",+ colSearchRegex = True,+ colSortable = False,+ colName = "id"+ },+ Column {+ colSearchable = False,+ colSearch = "quux",+ colSearchRegex = False,+ colSortable = True,+ colName = "name"+ } + ],+ reqSort = [("name",SortAsc), ("id", SortDesc)],+ reqEcho = 1+ }+++requestProperty :: Bool+requestProperty = parseRequest [("iDisplayStart", "0"),+ ("iDisplayLength", "10"),+ ("iColumns", "2"),+ ("sSearch", "foo"),+ ("bRegex", "false"),+ ("bSearchable_0", "true"),+ ("bSearchable_1", "false"),+ ("sSearch_0", "bar.*baz"),+ ("sSearch_1", "quux"),+ ("bRegex_0", "true"),+ ("bRegex_1", "false"),+ ("bSortable_0", "false"),+ ("bSortable_1", "true"),+ ("mDataProp_0", "id"),+ ("mDataProp_1", "name"),+ ("iSortingCols", "2"),+ ("iSortCol_0", "1"),+ ("sSortDir_0", "asc"),+ ("iSortCol_1", "0"),+ ("sSortDir_1", "desc"),+ ("sEcho", "1")+ ] == Just testRequest+ ++replyProperty :: Bool+replyProperty = expectedReply == formattedReply+ where+ records = J.toJSON [+ J.object [+ "id" .= (4321 :: Int),+ "name" .= ("row 1"::Text)+ ],+ J.object [+ "id" .= (2468 :: Int),+ "name" .= ("row 2"::Text)+ ]+ ]++ formattedReply = formatReply (Reply {+ replyNumRecords = 123,+ replyNumDisplayRecords = 64,+ replyRecords = records,+ replyEcho = 1+ }) + expectedReply = J.object [+ "iTotalRecords" .= (123 :: Int),+ "iTotalDisplayRecords" .= (64 :: Int),+ "sEcho" .= (1 :: Int),+ "aaData" .= records+ ]++queryTestRequest1 :: Request+queryTestRequest1 = Request {+ reqDisplayStart = 1,+ reqDisplayLength = 2,+ reqSearch = "",+ reqSearchRegex = False,+ reqColumns = [ + Column {+ colSearchable = False,+ colSearch = "",+ colSearchRegex = False,+ colSortable = True,+ colName = "id"+ },+ Column {+ colSearchable = False,+ colSearch = "",+ colSearchRegex = False,+ colSortable = True,+ colName = "name"+ },+ Column {+ colSearchable = False,+ colSearch = "",+ colSearchRegex = False,+ colSortable = True,+ colName = "age"+ } + ],+ reqSort = [("name",SortAsc)],+ reqEcho = 1+ }+queryTestReply1 :: Key val -> Key val -> Key val -> Key val -> Reply+queryTestReply1 johnId janeId jackId jillId = Reply {+ replyNumRecords = 3,+ replyNumDisplayRecords = 3,+ replyRecords = J.toJSON [+ J.object [+ "DT_RowId" .= ("2" :: Text),+ "id" .= ("2" :: Text),+ "name" .= ("Jane Doe" :: Text),+ "age" .= ("" :: Text)+ ],+ J.object [+ "DT_RowId" .= ("3" :: Text),+ "id" .= ("3" :: Text),+ "name" .= ("Jeff Black" :: Text),+ "age" .= ("24" :: Text)+ ]+ ],+ replyEcho = 1 + }+++queryTestDataTable :: DT.DataTable Person+queryTestDataTable = DT.DataTable {+ DT.dtGlobalSearch = \text regexFlag -> [],+ DT.dtSort = \sorts -> [],+ DT.dtColumnSearch = \cname search regex -> [],+ DT.dtFilters = [ PersonName <-. [ "John Doe", + "Jane Doe", + "Jeff Black" ] ],+ DT.dtValue = myDtValue,+ DT.dtRowId = myRowId + }+ where + myDtValue cname (Entity (Key (PersistInt64 key)) value)+ | cname == "id" = return $ T.pack $ show key+ | cname == "name" = return $ personName value+ | cname == "age" = return $ T.pack $ maybe "" show $ personAge value+ | otherwise = return $ ""+ myDtValue _ _ = return $ ""+ myRowId (Entity (Key (PersistInt64 key)) _) = return $ T.pack $ show key+ myRowId _ = return $ ""++queryTest :: IO ()+queryTest = do+ (reply, johnId, janeId, jackId, jillId) <- runResourceT + $ withSqliteConn ":memory:" $ runSqlConn $ do+ runMigration migrateAll+ johnId <- insert $ Person "John Doe" $ Just 35+ janeId <- insert $ Person "Jane Doe" Nothing+ jackId <- insert $ Person "Jeff Black" $ Just 24+ jillId <- insert $ Person "Jill Black" Nothing+ reply <- DT.dataTableSelect queryTestDataTable queryTestRequest1+ return (reply, johnId, janeId, jackId, jillId)+ reply @=? (queryTestReply1 johnId janeId jackId jillId)+ Prelude.putStrLn (show reply)++++tests :: [Test.Framework.Test]+tests = [+ testGroup "request" $ [+ testProperty "request-property" requestProperty+ ],+ testGroup "reply" $ [+ testProperty "reply-property" replyProperty+ ],+ testGroup "query" $ [+ testCase "query-test" queryTest+ ]+ ]
+ yesod-datatables.cabal view
@@ -0,0 +1,83 @@+name: yesod-datatables+version: 0.1+license: BSD3+license-file: LICENSE+author: Tero Laitinen+maintainer: Tero Laitinen+synopsis: Yesod plugin for DataTables (jQuery grid plugin)+description: DataTables (http://datatables.net) is a capable jQuery plugin. This package contains routines for implementing server-side processing (e.g. request parsing, database querying, and response formatting) for DataTables with Yesod platform. +category: Web, Yesod+stability: Experimental+cabal-version: >= 1.8+build-type: Simple+homepage: http://github.com/tlaitinen/yesod-datatables++library+ exposed-modules: Yesod.DataTables.Request+ , Yesod.DataTables.Reply+ , Yesod.DataTables.Query+ , Yesod.DataTables++ extensions: TemplateHaskell+ QuasiQuotes+ OverloadedStrings+ NoImplicitPrelude+ CPP+ MultiParamTypeClasses+ TypeFamilies+ GADTs+ GeneralizedNewtypeDeriving+ FlexibleContexts+ EmptyDataDecls+ NoMonomorphismRestriction++ build-depends: base >= 4 && < 5+ , yesod >= 1.1.5 + , yesod-core >= 1.1.7 + , yesod-auth >= 1.1 + , yesod-static >= 1.1 + , yesod-default >= 1.1 + , yesod-form >= 1.1 + , bytestring >= 0.9 + , text >= 0.11 + , persistent >= 1.1 + , attoparsec >= 0.10 + , aeson >= 0.6+ , data-default+++Test-suite tests+ Type: exitcode-stdio-1.0+ Hs-source-dirs: tests+ Main-is: main.hs+ ghc-options: -Wall+ Build-depends: base >= 4 && < 5,+ yesod-datatables >= 0.1+ , test-framework >= 0.3.3+ , test-framework-quickcheck2 >= 0.2.9+ , test-framework-hunit >= 0.3.0+ , QuickCheck >= 2.4.0+ , aeson >= 0.6+ , attoparsec >= 0.10 + , text >= 0.11 && < 0.12+ , bytestring >= 0.9 + , persistent >= 1.1 + , HUnit >= 1.2.5+ , persistent-sqlite >= 1.1 + , persistent-template >= 1.1.1 + , template-haskell+ , resourcet >= 0.4.4+ , transformers >= 0.2.2+ , monad-control >= 0.3.1+++++++ extensions: OverloadedStrings++source-repository head+ type: git+ location: https://github.com/tlaitinen/yesod-datatables.git+