happstack-helpers 0.11 → 0.20
raw patch · 23 files changed
+860/−829 lines, 23 files
Files
- HAppS/Data/IxSet/Helpers.hs +0/−26
- HAppS/Data/User/Password.hs +0/−90
- HAppS/Helpers.hs +0/−13
- HAppS/Helpers/DirBrowse.hs +0/−149
- HAppS/Helpers/HtmlOutput.hs +0/−19
- HAppS/Helpers/HtmlOutput/Common.hs +0/−242
- HAppS/Helpers/HtmlOutput/Menu.hs +0/−59
- HAppS/Helpers/ParseRequest.hs +0/−68
- HAppS/Helpers/Redirect.hs +0/−33
- HAppS/Server/CookieFixer.hs +0/−88
- HAppS/Server/Helpers.hs +0/−34
- Happstack/Data/IxSet/Helpers.hs +26/−0
- Happstack/Data/User/Password.hs +90/−0
- Happstack/Helpers.hs +15/−0
- Happstack/Helpers/DirBrowse.hs +150/−0
- Happstack/Helpers/HtmlOutput.hs +19/−0
- Happstack/Helpers/HtmlOutput/Common.hs +249/−0
- Happstack/Helpers/HtmlOutput/Menu.hs +59/−0
- Happstack/Helpers/ParseRequest.hs +68/−0
- Happstack/Helpers/Redirect.hs +33/−0
- Happstack/Server/CookieFixer.hs +90/−0
- Happstack/Server/Helpers.hs +50/−0
- happstack-helpers.cabal +11/−8
− HAppS/Data/IxSet/Helpers.hs
@@ -1,26 +0,0 @@--module HAppS.Data.IxSet.Helpers where-import HAppS.Data.IxSet-import Data.Typeable-import Data.Generics--{- | -Sort of like a foreign key constraint, if macid were a normal rdbms.--Eg, say you have a table called RepoUsers. When a user (or repo) is deleted , all the RepoUsers that match it should also be deleted--}-deleteWhere :: (Typeable k, Indexable a b, Ord a, Data a) => k -> IxSet a -> IxSet a-deleteWhere val ixset = - let elems = toList $ getEQ val ixset- 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" ) )--}
− HAppS/Data/User/Password.hs
@@ -1,90 +0,0 @@-{-# LANGUAGE TemplateHaskell,DeriveDataTypeable,FlexibleInstances,MultiParamTypeClasses,FlexibleContexts,UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module : HAppS.Data.User.Password--- Copyright : (c) 2008 Jeremy Shaw <jeremy@n-heptane.com>, --- modified by Thomas Hartman to use PBKDF2, and uploaded to hackage--- License : BSD3-style--- --- Maintainer : Thomas Hartman, thomashartman1@gmail.com--- Stability : experimental--- Portability : requires all sorts of crazy GHC extensions------ Data types and functions for handling salted passwords.-------------------------------------------------------------------------------module HAppS.Data.User.Password where--import Control.Monad-import HAppS.Data-import System.Random-import qualified Crypto.PBKDF2 as PBKDF2-import qualified Data.ByteString.Char8 as B-import Data.Word-import Control.Monad.Trans--$( deriveAll [''Ord,''Eq,''Read,''Show,''Default] - [d|- data Password = Password Salt PasswordHash- newtype PasswordHash = PasswordHash [Word8]- newtype Salt = Salt String- |] )--$(deriveSerialize ''Password)-instance Version Password-$(deriveSerialize ''PasswordHash)-instance Version PasswordHash-$(deriveSerialize ''Salt)-instance Version Salt---- |check if the submitted password matches the stored password-checkPassword :: Password -- ^ stored salt and password hash- -> String -- ^ password to test (unhashed)- -> Bool -- ^ did it match-checkPassword (Password salt hash) password = doHash salt password == hash--mkP salt password = Password salt $ doHash salt password--t = doHash ( Salt "fooie" ) "blee"--{- |hash a password using the supplied salt-Originally implemented using SHA1. By switching to pbkdf2, we don't rely on implementation of randomIO being cryptographically secure.--}--doHash :: Salt -> String -> PasswordHash-doHash (Salt salt) password =- case PBKDF2.pbkdf2 (PBKDF2.Password . PBKDF2.toOctets $ password) (PBKDF2.Salt . PBKDF2.toOctets $ salt) - of (PBKDF2.HashedPass hp) -> PasswordHash hp- -- PasswordHash (sha1 (salt ++ password))---{- |- changepass oldpassTryString newpassString p@(Password salt hash) = ... -- Change password, requires old password as an additional security measure--}-changepass :: (Monad m) => String -> String -> Password -> m Password-changepass oldpassTryString newpassString p@(Password salt hash) =- if checkPassword p oldpassTryString - then return $ mkP salt newpassString- else fail "incorrect old password"---- |generate some random salt- -- returns 4 'Char' of salt.-genSalt :: MonadIO m => m Salt-genSalt = liftIO . liftM Salt $ ( replicateM 4 randomIO :: IO String)---- |generate a new salted/hashed 'Password' from the given input string-newPassword :: MonadIO m => String -> m Password-newPassword password =- do salt <- genSalt- return $ mkP salt password------t = putStrLn . show =<< newPassword "blee"------
− HAppS/Helpers.hs
@@ -1,13 +0,0 @@-module HAppS.Helpers (- module HAppS.Helpers.DirBrowse- , module HAppS.Helpers.HtmlOutput- , module HAppS.Helpers.ParseRequest- , module HAppS.Helpers.Redirect- , module HAppS.Data.User.Password-) where--import HAppS.Helpers.DirBrowse-import HAppS.Helpers.HtmlOutput-import HAppS.Helpers.ParseRequest-import HAppS.Helpers.Redirect-import HAppS.Data.User.Password
− HAppS/Helpers/DirBrowse.hs
@@ -1,149 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}--{- | - Directory browsing for HAppS-- browsedir \"someDirectory\"--}-module HAppS.Helpers.DirBrowse - (browsedir, browsedirHS, browsedir')-where--import System.FilePath--import HAppS.Server -import Control.Monad.Trans (liftIO)-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-import Data.Char (toLower)-import Language.Haskell.HsColour.HTML-import Language.Haskell.HsColour.Colourise --{- | - browsedir = browsedir' defPaintdir defPaintfile -- define a ServerPartT value with something like-- sp = browsedir \"projectroot\" \".\" -- where projectroot is an alias (what you see in the url) and "." is the path relative to the executable running - - the happs server---}-browsedir :: FilePath -> FilePath -> ServerPartT IO Response-browsedir = browsedir' defPaintdir defPaintfile --{- | - like browsedir, but haskell files are rendered through hscolour-- browsedirHS = browsedir' defPaintdir hsPaintfile--}-browsedirHS :: FilePath -> FilePath -> ServerPartT IO Response-browsedirHS = browsedir' defPaintdir hsPaintfile--{- |- browsedir' paintdir paintfile diralias syspath-- paintdir/paintfile are rendering functions-- diralias: path that will appear in browser-- syspath: real system path --}-browsedir' :: (ToMessage a, ToMessage b) => (String -> [FilePath] -> a)- -> (String -> String -> b)- -> FilePath- -> FilePath- -> ServerPartT IO Response-browsedir' paintdir paintfile diralias syspath = multi [- ServerPartT $ \rq -> do- let aliaspath = ( mypathstring . rqPaths $ rq )- if (not $ isPrefixOf (addTrailingPathSeparator diralias) $ (addTrailingPathSeparator aliaspath) )- then noHandle- else do- -- to do: s/rqp/realpath/- let realpath = mypathstring $ syspath : (tail $ rqPaths rq)- isDir <- liftIO $ doesDirectoryExist realpath- if isDir- then do- fs <- liftIO $ getDirectoryContents realpath - return . toResponse $ paintdir aliaspath fs - else do- isfile <- liftIO $ doesFileExist realpath - f <- liftIO $ readFile realpath- return . toResponse $ paintfile realpath f - ] - where - -- Windows/Unix/Mac compatible - mypathstring pathparts =- let sep :: String- sep = [pathSeparator] - in intercalate sep pathparts--hsPaintfile filename f | isHaskellFile filename = BrowseHtmlString . ( hscolour defaultColourPrefs False False f ) $ f- | otherwise = BrowseHtmlString f- where - isHaskellFile :: FilePath -> Bool- isHaskellFile filename =- ( (drop (length filename - 3) n) ) == ".hs" - || (drop (length filename - 3) n) == ".lhs" - where n = map toLower filename- defaultColourPrefs = ColourPrefs- { keyword = [Foreground Green,Underscore]- , keyglyph = [Foreground Red]- , layout = [Foreground Cyan]- , comment = [Foreground Blue]- , conid = [Normal]- , varid = [Normal]- , conop = [Foreground Red,Bold]- , varop = [Foreground Cyan]- , string = [Foreground Magenta]- , char = [Foreground Magenta]- , number = [Foreground Magenta]- , cpp = [Foreground Magenta,Dim]- , selection = [Bold, Foreground Magenta]- , variantselection = [Dim, Foreground Red, Underscore]- , definition = [Foreground Blue]- }---defPaintfile _ f = f -defPaintdir aliaspath fs =- let flinks = map g . filter (not . boringfile ) . sort $ fs- g f = simpleLink ('/' : (combine aliaspath f)) f- in BrowseHtmlString $ "<h3>" ++ aliaspath ++ "</h3>\n<ul>" ++ concatMap li flinks ++ "</ul>"- where simpleLink url anchor = "<a href=" ++ url ++ ">" ++ anchor ++ "</a>"- li x = "<li>" ++ x ++ "</li>\n" --boringfile "." = False-boringfile ".." = False-boringfile ('.':xs) = True-boringfile ('#':xs) = True -boringfile f | last f == '~' || head f == '#' = True- | let e = takeExtension f in e == ".o" || e == ".hi" = True- | otherwise = False--------{---- eg: browsedirWith (ifHaskellFile [withRequest colorize]) "src" -browsedirWith sp alias d = multi [- sp- , browsedir alias d- ]--}--newtype BrowseHtmlString = BrowseHtmlString String-instance ToMessage BrowseHtmlString where- toContentType _ = B.pack "text/html"- toMessage (BrowseHtmlString s) = L.pack s --
− HAppS/Helpers/HtmlOutput.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-module HAppS.Helpers.HtmlOutput (- module HAppS.Helpers.HtmlOutput.Common- , module HAppS.Helpers.HtmlOutput.Menu- , directoryGroupsHAppS-) where--import HAppS.Helpers.HtmlOutput.Common-import HAppS.Helpers.HtmlOutput.Menu-import Text.StringTemplate.Helpers--directoryGroupsHAppS = directoryGroups' directoryGroupHAppS---- templates with naughty emacs backup character get ignored--- templates whose base names are invalid StringTemplate var names cause failure,--- because this significantly complicates working with them in HAppS-directoryGroupHAppS = directoryGroupNew' ignoret badTmplVarName- where ignoret f = not . null . filter (=='#') $ f -
− HAppS/Helpers/HtmlOutput/Common.hs
@@ -1,242 +0,0 @@-{- | - Simple stupid output of common types of html --}-module HAppS.Helpers.HtmlOutput.Common where-import HAppS.Server.SimpleHTTP-import Control.Monad (mplus)-import Text.StringTemplate-import Text.StringTemplate.Helpers-import Data.List-import Safe (atMay)-import Data.String.Utils---- | 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.-fullUrlLink :: FilePath -> String-fullUrlLink url = simpleLink (url,url)---- | simpleLink (\"http://www.google.com\",\"google is a nice way to look for information\")-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:--a.attention:link {color: orange}--a.attention:active {color: orange}--a.attention:visited {color: orange}--a.attention:hover {color: orange}----} -simpleAttentionLink :: (String, String) -> String-simpleAttentionLink (url,anchortext) = - render1 [("url",url),("anchortext",anchortext)] "<a class=attention href=\"$url$\">$anchortext$</a>"--{- |- width and height args blank blank if you don't want to specify this-- simpleImage (url, alttext) (width, height) = ...--}-simpleImage :: (FilePath,String) -> (String,String) -> String-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 - 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 = - case mbHeaderRows of- Just rs -> paintTable' defTableF defTrF defSpacerRow (Just (rs,defTrF))- Nothing -> paintTable' defTableF defTrF defSpacerRow Nothing- where - defTableF rows = render1 [("rows",rows)] "<table> $ rows $ </table>"- 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-- see paintTable for an example of how this can be used--}-paintTable' :: (String -> String) -- ^ table tag function- -> ([String] -> String) -- ^ row tag function, input is table cell contents- -> (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-paintTable' _ _ _ _ [] _ = ""-paintTable' tableF trF (spacerRow,morePadding) mbHeaderStuff datacells mbPagination =- let trows = case mbHeaderStuff of- Just (headerCells, htrF) -> htrF headerCells ++ rows- Nothing -> rows- where rows = let rows' = join spacerRow . map trF $ tableCells- in if morePadding- then spacerRow ++ rows' ++ spacerRow- else rows'- tableCells :: [[String]]- tableCells = maybe datacells (getPaginatedCells datacells) mbPagination - paginationBar :: String- 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 - , currentpage :: Int- , resultsPerPage :: Int - , baselink :: 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 - ---barRanges pg datacells = splitList (resultsPerBar pg) $ zip datacells [1..]--- tp = paintPaginationBar [[]] (Pagination 1 10000 1 20 "" "")----- variable nomenclature is kind of poor here--- think of "bar" as the outer loop and "page" as the inner loop-paintPaginationBar :: [[String]] -> Pagination -> String-paintPaginationBar datacells pg | resultsPerPage pg > length datacells = ""- | otherwise =- let paintresultsbar (barindex, ( xs,(fr,to)) ) = - let attrs = [("currentbar",show barindex)- , ("resultsPerBar",show $ resultsPerBar pg)- , ("currentpage", show 1)- , ("resultsPerPage",show $ resultsPerPage pg)- , ("from",show fr)- , ("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)- , ("resultsPerBar",show $ resultsPerBar pg)- , ("currentpage", show pageindex)- , ("resultsPerPage",show $ resultsPerPage pg)- , ("from",show $ adjust + fr)- , ("to",show $ adjust + to)]- in if currentpage pg == pageindex- 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..] - 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>"- in (paginationtitle pg) ++ ( concat . intersperse " | " $ barlinks )----getPaginatedCells :: [[String]] -> Pagination -> [[String]]-getPaginatedCells [] _ = [[]]-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 - in case splitList (resultsPerPage pg) datacells2 `atMay` currp of- Nothing -> [["getPaginatedCells, index not in range, currp: " ++ (show currp) ]]- Just (res,(_,_)) -> res---- splitList 3 [1..11]--- [([(1,1),(2,2),(3,3)],(1,3)),([(4,4),(5,5),(6,6)],(4,6)),([(7,7),(8,8),(9,9)],(7,9)),([(10,10),(11,11)],(10,11))]--- 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) - bounded = map (\l -> (map snd l,bounds l)) part- bounds [] = (0,0)- bounds l@((_,_):_) = (fst . head $ l,fst . last $ l)- in bounded- where - splitList' :: Int -> [a] -> [[a]]- splitList' _ [] = []- splitList' n l@(x:xs) =- let (a,b') = genericSplitAt n l- b = splitList' n b'- in a : b---- | substitute newlines with <br>-newlinesToHtmlLines :: String -> String-newlinesToHtmlLines = concatMap formatnewlines- where formatnewlines c = if c == '\n' then "<br>" else [c]--{- | -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: --attrs = [ ... , ("somethingIsChecked", checkedStringIfTrue $ someBoolVal ) ... ]--}-readcheckbox :: String -> RqData Bool-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 \"\"--}-checkedStringIfTrue :: Bool -> String-checkedStringIfTrue p = if p then "checked" else ""---- | Render a list of strings as an unordered list (<ul>...</ul>)-paintVUL :: [String] -> String-paintVUL xs = "<ul>" ++ (concatMap (\mi -> "<li>" ++ mi ++ "</li>") xs) ++ "</ul>"---- | Render a list of strings as an ordered list (<ol>...</ol>)-paintVOL :: [String] -> String-paintVOL xs = "<ol>" ++ (concatMap (\mi -> "<li>" ++ mi ++ "</li>") xs) ++ "</ol>"---- | render a list of strings horizontally, separated by \" | \"-paintHBars :: [String] -> String-paintHBars = intercalate " | "
− HAppS/Helpers/HtmlOutput/Menu.hs
@@ -1,59 +0,0 @@-module HAppS.Helpers.HtmlOutput.Menu where--import HAppS.Server.HTTP.Types -import Text.StringTemplate.Helpers-import Data.List (intercalate)-import HAppS.Helpers.HtmlOutput.Common--{- | -Render a link which changes color when the current page is active, modulo css.--menuLink rq (url,anchortext)--similar to simpleLink, outputs an html link. However, menuLink looks at the request to determine if the page being linked to is the current page. If it is, it's in class menuitemSelected, otherwise class menuitem. if the url is blank, -the link is unclickable, just displayed gray (e.g., features that haven't been enabled but are coming soon). You need to define the classes described here via css for these features to be useful. I usually do something like in a global css file:--a.menuitem:link {color: blue}--a.menuitem:active {color: blue}--a.menuitem:visited {color: blue}--a.menuitem:hover {color: blue}--a.menuitemSelected:link {color: purple}--a.menuitemSelected:active {color: purple}--a.menuitemSelected:visited {color: purple}--a.menuitemSelected:hover {color: purple}---}-menuLink :: Request -> (String, String) -> String-menuLink = menuLink' "menuitemSelected" "menuitem"--{- | menuLink' classSelected classUnselected rq (url,anchortext) = ... --}-menuLink' :: String -> String -> Request -> (String, String) -> String-menuLink' classSelected classUnselected rq (url,anchortext) = - render1 [("url",url),("anchortext",anchortext),("classSelected",classSelected),("classUnselected",classUnselected)] $- if currUrl == url- then "<a class=$classSelected$ href=\"$url$\">$anchortext$</a>"- else if null url- then "<font color=gray>$anchortext$</font>"- else "<a class=\"$classUnselected$\" href=\"$url$\">$anchortext$</a>"- where currUrl = rqURL rq----vMenuOL :: Request -> [(String, String)] -> String-vMenuOL rq = paintVOL . map (menuLink rq )--vMenuUL :: Request -> [(String, String)] -> String-vMenuUL rq = paintVUL . map (menuLink rq )---- | hMenuBars rq = paintHBars . map (menuLink rq) -hMenuBars :: Request -> [(String, String)] -> String-hMenuBars rq = paintHBars . map (menuLink rq) -
− HAppS/Helpers/ParseRequest.hs
@@ -1,68 +0,0 @@-module HAppS.Helpers.ParseRequest where--import HAppS.Server.HTTP.Types-import Text.StringTemplate.Helpers-import qualified Data.ByteString.Char8 as B-import qualified Data.Map as M-import Data.String.Utils (split)-{- |--> case modRewriteAppUrl "tutorial/registered" of -> Left e -> ...-> Right page -> ... --Given a page path, try to return the "home page" of a happs server, basically, the host plus an optional path.-At the same time, try to deal sanely with HAppS serving behind apache mod rewrite,-a common situation for me at least-because it lets you have multiple happs servers listening on different ports, all-looking to the casual user like they are being served on port 80, and also unblocked by firewalls.--Can fail monadically--}-modRewriteAppUrl :: String -> Request -> Either String String-modRewriteAppUrl path' rq =- let apphost = case getHeaderVal "x-forwarded-server" rq of- Right h -> Right h- Left _ -> case getHeaderVal "host" rq of- Right h -> Right h- Left _ -> Left "modRewriteAppUrl, can't determine host" - -- trim starting slash if necessary- path = case path' of- "" -> ""- '/':cs -> cs- x -> x- in case apphost of- Right apphost -> Right $ render1 [("apphost",apphost),("path",path)] "http://$apphost$/$path$"- Left e -> Left $ "modRewirteAppUrl error: " ++ e---{- | -getHost = getHeaderVal \"host\" --returns host with port numbers, if anything other than default 80--}-getHost :: Request -> Either String String-getHost = getHeaderVal "host" --{- |-retrieve val of header for key supplied, or an error message if the key isn't found--}-getHeaderVal :: String -> Request -> Either String String-getHeaderVal headerKey rq = maybe (Left $ "getHeaderVal, bad headerKey: " ++ headerKey)- ( Right . B.unpack . head . hValue )- ( M.lookup ( B.pack headerKey ) . rqHeaders $ rq )--{- | -host with port number stripped out, if any. --Useful, for example, for getting the right address to ssh to. --}-getDomain :: Request -> Either String String-getDomain rq = do- h <- getHost rq- let parts = split ":" h- case parts of- [d] -> Right d- [d,p] -> Right d- xs -> Left $ "getDomain, bad domain: " ++ h-
− HAppS/Helpers/Redirect.hs
@@ -1,33 +0,0 @@-module HAppS.Helpers.Redirect where --import HAppS.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 HAppS.Helpers.ParseRequest--{- | -redirectPath def path rq = ...--eg, redirectPath (fail "horribly) "/path/to/page" will redirect to http://myserver.com/path/to/page- or http://localhost:5001/path/to/page depending on whether it is servin in online environemnt- or for local development on port 5001- Could produce an error if the hostname can't be determined for some reason (malformed headers?)--}-redirectPath :: (MonadIO m) => WebT m Response -> String -> Request -> WebT m Response-redirectPath def p rq = do- case modRewriteAppUrl p rq of- Left _ -> def- Right au -> redirectToUrl au--{- |-Escape a serverPartT handler by redirecting somewhere--Basically a wrapper around supplied seeOther function, which doesn't quite do what I want--}-redirectToUrl :: MonadIO m => String -> WebT m Response-redirectToUrl url = seeOther url $ toResponse ()-
− HAppS/Server/CookieFixer.hs
@@ -1,88 +0,0 @@-module HAppS.Server.CookieFixer - ( cookieFixer- ) where--import HAppS.Server.Cookie (Cookie(..))-import HAppS.Server(ServerPartT(..),Request(..), getHeader)--import qualified Data.ByteString.Char8 as C-import Data.Char (chr, toLower)-import Data.List ((\\))-import Data.Maybe--import Control.Applicative-import Control.Monad (MonadPlus(..), ap)--- Hide Parsec's definitions of some Applicative functions.-import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))--instance Applicative (GenParser s a) where- pure = return- (<*>) = ap--instance Alternative (GenParser s a) where- empty = mzero- (<|>) = mplus---- Less complete but more robust way of parsing cookies. Note: not RFC 2068 compliant!-parseCookies :: String -> [Cookie]-parseCookies str = either (const []) id $ parse cookiesParser "" str--parseCookiesM :: (Monad m) => String -> m [Cookie]-parseCookiesM str = either (fail "Invalid cookie syntax!") return $ parse cookiesParser str str--cookiesParser = av_pairs- where -- Parsers based on RFC 2109- av_pairs = (:) <$> av_pair <*> many (char ';' *> av_pair)- av_pair = cookie <$> attr <*> option "" (char '=' *> value)- attr = spaces *> token- value = word- word = incomp_token <|> quoted_string-- -- Parsers based on RFC 2068- token = many1 $ oneOf ((chars \\ ctl) \\ tspecials)- quoted_string = char '"' *> many (oneOf qdtext) <* char '"'-- -- Custom parser, incompatible with RFC 2068, but very forgiving ;)- incomp_token = many1 $ oneOf ((chars \\ ctl) \\ "\";")-- -- Primitives from RFC 2068- tspecials = "()<>@,;:\\\"/[]?={} \t"- ctl = map chr (127:[0..31])- chars = map chr [0..127]- octet = map chr [0..255]- text = octet \\ ctl- qdtext = text \\ "\""--cookie key value = Cookie "" "" "" (low key) value-{--simpleHTTPCookieFixer :: ToMessage a => Conf -> [ServerPartT IO a] -> IO ()-simpleHTTPCookieFixer conf hs- = listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< simpleHTTP' hs (cookieFixer req))--cookieFixer :: Request -> Request-cookieFixer request = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" (rqHeaders request))), c <- cl ]--}--cookieFixer :: ServerPartT m a -> ServerPartT m a-cookieFixer (ServerPartT sp) = ServerPartT $ \request -> sp (request { rqCookies = (fixedCookies request) } )- where- fixedCookies request = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" (rqHeaders request))), c <- cl ]---- | Get all cookies from the HTTP request. The cookies are ordered per RFC from--- the most specific to the least specific. Multiple cookies with the same--- name are allowed to exist.-getCookies :: Monad m => C.ByteString -> m [Cookie]-getCookies header | C.null header = return []- | otherwise = parseCookiesM (C.unpack header)---- | Get the most specific cookie with the given name. Fails if there is no such--- cookie or if the browser did not escape cookies in a proper fashion.--- Browser support for escaping cookies properly is very diverse.-getCookie :: Monad m => String -> C.ByteString -> m Cookie-getCookie s h = do cs <- getCookies h- case filter ((==) (low s) . cookieName) cs of- [r] -> return r- _ -> fail ("getCookie: " ++ show s)--low :: String -> String-low = map toLower
− HAppS/Server/Helpers.hs
@@ -1,34 +0,0 @@-module HAppS.Server.Helpers- ( smartserver- ) where--import HAppS.Server-import HAppS.State-import System.Environment-import Control.Concurrent-import System.Time-import HAppS.Server.CookieFixer---- run the happs server on some port--- include cookie fix, various other enhancements that make things simpler-smartserver :: (Methods st, Component st, ToMessage a) =>- Conf -> String -> [ServerPartT IO a] -> Proxy st -> IO ()-smartserver conf progName c stateProxy = withProgName progName $ do- putStrLn . ( "starting happs server" ++ ) =<< time- control <- startSystemState stateProxy -- start the HAppS state system-- putStrLn . ( "happs state started" ++ ) =<< time-- tid <- forkIO $ simpleHTTP conf ( map cookieFixer c)- putStrLn . ( ( "simpleHttp started on port " ++ (show . port $ conf) ++ "\n" ++- "shut down with ctrl-c" ) ++) =<< time-- waitForTermination- killThread tid- putStrLn . ( "creating checkpoint: " ++ ) =<< time- createCheckpoint control-- putStrLn . ( "shutting down system: " ++ ) =<< time- shutdownSystem control - putStrLn . ( "exiting: " ++ ) =<< time- where time = return . ("\ntime: " ++ ) . show =<< getClockTime
+ Happstack/Data/IxSet/Helpers.hs view
@@ -0,0 +1,26 @@++module Happstack.Data.IxSet.Helpers where+import Happstack.Data.IxSet+import Data.Typeable+import Data.Generics++{- | +Sort of like a foreign key constraint, if macid were a normal rdbms.++Eg, say you have a table called RepoUsers. When a user (or repo) is deleted , all the RepoUsers that match it should also be deleted+-}+deleteWhere :: (Typeable k, Indexable a b, Ord a, Data a) => k -> IxSet a -> IxSet a+deleteWhere val ixset = + let elems = toList $ getEQ val ixset+ 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
@@ -0,0 +1,90 @@+{-# LANGUAGE TemplateHaskell,DeriveDataTypeable,FlexibleInstances,MultiParamTypeClasses,FlexibleContexts,UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : HAppS.Data.User.Password+-- Copyright : (c) 2008 Jeremy Shaw <jeremy@n-heptane.com>, +-- modified by Thomas Hartman to use PBKDF2, and uploaded to hackage+-- License : BSD3-style+-- +-- Maintainer : Thomas Hartman, thomashartman1@gmail.com+-- Stability : experimental+-- Portability : requires all sorts of crazy GHC extensions+--+-- Data types and functions for handling salted passwords.+-----------------------------------------------------------------------------+module Happstack.Data.User.Password where++import Control.Monad+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++$( deriveAll [''Ord,''Eq,''Read,''Show,''Default] + [d|+ data Password = Password Salt PasswordHash+ newtype PasswordHash = PasswordHash [Word8]+ newtype Salt = Salt String+ |] )++$(deriveSerialize ''Password)+instance Version Password+$(deriveSerialize ''PasswordHash)+instance Version PasswordHash+$(deriveSerialize ''Salt)+instance Version Salt++-- |check if the submitted password matches the stored password+checkPassword :: Password -- ^ stored salt and password hash+ -> String -- ^ password to test (unhashed)+ -> Bool -- ^ did it match+checkPassword (Password salt hash) password = doHash salt password == hash++mkP salt password = Password salt $ doHash salt password++t = doHash ( Salt "fooie" ) "blee"++{- |hash a password using the supplied salt+Originally implemented using SHA1. By switching to pbkdf2, we don't rely on implementation of randomIO being cryptographically secure.+-}++doHash :: Salt -> String -> PasswordHash+doHash (Salt salt) password =+ case PBKDF2.pbkdf2 (PBKDF2.Password . PBKDF2.toOctets $ password) (PBKDF2.Salt . PBKDF2.toOctets $ salt) + of (PBKDF2.HashedPass hp) -> PasswordHash hp+ -- PasswordHash (sha1 (salt ++ password))+++{- |+ changepass oldpassTryString newpassString p@(Password salt hash) = ... ++ Change password, requires old password as an additional security measure+-}+changepass :: (Monad m) => String -> String -> Password -> m Password+changepass oldpassTryString newpassString p@(Password salt hash) =+ if checkPassword p oldpassTryString + then return $ mkP salt newpassString+ else fail "incorrect old password"++-- |generate some random salt+ -- returns 4 'Char' of salt.+genSalt :: MonadIO m => m Salt+genSalt = liftIO . liftM Salt $ ( replicateM 4 randomIO :: IO String)++-- |generate a new salted/hashed 'Password' from the given input string+newPassword :: MonadIO m => String -> m Password+newPassword password =+ do salt <- genSalt+ return $ mkP salt password++++--t = putStrLn . show =<< newPassword "blee"++++++
+ Happstack/Helpers.hs view
@@ -0,0 +1,15 @@+module Happstack.Helpers (+ module Happstack.Helpers.DirBrowse+ , module Happstack.Helpers.HtmlOutput+ , module Happstack.Helpers.ParseRequest+ , module Happstack.Helpers.Redirect+ , module Happstack.Data.User.Password+ , module Happstack.Server.Helpers+) where++import Happstack.Helpers.DirBrowse+import Happstack.Helpers.HtmlOutput+import Happstack.Helpers.ParseRequest+import Happstack.Helpers.Redirect+import Happstack.Data.User.Password+import Happstack.Server.Helpers
+ Happstack/Helpers/DirBrowse.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++{- | + Directory browsing for HAppS++ browsedir \"someDirectory\"+-}+module Happstack.Helpers.DirBrowse + (browsedir, browsedirHS, browsedir')+where++import System.FilePath++import Happstack.Server +import Control.Monad.Trans (liftIO)+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+import Data.Char (toLower)+import Language.Haskell.HsColour.HTML+import Language.Haskell.HsColour.Colourise +import Control.Monad+import Control.Monad.Trans++{- | + browsedir = browsedir' defPaintdir defPaintfile ++ define a ServerPartT value with something like++ sp = browsedir \"projectroot\" \".\" ++ where projectroot is an alias (what you see in the url) and "." is the path relative to the executable running + + the happs server++-}+browsedir :: (MonadIO m) => FilePath -> FilePath -> ServerPartT m Response+browsedir = browsedir' defPaintdir defPaintfile ++{- | + like browsedir, but haskell files are rendered through hscolour++ browsedirHS = browsedir' defPaintdir hsPaintfile+-}+browsedirHS :: (MonadIO m) => FilePath -> FilePath -> ServerPartT m Response+browsedirHS = browsedir' defPaintdir hsPaintfile++{- |+ browsedir' paintdir paintfile diralias syspath++ paintdir/paintfile are rendering functions++ diralias: path that will appear in browser++ syspath: real system path +-}+browsedir' :: (ToMessage a, ToMessage b, MonadIO m) => (String -> [FilePath] -> a)+ -> (String -> String -> b)+ -> FilePath+ -> FilePath+ -> ServerPartT m Response+browsedir' paintdir paintfile diralias syspath = do+ rq <- askRq+ let aliaspath = ( mypathstring . rqPaths $ rq )+ if (not $ isPrefixOf (addTrailingPathSeparator diralias) $ (addTrailingPathSeparator aliaspath) )+ then mzero+ else do+ -- to do: s/rqp/realpath/+ let realpath = mypathstring $ syspath : (tail $ rqPaths rq)+ isDir <- liftIO $ doesDirectoryExist realpath+ if isDir+ then do+ fs <- liftIO $ getDirectoryContents realpath+ return . toResponse $ paintdir aliaspath fs+ else do+ isfile <- liftIO $ doesFileExist realpath + f <- liftIO $ readFile realpath+ return . toResponse $ paintfile realpath f + where + -- Windows/Unix/Mac compatible + mypathstring pathparts =+ let sep :: String+ sep = [pathSeparator] + in intercalate sep pathparts++hsPaintfile filename f | isHaskellFile filename = BrowseHtmlString . ( hscolour defaultColourPrefs False False f ) $ f+ | otherwise = BrowseHtmlString f+ where + isHaskellFile :: FilePath -> Bool+ isHaskellFile filename =+ ( (drop (length filename - 3) n) ) == ".hs" + || (drop (length filename - 3) n) == ".lhs" + where n = map toLower filename+ defaultColourPrefs = ColourPrefs+ { keyword = [Foreground Green,Underscore]+ , keyglyph = [Foreground Red]+ , layout = [Foreground Cyan]+ , comment = [Foreground Blue]+ , conid = [Normal]+ , varid = [Normal]+ , conop = [Foreground Red,Bold]+ , varop = [Foreground Cyan]+ , string = [Foreground Magenta]+ , char = [Foreground Magenta]+ , number = [Foreground Magenta]+ , cpp = [Foreground Magenta,Dim]+ , selection = [Bold, Foreground Magenta]+ , variantselection = [Dim, Foreground Red, Underscore]+ , definition = [Foreground Blue]+ }+++defPaintfile _ f = f +defPaintdir aliaspath fs =+ let flinks = map g . filter (not . boringfile ) . sort $ fs+ g f = simpleLink ('/' : (combine aliaspath f)) f+ in BrowseHtmlString $ "<h3>" ++ aliaspath ++ "</h3>\n<ul>" ++ concatMap li flinks ++ "</ul>"+ where simpleLink url anchor = "<a href=" ++ url ++ ">" ++ anchor ++ "</a>"+ li x = "<li>" ++ x ++ "</li>\n" ++boringfile "." = False+boringfile ".." = False+boringfile ('.':xs) = True+boringfile ('#':xs) = True +boringfile f | last f == '~' || head f == '#' = True+ | let e = takeExtension f in e == ".o" || e == ".hi" = True+ | otherwise = False++++++++{-+-- eg: browsedirWith (ifHaskellFile [withRequest colorize]) "src" +browsedirWith sp alias d = multi [+ sp+ , browsedir alias d+ ]+-}++newtype BrowseHtmlString = BrowseHtmlString String+instance ToMessage BrowseHtmlString where+ toContentType _ = B.pack "text/html"+ toMessage (BrowseHtmlString s) = L.pack s ++
+ Happstack/Helpers/HtmlOutput.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module Happstack.Helpers.HtmlOutput (+ module Happstack.Helpers.HtmlOutput.Common+ , module Happstack.Helpers.HtmlOutput.Menu+ , directoryGroupsHAppS+) where++import Happstack.Helpers.HtmlOutput.Common+import Happstack.Helpers.HtmlOutput.Menu+import Text.StringTemplate.Helpers++directoryGroupsHAppS = directoryGroups' directoryGroupHAppS++-- templates with naughty emacs backup character get ignored+-- templates whose base names are invalid StringTemplate var names cause failure,+-- because this significantly complicates working with them in HAppS+directoryGroupHAppS = directoryGroupNew' ignoret badTmplVarName+ where ignoret f = not . null . filter (=='#') $ f +
+ Happstack/Helpers/HtmlOutput/Common.hs view
@@ -0,0 +1,249 @@+{- | + 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++-- | 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.+fullUrlLink :: FilePath -> String+fullUrlLink url = simpleLink (url,url)++-- | simpleLink (\"http://www.google.com\",\"google is a nice way to look for information\")+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:++a.attention:link {color: orange}++a.attention:active {color: orange}++a.attention:visited {color: orange}++a.attention:hover {color: orange}+++-} +simpleAttentionLink :: (String, String) -> String+simpleAttentionLink (url,anchortext) = + render1 [("url",url),("anchortext",anchortext)] "<a class=attention href=\"$url$\">$anchortext$</a>"++{- |+ width and height args blank blank if you don't want to specify this++ simpleImage (url, alttext) (width, height) = ...+-}+simpleImage :: (FilePath,String) -> (String,String) -> String+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 + 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 = + case mbHeaderRows of+ Just rs -> paintTable' defTableF defTrF defSpacerRow (Just (rs,defTrF))+ Nothing -> paintTable' defTableF defTrF defSpacerRow Nothing+ where + defTableF rows = render1 [("rows",rows)] "<table> $ rows $ </table>"+ 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++ see paintTable for an example of how this can be used+-}+paintTable' :: (String -> String) -- ^ table tag function+ -> ([String] -> String) -- ^ row tag function, input is table cell contents+ -> (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+paintTable' _ _ _ _ [] _ = ""+paintTable' tableF trF (spacerRow,morePadding) mbHeaderStuff datacells mbPagination =+ let trows = case mbHeaderStuff of+ Just (headerCells, htrF) -> htrF headerCells ++ rows+ Nothing -> rows+ where rows = let rows' = join spacerRow . map trF $ tableCells+ in if morePadding+ then spacerRow ++ rows' ++ spacerRow+ else rows'+ tableCells :: [[String]]+ tableCells = maybe datacells (getPaginatedCells datacells) mbPagination + paginationBar :: String+ 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 + , currentpage :: Int+ , resultsPerPage :: Int + , baselink :: 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 + +--barRanges pg datacells = splitList (resultsPerBar pg) $ zip datacells [1..]+-- tp = paintPaginationBar [[]] (Pagination 1 10000 1 20 "" "")+++-- variable nomenclature is kind of poor here+-- think of "bar" as the outer loop and "page" as the inner loop+paintPaginationBar :: [[String]] -> Pagination -> String+paintPaginationBar datacells pg | resultsPerPage pg > length datacells = ""+ | otherwise =+ let paintresultsbar (barindex, ( xs,(fr,to)) ) = + let attrs = [("currentbar",show barindex)+ , ("resultsPerBar",show $ resultsPerBar pg)+ , ("currentpage", show 1)+ , ("resultsPerPage",show $ resultsPerPage pg)+ , ("from",show fr)+ , ("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)+ , ("resultsPerBar",show $ resultsPerBar pg)+ , ("currentpage", show pageindex)+ , ("resultsPerPage",show $ resultsPerPage pg)+ , ("from",show $ adjust + fr)+ , ("to",show $ adjust + to)]+ in if currentpage pg == pageindex+ 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..] + 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>"+ in (paginationtitle pg) ++ ( concat . intersperse " | " $ barlinks )++++getPaginatedCells :: [[String]] -> Pagination -> [[String]]+getPaginatedCells [] _ = [[]]+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 + in case splitList (resultsPerPage pg) datacells2 `atMay` currp of+ Nothing -> [["getPaginatedCells, index not in range, currp: " ++ (show currp) ]]+ Just (res,(_,_)) -> res++-- splitList 3 [1..11]+-- [([(1,1),(2,2),(3,3)],(1,3)),([(4,4),(5,5),(6,6)],(4,6)),([(7,7),(8,8),(9,9)],(7,9)),([(10,10),(11,11)],(10,11))]+-- 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) + bounded = map (\l -> (map snd l,bounds l)) part+ bounds [] = (0,0)+ bounds l@((_,_):_) = (fst . head $ l,fst . last $ l)+ in bounded+ where + splitList' :: Int -> [a] -> [[a]]+ splitList' _ [] = []+ splitList' n l@(x:xs) =+ let (a,b') = genericSplitAt n l+ b = splitList' n b'+ in a : b++-- | substitute newlines with <br>+newlinesToHtmlLines :: String -> String+newlinesToHtmlLines = concatMap formatnewlines+ where formatnewlines c = if c == '\n' then "<br>" else [c]++{- | +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: ++attrs = [ ... , ("somethingIsChecked", checkedStringIfTrue $ someBoolVal ) ... ]+-}+readcheckbox :: String -> RqData Bool+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 \"\"+-}+checkedStringIfTrue :: Bool -> String+checkedStringIfTrue p = if p then "checked" else ""++-- | Render a list of strings as an unordered list (<ul>...</ul>)+paintVUL :: [String] -> String+paintVUL xs = "<ul>" ++ (concatMap (\mi -> "<li>" ++ mi ++ "</li>") xs) ++ "</ul>"++-- | Render a list of strings as an ordered list (<ol>...</ol>)+paintVOL :: [String] -> String+paintVOL xs = "<ol>" ++ (concatMap (\mi -> "<li>" ++ mi ++ "</li>") xs) ++ "</ol>"++-- | render a list of strings horizontally, separated by \" | \"+paintHBars :: [String] -> String+paintHBars = intercalate " | " ++newtype HtmlString = HtmlString String+instance ToMessage HtmlString where+ toContentType _ = B.pack "text/html"+ toMessage (HtmlString s) = L.pack s
+ Happstack/Helpers/HtmlOutput/Menu.hs view
@@ -0,0 +1,59 @@+module Happstack.Helpers.HtmlOutput.Menu where++import Happstack.Server.HTTP.Types +import Text.StringTemplate.Helpers+import Data.List (intercalate)+import Happstack.Helpers.HtmlOutput.Common++{- | +Render a link which changes color when the current page is active, modulo css.++menuLink rq (url,anchortext)++similar to simpleLink, outputs an html link. However, menuLink looks at the request to determine if the page being linked to is the current page. If it is, it's in class menuitemSelected, otherwise class menuitem. if the url is blank, +the link is unclickable, just displayed gray (e.g., features that haven't been enabled but are coming soon). You need to define the classes described here via css for these features to be useful. I usually do something like in a global css file:++a.menuitem:link {color: blue}++a.menuitem:active {color: blue}++a.menuitem:visited {color: blue}++a.menuitem:hover {color: blue}++a.menuitemSelected:link {color: purple}++a.menuitemSelected:active {color: purple}++a.menuitemSelected:visited {color: purple}++a.menuitemSelected:hover {color: purple}++-}+menuLink :: Request -> (String, String) -> String+menuLink = menuLink' "menuitemSelected" "menuitem"++{- | menuLink' classSelected classUnselected rq (url,anchortext) = ... +-}+menuLink' :: String -> String -> Request -> (String, String) -> String+menuLink' classSelected classUnselected rq (url,anchortext) = + render1 [("url",url),("anchortext",anchortext),("classSelected",classSelected),("classUnselected",classUnselected)] $+ if currUrl == url+ then "<a class=$classSelected$ href=\"$url$\">$anchortext$</a>"+ else if null url+ then "<font color=gray>$anchortext$</font>"+ else "<a class=\"$classUnselected$\" href=\"$url$\">$anchortext$</a>"+ where currUrl = rqURL rq++++vMenuOL :: Request -> [(String, String)] -> String+vMenuOL rq = paintVOL . map (menuLink rq )++vMenuUL :: Request -> [(String, String)] -> String+vMenuUL rq = paintVUL . map (menuLink rq )++-- | hMenuBars rq = paintHBars . map (menuLink rq) +hMenuBars :: Request -> [(String, String)] -> String+hMenuBars rq = paintHBars . map (menuLink rq) +
+ Happstack/Helpers/ParseRequest.hs view
@@ -0,0 +1,68 @@+module Happstack.Helpers.ParseRequest where++import Happstack.Server.HTTP.Types+import Text.StringTemplate.Helpers+import qualified Data.ByteString.Char8 as B+import qualified Data.Map as M+import Data.String.Utils (split)+{- |++> case modRewriteAppUrl "tutorial/registered" of +> Left e -> ...+> Right page -> ... ++Given a page path, try to return the "home page" of a happs server, basically, the host plus an optional path.+At the same time, try to deal sanely with HAppS serving behind apache mod rewrite,+a common situation for me at least+because it lets you have multiple happs servers listening on different ports, all+looking to the casual user like they are being served on port 80, and also unblocked by firewalls.++Can fail monadically+-}+modRewriteAppUrl :: String -> Request -> Either String String+modRewriteAppUrl path' rq =+ let apphost = case getHeaderVal "x-forwarded-server" rq of+ Right h -> Right h+ Left _ -> case getHeaderVal "host" rq of+ Right h -> Right h+ Left _ -> Left "modRewriteAppUrl, can't determine host" + -- trim starting slash if necessary+ path = case path' of+ "" -> ""+ '/':cs -> cs+ x -> x+ in case apphost of+ Right apphost -> Right $ render1 [("apphost",apphost),("path",path)] "http://$apphost$/$path$"+ Left e -> Left $ "modRewirteAppUrl error: " ++ e+++{- | +getHost = getHeaderVal \"host\" ++returns host with port numbers, if anything other than default 80+-}+getHost :: Request -> Either String String+getHost = getHeaderVal "host" ++{- |+retrieve val of header for key supplied, or an error message if the key isn't found+-}+getHeaderVal :: String -> Request -> Either String String+getHeaderVal headerKey rq = maybe (Left $ "getHeaderVal, bad headerKey: " ++ headerKey)+ ( Right . B.unpack . head . hValue )+ ( M.lookup ( B.pack headerKey ) . rqHeaders $ rq )++{- | +host with port number stripped out, if any. ++Useful, for example, for getting the right address to ssh to. +-}+getDomain :: Request -> Either String String+getDomain rq = do+ h <- getHost rq+ let parts = split ":" h+ case parts of+ [d] -> Right d+ [d,p] -> Right d+ xs -> Left $ "getDomain, bad domain: " ++ h+
+ Happstack/Helpers/Redirect.hs view
@@ -0,0 +1,33 @@+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++{- | +redirectPath def path rq = ...++eg, redirectPath (fail "horribly) "/path/to/page" will redirect to http://myserver.com/path/to/page+ or http://localhost:5001/path/to/page depending on whether it is servin in online environemnt+ or for local development on port 5001+ Could produce an error if the hostname can't be determined for some reason (malformed headers?)+-}+redirectPath :: (MonadIO m) => WebT m Response -> String -> Request -> WebT m Response+redirectPath def p rq = do+ case modRewriteAppUrl p rq of+ Left _ -> def+ Right au -> redirectToUrl au++{- |+Escape a serverPartT handler by redirecting somewhere++Basically a wrapper around supplied seeOther function, which doesn't quite do what I want+-}+redirectToUrl :: MonadIO m => String -> WebT m Response+redirectToUrl url = seeOther url $ toResponse ()+
+ Happstack/Server/CookieFixer.hs view
@@ -0,0 +1,90 @@+module Happstack.Server.CookieFixer + ( cookieFixer+ ) where++import Happstack.Server.Cookie (Cookie(..))+import Happstack.Server(ServerPartT(..),Request(..), getHeader,+ localRq)++import qualified Data.ByteString.Char8 as C+import Data.Char (chr, toLower)+import Data.List ((\\))+import Data.Maybe++import Control.Monad.Reader+import Control.Applicative+import Control.Monad (MonadPlus(..), ap)+-- Hide Parsec's definitions of some Applicative functions.+import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))++instance Applicative (GenParser s a) where+ pure = return+ (<*>) = ap++instance Alternative (GenParser s a) where+ empty = mzero+ (<|>) = mplus++-- Less complete but more robust way of parsing cookies. Note: not RFC 2068 compliant!+parseCookies :: String -> [Cookie]+parseCookies str = either (const []) id $ parse cookiesParser "" str++parseCookiesM :: (Monad m) => String -> m [Cookie]+parseCookiesM str = either (fail "Invalid cookie syntax!") return $ parse cookiesParser str str++cookiesParser = av_pairs+ where -- Parsers based on RFC 2109+ av_pairs = (:) <$> av_pair <*> many (char ';' *> av_pair)+ av_pair = cookie <$> attr <*> option "" (char '=' *> value)+ attr = spaces *> token+ value = word+ word = incomp_token <|> quoted_string++ -- Parsers based on RFC 2068+ token = many1 $ oneOf ((chars \\ ctl) \\ tspecials)+ quoted_string = char '"' *> many (oneOf qdtext) <* char '"'++ -- Custom parser, incompatible with RFC 2068, but very forgiving ;)+ incomp_token = many1 $ oneOf ((chars \\ ctl) \\ "\";")++ -- Primitives from RFC 2068+ tspecials = "()<>@,;:\\\"/[]?={} \t"+ ctl = map chr (127:[0..31])+ chars = map chr [0..127]+ octet = map chr [0..255]+ text = octet \\ ctl+ qdtext = text \\ "\""++cookie key value = Cookie "" "" "" (low key) value+{-+simpleHTTPCookieFixer :: ToMessage a => Conf -> [ServerPartT IO a] -> IO ()+simpleHTTPCookieFixer conf hs+ = listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< simpleHTTP' hs (cookieFixer req))++cookieFixer :: Request -> Request+cookieFixer request = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" (rqHeaders request))), c <- cl ]+-}++cookieFixer :: (Monad m) => ServerPartT m a -> ServerPartT m a+cookieFixer = localRq fixedCookies+ where+ fixedCookies request = request{rqCookies=[ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" (rqHeaders request))), c <- cl ]}++-- | Get all cookies from the HTTP request. The cookies are ordered per RFC from+-- the most specific to the least specific. Multiple cookies with the same+-- name are allowed to exist.+getCookies :: Monad m => C.ByteString -> m [Cookie]+getCookies header | C.null header = return []+ | otherwise = parseCookiesM (C.unpack header)++-- | Get the most specific cookie with the given name. Fails if there is no such+-- cookie or if the browser did not escape cookies in a proper fashion.+-- Browser support for escaping cookies properly is very diverse.+getCookie :: Monad m => String -> C.ByteString -> m Cookie+getCookie s h = do cs <- getCookies h+ case filter ((==) (low s) . cookieName) cs of+ [r] -> return r+ _ -> fail ("getCookie: " ++ show s)++low :: String -> String+low = map toLower
+ Happstack/Server/Helpers.hs view
@@ -0,0 +1,50 @@+module Happstack.Server.Helpers+ ( smartserver, exactdir, smartserver'+ ) where++import Happstack.Server+import Happstack.State+import System.Environment+import Control.Concurrent+import System.Time+import Happstack.Server.CookieFixer+import Control.Monad++-- run the happs server on some port+-- include cookie fix, various other enhancements that make things simpler+smartserver' :: (Methods st, Component st, ToMessage b, Monad m) => + (m (Maybe (Either Response a, FilterFun Response)) ->+ IO (Maybe (Either Response b, FilterFun Response))) ->+ Conf -> String -> ServerPartT m a -> Proxy st -> IO ()+smartserver' f conf progName handler stateProxy = withProgName progName $ do+ putStrLn . ( "starting happs server" ++ ) =<< time+ control <- startSystemState stateProxy -- start the HAppS state system++ putStrLn . ( "happs state started" ++ ) =<< time+ tid <- forkIO $ simpleHTTP' f conf (cookieFixer handler)+ putStrLn . ( ( "simpleHttp started on port " ++ (show . port $ conf) ++ "\n" +++ "shut down with ctrl-c" ) ++) =<< time+ waitForTermination+ killThread tid+ putStrLn . ( "creating checkpoint: " ++ ) =<< time+ createCheckpoint control++ putStrLn . ( "shutting down system: " ++ ) =<< time+ shutdownSystem control + putStrLn . ( "exiting: " ++ ) =<< time+ where time = return . ("\ntime: " ++ ) . show =<< getClockTime++smartserver :: (Methods st, Component st, ToMessage a) =>+ Conf -> String -> ServerPartT IO a -> Proxy st -> IO ()+smartserver = smartserver' id++exactdir :: (Monad m) => String -> ServerPartT m a -> ServerPartT m a+exactdir staticPath = spsIf (\rq -> rqURL rq == staticPath)++spsIf :: (Monad m) => (Request -> Bool) -> ServerPartT m a -> ServerPartT m a+spsIf p sps = do+ rq <- askRq+ if p rq+ then sps+ else mzero+
happstack-helpers.cabal view
@@ -1,22 +1,25 @@ Name: happstack-helpers-Version: 0.11+Version: 0.20 License: BSD3 License-file: bsd3.txt 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. -Maintainer: Thomas Hartman <thomashartman1 at gmail>, Creighton Hogg <wchogg at gmail>-Author: Thomas Hartman & Eelco Lempsink & Jeremy Shaw+Maintainer: Creighton Hogg <wchogg at gmail>+Author: Thomas Hartman, Eelco Lempsink, Jeremy Shaw, Creighton Hogg Stability: Beta Copyright: Copyright (c) 2008 Thomas Hartman-Exposed-Modules: HAppS.Helpers,HAppS.Helpers.DirBrowse, HAppS.Helpers.HtmlOutput, HAppS.Helpers.HtmlOutput.Common, - HAppS.Helpers.HtmlOutput.Menu, HAppS.Helpers.ParseRequest,HAppS.Helpers.Redirect, - HAppS.Data.User.Password, HAppS.Server.CookieFixer, HAppS.Data.IxSet.Helpers- HAppS.Server.Helpers+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.Server.CookieFixer, + Happstack.Data.IxSet.Helpers+ Happstack.Server.Helpers Build-Depends: base, mtl, happstack-server, hscolour, filepath, directory, bytestring, HStringTemplate, HStringTemplateHelpers, safe, MissingH, containers, parsec, haskell98, happstack-ixset, happstack-state, random, happstack-data, old-time, pureMD5, PBKDF2+ghc-options: -Wall Category: Distributed Computing Build-type: Simple-