diff --git a/Happstack/Data/IxSet/Helpers.hs b/Happstack/Data/IxSet/Helpers.hs --- a/Happstack/Data/IxSet/Helpers.hs +++ b/Happstack/Data/IxSet/Helpers.hs @@ -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" ) ) diff --git a/Happstack/Data/User/Password.hs b/Happstack/Data/User/Password.hs --- a/Happstack/Data/User/Password.hs +++ b/Happstack/Data/User/Password.hs @@ -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 diff --git a/Happstack/Helpers/DirBrowse.hs b/Happstack/Helpers/DirBrowse.hs --- a/Happstack/Helpers/DirBrowse.hs +++ b/Happstack/Helpers/DirBrowse.hs @@ -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 diff --git a/Happstack/Helpers/HtmlOutput/Common.hs b/Happstack/Helpers/HtmlOutput/Common.hs --- a/Happstack/Helpers/HtmlOutput/Common.hs +++ b/Happstack/Helpers/HtmlOutput/Common.hs @@ -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)] "$anchortext$" -{- | +{- | 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)] "$anchortext$" {- | @@ -50,36 +50,36 @@ simpleImage (url, alttext) (width, height) = render1 [("url",url),("alttext",alttext),("width",width),("height",height)] "\"$alttext$\"" - + -- | 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)] "

$s$

" -{- | +{- | 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)] " $ rows $
" - defTrFMeh row = render1 [("row",row)] " $ row $ " + defTrFMeh row = render1 [("row",row)] " $ row $ " defTdF cell = render1 [("cell",cell)] " $cell$ " 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 = "" ++ x ++ "" -- 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 = " $from$ - $to$ " pagunselected = " $from$ - $to$ " @@ -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
@@ -211,20 +211,20 @@ newlinesToHtmlLines = concatMap formatnewlines where formatnewlines c = if c == '\n' then "
" 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 diff --git a/Happstack/Helpers/HtmlOutput/Menu.hs b/Happstack/Helpers/HtmlOutput/Menu.hs --- a/Happstack/Helpers/HtmlOutput/Menu.hs +++ b/Happstack/Helpers/HtmlOutput/Menu.hs @@ -2,7 +2,6 @@ import Happstack.Server.HTTP.Types import Text.StringTemplate.Helpers -import Data.List (intercalate) import Happstack.Helpers.HtmlOutput.Common {- | diff --git a/Happstack/Helpers/ParseRequest.hs b/Happstack/Helpers/ParseRequest.hs --- a/Happstack/Helpers/ParseRequest.hs +++ b/Happstack/Helpers/ParseRequest.hs @@ -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 diff --git a/Happstack/Helpers/Redirect.hs b/Happstack/Helpers/Redirect.hs --- a/Happstack/Helpers/Redirect.hs +++ b/Happstack/Helpers/Redirect.hs @@ -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 diff --git a/Happstack/Server/Helpers.hs b/Happstack/Server/Helpers.hs --- a/Happstack/Server/Helpers.hs +++ b/Happstack/Server/Helpers.hs @@ -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 diff --git a/happstack-helpers.cabal b/happstack-helpers.cabal --- a/happstack-helpers.cabal +++ b/happstack-helpers.cabal @@ -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 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