Phsu-0.1.0.1: src/Search.hs

{-# LANGUAGE OverloadedStrings #-}
module Search(serveSearch, editSearch) where

import BoilerplateDB (App, URLSubDb, URLSub, exportURLSub, exportAllURLSubRules, exportAddURLSub, exportRemoveURLSub, exportUpdateURLSub, exportHitRule, exportReorderURLSub, regex, substitute, ruleId, hits)
import Control.Applicative (optional, (<$>))
import Control.Concurrent.MVar (takeMVar)
import Control.Monad (forM_)
import Control.Monad.Trans  (MonadIO(..))
import Data.List (sortBy)
import Data.List.Utils (startswith)
import Data.Maybe (mapMaybe)
import Data.Ord (comparing)
import Data.String.Conversions (cs)
import Happstack.Server
import Happstack.Server.SURI (parse, SURI)
import Network.URI (escapeURIString, isUnescapedInURI)
import Template (template, myPolicy)
import Text.Blaze.Html5 (Html, (!), toHtml, toValue)
import Text.Blaze.Html5.Attributes (action, name, size, type_, value)
import Text.Regex.PCRE ((=~))
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Map as Map
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A

defaultSearch str = (++) "https://www.google.com/search?q=" $ str

groups :: String -> String -> [String]
groups regx str = let (_, _, _, g) = ((str =~ regx)::(String, String, String, [String])) in g

repl :: String -> String -> String -> String
repl "" g id = ""
repl ('\\':'\\':x) g id = (++) "\\\\" $ repl x g id
repl ('\\':x) g id =
	if startswith id x then g ++ (repl (drop (length id) x) g id) else '\\':(repl x g id)
repl (x:xs) g id = x:(repl xs g id)

applySub :: String -> [String] -> String
applySub str grps = foldl (\s -> \(g, i) -> repl s g $ show i) str $ zip grps [1..]


applyRule :: String -> URLSub -> Maybe (String, URLSub)
applyRule q rule =
	let pat = regex rule
	    sub = substitute rule
	in if q =~ ("^"++pat++"$") then Just (applySub sub $ groups pat q, rule) else Nothing

myparse :: String -> SURI
myparse str = case (parse $ escapeURIString isUnescapedInURI str) of Just x -> x

urlResponse url = seeOther (myparse url) $ template "Happstack Server Utils" "HSU"
serveSearch :: App Response
serveSearch = do
	q <- lookText "q"
	rules <- (sortBy (comparing $ \x -> ruleId x)) <$> exportAllURLSubRules
	let matches = (mapMaybe (applyRule $ cs q) rules) in
		case matches of
			(url, r):_ -> do
							exportHitRule $ ruleId r
							urlResponse url
			[]         -> urlResponse (defaultSearch $ cs q)

renderRule::URLSub -> Html
renderRule rule = do
	H.td $ H.input ! type_ "text"
	               ! (name . toValue) ("reorder-" ++ (show $ ruleId rule))
	               ! (value . toValue) (show $ ruleId rule)
	               ! size "2"
	H.td $ H.input ! type_ "checkbox"
	               ! (name . toValue) ("remove-" ++ (show $ ruleId rule))
	               ! (value . toValue) ("yes" :: String)
	H.td (H.label (toHtml $ show (ruleId rule)))
	H.td $ H.input ! type_ "text"
	               ! (name . toValue) ("regex-" ++ (show $ ruleId rule))
	               ! size "20"
	               ! value (toValue $ regex rule)
	H.td $ H.input ! type_ "text"
	               ! (name . toValue) ("substitute-" ++ (show $ ruleId rule))
	               ! size "100"
	               ! value (toValue $ substitute rule)
	H.td (H.label (toHtml $ show (hits rule)))

rulesHeader::Html
rulesHeader = do
	H.td (H.label "Re-ord")
	H.td (H.label "Delete")
	H.td (H.label "Rule ID")
	H.td (H.label "Regex")
	H.td (H.label "Substitution Rule")
	H.td (H.label "Hits so far")

rulesFoot::Html
rulesFoot = do
	H.td $ do
		H.button ! name "op" ! value (toValue ("reorder"::String)) $ do 
			toHtml ("Reoder"::String)
	H.td ! A.colspan (toValue ("5"::String))
	     ! A.style (toValue ("text-align:right"::String)) $ do
		H.button ! name "op" ! value (toValue ("edit"::String)) $ toHtml ("Save Changes"::String)

serveEditSearch::String -> App Response
serveEditSearch str = do
	rules <- (sortBy (comparing $ \x -> ruleId x)) <$> exportAllURLSubRules
	ok $
		template "Search Pattern Settings" $ do
			H.body $ do
				H.h1 . toHtml $ "Total rules :: " ++ (show $ length rules)
				H.form ! action "/edit-search" ! A.method (toValue ("POST"::String)) $ do
					H.table $ do
						H.thead rulesHeader
						H.tbody (forM_ rules (H.tr . renderRule))
						H.tfoot ! A.style (toValue $ ("border:0px"::String)) $ rulesFoot
				H.form ! action "/edit-search" ! A.method (toValue ("POST"::String)) $ do
					H.table $ do
						H.thead $ do
							H.td ! A.colspan (toValue ("2"::String))
							     ! A.style (toValue ("padding-left:80px"::String)) $ do
							     	H.b $ toHtml ("Add a new Rule"::String)
						H.tbody $ do
							H.tr $ do
								H.td $ H.label . toHtml $ ("regex"::String)
								H.td $ H.input ! type_ "text" ! name "regex" ! size "100"
							H.tr $ do
								H.td $ H.label . toHtml $ ("substitution regex"::String)
								H.td $ H.input ! type_ "text" ! name "substitute" ! size "100"
						H.tfoot $ do
							H.td ! A.colspan (toValue ("2"::String)) $ do
								H.button ! name "op" ! value (toValue ("add"::String)) $ toHtml ("Add Rule"::String)

data Edit = Delete Int | Ed URLSub deriving (Show)

rid :: String -> String -> Int
rid str "" = read str
rid (a:as) (b:bs) = rid as bs

defaultEdit :: Int -> URLSub
defaultEdit id = exportURLSub undefined undefined 0 id

--extractStr value
handleRemove intMap id = IntMap.insert id (Delete id) intMap
handleEditRegex intMap reg id = case IntMap.findWithDefault (Ed $ defaultEdit id) id intMap of
			Delete _ -> intMap
			Ed r -> IntMap.insert id (Ed r{regex=reg}) intMap
handleEditSubstitute intMap sub id = case IntMap.findWithDefault (Ed $ defaultEdit id) id intMap of
			Delete _ -> intMap
			Ed r -> IntMap.insert id (Ed r{substitute=sub}) intMap

handleSingleParam param value intMap
	| startswith "remove-" param = handleRemove intMap $ rid param "remove-"
	| startswith "regex-" param = handleEditRegex intMap (extractStr value) $ rid param "regex-"
	| startswith "substitute-" param = handleEditSubstitute intMap (extractStr value) $ rid param "substitute-"
	| otherwise = intMap

prepareEdits reqMap = Map.foldWithKey handleSingleParam IntMap.empty reqMap

processEdits (Delete id) = (:) $ exportRemoveURLSub id
processEdits (Ed rule) = (:) $ exportUpdateURLSub rule
reqMapToMods reqMap = IntMap.fold processEdits [] $ prepareEdits reqMap

handleReorderParam param value intMap
	| startswith "reorder-" param = IntMap.insert (rid param "reorder-") (read $ extractStr value) intMap
	| otherwise = intMap

fetchReMapping reqMap = Map.foldWithKey handleReorderParam IntMap.empty reqMap

checkNoOverLap :: (IntMap.IntMap Int) -> (IntMap.IntMap Int)
checkNoOverLap = fst . (IntMap.foldWithKey func (IntMap.empty, IntSet.empty)) where
	func key val (mp, st)
		| IntSet.member val st = (mp, st)
		| otherwise = (IntMap.insert key val mp, IntSet.insert val st)

processEditForm reqMap = do
	case readKey reqMap "op" of
		"add" -> let regex = cs $ readKey reqMap "regex"
		             sub = cs $ readKey reqMap "substitute"
		         in exportAddURLSub $ exportURLSub regex sub 0 0
		"edit" -> foldl (>>) (return ()) $ reqMapToMods reqMap
		"reorder" -> exportReorderURLSub . checkNoOverLap . fetchReMapping $ reqMap

extractStr :: Input -> String
extractStr input = case (inputValue input) of
	Right x -> cs x
readKey reqMap key =
	extractStr (reqMap Map.! key) where

editSearch :: App Response
editSearch = do
	m <- rqMethod <$> askRq
	case m of
		GET ->
			serveEditSearch $ "Meh"
		POST -> do
			decodeBody myPolicy
			all <- rqInputsBody <$> askRq
			dat <- Map.fromList <$> (liftIO $ takeMVar all)
			processEditForm dat
			serveEditSearch $ (show.prepareEdits) dat