snap-app 0.6.1 → 0.7.0
raw patch · 17 files changed
+5/−827 lines, 17 filesdep −MonadCatchIO-transformersdep −basedep −blaze-html
Dependencies removed: MonadCatchIO-transformers, base, blaze-html, blaze-markup, bytestring, cgi, data-default, directory, feed, filepath, mtl, network-uri, old-locale, postgresql-simple, safe, snap-core, text, time, utf8-string, xml
Files
- LICENSE +0/−30
- snap-app.cabal +5/−37
- src/Control/Monad/Catch.hs +0/−5
- src/Control/Monad/Env.hs +0/−14
- src/Data/Monoid/Operator.hs +0/−11
- src/Data/Pagination.hs +0/−53
- src/Network/URI/Params.hs +0/−34
- src/Snap/App.hs +0/−11
- src/Snap/App/Cache.hs +0/−91
- src/Snap/App/Controller.hs +0/−110
- src/Snap/App/Migrate.hs +0/−53
- src/Snap/App/Model.hs +0/−116
- src/Snap/App/RSS.hs +0/−33
- src/Snap/App/Types.hs +0/−72
- src/Snap/App/XML.hs +0/−9
- src/Text/Blaze/Extra.hs +0/−60
- src/Text/Blaze/Pagination.hs +0/−88
− LICENSE
@@ -1,30 +0,0 @@-Copyright (c) 2013, Chris Done--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.-- * Neither the name of Chris Done nor the names of other- 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-OWNER 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.
snap-app.cabal view
@@ -1,41 +1,9 @@ name: snap-app-version: 0.6.1-synopsis: Simple modules for writing apps with Snap, abstracted from hpaste.-homepage: https://github.com/chrisdone/snap-app+version: 0.7.0+synopsis: None+description: None license: BSD3-license-file: LICENSE-author: Chris Done-maintainer: chrisdone@gmail.com-category: Web+author: None build-type: Simple-cabal-version: >=1.8-+cabal-version: >=1.2 library- ghc-options: -O2 -Wall -fno-warn-type-defaults- hs-source-dirs: src- exposed-modules: Snap.App, Snap.App.Types, Snap.App.Controller, Snap.App.Model, Snap.App.Migrate,- Snap.App.Cache, Snap.App.XML, Snap.App.RSS,- Data.Pagination, Text.Blaze.Extra, Text.Blaze.Pagination,- Control.Monad.Env, Data.Monoid.Operator,- Network.URI.Params- other-modules: Control.Monad.Catch- build-depends: base >= 4 && <5,- snap-core,- network-uri,- postgresql-simple,- mtl,- blaze-html >= 0.6,- blaze-markup >= 0.5,- safe,- text,- utf8-string,- bytestring,- MonadCatchIO-transformers,- cgi,- data-default,- filepath,- directory,- feed,- xml,- old-locale,- time
− src/Control/Monad/Catch.hs
@@ -1,5 +0,0 @@-{-# LANGUAGE PackageImports #-}--module Control.Monad.Catch (module Control.Monad.CatchIO) where--import "MonadCatchIO-transformers" Control.Monad.CatchIO
− src/Control/Monad/Env.hs
@@ -1,14 +0,0 @@-{-# OPTIONS -Wall #-}-{-# LANGUAGE OverloadedStrings #-}---- | Abstraction of environment functions (could be state, could be--- reader, whatever). Intended to ease migration from Reader/State.--module Control.Monad.Env- (env)- where--import Control.Monad.Reader--env :: MonadReader env m => (env -> val) -> m val-env = asks
− src/Data/Monoid/Operator.hs
@@ -1,11 +0,0 @@--- | Useful operator (++) = mappend.--module Data.Monoid.Operator where--import Data.Monoid (Monoid)-import Data.Monoid (mappend)-import Prelude()--(++) :: Monoid a => a -> a -> a-(++) = mappend-infixr 5 ++
− src/Data/Pagination.hs
@@ -1,53 +0,0 @@-{-# 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
@@ -1,34 +0,0 @@-{-# 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.hs
@@ -1,11 +0,0 @@-module Snap.App- (module Snap.Core- ,module Snap.App.Types- ,module Snap.App.Controller- ,module Snap.App.Model)- where--import Snap.Core-import Snap.App.Types-import Snap.App.Controller-import Snap.App.Model
− src/Snap/App/Cache.hs
@@ -1,91 +0,0 @@-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}---- | Caching of Blaze HTML pages caching.--module Snap.App.Cache- (cache- ,cacheIf- ,resetCache- ,clearCache- ,resetCacheModel- ,viewCached- ,Key(..)- ,CacheDir(..))- where--import Control.Monad.Reader-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy.IO as T-import Snap.App-import System.Directory-import System.FilePath-import Text.Blaze-import Text.Blaze.Html.Renderer.Text---- | A key for the cache.-class Key key where- keyToString :: key -> FilePath---- | A config that can return a cache directory.-class CacheDir config where- getCacheDir :: config -> FilePath---- | Cache conditionally.-cacheIf :: (CacheDir c,Key key) => Bool -> key -> Controller c s (Maybe Markup) -> Controller c s (Maybe Text)-cacheIf pred key generate =- if pred- then cache key generate- else fmap (fmap renderHtml) generate---- | Generate and save into the cache, or retrieve existing from the--- | cache.-cache :: (CacheDir c,Key key) => key -> Controller c s (Maybe Markup) -> Controller c s (Maybe Text)-cache key generate = do- tmpdir <- asks (getCacheDir . controllerStateConfig)- let cachePath = tmpdir ++ "/" ++ keyToString key- exists <- io $ doesFileExist cachePath- if exists- then do text <- io $ T.readFile cachePath- return (Just text)- else do text <- fmap (fmap renderHtml) generate- case text of- Just text' -> do io $ createDirectoryIfMissing True tmpdir- io $ T.writeFile cachePath text'- return text- Nothing -> return text---- | Clear the whole cache.-clearCache :: CacheDir c => c -> IO ()-clearCache config = do- files <- getDirectoryContents dir- forM_ (filter (not . all (=='.')) files) $ removeFile . (dir </>)-- where dir = getCacheDir config---- | Reset an item in the cache.-resetCache :: (CacheDir c,Key key) => key -> Controller c s ()-resetCache key = do- tmpdir <- asks (getCacheDir . controllerStateConfig)- io $ do- let cachePath = tmpdir ++ "/" ++ keyToString key- exists <- io $ doesFileExist cachePath- when exists $ removeFile cachePath---- | Reset an item in the cache.-resetCacheModel :: (CacheDir c,Key key) => key -> Model c s ()-resetCacheModel key = do- tmpdir <- asks (getCacheDir . modelStateConfig)- io $ do- let cachePath = tmpdir ++ "/" ++ keyToString key- exists <- io $ doesFileExist cachePath- when exists $ removeFile cachePath---- | Because.-io :: MonadIO m => IO a -> m a-io = liftIO---- | View some HTML generator cached.-viewCached :: (CacheDir c,Key key) => key -> Controller c s Markup -> Controller c s ()-viewCached key generate = do- text <- cache key (fmap Just generate)- maybe (return ()) outputText text
− src/Snap/App/Controller.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS -Wall #-}-{-# LANGUAGE OverloadedStrings #-}---- | Controller routing/handling.--module Snap.App.Controller- (runHandler- ,output- ,outputText- ,goHome- ,justOrGoHome- ,getInteger- ,getString- ,getStringMaybe- ,getPagination- ,getMyURI)- where--import Snap.Core-import Snap.App.Model (Pool,withPoolConnection)-import Snap.App.Types--import Control.Applicative-import Control.Monad.Env-import Control.Monad.Reader (runReaderT)-import Data.ByteString (ByteString)-import Data.ByteString.UTF8 (toString)-import Data.String-import Data.Pagination-import Network.URI-import Data.Text.Lazy (Text,toStrict)-import Safe (readMay)-import Text.Blaze (Markup)-import Text.Blaze.Html.Renderer.Text (renderHtml)-import Text.Blaze.Pagination (PN(..))---- | Run a controller handler.-runHandler :: s -> c -> Pool -> Controller c s () -> Snap ()-runHandler st conf pool ctrl = do- withPoolConnection pool $ \conn -> do- let state = ControllerState conf conn st- -- Default to HTML, can be overridden.- modifyResponse $ setContentType "text/html"- runReaderT (runController ctrl) state---- | Strictly renders HTML to Text before outputting it via Snap.--- This ensures that any lazy exceptions are caught by the Snap--- handler.-output :: Markup -> Controller c s ()-output html = outputText $ renderHtml $ html---- | Strictly renders text before outputting it via Snap.--- This ensures that any lazy exceptions are caught by the Snap--- handler.-outputText :: Text -> Controller c s ()-outputText text = do- let !x = toStrict $ text- writeText x---- | Generic redirect to home page.-goHome :: Controller c s ()-goHome = redirect "/"---- | Extract a Just value or go home.-justOrGoHome :: Maybe a -> (a -> Controller c s ()) -> Controller c s ()-justOrGoHome x m = maybe goHome m x---- | Get integer parmater.-getInteger :: ByteString -> Integer -> Controller c s Integer-getInteger name def = do- pid <- (>>= readMay . toString) <$> getParam name- maybe (return def) return pid---- | Get string.-getString :: ByteString -> String -> Controller c s String-getString name def = do- pid <- (>>= return . toString) <$> getParam name- maybe (return def) return pid---- | Get string (maybe).-getStringMaybe :: ByteString -> Controller c s (Maybe String)-getStringMaybe name = do- pid <- (>>= return . toString) <$> getParam name- return pid---- | Get pagination data.-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- let pag = Pagination { pnCurrentPage = max 1 p- , pnPerPage = max 1 (min 100 limit)- , pnTotal = 0- , pnName = name- , pnShowDesc = True- }- return (PN uri pag Nothing)--getMyURI :: AppConfig c => Controller c s URI-getMyURI = do- domain <- env (getConfigDomain . controllerStateConfig)- result <- fmap (parseURI . (("http://" ++ domain) ++) . toString . rqURI)- getRequest- case result of- Nothing -> case parseURI ("http://" ++ domain) of- Nothing -> error $ "Unable to parse my own domain! It's this: " ++ domain- Just d -> return d- Just d -> return d
− src/Snap/App/Migrate.hs
@@ -1,53 +0,0 @@--- | Migration library--module Snap.App.Migrate where--import Snap.App.Types-import Snap.App.Model-import Control.Monad-import Control.Monad.Trans-import GHC.Int---- | Migrate the DB to the latest version.-migrate :: Bool -> [(Int,Model c s Int64)] -> Model c s ()-migrate create versions = go where- go = do- when create $ void $ ensureExists- rows <- query ["SELECT version FROM version"] ()- case rows of- [] -> do echo "No database version, initializing to version 0."- createVersion- setVersion 0- [Only v] -> do- case lookup (v+1) versions of- Just doMigrate -> do echo $ "Migrating to version " ++ show (v+1)- changes <- doMigrate- setVersion (v+1)- echo $ "Rows changed: " ++ show changes- go- Nothing -> echo $ "At version " ++ show v ++ "."- vs -> error $ "There is more than one database version, fix it: " ++- show vs---- | Set the current database version.-setVersion :: Int -> Model c s ()-setVersion v = do- _ <- exec ["UPDATE version SET version = ?"] (Only v)- echo $ "Version set to " ++ show v ++ "."- return ()---- | Ensure the version table exists.-ensureExists :: Model c s ()-ensureExists = do- _ <- exec ["CREATE TABLE version (version int not null default 0)"] ()- return ()---- | Create the version number.-createVersion :: Model c s ()-createVersion = do- _ <- exec ["INSERT INTO version (version) VALUES (0)"] ()- echo $ "Version table created."---- | Just print to stdout for now.-echo :: String -> Model c s ()-echo = liftIO . putStrLn
− src/Snap/App/Model.hs
@@ -1,116 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS -Wall #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}---- | Model running.--module Snap.App.Model- (model- ,runDB- ,query- ,single- ,singleNoParams- ,queryNoParams- ,withPoolConnection- ,exec- ,DB.Only(..)- ,newPool- ,Pool)- where--import Control.Concurrent-import Control.Monad.CatchIO as E-import Control.Monad.Env (env)-import Control.Monad.Reader-import Data.String-import qualified Database.PostgreSQL.Simple as DB-import Database.PostgreSQL.Simple hiding (query)-import GHC.Int-import Snap.App.Types---- | Run a model action at the top-level.-runDB :: s -> c -> Pool -> Model c s () -> IO ()-runDB st conf pool mdl = do- withPoolConnection pool $ \conn -> do- let state = ModelState conn st conf- -- Default to HTML, can be overridden.- runReaderT (runModel mdl) state---- | Run a model action from within a controller.-model :: AppLiftModel c s => Model c s a -> Controller c s a-model = liftModel---- | Query with some parameters.-query :: (ToRow ps,FromRow r) => [String] -> ps -> Model c s [r]-query q ps = do- conn <- env modelStateConn- Model $ ReaderT (\_ -> DB.query conn (fromString (unlines q)) ps)---- | Query a single field from a single result.-single :: (ToRow ps,FromRow (Only r)) => [String] -> ps -> Model c s (Maybe r)-single q ps = do- rows <- query q ps- case rows of- [(Only r)] -> return (Just r)- _ -> return Nothing---- | Query a single field from a single result (no params).-singleNoParams :: (FromRow (Only r)) => [String] -> Model c s (Maybe r)-singleNoParams q = do- rows <- queryNoParams q- case rows of- [(Only r)] -> return (Just r)- _ -> return Nothing---- | Query with no parameters.-queryNoParams :: (FromRow r) => [String] -> Model c s [r]-queryNoParams q = do- conn <- env modelStateConn- Model $ ReaderT (\_ -> DB.query_ conn (fromString (unlines q)))---- | Execute some SQL returning the rows affected.-exec :: (ToRow ps) => [String] -> ps -> Model c s Int64-exec q ps = do- conn <- env modelStateConn- Model $ ReaderT (\_ -> DB.execute conn (fromString (unlines q)) ps)---- | Create a new connection pool.-newPool :: MonadIO m- => ConnectInfo -- ^ Connect info.- -> m Pool-newPool info = liftIO $ do- var <- newMVar $ PoolState {- poolConnections = []- , poolConnectInfo = info- }- return $ Pool var---- | Connect using the connection pool.-pconnect :: MonadIO m => Pool -> m Connection-pconnect (Pool var) = liftIO $ do- modifyMVar var $ \state@PoolState{..} -> do- case poolConnections of- [] -> do conn <- connect poolConnectInfo- return (state,conn)- (conn:conns) -> return (state { poolConnections = conns },conn)---- | Restore a connection to the pool.-restore :: MonadIO m => Pool -> Connection -> m ()-restore (Pool var) conn = liftIO $ do- modifyMVar_ var $ \state -> do- return state { poolConnections = conn : poolConnections state }---- | Use the connection pool.-withPoolConnection :: (MonadCatchIO m,MonadIO m) => Pool -> (Connection -> m a) -> m ()-withPoolConnection pool m = do- _ <- E.bracket (pconnect pool) (restore pool) m- return ()---- | A connection pool.-data PoolState = PoolState {- poolConnections :: [Connection]- , poolConnectInfo :: ConnectInfo- }--newtype Pool = Pool (MVar PoolState)
− src/Snap/App/RSS.hs
@@ -1,33 +0,0 @@--- | Output RSS feeds.--module Snap.App.RSS where--import Data.Text (Text)-import qualified Data.Text as T-import Data.Time-import Snap.App-import Snap.App.XML-import System.Locale-import Text.Feed.Export-import Text.Feed.Types-import Text.RSS.Syntax-import Text.XML.Light---- | Output the given XML element.-outputRSS :: String -> String -> [(UTCTime,Text,Text,Text)] -> Controller c s ()-outputRSS title link = outputXML . makeFeed title link---- | Make a simple RSS feed.-makeFeed :: String -> String -> [(UTCTime,Text,Text,Text)] -> Element-makeFeed title link = xmlFeed . RSSFeed . makeRSS where- makeRSS qs = (nullRSS title link)- { rssChannel = makeChannel qs }- makeChannel qs = (nullChannel title link)- { rssItems = map makeItem qs }- makeItem (time,itemtitle,desc,itemlink) =- (nullItem (T.unpack itemtitle))- { rssItemPubDate = return (toPubDate time)- , rssItemDescription = return (T.unpack desc)- , rssItemLink = return (T.unpack itemlink)- }- toPubDate = formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S UT"
− src/Snap/App/Types.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS -Wall #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Model-view-controller app types.--module Snap.App.Types- (Controller(..)- ,Model(..)- ,ControllerState(..)- ,ModelState(..)- ,AppConfig(..)- ,AppLiftModel(..))- where--import Control.Applicative (Applicative,Alternative)-import Control.Monad (MonadPlus)-import Control.Monad.Catch (MonadCatchIO)-import Control.Monad.Reader (ReaderT,MonadReader)-import Control.Monad.Trans (MonadIO)-import Database.PostgreSQL.Simple (Connection)--import Snap.Core (Snap,MonadSnap)---- | The state accessible to the controller (DB/session stuff).-data ControllerState config state = ControllerState {- controllerStateConfig :: config- , controllerStateConn :: Connection- , controllerState :: state- }---- | The controller monad.-newtype Controller config state a = Controller {- runController :: ReaderT (ControllerState config state) Snap a- } deriving (Monad- ,Functor- ,Applicative- ,Alternative- ,MonadReader (ControllerState config state)- ,MonadSnap- ,MonadIO- ,MonadPlus- ,MonadCatchIO)---- | The state accessible to the model (just DB connection).-data ModelState config state = ModelState {- modelStateConn :: Connection- , modelStateAnns :: state- , modelStateConfig :: config- }---- | The model monad (limited access to IO, only DB access).-newtype Model config state a = Model {- 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--class AppConfig config where- getConfigDomain :: config -> String--class AppLiftModel c s where- liftModel :: Model c s a -> Controller c s a
− src/Snap/App/XML.hs
@@ -1,9 +0,0 @@-module Snap.App.XML where--import Text.XML.Light-import Snap.App-import qualified Data.Text as T---- | Output the given XML element.-outputXML :: Element -> Controller c s ()-outputXML = writeText . T.pack . showElement
− src/Text/Blaze/Extra.hs
@@ -1,60 +0,0 @@-{-# 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
@@ -1,88 +0,0 @@-{-# 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 "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