happstack-helpers 0.50 → 0.51
raw patch · 9 files changed
+92/−111 lines, 9 filesdep +textdep ~containersdep ~happstack-datadep ~happstack-ixset
Dependencies added: text
Dependency ranges changed: containers, happstack-data, happstack-ixset, happstack-server, happstack-state, utf8-string
Files
- Happstack/Data/IxSet/Helpers.hs +1/−5
- Happstack/Data/User/Password.hs +0/−1
- Happstack/Helpers/DirBrowse.hs +9/−11
- Happstack/Helpers/HtmlOutput/Common.hs +56/−52
- Happstack/Helpers/HtmlOutput/Menu.hs +0/−1
- Happstack/Helpers/ParseRequest.hs +3/−3
- Happstack/Helpers/Redirect.hs +0/−4
- Happstack/Server/Helpers.hs +3/−17
- happstack-helpers.cabal +20/−17
Happstack/Data/IxSet/Helpers.hs view
@@ -1,5 +1,6 @@ module Happstack.Data.IxSet.Helpers where+import Prelude hiding (elem) import Happstack.Data.IxSet import Data.Typeable import Data.Generics@@ -15,11 +16,6 @@ f elem ixs = delete elem ixs in foldr f ixset elems ------------------------------------------------------------- Candidate for test case patch into happs sources.-----------------------------------------------------------instance (Ord a) => Eq (IxSet a) where- a == b = (toList a) == (toList b) {- tDupe = ( insert t1 . insert t1 $ empty ) == ( insert t1 empty ) where t1 = RepoUser (RepoName (B.pack "repmee" )) (UserName (B.pack "usermee" ) )
Happstack/Data/User/Password.hs view
@@ -17,7 +17,6 @@ import Happstack.Data import System.Random import qualified Crypto.PBKDF2 as PBKDF2-import qualified Data.ByteString.Char8 as B import Data.Word import Control.Monad.Trans
Happstack/Helpers/DirBrowse.hs view
@@ -11,10 +11,8 @@ import System.FilePath -import Happstack.Server -import Control.Monad.Trans (liftIO)+import Happstack.Server import System.Directory (doesDirectoryExist,getDirectoryContents,doesFileExist)-import System.FilePath (combine,takeExtension,pathSeparator) import Data.List (isPrefixOf,sort,intercalate) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L@@ -85,13 +83,13 @@ sep = [pathSeparator] in intercalate sep pathparts -hsPaintfile filename f | isHaskellFile filename = BrowseHtmlString . ( hscolour defaultColourPrefs False False f ) $ f+hsPaintfile filename f | isHaskellFile = BrowseHtmlString . ( hscolour defaultColourPrefs False False filename ) $ f | otherwise = BrowseHtmlString f- where - isHaskellFile :: FilePath -> Bool- isHaskellFile filename =- ( (drop (length filename - 3) n) ) == ".hs" - || (drop (length filename - 3) n) == ".lhs" + where+ isHaskellFile :: Bool+ isHaskellFile =+ ( (drop (length filename - 3) n) ) == ".hs"+ || (drop (length filename - 3) n) == ".lhs" where n = map toLower filename defaultColourPrefs = ColourPrefs { keyword = [Foreground Green,Underscore]@@ -122,8 +120,8 @@ boringfile "." = False boringfile ".." = False-boringfile ('.':xs) = True-boringfile ('#':xs) = True +boringfile ('.':_) = True+boringfile ('#':_) = True boringfile f | last f == '~' || head f == '#' = True | let e = takeExtension f in e == ".o" || e == ".hi" = True | otherwise = False
Happstack/Helpers/HtmlOutput/Common.hs view
@@ -1,17 +1,17 @@-{- | - Simple stupid output of common types of html +{- |+ Simple stupid output of common types of html -} module Happstack.Helpers.HtmlOutput.Common where import Happstack.Server.SimpleHTTP import Control.Monad (mplus)-import Text.StringTemplate import Text.StringTemplate.Helpers import Data.List import Safe (atMay) import Data.String.Utils import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as UTF+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy.Encoding as TE -- | fullUrlLink \"http://www.google.com\" -- | for when you want a link that the anchor text is the full url. eg, for displaying a url for darcs get.@@ -22,7 +22,7 @@ simpleLink :: (FilePath,String) -> String simpleLink (url,anchortext) = render1 [("url",url),("anchortext",anchortext)] "<a href=\"$url$\">$anchortext$</a>" -{- | +{- | like simpleLink, but a link tag is class=attention if class attention is defined via css you can get some useful behavior. I typically do something like the following, in a global css file:@@ -36,9 +36,9 @@ a.attention:hover {color: orange} --} +-} simpleAttentionLink :: (String, String) -> String-simpleAttentionLink (url,anchortext) = +simpleAttentionLink (url,anchortext) = render1 [("url",url),("anchortext",anchortext)] "<a class=attention href=\"$url$\">$anchortext$</a>" {- |@@ -50,36 +50,36 @@ simpleImage (url, alttext) (width, height) = render1 [("url",url),("alttext",alttext),("width",width),("height",height)] "<img src=\"$url$\" alt=\"$alttext$\" width=$width$ height=$height$>" - + -- | format a list of text vertically by putting list items in paragraphs paintVHtml :: [String] -> String-paintVHtml = concatMap p +paintVHtml = concatMap p where p s = render1 [("s",s)] "<p>$s$</p>" -{- | +{- | paintTable mbHeaderCells datacells mbPagination = ... mbHeaderCells: text for header cells, if you want them. Can use html formatting if desired.- + pagination also optional -} paintTable :: Maybe [String] -- ^ optional header rows -> [[String]] -- ^ table cells -> Maybe Pagination -- ^ optional pagination -> String-paintTable mbHeaderRows = +paintTable mbHeaderRows = case mbHeaderRows of Just rs -> paintTable' defTableF defTrF defSpacerRow (Just (rs,defTrF)) Nothing -> paintTable' defTableF defTrF defSpacerRow Nothing- where + where defTableF rows = render1 [("rows",rows)] "<table> $ rows $ </table>"- defTrFMeh row = render1 [("row",row)] "<tr> $ row $ </tr>" + defTrFMeh row = render1 [("row",row)] "<tr> $ row $ </tr>" defTdF cell = render1 [("cell",cell)] "<td> $cell$ </td>" defSpacerRow = ("",False) defTrF cells = defTrFMeh . concat . map defTdF $ cells -{- | +{- | paintTable' tableF trF spacerRow mbHeaderStuff datacells mbPagination = helper function for a table with pagination@@ -88,13 +88,13 @@ -} paintTable' :: (String -> String) -- ^ table tag function -> ([String] -> String) -- ^ row tag function, input is table cell contents- -> (String,Bool) -- ^ (spacer row, more padding) + -> (String,Bool) -- ^ (spacer row, more padding) -- (use ("",False) for no spacer rows) -- if more padding is true, prepend and append spacers -> Maybe ([String], [String] -> String) -- ^ optional (header rows, header row tag function)- -> [[String]] -- ^ table cells - -> Maybe Pagination -- ^ optional pagination + -> [[String]] -- ^ table cells+ -> Maybe Pagination -- ^ optional pagination -> String paintTable' _ _ _ _ [] _ = "" paintTable' tableF trF (spacerRow,morePadding) mbHeaderStuff datacells mbPagination =@@ -106,36 +106,36 @@ then spacerRow ++ rows' ++ spacerRow else rows' tableCells :: [[String]]- tableCells = maybe datacells (getPaginatedCells datacells) mbPagination + tableCells = maybe datacells (getPaginatedCells datacells) mbPagination paginationBar :: String- paginationBar = maybe "" (paintPaginationBar datacells) mbPagination + paginationBar = maybe "" (paintPaginationBar datacells) mbPagination in ( tableF trows ) ++ paginationBar - + biggerfont x = "<font size=+1>" ++ x ++ "</font>" -- import Text.StringTemplate hiding (directoryGroup) data Pagination = Pagination { currentbar :: Int- , resultsPerBar :: Int + , resultsPerBar :: Int , currentpage :: Int- , resultsPerPage :: Int + , resultsPerPage :: Int , baselink :: String- , paginationtitle :: String + , paginationtitle :: String } --tpr = paginationRanges (Pagination 1 10000 1 3 "" "") tbl -- [["blee","blah","bloo"],["mee","mah","moo"]] -- where tbl = map (const ["blee","blah","bloo"]) [1..10] --paginationRanges :: Pagination -> [[String]] -> [ ([(Int,[String])], (Int, Int) ) ]---paginationRanges pg datacells = barRanges = splitList (resultsPerPage pg) datacells - +--paginationRanges pg datacells = barRanges = splitList (resultsPerPage pg) datacells+ --barRanges pg datacells = splitList (resultsPerBar pg) $ zip datacells [1..] -- tp = paintPaginationBar [[]] (Pagination 1 10000 1 20 "" "") @@ -145,7 +145,7 @@ paintPaginationBar :: [[String]] -> Pagination -> String paintPaginationBar datacells pg | resultsPerPage pg > length datacells = "" | otherwise =- let paintresultsbar (barindex, ( xs,(fr,to)) ) = + let paintresultsbar (barindex, ( xs,(fr,to)) ) = let attrs = [("currentbar",show barindex) , ("resultsPerBar",show $ resultsPerBar pg) , ("currentpage", show 1)@@ -154,21 +154,21 @@ , ("to",show to)] in if (currentbar pg) == barindex- then let paintresultspage (pageindex, (xs,(fr,to))) =- let adjust = (barindex-1)*(resultsPerBar pg) - attrs = [("currentbar",show barindex)+ then let paintresultspage (pageindex, (_,(fr',to'))) =+ let adjust = (barindex-1)*(resultsPerBar pg)+ attrs' = [("currentbar",show barindex) , ("resultsPerBar",show $ resultsPerBar pg) , ("currentpage", show pageindex) , ("resultsPerPage",show $ resultsPerPage pg)- , ("from",show $ adjust + fr)- , ("to",show $ adjust + to)]+ , ("from",show $ adjust + fr')+ , ("to",show $ adjust + to')] in if currentpage pg == pageindex- then render1 attrs pagselected - else render1 attrs pagunselected + then render1 attrs' pagselected+ else render1 attrs' pagunselected pglinks = map paintresultspage $ zip [1..] ( splitList (resultsPerPage pg) xs )- in concat . intersperse " | " $ pglinks - else render1 attrs pagunselected - -- barlinks = map paintbarlinks $ zip [1..] + in concat . intersperse " | " $ pglinks+ else render1 attrs pagunselected+ -- barlinks = map paintbarlinks $ zip [1..] barlinks = map paintresultsbar $ zip [1..] ( splitList (resultsPerBar pg) datacells ) pagselected = "<a class=menuitemSelected href=$baselink$?currentbar=$currentbar$&resultsPerBar=$resultsPerBar$¤tpage=$currentpage$&resultsPerPage=$resultsPerPage$> $from$ - $to$ </a>" pagunselected = "<a class=menuitem href=$baselink$?currentbar=$currentbar$&resultsPerBar=$resultsPerBar$¤tpage=$currentpage$&resultsPerPage=$resultsPerPage$> $from$ - $to$ </a>"@@ -178,12 +178,12 @@ getPaginatedCells :: [[String]] -> Pagination -> [[String]] getPaginatedCells [] _ = [[]]-getPaginatedCells datacells pg = - let currb = (currentbar pg)-1 +getPaginatedCells datacells pg =+ let currb = (currentbar pg)-1 in case splitList (resultsPerBar pg) datacells `atMay` currb of Nothing -> [["getPaginatedCells, index not in range, currb: " ++ (show currb) ]]- Just (datacells2, (_,_) ) -> - let currp = (currentpage pg)-1 + Just (datacells2, (_,_) ) ->+ let currp = (currentpage pg)-1 in case splitList (resultsPerPage pg) datacells2 `atMay` currp of Nothing -> [["getPaginatedCells, index not in range, currp: " ++ (show currp) ]] Just (res,(_,_)) -> res@@ -193,17 +193,17 @@ -- the result is a list of (indexed sublist,(fist index, last index)) --splitList :: Int -> [b] -> [([b], (Int, Int))] splitList n x = let- part = splitList' n ( zip [1..] x) + part = splitList' n ( zip [1..] x) bounded = map (\l -> (map snd l,bounds l)) part bounds [] = (0,0) bounds l@((_,_):_) = (fst . head $ l,fst . last $ l) in bounded- where + where splitList' :: Int -> [a] -> [[a]] splitList' _ [] = []- splitList' n l@(x:xs) =- let (a,b') = genericSplitAt n l- b = splitList' n b'+ splitList' n' l@(_:_) =+ let (a,b') = genericSplitAt n' l+ b = splitList' n' b' in a : b -- | substitute newlines with <br>@@ -211,20 +211,20 @@ newlinesToHtmlLines = concatMap formatnewlines where formatnewlines c = if c == '\n' then "<br>" else [c] -{- | -The checkbox form element has optional attribute "checked". +{- |+The checkbox form element has optional attribute "checked". If this attribute is present, readcheckbox returns true, otherwise false. -use in conjunction with checkStringIfTrue, when, eg, writing StringTemplate code that renders a from with a box that might or not be checked. Something like: +use in conjunction with checkStringIfTrue, when, eg, writing StringTemplate code that renders a from with a box that might or not be checked. Something like: attrs = [ ... , ("somethingIsChecked", checkedStringIfTrue $ someBoolVal ) ... ] -} readcheckbox :: String -> RqData Bool-readcheckbox checkboxname = (return . (=="on") =<< look checkboxname `mplus` return "") +readcheckbox checkboxname = (return . (=="on") =<< look checkboxname `mplus` return "") -{- | +{- | useful hack for dealing with checkboxes in HAppS. Maybe there's a better way? checkedStringIfTrue p = if p then \"checked\" else \"\"@@ -242,10 +242,14 @@ -- | render a list of strings horizontally, separated by \" | \" paintHBars :: [String] -> String-paintHBars = intercalate " | " +paintHBars = intercalate " | " newtype HtmlString = HtmlString String instance ToMessage HtmlString where toContentType _ = B.pack "text/html;charset=utf-8" toMessage (HtmlString s) = UTF.fromString s +newtype HtmlText = HtmlText Text+instance ToMessage HtmlText where+ toContentType _ = B.pack "text/html; charset=utf-8"+ toMessage (HtmlText s) = TE.encodeUtf8 s
Happstack/Helpers/HtmlOutput/Menu.hs view
@@ -2,7 +2,6 @@ import Happstack.Server.HTTP.Types import Text.StringTemplate.Helpers-import Data.List (intercalate) import Happstack.Helpers.HtmlOutput.Common {- |
Happstack/Helpers/ParseRequest.hs view
@@ -32,7 +32,7 @@ '/':cs -> cs x -> x in case apphost of- Right apphost -> Right $ render1 [("apphost",apphost),("path",path)] "http://$apphost$/$path$"+ Right apphost' -> Right $ render1 [("apphost",apphost'),("path",path)] "http://$apphost$/$path$" Left e -> Left $ "modRewirteAppUrl error: " ++ e @@ -63,6 +63,6 @@ let parts = split ":" h case parts of [d] -> Right d- [d,p] -> Right d- xs -> Left $ "getDomain, bad domain: " ++ h+ [d,_] -> Right d+ _ -> Left $ "getDomain, bad domain: " ++ h
Happstack/Helpers/Redirect.hs view
@@ -1,10 +1,6 @@ module Happstack.Helpers.Redirect where import Happstack.Server-import qualified Data.ByteString.Char8 as B-import Text.StringTemplate.Helpers-import qualified Data.Map as M-import Data.String.Utils (split) import Control.Monad.Trans import Happstack.Helpers.ParseRequest
Happstack/Server/Helpers.hs view
@@ -2,28 +2,14 @@ module Happstack.Server.Helpers -- ( smartserver, exactdir, smartserver',getData',vhosts,vhost, cleanUpLockFile, scrapeUrl, websiteUp, stateShutDown ) where- -import Network.Stream-import qualified Network.HTTP as HTTP-import Data.Char (toLower)-import Data.List (isInfixOf)-import Network.URI (parseURI)-import System.FilePath ((</>))-import System.Timeout (timeout)+ import Control.Monad.Error-import System.Directory (getCurrentDirectory, doesFileExist, removeFile)-import qualified Control.Exception as E-import Data.IORef import Happstack.Server import Happstack.State-import System.Environment import Control.Concurrent import System.Time-import Control.Monad-import Debug.Trace.Helpers import Data.Maybe (fromMaybe) import qualified Data.ByteString.Char8 as B-import System.Exit -- run the happs server on some port -- using simpleHTTPWithSocket instead of simpleHTTP helps the app restart sanely when daemonized with supervisord, instead of getting bind failed@@ -86,10 +72,10 @@ vhost ("mysite.com",80) mySiteController -} vhost :: (String,Int) -> ServerPartT IO Response -> ServerPartT IO Response-vhost vh@(domain, port) sp = do+vhost vh@(_, _) sp = do (p :: Int) <- liftM ( snd . rqPeer ) askRq (d :: String) <- (B.unpack . fromMaybe (error "Happstack.Helpers.Server.vhost, no host header")) `liftM` getHeaderM "host"- guardRq $ \rq -> (d,p) == vh+ guardRq $ \_ -> (d,p) == vh sp
happstack-helpers.cabal view
@@ -1,28 +1,30 @@ Name: happstack-helpers-Version: 0.50+Version: 0.51 License: BSD3 License-file: bsd3.txt-Description: Functions I found I was using repeatedly when programming Happstack based web-apps. +Description: Functions I found I was using repeatedly when programming Happstack based web-apps. I'll deprecate whatever bits of this make their way into the Happstack core on hackage.-Synopsis: Convenience functions for Happstack. +Synopsis: Convenience functions for Happstack. Maintainer: Creighton Hogg <wchogg at gmail> Author: Thomas Hartman, Eelco Lempsink, Jeremy Shaw, Creighton Hogg Stability: Beta Copyright: Copyright (c) 2008 Thomas Hartman Category: Distributed Computing-homepage: http://patch-tag.com/r/HAppSHelpers+homepage: http://patch-tag.com/r/tphyahoo/HAppSHelpers/home Build-type: Simple Cabal-Version: >= 1.6 flag base4 -+source-repository head+ type: darcs+ location: http://patch-tag.com/r/tphyahoo/HAppSHelpers Library- Exposed-Modules: Happstack.Helpers,Happstack.Helpers.DirBrowse, Happstack.Helpers.HtmlOutput, - Happstack.Helpers.HtmlOutput.Common, - Happstack.Helpers.HtmlOutput.Menu, - Happstack.Helpers.ParseRequest,Happstack.Helpers.Redirect, - Happstack.Data.User.Password, + Exposed-Modules: Happstack.Helpers,Happstack.Helpers.DirBrowse, Happstack.Helpers.HtmlOutput,+ Happstack.Helpers.HtmlOutput.Common,+ Happstack.Helpers.HtmlOutput.Menu,+ Happstack.Helpers.ParseRequest,Happstack.Helpers.Redirect,+ Happstack.Data.User.Password, Happstack.Data.IxSet.Helpers Happstack.Server.Helpers @@ -33,27 +35,28 @@ Build-Depends: base >=3 && < 4 Build-Depends: mtl >= 1.1.0.0 && < 2.0.0.0- , happstack-server >= 0.3 && < 0.5+ , happstack-server >= 0.3 && < 0.6 , hscolour >= 1.0 && < 1.14 , filepath >= 1.1.0.0 && < 1.2.0.0 , directory >= 1.0.0.0 && < 1.1.0.0 , bytestring >= 0.9.0.0 && < 0.10.0.0 , HStringTemplate >= 0.4.0 && < 0.7.0- , HStringTemplateHelpers >= 0.0.14 + , HStringTemplateHelpers >= 0.0.14 , safe >= 0.2 && < 0.3 , MissingH >= 1.0.3- , containers >= 0.2.0.0 && < 0.3.0.0+ , containers >= 0.2.0.0 && < 0.4.0.0 , parsec >= 2.1.0.0 && < 2.2.0.0 , haskell98 >= 1.0.0.0 && < 2.0.0.0- , happstack-ixset >= 0.3 && < 0.5- , happstack-state >= 0.3 && < 0.5+ , happstack-ixset >= 0.3 && < 0.6+ , happstack-state >= 0.3 && < 0.6 , random >= 1.0 && < 2- , happstack-data >= 0.3 && < 0.5+ , happstack-data >= 0.3 && < 0.6 , old-time >= 1.0.0.0 && < 1.1.0.0 , pureMD5 >= 1.0.0.0 && < 1.1.0.0 , PBKDF2 >= 0.3 && < 0.4 , DebugTraceHelpers , network >= 2.2 , HTTP >= 4000- , utf8-string >= 0.3.6+ , utf8-string >= 0.3.4 && < 0.4.0+ , text >= 0.7 && < 0.8 ghc-options: -Wall