diff --git a/HAppS/Data/User/Password.hs b/HAppS/Data/User/Password.hs --- a/HAppS/Data/User/Password.hs +++ b/HAppS/Data/User/Password.hs @@ -15,7 +15,6 @@ module HAppS.Data.User.Password where import Control.Monad ---import HAppS.Crypto.SHA1 import HAppS.Data import System.Random import qualified Crypto.PBKDF2 as PBKDF2 @@ -43,11 +42,14 @@ -> 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) @@ -73,7 +75,7 @@ do salt <- genSalt return $ mkP salt password -mkP salt password = Password salt $ doHash salt password + --t = putStrLn . show =<< newPassword "blee" diff --git a/HAppS/Helpers/HtmlOutput.hs b/HAppS/Helpers/HtmlOutput.hs --- a/HAppS/Helpers/HtmlOutput.hs +++ b/HAppS/Helpers/HtmlOutput.hs @@ -1,7 +1,19 @@ +{-# 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 + diff --git a/HAppS/Helpers/HtmlOutput/Common.hs b/HAppS/Helpers/HtmlOutput/Common.hs --- a/HAppS/Helpers/HtmlOutput/Common.hs +++ b/HAppS/Helpers/HtmlOutput/Common.hs @@ -3,12 +3,12 @@ -} module HAppS.Helpers.HtmlOutput.Common where import HAppS.Server.SimpleHTTP -import Control.Monad +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. @@ -60,25 +60,63 @@ pagination also optional -} -paintTable :: Maybe [String] -> [[String]] -> Maybe Pagination -> String -paintTable _ [] _ = "" -paintTable mbHeaderCells datacells mbPagination = - let trows = maybe rows ( (++rows) . paintHeaderTr) mbHeaderCells - where rows = paintTrs tableCells +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)] " $ rows $
" + defTrFMeh row = render1 [("row",row)] " $ row $ " + defTdF cell = render1 [("cell",cell)] " $cell$ " + defSpacerRow = ("",False) + defTrF cells = defTrFMeh . concat . map defTdF $ cells - tableCells :: [[String]] - tableCells = maybe datacells (getPaginatedCells datacells) mbPagination +{- | + 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 ( table trows ) ++ paginationBar - where paintHeaderTr hc = tr . concat . (map (td {-. biggerfont -} ) ) $ hc - paintTrs cells = concat . map (tr . concat) . ( (map . map) td ) $ cells - tr x = "" ++ x ++ "" - td x = "" ++ x ++ "" - table x = "" ++ x ++ "
" + paginationBar = maybe "" (paintPaginationBar datacells) mbPagination + in ( tableF trows ) ++ paginationBar + + + + + + + + + biggerfont x = "" ++ x ++ "" -- import Text.StringTemplate hiding (directoryGroup) @@ -166,7 +204,7 @@ in a : b -- | substitute newlines with
-newlinesToHtmlLines :: [Char] -> [Char] +newlinesToHtmlLines :: String -> String newlinesToHtmlLines = concatMap formatnewlines where formatnewlines c = if c == '\n' then "
" else [c] diff --git a/HAppS/Helpers/HtmlOutput/Menu.hs b/HAppS/Helpers/HtmlOutput/Menu.hs --- a/HAppS/Helpers/HtmlOutput/Menu.hs +++ b/HAppS/Helpers/HtmlOutput/Menu.hs @@ -31,14 +31,21 @@ -} menuLink :: Request -> (String, String) -> String -menuLink rq (url,anchortext) = - let currUrl = rqURL rq - r = render1 [("url",url),("anchortext",anchortext)] - in if currUrl == url - then r "$anchortext$" +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 "$anchortext$" else if null url - then r "$anchortext$" - else r "$anchortext$" + then "$anchortext$" + else "$anchortext$" + where currUrl = rqURL rq + + vMenuOL :: Request -> [(String, String)] -> String vMenuOL rq = paintVOL . map (menuLink rq ) diff --git a/HAppS/Helpers/ParseRequest.hs b/HAppS/Helpers/ParseRequest.hs --- a/HAppS/Helpers/ParseRequest.hs +++ b/HAppS/Helpers/ParseRequest.hs @@ -6,28 +6,34 @@ import qualified Data.Map as M import Data.String.Utils (split) {- | -Try to return the "home page" of a happs server, basically, the host plus an optional path. -The "smart" part is trying to deal sanely with HAppS serving behind apache mod rewrite, + +> 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 -} -smartAppUrl :: String -> Request -> String -smartAppUrl path' rq = - let forwardinghost = getHeaderVal "x-forwarded-server" rq - vanillahost = getHeaderVal "host" rq - apphost = case forwardinghost of - Right h -> h - Left _ -> case vanillahost of - Right h -> h - Left _ -> "getAppUrlCantDetermineHost" --ugly way to propogate error! +modRewriteAppUrl :: String -> Request -> Either [Char] 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 render1 [("apphost",apphost),("path",path)] "http://$apphost$/$path$" - + in case apphost of + Right apphost -> Right $ render1 [("apphost",apphost),("path",path)] "http://$apphost$/$path$" + Left e -> Left $ "modRewirteAppUrl error: " ++ e {- | @@ -59,3 +65,4 @@ [d] -> Right d [d,p] -> Right d xs -> Left $ "getDomain, bad domain: " ++ h + diff --git a/HAppS/Helpers/Redirect.hs b/HAppS/Helpers/Redirect.hs --- a/HAppS/Helpers/Redirect.hs +++ b/HAppS/Helpers/Redirect.hs @@ -5,21 +5,29 @@ import Text.StringTemplate.Helpers import qualified Data.Map as M import Data.String.Utils (split) +import Control.Monad.Trans import HAppS.Helpers.ParseRequest {- | -redirectPath p rq = redirectToUrl $ getAppUrl p rq +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 :: String -> Request -> WebT IO Response -redirectPath p rq = redirectToUrl $ smartAppUrl p rq +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 servrPartT handler by redirecting somewhere +Escape a serverPartT handler by redirecting somewhere Basically a wrapper around supplied seeOther function, which doesn't quite do what I want -} -redirectToUrl :: String -> WebT IO Response +redirectToUrl :: MonadIO m => String -> WebT m Response redirectToUrl url = seeOther url $ toResponse () - diff --git a/HAppSHelpers.cabal b/HAppSHelpers.cabal --- a/HAppSHelpers.cabal +++ b/HAppSHelpers.cabal @@ -1,5 +1,5 @@ Name: HAppSHelpers -Version: 0.9 +Version: 0.10 License: BSD3 License-file: bsd3.txt Description: Functions I found I was using repeatedly when programming HAppS based web-apps. @@ -15,8 +15,8 @@ HAppS.Server.Helpers Build-Depends: base, mtl, HAppS-Server, hscolour, filepath, directory, bytestring, - HStringTemplate, HStringTemplateHelpers, safe, MissingH, containers, parsec, Crypto, haskell98, - HAppS-IxSet, HAppS-State, PBKDF2, random, HAppS-Data, old-time + HStringTemplate, HStringTemplateHelpers, safe, MissingH, containers, parsec, haskell98, + HAppS-IxSet, HAppS-State, random, HAppS-Data, old-time, pureMD5, PBKDF2 Category: Distributed Computing Build-type: Simple