HAppSHelpers 0.10 → 0.11
raw patch · 15 files changed
+87/−866 lines, 15 filesdep −HAppS-Datadep −HAppS-IxSetdep −HAppS-Serversetup-changed
Dependencies removed: HAppS-Data, HAppS-IxSet, HAppS-Server, HAppS-State, HStringTemplate, HStringTemplateHelpers, MissingH, PBKDF2, base, bytestring, containers, directory, filepath, haskell98, hscolour, mtl, old-time, parsec, pureMD5, random, safe
Files
- HAppS/Data/IxSet/Helpers.hs +0/−26
- HAppS/Data/User/Password.hs +0/−86
- 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
- HAppSHelpers.cabal +57/−21
- LICENSE +30/−0
- Setup.hs +0/−1
- bsd3.txt +0/−27
− 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,86 +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 :: (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 [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 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
HAppSHelpers.cabal view
@@ -1,22 +1,58 @@-Name: HAppSHelpers-Version: 0.10-License: BSD3-License-file: bsd3.txt-Description: Functions I found I was using repeatedly when programming HAppS based web-apps. - I'll deprecate whatever bits of this make their way into the HAppS core on hackage.-Synopsis: Convenience functions for HAppS. -Maintainer: Thomas Hartman <thomashartman1 at gmail>-Author: Thomas Hartman & Eelco Lempsink & Jeremy Shaw-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- -Build-Depends: base, mtl, HAppS-Server, hscolour, filepath, directory, bytestring,- HStringTemplate, HStringTemplateHelpers, safe, MissingH, containers, parsec, haskell98,- HAppS-IxSet, HAppS-State, random, HAppS-Data, old-time, pureMD5, PBKDF2-Category: Distributed Computing-Build-type: Simple+-- HAppSHelpers.cabal auto-generated by cabal init. For additional+-- options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: HAppSHelpers +-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.11++-- A short (one-line) description of the package.+Synopsis: OBSOLETE. Please use happstack-helpers++-- A longer description of the package.+Description: OBSOLETE. Please use happstack-helpers++-- The license under which the package is released.+License: BSD3++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Thomas Hartman++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: thomashartman1@gmail.com++-- A copyright notice.+-- Copyright: ++Category: Web++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files: ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.2+++Library+ -- Modules exported by the library.+ -- Exposed-modules: + + -- Packages needed in order to build this package.+ -- Build-depends: + + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: +
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Thomas Hartman++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Thomas Hartman nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hs view
@@ -1,3 +1,2 @@-#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain
− bsd3.txt
@@ -1,27 +0,0 @@-Copyright (c) Benedikt Schmidt, Eelco Lempsink 2008--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:-1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.-3. Neither the name of the author nor the names of his contributors- may be used to endorse or promote products derived from this software- without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF-SUCH DAMAGE.