snap-app 0.1.5 → 0.2.0
raw patch · 7 files changed
+268/−25 lines, 7 filesdep +cgidep +data-default
Dependencies added: cgi, data-default
Files
- snap-app.cabal +9/−4
- src/Data/Pagination.hs +53/−0
- src/Network/URI/Params.hs +34/−0
- src/Snap/App/Controller.hs +14/−10
- src/Snap/App/Types.hs +10/−11
- src/Text/Blaze/Extra.hs +60/−0
- src/Text/Blaze/Pagination.hs +88/−0
snap-app.cabal view
@@ -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
+ src/Data/Pagination.hs view
@@ -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
+ src/Network/URI/Params.hs view
@@ -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
src/Snap/App/Controller.hs view
@@ -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
src/Snap/App/Types.hs view
@@ -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
+ src/Text/Blaze/Extra.hs view
@@ -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
+ src/Text/Blaze/Pagination.hs view
@@ -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