diff --git a/snap-app.cabal b/snap-app.cabal --- a/snap-app.cabal +++ b/snap-app.cabal @@ -1,5 +1,5 @@ name: snap-app -version: 0.1.5 +version: 0.2.0 synopsis: Simple modules for writing apps with Snap, abstracted from hpaste. homepage: Simple modules for writing apps with Snap, abstracted from hpaste. license: BSD3 @@ -12,8 +12,11 @@ library hs-source-dirs: src - exposed-modules: Snap.App, Snap.App.Types, Snap.App.Controller, Snap.App.Model, Snap.App.Migrate - other-modules: Control.Monad.Catch, Control.Monad.Env + exposed-modules: Snap.App, Snap.App.Types, Snap.App.Controller, Snap.App.Model, Snap.App.Migrate, + Data.Pagination, Text.Blaze.Extra, Text.Blaze.Pagination, + Control.Monad.Env, + Network.URI.Params + other-modules: Control.Monad.Catch build-depends: base >= 4 && <5, snap-core, network, @@ -24,4 +27,6 @@ text, utf8-string, bytestring, - MonadCatchIO-transformers + MonadCatchIO-transformers, + cgi, + data-default diff --git a/src/Data/Pagination.hs b/src/Data/Pagination.hs new file mode 100644 --- /dev/null +++ b/src/Data/Pagination.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE RecordWildCards #-} +-- | Data pagination. + +module Data.Pagination where + +import Data.Default +import Data.Maybe +import Safe +import Network.URI +import Network.URI.Params + +-- | A pagination object, holds information about the name, total, per +-- page, current page, etc. +data Pagination = Pagination + { pnTotal :: Integer + , pnPerPage :: Integer + , pnName :: String + , pnCurrentPage :: Integer + , pnShowDesc :: Bool + } deriving (Show) + +instance Default Pagination where + def = Pagination + { pnTotal = 0 + , pnPerPage = 5 + , pnName = "" + , pnCurrentPage = 1 + , pnShowDesc = True + } + +-- | Get the page count of the pagination results. +pnPageCount :: Pagination -> Integer +pnPageCount Pagination{..} = max 1 $ + if total/perpage > fromIntegral (round (total/perpage)) + then round (total/perpage) + 1 + else round (total/perpage) + where total = fromIntegral pnTotal + perpage = fromIntegral pnPerPage + +-- | Add the current page of the pagination from the current URI. +addCurrentPNData :: URI -> Pagination -> Pagination +addCurrentPNData uri pagination = + pagination { pnCurrentPage = currentPage + , pnPerPage = perPage + } + + where currentPage = fromMaybe 1 $ do + p <- lookup (param "page") $ uriParams uri + readMay p + perPage = fromMaybe (pnPerPage pagination) $ do + p <- lookup (param "per_page") $ uriParams uri + readMay p + param n = pnName pagination ++ "_" ++ n diff --git a/src/Network/URI/Params.hs b/src/Network/URI/Params.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/Params.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS -fno-warn-missing-signatures #-} +module Network.URI.Params where + +import Control.Arrow +import Network.URI +import Data.List +import Data.Function +import Network.CGI + +updateUrlParam :: String -> String -> URI -> URI +updateUrlParam this value uri@(URI{uriQuery}) = + uri { uriQuery = updated uriQuery } where + updated = editQuery $ ((this,value):) . deleteBy ((==) `on` fst) (this,"") + +clearUrlQueries :: URI -> URI +clearUrlQueries uri = uri { uriQuery = [] } + +deleteQueryKey :: String -> URI -> URI +deleteQueryKey key uri = + uri { uriQuery = editQuery (filter ((/=key).fst)) (uriQuery uri) } + +editQuery :: ([(String,String)] -> [(String,String)]) -> String -> String +editQuery f = ('?':) . formEncodeUrl . f . formDecode . dropWhile (=='?') + +formEncodeUrl = intercalate "&" . map keyval . map (esc *** esc) + where keyval (key,val) = key ++ "=" ++ val + esc = escapeURIString isAllowedInURI + +updateUrlParams :: [(String,String)] -> URI -> URI +updateUrlParams = flip $ foldr $ uncurry updateUrlParam + +uriParams :: URI -> [(String,String)] +uriParams = formDecode . dropWhile (=='?') . uriQuery diff --git a/src/Snap/App/Controller.hs b/src/Snap/App/Controller.hs --- a/src/Snap/App/Controller.hs +++ b/src/Snap/App/Controller.hs @@ -26,6 +26,8 @@ import Data.ByteString (ByteString) import Data.ByteString.UTF8 (toString) import Data.Maybe +import Data.String +import Data.Pagination import Network.URI import Data.Text.Lazy (Text,toStrict) import Database.PostgreSQL.Base (withPoolConnection,withTransaction) @@ -33,6 +35,7 @@ import Safe (readMay) import Text.Blaze (Html) import Text.Blaze.Renderer.Text (renderHtml) +import Text.Blaze.Pagination (PN(..)) -- | Run a controller handler. runHandler :: s -> c -> Pool -> Controller c s () -> Snap () @@ -85,17 +88,18 @@ return pid -- | Get pagination data. -getPagination :: AppConfig c => Controller c s Pagination -getPagination = do - p <- getInteger "page" 1 - limit <- getInteger "limit" 35 +getPagination :: AppConfig c => String -> Controller c s PN +getPagination name = do + p <- getInteger (fromString (name ++ "_page")) 1 + limit <- getInteger (fromString (name ++ "_per_page")) 35 uri <- getMyURI - return Pagination { pnPage = max 1 p - , pnLimit = max 1 (min 100 limit) - , pnURI = uri - , pnResults = 0 - , pnTotal = 0 - } + let pag = Pagination { pnCurrentPage = max 1 p + , pnPerPage = max 1 (min 100 limit) + , pnTotal = 0 + , pnName = "events" + , pnShowDesc = True + } + return (PN uri pag Nothing) getMyURI :: AppConfig c => Controller c s URI getMyURI = do diff --git a/src/Snap/App/Types.hs b/src/Snap/App/Types.hs --- a/src/Snap/App/Types.hs +++ b/src/Snap/App/Types.hs @@ -12,8 +12,7 @@ ,ControllerState(..) ,ModelState(..) ,AppConfig(..) - ,AppLiftModel(..) - ,Pagination(..)) + ,AppLiftModel(..)) where import Control.Applicative (Applicative,Alternative) @@ -22,7 +21,7 @@ import Control.Monad.Reader (ReaderT,MonadReader) import Control.Monad.Trans (MonadIO) import Database.PostgreSQL.Simple (Connection) -import Network.URI (URI) + import Snap.Core (Snap,MonadSnap) -- | The state accessible to the controller (DB/session stuff). @@ -57,14 +56,14 @@ runModel :: ReaderT (ModelState config state) IO a } deriving (Monad,Functor,Applicative,MonadReader (ModelState config state),MonadIO) --- | Pagination data. -data Pagination = Pagination { - pnPage :: Integer - , pnLimit :: Integer - , pnURI :: URI - , pnResults :: Integer - , pnTotal :: Integer -} deriving Show +-- -- | Pagination data. +-- data Pagination = Pagination { +-- pnPage :: Integer +-- , pnLimit :: Integer +-- , pnURI :: URI +-- , pnResults :: Integer +-- , pnTotal :: Integer +-- } deriving Show class AppConfig config where getConfigDomain :: config -> String diff --git a/src/Text/Blaze/Extra.hs b/src/Text/Blaze/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Text/Blaze/Extra.hs @@ -0,0 +1,60 @@ +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} + +module Text.Blaze.Extra where + +import Control.Monad +import Data.Monoid +import Data.Monoid.Operator +import Prelude hiding ((++),head,div) +import Text.Blaze.Html5 as H hiding (map) +import Text.Blaze.Html5.Attributes as A +import Text.Blaze.Internal (Attributable) +import Network.URI.Params +import Network.URI +import Text.Printf +import Data.List (intercalate) + +(!.) :: (Attributable h) => h -> AttributeValue -> h +elem !. className = elem ! class_ className + +(!#) :: (Attributable h) => h -> AttributeValue -> h +elem !# idName = elem ! A.id idName + +linesToHtml :: String -> Html +linesToHtml str = forM_ (lines str) $ \line -> do toHtml line; br + +htmlIntercalate :: Html -> [Html] -> Html +htmlIntercalate _ [x] = x +htmlIntercalate sep (x:xs) = do x; sep; htmlIntercalate sep xs +htmlIntercalate _ [] = mempty + +htmlCommasAnd :: [Html] -> Html +htmlCommasAnd [x] = x +htmlCommasAnd [x,y] = do x; " and "; y +htmlCommasAnd (x:xs) = do x; ", "; htmlCommasAnd xs +htmlCommasAnd [] = mempty + +htmlCommas :: [Html] -> Html +htmlCommas = htmlIntercalate ", " + +hrefSet :: URI -> String -> String -> Attribute +hrefSet uri key value = hrefURI updated where + updated = updateUrlParam key value uri + +hrefURI :: URI -> Attribute +hrefURI uri = href (toValue (showURI uri)) where + showURI URI{..} = uriPath ++ uriQuery + +hrefURIWithHash :: URI -> String -> Attribute +hrefURIWithHash uri hash = href (toValue (showURI uri ++ "#" ++ hash)) where + showURI URI{..} = uriPath ++ uriQuery + +hrefAssoc :: String -> [(String,String)] -> Attribute +hrefAssoc path qs = href (toValue uri) where + uri = "/" ++ path ++ "?" ++ intercalate "&" (map (uncurry (printf "%s=%s")) qs) + +instance ToValue URI where + toValue = toValue . show diff --git a/src/Text/Blaze/Pagination.hs b/src/Text/Blaze/Pagination.hs new file mode 100644 --- /dev/null +++ b/src/Text/Blaze/Pagination.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} + +-- | Simple pagination support for blaze. + +module Text.Blaze.Pagination + (pagination,PN(..)) + where + +import Data.Foldable hiding (foldr) +import Control.Monad hiding (forM_) +import Data.Monoid.Operator +import Data.Pagination +import Network.URI +import qualified Prelude as P +import Prelude hiding ((++),div,span) +import Text.Blaze.Extra +import Text.Blaze.Html5 as H hiding (map) + +data PN = PN { pnURI :: URI + , pnPn :: Pagination + , pnResultsPerPage :: Maybe [Integer] + } + +-- | Render pagination as html. +pagination :: PN -> Html +pagination PN{pnURI=uri, pnPn=pn@Pagination{..}, pnResultsPerPage=perPage} = + div !. "pagination" $ do + when pnShowDesc description + forM_ perPage $ resultsPerPage + chooser + + where description = do + p !. "description" $ do + "Showing " + toHtml (showCount ((pnCurrentPage-1)*pnPerPage + 1)) + "–" + toHtml (showCount (min pnTotal (pnCurrentPage * pnPerPage))) + " of " + toHtml (showCount (pnTotal)) + " results" + + resultsPerPage perPage = do + div !. "results-per-page" $ do + "Page size: " + forM_ perPage $ \count -> + span !. "per-page-choice" $ do + let theclass = if count == pnPerPage then "current" else "" + if count == pnPerPage + then a !. theclass $ toHtml (show count) + else a !. theclass ! hrefSet uri (param "per_page") (show count) $ + toHtml (show count) + + chooser = do + div !. "pages" $ do + ul !. "pages-list" $ do + when (pnCurrentPage > 1) $ do + li !. "page" $ a ! hrefSet uri paramName (show 1) $ + "First" + li !. "page" $ a ! hrefSet uri paramName (show (pnCurrentPage-1)) $ + "Previous" + let w = 10 :: Integer + start = max 1 (pnCurrentPage - (w // 2)) + end = min (pageCount) (start + w) + forM_ [start..end] $ \i -> do + let theclass = if i == pnCurrentPage then "active" else "" + li !. theclass $ do + a ! hrefSet uri paramName (show i) !. theclass $ + toHtml (showCount i) + when (end < pageCount) $ + li !. "disabled" $ a "…" + when (pnCurrentPage < pageCount) $ do + li !. "page" $ a ! hrefSet uri paramName (show (pnCurrentPage+1)) $ + "Next" + li !. "page" $ a ! hrefSet uri paramName (show pageCount) $ + "Last" + + paramName = param "page" + param p = pnName ++ "_" ++ p + + (//) = P.div + pageCount = pnPageCount pn + +showCount :: (Show n,Integral n) => n -> String +showCount = reverse . foldr merge "" . zip ("000,00,00,00"::String) . reverse . show where + merge (f,c) rest | f == ',' = "," ++ [c] ++ rest + | otherwise = [c] ++ rest